-- Copyright (C) 2002-2004,2007-2008 David Roundy
-- Copyright (C) 2005 Juliusz Chroboczek
--
-- This program is free software; you can redistribute it and/or modify
-- it under the terms of the GNU General Public License as published by
-- the Free Software Foundation; either version 2, or (at your option)
-- any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-- GNU General Public License for more details.
--
-- You should have received a copy of the GNU General Public License
-- along with this program; see the file COPYING.  If not, write to
-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
-- Boston, MA 02110-1301, USA.

{-# LANGUAGE CPP, ScopedTypeVariables, Rank2Types, RankNTypes, PatternGuards #-}

module Darcs.Repository.Internal
    ( Repository(..)
    , maybeIdentifyRepository
    , identifyRepository
    , identifyRepositoryFor
    , IdentifyRepo(..)
    , findRepository
    , amInRepository
    , amNotInRepository
    , amInHashedRepository
    , revertRepositoryChanges
    , announceMergeConflicts
    , setTentativePending
    , checkUnrecordedConflicts
    , readRepo
    , readTentativeRepo
    , readRepoUsingSpecificInventory
    , prefsUrl
    , withRecorded
    , withTentative
    , tentativelyAddPatch
    , tentativelyRemovePatches
    , tentativelyRemovePatches_
    , tentativelyRemoveFromPending
    , tentativelyAddToPending
    , tentativelyAddPatch_
    , tentativelyAddPatches_
    , tentativelyReplacePatches
    , finalizeRepositoryChanges
    , unrevertUrl
    , applyToWorking
    , createPristineDirectoryTree
    , createPartialsPristineDirectoryTree
    , reorderInventory
    , cleanRepository
    , setScriptsExecutable
    , setScriptsExecutablePatches
    , UpdatePristine(..)
    , MakeChanges(..)
    , applyToTentativePristine
    , makeNewPending
    , seekRepo
    , repoPatchType
    , repoXor
    ) where

import Prelude ()
import Darcs.Prelude

import Darcs.Util.Printer ( putDocLn
               , (<+>)
               , text
               , ($$)
               , redText
               , putDocLnWith
               , ($$)
               )
import Darcs.Util.Printer.Color (fancyPrinters)
import Darcs.Util.Crypt.SHA1 ( SHA1, sha1Xor, zero )
import Darcs.Repository.State ( readRecorded
                              , readWorking
                              , updateIndex
                              )
import Darcs.Repository.Pending
    ( readPending
    , readTentativePending
    , writeTentativePending
    , readNewPending
    , writeNewPending
    , pendingName
    )
import System.Exit ( exitSuccess )
import Darcs.Repository.ApplyPatches
    ( runTolerantly
    , runSilently
    , runDefault
    )

import Darcs.Util.SignalHandler ( withSignalsBlocked )
import Darcs.Repository.Format ( RepoFormat
                               , RepoProperty( HashedInventory
                                             , NoWorkingDir
                                             )
                               , tryIdentifyRepoFormat
                               , formatHas
                               , readProblem
                               , transferProblem
                               )
import System.Directory ( doesDirectoryExist
                        , setCurrentDirectory
                        , createDirectoryIfMissing
                        , doesFileExist
                        )
import Control.Monad ( when
                     , unless
                     , filterM
                     , void
                     )

import Control.Exception ( catch, IOException )

import qualified Data.ByteString as B ( readFile
                                      , isPrefixOf
                                      )
import qualified Data.ByteString.Char8 as BC (pack)
import Data.List( foldl' )
import Data.List.Ordered ( nubSort )
import Data.Maybe ( fromMaybe )
import Darcs.Patch ( Effect
                   , primIsHunk
                   , primIsBinary
                   , description
                   , tryToShrink
                   , commuteFLorComplain
                   , commute
                   , fromPrim
                   , RepoPatch
                   , IsRepoType
                   , Patchy
                   , merge
                   , listConflictedFiles
                   , listTouchedFiles
                   , WrappedNamed
                   , commuteRL
                   , fromPrims
                   , readPatch
                   , effect
                   , invert
                   , primIsAddfile
                   , primIsAdddir
                   , primIsSetpref
                   , apply
                   , applyToTree
                   )

import Darcs.Patch.Dummy ( DummyPatch )

import Darcs.Patch.Apply ( ApplyState )

import Darcs.Patch.Inspect ( PatchInspect )
import Darcs.Patch.Prim ( PrimPatchBase
                        , PrimOf
                        , tryShrinkingInverse
                        , PrimPatch
                        )
import Darcs.Patch.Bundle ( scanBundle
                          , makeBundleN
                          )
import Darcs.Patch.Info ( isTag, makePatchname )
import Darcs.Patch.Named.Wrapped ( namedIsInternal )
import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd
                                , hopefully
                                , info
                                )
import Darcs.Patch.Type ( PatchType(..) )

import qualified Darcs.Repository.HashedRepo as HashedRepo
                            ( revertTentativeChanges
                            , finalizeTentativeChanges
                            , removeFromTentativeInventory
                            , copyPristine
                            , copyPartialsPristine
                            , applyToTentativePristine
                            , addToTentativeInventory
                            , readRepo
                            , readTentativeRepo
                            , readRepoUsingSpecificInventory
                            , cleanPristine
                            , cleanInventories
                            , cleanPatches
                            )
import qualified Darcs.Repository.Old as Old
                            ( revertTentativeChanges
                            , readOldRepo
                            , oldRepoFailMsg
                            )
import Darcs.Repository.Flags
    ( Compression, Verbosity(..), UseCache(..), UpdateWorking (..), AllowConflicts (..), ExternalMerge (..)
    , WorkRepo (..), WithWorkingDir (WithWorkingDir) )
import Darcs.Patch.Witnesses.Eq ( EqCheck(..) )
import Darcs.Patch.Witnesses.Unsafe
    ( unsafeCoerceP, unsafeCoercePStart )
import Darcs.Patch.Witnesses.Ordered
    ( FL(..)
    , RL(..)
    , (:\/:)(..)
    , (:/\:)(..)
    , (:>)(..)
    , (+>+)
    , (+<+)
    , lengthFL
    , allFL
    , filterOutFLFL
    , reverseFL
    , mapFL_FL
    , concatFL
    , reverseRL
    , mapRL
    )
import Darcs.Patch.Witnesses.Sealed
    ( Sealed(Sealed)
    , seal
    , FlippedSeal(FlippedSeal)
    , flipSeal
    , mapSeal
    )
import Darcs.Patch.Permutations ( commuteWhatWeCanFL
                                , removeFL
                                )
import Darcs.Patch.Set ( PatchSet(..)
                       , SealedPatchSet
                       , newset2RL
                       , Origin
                       )
import Darcs.Patch.Depends ( removeFromPatchSet
                           , mergeThem
                           , splitOnTag
                           )
import Darcs.Patch.Show ( ShowPatch )
import Darcs.Util.Path
    ( FilePathLike
    , AbsolutePath
    , toFilePath
    , ioAbsoluteOrRemote
    , toPath
    , anchorPath
    )
import Darcs.Util.Exception ( catchall )
import Darcs.Util.File ( withCurrentDirectory )
import Darcs.Util.Prompt ( promptYorn )
import Darcs.Util.Progress ( debugMessage )
import Darcs.Patch.Progress (progressFL)
import Darcs.Util.URL ( isValidLocalPath )
import Darcs.Util.Workaround
    ( getCurrentDirectory
    , renameFile
    , setExecutable
    )
import Darcs.Repository.Prefs ( getCaches )
import Darcs.Util.Lock
    ( writeDocBinFile
    , removeFileMayNotExist
    )
import Darcs.Repository.InternalTypes( Repository(..)
                                     , Pristine(..)
                                     )
import Darcs.Util.Global ( darcsdir )

import System.Mem( performGC )

import Darcs.Util.Tree ( Tree )
import qualified Darcs.Util.Tree as Tree
import Darcs.Repository.PatchIndex ( createOrUpdatePatchIndexDisk, doesPatchIndexExist )
#include "impossible.h"

-- | The status of a given directory: is it a darcs repository?
data IdentifyRepo rt p wR wU wT
    = BadRepository String -- ^ looks like a repository with some error
    | NonRepository String -- ^ safest guess
    | GoodRepository (Repository rt p wR wU wT)

-- | Tries to identify the repository in a given directory
maybeIdentifyRepository :: UseCache -> String -> IO (IdentifyRepo rt p wR wU wT)
maybeIdentifyRepository useCache "." =
    do darcs <- doesDirectoryExist darcsdir
       if not darcs
        then return (NonRepository $ "Missing " ++ darcsdir ++ " directory")
        else do
        repoFormatOrError <- tryIdentifyRepoFormat "."
        here <- toPath `fmap` ioAbsoluteOrRemote "."
        case repoFormatOrError of
          Left err -> return $ NonRepository err
          Right rf ->
              case readProblem rf of
              Just err -> return $ BadRepository err
              Nothing -> do pris <- identifyPristine
                            cs <- getCaches useCache here
                            return $ GoodRepository $ Repo here rf pris cs
maybeIdentifyRepository useCache url' =
 do url <- toPath `fmap` ioAbsoluteOrRemote url'
    repoFormatOrError <- tryIdentifyRepoFormat url
    case repoFormatOrError of
      Left e -> return $ NonRepository e
      Right rf -> case readProblem rf of
                  Just err -> return $ BadRepository err
                  Nothing ->  do cs <- getCaches useCache url
                                 return $ GoodRepository $ Repo url rf NoPristine cs

identifyPristine :: IO Pristine
identifyPristine =
    do pristine <- doesDirectoryExist $ darcsdir++"/pristine"
       current  <- doesDirectoryExist $ darcsdir++"/current"
       hashinv  <- doesFileExist      $ darcsdir++"/hashed_inventory"
       case (pristine || current, hashinv) of
           (False, False) -> return NoPristine
           (True,  False) -> return PlainPristine
           (False, True ) -> return HashedPristine
           _ -> fail "Multiple pristine trees."

-- | identifyRepository identifies the repo at 'url'. Warning:
-- you have to know what kind of patches are found in that repo.
identifyRepository :: forall rt p wR wU wT. UseCache -> String
                           -> IO (Repository rt p wR wU wT)
identifyRepository useCache url =
    do er <- maybeIdentifyRepository useCache url
       case er of
         BadRepository s -> fail s
         NonRepository s -> fail s
         GoodRepository r -> return r

-- | @identifyRepositoryFor repo url@ identifies (and returns) the repo at 'url',
-- but fails if it is not compatible for reading from and writing to.
identifyRepositoryFor :: forall rt p wR wU wT vR vU vT. RepoPatch p
                      => Repository rt p wR wU wT
                      -> UseCache
                      -> String
                      -> IO (Repository rt p vR vU vT)
identifyRepositoryFor (Repo _ source _ _) useCache url =
    do Repo absurl target x c <- identifyRepository useCache url
       case transferProblem target source of
         Just e -> fail $ "Incompatibility with repository " ++ url ++ ":\n" ++ e
         Nothing -> return $ Repo absurl target x c

amInRepository :: WorkRepo -> IO (Either String ())
amInRepository (WorkRepoDir d) = do
       setCurrentDirectory d `catchall` fail ("can't set directory to "++d)
       status <- maybeIdentifyRepository YesUseCache "."
       case status of
         GoodRepository _ -> return (Right ())
         BadRepository  e -> return (Left $ "While " ++ d ++ " looks like a repository directory, we have a problem with it:\n" ++ e)
         NonRepository  _ -> return (Left "You need to be in a repository directory to run this command.")
amInRepository _ =
       fromMaybe (Left "You need to be in a repository directory to run this command.") <$> seekRepo

amInHashedRepository :: WorkRepo -> IO (Either String ())
amInHashedRepository wd
 = do inrepo <- amInRepository wd
      case inrepo of
       Right _ -> do pristine <- identifyPristine
                     case pristine of
                       HashedPristine -> return (Right ())
                       _ -> return (Left Old.oldRepoFailMsg)
       left    -> return left

repoPatchType :: Repository rt p wR wU wT -> PatchType rt p
repoPatchType _ = PatchType

-- | hunt upwards for the darcs repository
-- This keeps changing up one parent directory, testing at each
-- step if the current directory is a repository or not.  $
-- The result is:
--   Nothing, if no repository found
--   Just (Left errorMessage), if bad repository found
--   Just (Right ()), if good repository found.
-- WARNING this changes the current directory for good if matchFn succeeds
seekRepo :: IO (Maybe (Either String ()))
seekRepo = getCurrentDirectory >>= helper where
   helper startpwd = do
    status <- maybeIdentifyRepository YesUseCache "."
    case status of
      GoodRepository _ -> return . Just $ Right ()
      BadRepository e  -> return . Just $ Left e
      NonRepository _ ->
            do cd <- toFilePath `fmap` getCurrentDirectory
               setCurrentDirectory ".."
               cd' <- toFilePath `fmap` getCurrentDirectory
               if cd' /= cd
                  then helper startpwd
                  else do setCurrentDirectory startpwd
                          return Nothing

-- The performGC in this function is a workaround for a library/GHC bug,
-- http://hackage.haskell.org/trac/ghc/ticket/2924 -- (doesn't seem to be a
-- problem on fast machines, but virtual ones trip this from time to time)
amNotInRepository :: WorkRepo -> IO (Either String ())
amNotInRepository (WorkRepoDir d) = do
    createDirectoryIfMissing False d
       `catchall` (performGC >> createDirectoryIfMissing False d)
    -- note that the above could always fail
    setCurrentDirectory d
    amNotInRepository WorkRepoCurrentDir
amNotInRepository _ = do
       status <- maybeIdentifyRepository YesUseCache "."
       case status of
         GoodRepository _ -> return (Left "You may not run this command in a repository.")
         BadRepository e  -> return (Left $ "You may not run this command in a repository.\nBy the way, we have a problem with it:\n" ++ e)
         NonRepository _  -> return (Right ())

findRepository :: WorkRepo -> IO (Either String ())
findRepository (WorkRepoPossibleURL d) | isValidLocalPath d =
    do setCurrentDirectory d `catchall` fail ("can't set directory to "++d)
       findRepository WorkRepoCurrentDir
findRepository (WorkRepoDir d) =
    do setCurrentDirectory d `catchall` fail ("can't set directory to "++d)
       findRepository WorkRepoCurrentDir
findRepository _ = fromMaybe (Right ()) <$> seekRepo

-- TODO: see also Repository.State.readPendingLL ... to be removed after GHC 7.2
readNewPendingLL :: (RepoPatch p, ApplyState p ~ Tree)
              => Repository rt p wR wU wT -> IO (Sealed ((FL p) wT))
readNewPendingLL repo = mapSeal (mapFL_FL fromPrim) `fmap` readNewPending repo


-- | @makeNewPending repo YesUpdateWorking pendPs@ verifies that the
--   @pendPs@ could be applied to pristine if we wanted to, and if so
--   writes it to disk.  If it can't be applied, @pendPs@ must
--   be somehow buggy, so we save it for forensics and crash.
makeNewPending :: forall rt p wR wU wT wY. (RepoPatch p, ApplyState p ~ Tree)
                 => Repository rt p wR wU wT
                 -> UpdateWorking
                 -> FL (PrimOf p) wT wY
                 -> IO ()
makeNewPending _                  NoUpdateWorking _ = return ()
makeNewPending repo@(Repo r _ _ _) YesUpdateWorking origp =
    withCurrentDirectory r $
    do let newname = pendingName ++ ".new"
       debugMessage $ "Writing new pending:  " ++ newname
       Sealed sfp <- return $ siftForPending origp
       writeNewPending repo sfp
       cur <- readRecorded repo
       Sealed p <- readNewPendingLL repo -- :: IO (Sealed (FL (PrimOf p) wT))
       -- We don't ever use the resulting tree.
       _ <- catch (applyToTree p cur) $ \(err :: IOException) -> do
         let buggyname = pendingName ++ "_buggy"
         renameFile newname buggyname
         bugDoc $ text ("There was an attempt to write an invalid pending! " ++ show err)
                    $$ text "If possible, please send the contents of"
                    <+> text buggyname
                    $$ text "along with a bug report."
       renameFile newname pendingName
       debugMessage $ "Finished writing new pending:  " ++ newname

-- | @siftForPending ps@ simplifies the candidate pending patch @ps@
--   through a combination of looking for self-cancellations
--   (sequences of patches followed by their inverses), coalescing,
--   and getting rid of any hunk/binary patches we can commute out
--   the back
--
--   The visual image of sifting can be quite helpful here.  We are
--   repeatedly tapping (shrinking) the patch sequence and
--   shaking it (sift). Whatever falls out is the pending we want
--   to keep. We do this until the sequence looks about as clean as
--   we can get it
siftForPending :: forall prim wX wY . PrimPatch prim => FL prim wX wY -> Sealed (FL prim wX)
siftForPending simple_ps =
    if allFL (\p -> primIsAddfile p || primIsAdddir p) oldps
       then seal oldps
       else fromJust $ do
           Sealed x <- return $ sift NilFL $ reverseFL oldps
           return $ case tryToShrink x of
               ps | lengthFL ps < lengthFL oldps -> siftForPending ps
                  | otherwise -> seal ps
  where
    oldps = fromMaybe simple_ps $ tryShrinkingInverse $ crudeSift simple_ps
    -- get rid of any hunk/binary patches that we can commute out the
    -- back (ie. we work our way backwards, pushing the patches down
    -- to the very end and popping them off; so in (addfile f :> hunk)
    -- we can nuke the hunk, but not so in (hunk :> replace)
    sift :: FL prim wA wB -> RL prim wC wA -> Sealed (FL prim wC)
    sift sofar NilRL = seal sofar
    sift sofar (ps:<:p) | primIsHunk p || primIsBinary p =
        case commuteFLorComplain (p :> sofar) of
            Right (sofar' :> _) -> sift sofar'      ps
            Left _              -> sift (p:>:sofar) ps
    sift sofar (ps:<:p) = sift (p:>:sofar) ps

readTentativeRepo :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)
                  => Repository rt p wR wU wT
                  -> IO (PatchSet rt p Origin wT)
readTentativeRepo repo@(Repo r rf _ _)
    | formatHas HashedInventory rf = HashedRepo.readTentativeRepo repo r
    | otherwise = fail Old.oldRepoFailMsg

readRepoUsingSpecificInventory :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)
                               => String
                               -> Repository rt p wR wU wT
                               -> IO (PatchSet rt p Origin wT)
readRepoUsingSpecificInventory invPath repo@(Repo r rf _ _)
    | formatHas HashedInventory rf =
        HashedRepo.readRepoUsingSpecificInventory invPath repo r
    | otherwise = fail Old.oldRepoFailMsg

prefsUrl :: Repository rt p wR wU wT -> String
prefsUrl (Repo r _ _ _) = r ++ "/"++darcsdir++"/prefs"

unrevertUrl :: Repository rt p wR wU wT -> String
unrevertUrl (Repo r _ _ _) = r ++ "/"++darcsdir++"/patches/unrevert"

applyToWorking :: (ApplyState (PrimOf p) ~ Tree, RepoPatch p)
               => Repository rt p wR wU wT -> Verbosity -> FL (PrimOf p) wU wY
               -> IO (Repository rt p wR wY wT)
applyToWorking (Repo r rf t c) verb patch =
  do
    unless (formatHas NoWorkingDir rf) $
      withCurrentDirectory r $ if verb == Quiet
                               then runSilently $ apply patch
                               else runTolerantly $ apply patch
    return (Repo r rf t c)

-- | @tentativelyRemoveFromPending p@ is used by Darcs whenever it
--   adds a patch to the repository (eg. with apply or record).
--   Think of it as one part of transferring patches from pending to
--   somewhere else.
--
--   Question (Eric Kow): how do we detect patch equivalence?
tentativelyRemoveFromPending :: forall rt p wR wU wT wX wY. (RepoPatch p)
                 => Repository rt p wR wU wT
                 -> UpdateWorking
                 -> PatchInfoAnd rt p wX wY
                 -> IO ()
tentativelyRemoveFromPending _    NoUpdateWorking  _ = return ()
tentativelyRemoveFromPending repo YesUpdateWorking p = do
    Sealed pend <- readTentativePending repo
    -- Question (Eric Kow): why does pending being all simple matter for
    -- changepref patches in p? isSimple includes changepref, so what do
    -- adddir/etc have to do with it?  Why don't we we systematically
    -- crudeSift/not?
    let effectp = if isSimple pend
                     then crudeSift $ effect p
                     else effect p
    Sealed newpend <- return $ rmpend (progressFL "Removing from pending:" effectp)
                               (unsafeCoercePStart pend)
    writeTentativePending repo (unsafeCoercePStart newpend)
  where
    -- @rmpend effect pending@ removes as much of @effect@ from @pending@
    -- as possible
    --
    -- Note that @effect@ and @pending@ must start from the same context
    -- This is not a bad thing to assume because @effect@ is a patch we want to
    -- add to the repository anyway so it'd kind of have to start from wR anyway
    --
    -- Question (Eric Kow), ok then why not
    -- @PatchInfoAnd p wR wY@ in the type signature above?
    rmpend :: FL (PrimOf p) wA wB -> FL (PrimOf p) wA wC -> Sealed (FL (PrimOf p) wB)
    rmpend NilFL x = Sealed x
    rmpend _ NilFL = Sealed NilFL
    rmpend (x:>:xs) xys | Just ys <- removeFL x xys = rmpend xs ys
    rmpend (x:>:xs) ys =
        case commuteWhatWeCanFL (x:>xs) of
            a:>x':>b -> case rmpend a ys of
                Sealed ys' -> case commute (invert (x':>:b) :> ys') of
                    Just (ys'' :> _) -> seal ys''
                    Nothing          -> seal $ invert (x':>:b)+>+ys'
                    -- DJR: I don't think this last case should be
                    -- reached, but it also shouldn't lead to corruption.

-- | A sequence of primitive patches (candidates for the pending patch)
--   is considered simple if we can reason about their continued status as
--   pending patches solely on the basis of them being hunk/binary patches.
--
--   Simple here seems to mean that all patches are either hunk/binary
--   patches, or patches that cannot (indirectly) depend on hunk/binary
--   patches.  For now, the only other kinds of patches in this category
--   are changepref patches.
--
--   It might be tempting to add, say, adddir patches but it's probably not a
--   good idea because Darcs also inverts patches a lot in its reasoning so an
--   innocent addir may be inverted to a rmdir which in turn may depend on
--   a rmfile, which in turn depends on a hunk/binary. Likewise, we would
--   not want to add move patches to this category for similar reasons of
--   a potential dependency chain forming.
isSimple :: PrimPatch prim => FL prim wX wY -> Bool
isSimple =
    allFL isSimp
  where
    isSimp x = primIsHunk x || primIsBinary x || primIsSetpref x

-- | 'crudeSift' can be seen as a first pass approximation of 'siftForPending'
--    that works without having to do any commutation.  It either returns a
--    sifted pending (if the input is simple enough for this crude approach)
--    or has no effect.
crudeSift :: forall prim wX wY . PrimPatch prim => FL prim wX wY -> FL prim wX wY
crudeSift xs =
    if isSimple xs then filterOutFLFL ishunkbinary xs else xs
  where
    ishunkbinary :: prim wA wB -> EqCheck wA wB
    ishunkbinary x | primIsHunk x || primIsBinary x = unsafeCoerceP IsEq
                   | otherwise = NotEq

data HashedVsOld a = HvsO { old, hashed :: a }

decideHashedOrNormal :: Monad m => RepoFormat -> HashedVsOld (m a) -> m a
decideHashedOrNormal rf (HvsO { hashed = h, old = o })
    | formatHas HashedInventory rf = h
    | otherwise = o

data MakeChanges = MakeChanges | DontMakeChanges deriving ( Eq )

announceMergeConflicts :: (PrimPatch p, PatchInspect p)
                       => String
                       -> AllowConflicts
                       -> ExternalMerge
                       -> FL p wX wY
                       -> IO Bool
announceMergeConflicts cmd allowConflicts externalMerge resolved_pw =
  case nubSort $ listTouchedFiles resolved_pw of
    [] -> return False
    cfs -> if allowConflicts `elem` [YesAllowConflicts,YesAllowConflictsAndMark]
              || externalMerge /= NoExternalMerge
           then do putDocLnWith fancyPrinters $
                     redText "We have conflicts in the following files:" $$ text (unlines cfs)
                   return True
           else do putDocLnWith fancyPrinters $
                     redText "There are conflicts in the following files:" $$ text (unlines cfs)
                   fail $ "Refusing to "++cmd++" patches leading to conflicts.\n"++
                          "If you would rather apply the patch and mark the conflicts,\n"++
                          "use the --mark-conflicts or --allow-conflicts options to "++cmd++"\n"++
                          "These can set as defaults by adding\n"++
                          " "++cmd++" mark-conflicts\n"++
                          "to "++darcsdir++"/prefs/defaults in the target repo. "

checkUnrecordedConflicts :: forall rt p wT wY. RepoPatch p
                         => UpdateWorking
                         -> FL (WrappedNamed rt p) wT wY
                         -> IO Bool
checkUnrecordedConflicts NoUpdateWorking _
 = return False -- because we are called by `darcs convert` hence we don't care
checkUnrecordedConflicts _ pc =
    do repository <- identifyRepository NoUseCache "."
       cuc repository
    where cuc :: Repository rt p wR wU wT -> IO Bool
          cuc r = do Sealed (mpend :: FL (PrimOf p) wT wX) <- readPending r :: IO (Sealed (FL (PrimOf p) wT))
                     case mpend of
                       NilFL -> return False
                       pend ->
                           case merge (fromPrims_ pend :\/: fromPrims_ (concatFL $ mapFL_FL effect pc)) of
                           _ :/\: pend' ->
                               case listConflictedFiles pend' of
                               [] -> return False
                               fs -> do putStrLn ("You have conflicting local changes to:\n"
                                                 ++ unwords fs)
                                        confirmed <- promptYorn "Proceed?"
                                        unless confirmed $
                                             do putStrLn "Cancelled."
                                                exitSuccess
                                        return True
          fromPrims_ :: FL (PrimOf p) wA wB -> FL p wA wB
          fromPrims_ = fromPrims

tentativelyAddPatch :: (RepoPatch p, ApplyState p ~ Tree)
                    => Repository rt p wR wU wT
                    -> Compression
                    -> Verbosity
                    -> UpdateWorking
                    -> PatchInfoAnd rt p wT wY
                    -> IO (Repository rt p wR wU wY)
tentativelyAddPatch = tentativelyAddPatch_ UpdatePristine

data UpdatePristine = UpdatePristine 
                    | DontUpdatePristine
                    | DontUpdatePristineNorRevert deriving Eq

tentativelyAddPatches_
                     :: forall rt p wR wU wT wY
                      . (RepoPatch p, ApplyState p ~ Tree)
                     => UpdatePristine
                     -> Repository rt p wR wU wT
                     -> Compression
                     -> Verbosity
                     -> UpdateWorking
                     -> FL (PatchInfoAnd rt p) wT wY
                     -> IO (Repository rt p wR wU wY)
tentativelyAddPatches_ _up r _compr _verb _uw NilFL = return r
tentativelyAddPatches_ up r compr verb uw (p:>:ps) = do
    r' <- tentativelyAddPatch_ up r compr verb uw p
    tentativelyAddPatches_ up r' compr verb uw ps

-- TODO re-add a safety catch for --dry-run? Maybe using a global, like dryRun
-- :: Bool, with dryRun = unsafePerformIO $ readIORef ...
tentativelyAddPatch_ :: forall rt p wR wU wT wY
                      . (RepoPatch p, ApplyState p ~ Tree)
                     => UpdatePristine
                     -> Repository rt p wR wU wT
                     -> Compression
                     -> Verbosity
                     -> UpdateWorking
                     -> PatchInfoAnd rt p wT wY
                     -> IO (Repository rt p wR wU wY)

tentativelyAddPatch_ up r@(Repo dir rf t c) compr verb uw p =
    withCurrentDirectory dir $ do
       decideHashedOrNormal rf HvsO {
          hashed = void $ HashedRepo.addToTentativeInventory c compr p,
          old = fail Old.oldRepoFailMsg}
       when (up == UpdatePristine) $ do debugMessage "Applying to pristine cache..."
                                        applyToTentativePristine r verb p
                                        debugMessage "Updating pending..."
                                        tentativelyRemoveFromPending r uw p
       return (Repo dir rf t c)

applyToTentativePristine :: (ApplyState q ~ Tree, Effect q, Patchy q, ShowPatch q, PrimPatchBase q)
                         => Repository rt p wR wU wT
                         -> Verbosity
                         -> q wT wY
                         -> IO ()
applyToTentativePristine (Repo dir rf _ _) verb p =
    withCurrentDirectory dir $
    do when (verb == Verbose) $ putDocLn $ text "Applying to pristine..." <+> description p
       decideHashedOrNormal rf HvsO {hashed = HashedRepo.applyToTentativePristine p,
                                     old = fail Old.oldRepoFailMsg}

-- | @tentativelyAddToPending repo NoDryRun YesUpdateWorking pend ps@
--   appends @ps@ to the pending patch.
--
--   It has no effect with @NoUpdateWorking@.
--
--   This fuction is unsafe because it accepts a patch that works on the
--   tentative pending and we don't currently track the state of the
--   tentative pending.
tentativelyAddToPending :: forall rt p wR wU wT wX wY. RepoPatch p
                        => Repository rt p wR wU wT
                        -> UpdateWorking
                        -> FL (PrimOf p) wX wY
                        -> IO ()
tentativelyAddToPending _                   NoUpdateWorking  _     = return ()
tentativelyAddToPending repo@(Repo dir _ _ _) YesUpdateWorking patch =
    withCurrentDirectory dir $ do
        Sealed pend <- readTentativePending repo
        FlippedSeal newpend_ <- return $
            newpend (unsafeCoerceP pend :: FL (PrimOf p) wA wX) patch
        writeTentativePending repo (unsafeCoercePStart newpend_)
  where
    newpend :: FL prim wA wB -> FL prim wB wC -> FlippedSeal (FL prim) wC
    newpend NilFL patch_ = flipSeal patch_
    newpend p     patch_ = flipSeal $ p +>+ patch_

-- | setTentativePending is basically unsafe.  It overwrites the pending
--   state with a new one, not related to the repository state.
setTentativePending :: forall rt p wR wU wT wX wY. RepoPatch p
                    => Repository rt p wR wU wT
                    -> UpdateWorking
                    -> FL (PrimOf p) wX wY
                    -> IO ()
setTentativePending _                   NoUpdateWorking  _ = return ()
setTentativePending repo@(Repo dir _ _ _) YesUpdateWorking patch = do
    Sealed prims <- return $ siftForPending patch
    withCurrentDirectory dir $ writeTentativePending repo (unsafeCoercePStart prims)

-- | @prepend repo YesUpdateWorking ps@ prepends @ps@ to the pending patch
--   It's used right before removing @ps@ from the repo.  This ensures that
--   the pending patch can still be applied on top of the recorded state.
--
--   This function is basically unsafe.  It overwrites the pending state
--   with a new one, not related to the repository state.
prepend :: forall rt p wR wU wT wX wY. RepoPatch p
        => Repository rt p wR wU wT
        -> UpdateWorking
        -> FL (PrimOf p) wX wY
        -> IO ()
prepend _    NoUpdateWorking  _     = return ()
prepend repo YesUpdateWorking patch = do
    Sealed pend <- readTentativePending repo
    Sealed newpend_ <- return $ newpend (unsafeCoerceP pend) patch
    writeTentativePending repo (unsafeCoercePStart $ crudeSift newpend_)
  where
    newpend :: FL prim wB wC -> FL prim wA wB -> Sealed (FL prim wA)
    newpend NilFL patch_ = seal patch_
    newpend p     patch_ = seal $ patch_ +>+ p

tentativelyRemovePatches :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)
                         => Repository rt p wR wU wT
                         -> Compression
                         -> UpdateWorking
                         -> FL (PatchInfoAnd rt p) wX wT
                         -> IO (Repository rt p wR wU wX)
tentativelyRemovePatches = tentativelyRemovePatches_ UpdatePristine

tentativelyRemovePatches_ :: forall rt p wR wU wT wX
                           . (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)
                          => UpdatePristine
                          -> Repository rt p wR wU wT
                          -> Compression
                          -> UpdateWorking
                          -> FL (PatchInfoAnd rt p) wX wT
                          -> IO (Repository rt p wR wU wX)
tentativelyRemovePatches_ up repository@(Repo dir rf t c) compr uw ps =
    withCurrentDirectory dir $ do
      when (up == UpdatePristine) $ do debugMessage "Adding changes to pending..."
                                       prepend repository uw $ effect ps
      unless (up == DontUpdatePristineNorRevert) $ removeFromUnrevertContext repository ps
      debugMessage "Removing changes from tentative inventory..."
      if formatHas HashedInventory rf
        then do HashedRepo.removeFromTentativeInventory repository compr ps
                when (up == UpdatePristine) $
                     HashedRepo.applyToTentativePristine $
                     progressFL "Applying inverse to pristine" $ invert ps
        else fail Old.oldRepoFailMsg
      return (Repo dir rf t c)

-- FIXME this is a rather weird API. If called with a patch that isn't already
-- in the repo, it fails with an obscure error from 'commuteToEnd'. It also
-- ends up redoing the work that the caller has already done - if it has
-- already commuted these patches to the end, it must also know the commuted
-- versions of the other patches in the repo.
-- |Given a sequence of patches anchored at the end of the current repository,
-- actually pull them to the end of the repository by removing any patches
-- with the same name and then adding the passed in sequence.
-- Typically callers will have obtained the passed in sequence using
-- 'findCommon' and friends.
tentativelyReplacePatches :: forall rt p wR wU wT wX
                           . (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)
                          => Repository rt p wR wU wT
                          -> Compression
                          -> UpdateWorking
                          -> Verbosity
                          -> FL (PatchInfoAnd rt p) wX wT
                          -> IO ()
tentativelyReplacePatches repository compr uw verb ps =
    do let ps' = filterOutFLFL (namedIsInternal . hopefully) ps
       repository' <- tentativelyRemovePatches_ DontUpdatePristineNorRevert repository compr uw ps'
       mapAdd repository' ps'
  where mapAdd :: Repository rt p wM wL wI
               -> FL (PatchInfoAnd rt p) wI wJ
               -> IO ()
        mapAdd _ NilFL = return ()
        mapAdd r (a:>:as) =
               do r' <- tentativelyAddPatch_ DontUpdatePristine r compr verb uw a
                  mapAdd r' as

-- | Replace the pending patch with the tentative pending.
--   If @NoUpdateWorking@, this merely deletes the tentative pending
--   without replacing the current one.
--
--   Question (Eric Kow): shouldn't this also delete the tentative
--   pending if @YesUpdateWorking@?  I'm just puzzled by the seeming
--   inconsistency of the @NoUpdateWorking@ doing deletion, but
--   @YesUpdateWorking@ not bothering.
finalizePending :: (RepoPatch p, ApplyState p ~ Tree)
                => Repository rt p wR wU wT
                -> UpdateWorking
                -> IO ()
finalizePending (Repo dir _ _ _) NoUpdateWorking =
        withCurrentDirectory dir $ removeFileMayNotExist pendingName
finalizePending repository@(Repo dir _ _ _) updateWorking@YesUpdateWorking =
  withCurrentDirectory dir $ do
      Sealed tpend <- readTentativePending repository
      Sealed new_pending <- return $ siftForPending tpend
      makeNewPending repository updateWorking new_pending

finalizeRepositoryChanges :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)
                          => Repository rt p wR wU wT
                          -> UpdateWorking
                          -> Compression
                          -> IO ()
finalizeRepositoryChanges repository@(Repo dir rf _ _) updateWorking compr
    | formatHas HashedInventory rf =
        withCurrentDirectory dir $ do
            debugMessage "Finalizing changes..."
            withSignalsBlocked $ do
                 HashedRepo.finalizeTentativeChanges repository compr
                 finalizePending repository updateWorking
            debugMessage "Done finalizing changes..."
            doesPatchIndexExist dir >>= (`when` createOrUpdatePatchIndexDisk repository)
            updateIndex repository
    | otherwise = fail Old.oldRepoFailMsg

-- TODO: rename this and document the transaction protocol (revert/finalize)
-- clearly.
-- |Slightly confusingly named: as well as throwing away any tentative
-- changes, revertRepositoryChanges also re-initialises the tentative state.
-- It's therefore used before makign any changes to the repo.
revertRepositoryChanges :: RepoPatch p
                        => Repository rt p wR wU wT
                        -> UpdateWorking
                        -> IO ()
revertRepositoryChanges r@(Repo dir rf _ _) uw =
    withCurrentDirectory dir $
    do removeFileMayNotExist (pendingName ++ ".tentative")
       Sealed x <- readPending r
       setTentativePending r uw x
       when (uw == NoUpdateWorking) $ removeFileMayNotExist pendingName
       decideHashedOrNormal rf HvsO { hashed = HashedRepo.revertTentativeChanges,
                                      old = Old.revertTentativeChanges }

removeFromUnrevertContext :: forall rt p wR wU wT wX
                           . (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)
                          => Repository rt p wR wU wT
                          -> FL (PatchInfoAnd rt p) wX wT
                          -> IO ()
removeFromUnrevertContext repository ps = do
  Sealed bundle <- unrevert_patch_bundle `catchall` return (seal (PatchSet NilRL NilRL))
  remove_from_unrevert_context_ bundle
  where unrevert_impossible =
            do confirmed <- promptYorn "This operation will make unrevert impossible!\nProceed?"
               if confirmed then removeFileMayNotExist (unrevertUrl repository)
                            else fail "Cancelled."
        unrevert_patch_bundle :: IO (SealedPatchSet rt p Origin)
        unrevert_patch_bundle = do pf <- B.readFile (unrevertUrl repository)
                                   case scanBundle pf of
                                     Right foo -> return foo
                                     Left err -> fail $ "Couldn't parse unrevert patch:\n" ++ err
        remove_from_unrevert_context_ :: PatchSet rt p Origin wZ -> IO ()
        remove_from_unrevert_context_ (PatchSet NilRL NilRL) = return ()
        remove_from_unrevert_context_ bundle =
         do debugMessage "Adjusting the context of the unrevert changes..."
            debugMessage $ "Removing "++ show (lengthFL ps) ++
                                  " patches in removeFromUnrevertContext!"
            ref <- readTentativeRepo repository
            let withSinglet :: Sealed (FL ppp wXxx)
                            -> (forall wYyy . ppp wXxx wYyy -> IO ()) -> IO ()
                withSinglet (Sealed (x :>: NilFL)) j = j x
                withSinglet _ _ = return ()
            withSinglet (mergeThem ref bundle) $ \h_us ->
                  case commuteRL (reverseFL ps :> h_us) of
                    Nothing -> unrevert_impossible
                    Just (us' :> _) ->
                      case removeFromPatchSet ps ref of
                      Nothing -> unrevert_impossible
                      Just common ->
                          do debugMessage "Have now found the new context..."
                             bundle' <- makeBundleN Nothing common (hopefully us':>:NilFL)
                             writeDocBinFile (unrevertUrl repository) bundle'
            debugMessage "Done adjusting the context of the unrevert changes!"

cleanRepository :: RepoPatch p => Repository rt p wR wU wT -> IO ()
cleanRepository repository@(Repo _ rf _ _) =
    decideHashedOrNormal rf
    HvsO { hashed = cleanHashedRepo repository,
           old = fail Old.oldRepoFailMsg}
           where
            cleanHashedRepo r = do
              HashedRepo.cleanPristine r
              HashedRepo.cleanInventories r
              HashedRepo.cleanPatches r


-- | grab the pristine hash of _darcs/hash_inventory, and retrieve whole pristine tree,
--   possibly writing a clean working copy in the process.
createPristineDirectoryTree :: RepoPatch p => Repository rt p wR wU wT -> FilePath -> WithWorkingDir -> IO ()
createPristineDirectoryTree (Repo r rf _ c) reldir wwd
    | formatHas HashedInventory rf =
        do createDirectoryIfMissing True reldir
           withCurrentDirectory reldir $ HashedRepo.copyPristine c r (darcsdir++"/hashed_inventory") wwd
    | otherwise = fail Old.oldRepoFailMsg

-- fp below really should be FileName
-- | Used by the commands dist and diff
createPartialsPristineDirectoryTree :: (FilePathLike fp, RepoPatch p)
                                    => Repository rt p wR wU wT
                                    -> [fp]
                                    -> FilePath
                                    -> IO ()
createPartialsPristineDirectoryTree (Repo r rf _ c) prefs dir
    | formatHas HashedInventory rf =
        do createDirectoryIfMissing True dir
           withCurrentDirectory dir $
               HashedRepo.copyPartialsPristine c r (darcsdir++"/hashed_inventory") prefs
    | otherwise = fail Old.oldRepoFailMsg

withRecorded :: RepoPatch p
             => Repository rt p wR wU wT
             -> ((AbsolutePath -> IO a) -> IO a)
             -> (AbsolutePath -> IO a)
             -> IO a
withRecorded repository mk_dir f
    = mk_dir $ \d -> do createPristineDirectoryTree repository (toFilePath d) WithWorkingDir
                        f d

withTentative :: forall rt p a wR wU wT. (RepoPatch p, ApplyState p ~ Tree)
              => Repository rt p wR wU wT
              -> ((AbsolutePath -> IO a) -> IO a)
              -> (AbsolutePath -> IO a)
              -> IO a
withTentative (Repo dir rf _ c) mk_dir f
    | formatHas HashedInventory rf =
        mk_dir $ \d -> do HashedRepo.copyPristine
                              c
                              dir
                              (darcsdir++"/tentative_pristine")
                              WithWorkingDir
                          f d
withTentative repository@(Repo dir _ _ _) mk_dir f =
    withRecorded repository mk_dir $ \d ->
    do Sealed ps <- read_patches (dir ++ "/"++darcsdir++"/tentative_pristine")
       runDefault $ apply ps
       f d
    where read_patches :: FilePath -> IO (Sealed (FL p wX))
          read_patches fil = do ps <- B.readFile fil
                                return $ fromMaybe (seal NilFL) $ readPatch ps

-- | Sets scripts in or below the current directory executable.
--   A script is any file that starts with the bytes '#!'.
--   This is used for --set-scripts-executable.
setScriptsExecutable_ :: PatchInspect p => Maybe (p wX wY) -> IO ()
setScriptsExecutable_ pw = do
    debugMessage "Making scripts executable"
    tree <- readWorking
    paths <- case pw of
          Just ps -> filterM doesFileExist $ listTouchedFiles ps
          Nothing -> return [ anchorPath "." p | (p, Tree.File _) <- Tree.list tree ]
    let setExecutableIfScript f =
              do contents <- B.readFile f
                 when (BC.pack "#!" `B.isPrefixOf` contents) $ do
                   debugMessage ("Making executable: " ++ f)
                   setExecutable f True
    mapM_ setExecutableIfScript paths

setScriptsExecutable :: IO ()
setScriptsExecutable = setScriptsExecutable_ (Nothing :: Maybe (FL DummyPatch wX wY))

setScriptsExecutablePatches :: PatchInspect p => p wX wY -> IO ()
setScriptsExecutablePatches = setScriptsExecutable_ . Just


-- | Writes out a fresh copy of the inventory that minimizes the
-- amount of inventory that need be downloaded when people pull from
-- the repository.
--
-- Specifically, it breaks up the inventory on the most recent tag.
-- This speeds up most commands when run remotely, both because a
-- smaller file needs to be transfered (only the most recent
-- inventory).  It also gives a guarantee that all the patches prior
-- to a given tag are included in that tag, so less commutation and
-- history traversal is needed.  This latter issue can become very
-- important in large repositories.
reorderInventory :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)
                 => Repository rt p wR wU wR
                 -> Compression
                 -> UpdateWorking
                 -> Verbosity
                 -> IO ()
reorderInventory repository@(Repo _ rf _ _) compr uw verb =
    decideHashedOrNormal rf HvsO {
    hashed = do
        debugMessage "Reordering the inventory."
        PatchSet _ ps <- misplacedPatches `fmap` readRepo repository
        tentativelyReplacePatches repository compr uw verb $ reverseRL ps
        HashedRepo.finalizeTentativeChanges repository compr
        debugMessage "Done reordering the inventory.",
    old = fail Old.oldRepoFailMsg }

-- | Returns the patches that make the most recent tag dirty.
misplacedPatches :: forall rt p wS wX . RepoPatch p
                 => PatchSet rt p wS wX
                 -> PatchSet rt p wS wX
misplacedPatches ps = 
        -- Filter the repository keeping only with the tags, ordered from the
        -- most recent.
        case filter isTag $ mapRL info $ newset2RL ps of
                [] -> ps
                (lt:_) -> 
                    -- Take the most recent tag, and split the repository in,
                    -- the clean PatchSet "up to" the tag (ts), and a RL of
                    -- patches after the tag (r).
                    case splitOnTag lt ps of
                        Just (PatchSet ts xs :> r) -> PatchSet ts (xs+<+r)
                        _ -> impossible -- Because the tag is in ps.

-- @todo: we should not have to open the result of HashedRepo and
-- seal it.  Instead, update this function to work with type witnesses
-- by fixing DarcsRepo to match HashedRepo in the handling of
-- Repository state.
readRepo :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)
         => Repository rt p wR wU wT
         -> IO (PatchSet rt p Origin wR)
readRepo repo@(Repo r rf _ _)
    | formatHas HashedInventory rf = HashedRepo.readRepo repo r
    | otherwise = do Sealed ps <- Old.readOldRepo r
                     return $ unsafeCoerceP ps

-- | XOR of all hashes of the patches' metadata.
-- It enables to quickly see whether two repositories
-- have the same patches, independently of their order.
-- It relies on the assumption that the same patch cannot
-- be present twice in a repository.
-- This checksum is not cryptographically secure,
-- see http://robotics.stanford.edu/~xb/crypto06b/ .
repoXor :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)
        => Repository rt p wR wU wR -> IO SHA1
repoXor repo = do
  hashes <- mapRL (makePatchname . info) . newset2RL <$> readRepo repo
  return $ foldl' sha1Xor zero hashes