-- 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.

{-# OPTIONS_GHC -cpp -fglasgow-exts #-}
{-# LANGUAGE CPP, ScopedTypeVariables, Rank2Types, RankNTypes, PatternGuards #-}

#include "gadts.h"

module Darcs.Repository.Internal ( Repository(..), RepoType(..), RIO(unsafeUnRIO), ($-),
                    maybeIdentifyRepository, identifyDarcs1Repository, identifyRepositoryFor,
                    IdentifyRepo(..),
                    findRepository, amInRepository, amNotInRepository,
                    revertRepositoryChanges,
                    announceMergeConflicts, setTentativePending,
                    checkUnrecordedConflicts,
                    withRecorded,
                    readRepo, readTentativeRepo,
                    prefsUrl, makePatchLazy,
                    withRepoLock, withRepoReadLock,
                    withRepository, withRepositoryDirectory, withGutsOf,
                    tentativelyAddPatch, tentativelyRemovePatches, tentativelyAddToPending,
                    tentativelyAddPatch_,
                    tentativelyReplacePatches,
                    finalizeRepositoryChanges,
                    unrevertUrl,
                    applyToWorking, patchSetToPatches,
                    createPristineDirectoryTree, createPartialsPristineDirectoryTree,
                    optimizeInventory, cleanRepository,
                    getMarkedupFile,
                    PatchSet, SealedPatchSet,
                    setScriptsExecutable,
                    getRepository, rIO,
                    testTentative, testRecorded,
                    UpdatePristine(..), MakeChanges(..), applyToTentativePristine,
                    makeNewPending
                  ) where

import Printer ( putDocLn, (<+>), text, ($$) )

import Darcs.Repository.Prefs ( getPrefval )
import Darcs.Repository.State ( readRecorded, readWorking )
import Darcs.Repository.LowLevel ( readPending, pendingName, readPrims, readPendingfile )
import System.Exit ( ExitCode(..), exitWith )
import System.Cmd ( system )
import Darcs.External ( clonePartialsTree )
import Darcs.IO ( runTolerantly, runSilently )
import Darcs.Repository.Pristine ( identifyPristine, nopristine,
                                   easyCreatePristineDirectoryTree,
                                   easyCreatePartialsPristineDirectoryTree )

import Darcs.SignalHandler ( withSignalsBlocked )
import Darcs.Repository.Format ( RepoFormat, RepoProperty( Darcs2, HashedInventory ),
                                 identifyRepoFormat, formatHas,
                                 writeProblem, readProblem, readfromAndWritetoProblem )
import System.Directory ( doesDirectoryExist, setCurrentDirectory,
                          createDirectoryIfMissing )
import Control.Monad ( liftM, when, unless )
import Workaround ( getCurrentDirectory, renameFile, setExecutable )

import ByteStringUtils ( gzReadFilePS )
import qualified Data.ByteString as B ( empty, readFile, isPrefixOf )
import qualified Data.ByteString.Char8 as BC (pack)

import Darcs.Patch ( Patch, RealPatch, Effect, primIsHunk, primIsBinary, description,

                     tryToShrink, commuteFLorComplain, commute )
import Darcs.Patch.Prim ( tryShrinkingInverse )
import Darcs.Patch.Bundle ( scanBundle, makeBundleN )
import Darcs.Hopefully ( PatchInfoAnd, info,
                         hopefully, hopefullyM )
import Darcs.Repository.ApplyPatches ( applyPatches )
import qualified Darcs.Repository.HashedRepo as HashedRepo
                            ( revertTentativeChanges, finalizeTentativeChanges,
                              removeFromTentativeInventory,
                              copyPristine, copyPartialsPristine,
                              applyToTentativePristine,
                              writeTentativeInventory, writeAndReadPatch,
                              addToTentativeInventory,
                              readRepo, readTentativeRepo, cleanPristine )
import qualified Darcs.Repository.DarcsRepo as DarcsRepo
import Darcs.Flags ( DarcsFlag(Verbose, Quiet,
                               MarkConflicts, AllowConflicts, NoUpdateWorking,
                               WorkRepoUrl, WorkRepoDir, UMask, Test, LeaveTestDir,
                               SetScriptsExecutable, DryRun ),
                     wantExternalMerge, compression )
import Darcs.Witnesses.Ordered ( FL(..), RL(..), EqCheck(..), unsafeCoerceP,
                             (:\/:)(..), (:/\:)(..), (:>)(..),
                             (+>+), lengthFL,
                             allFL, filterFLFL,
                             reverseFL, mapFL_FL, concatFL )
import Darcs.Patch ( RepoPatch, Patchy, Prim, merge,
                     joinPatches,
                     listConflictedFiles, listTouchedFiles,
                     Named, patchcontents,
                     commuteRL, fromPrims,
                     readPatch,
                     writePatch, effect, invert,
                     primIsAddfile, primIsAdddir,
                     primIsSetpref,
                     apply, applyToTree,
                     emptyMarkedupFile, MarkedUpFile
                   )
import Darcs.Patch.Permutations ( commuteWhatWeCanFL, removeFL )
import Darcs.Patch.Info ( PatchInfo )
import Darcs.Patch.Set ( PatchSet(..), SealedPatchSet, newset2FL )
#ifdef GADT_WITNESSES
import Darcs.Patch.Set ( Origin )
#endif
import Darcs.Patch.Apply ( markupFile, LineMark(None) )
import Darcs.Patch.Depends ( deepOptimizePatchset, removeFromPatchSet, mergeThem )
import Darcs.RepoPath ( FilePathLike, AbsolutePath, toFilePath,
                        ioAbsoluteOrRemote, toPath )
import Darcs.Utils ( promptYorn, catchall, withCurrentDirectory, withUMask, nubsort )
import Progress ( debugMessage )
import Darcs.ProgressPatches (progressFL)
import Darcs.URL ( isFile )
import Darcs.Repository.Prefs ( getCaches )
import Darcs.Lock ( withLock, writeDocBinFile, removeFileMayNotExist,
                    withTempDir, withPermDir )
import Darcs.Witnesses.Sealed ( Sealed(Sealed), seal, FlippedSeal(FlippedSeal), flipSeal )
import Darcs.Repository.InternalTypes( Repository(..), RepoType(..) )
import Darcs.Global ( darcsdir )

import System.Mem( performGC )

import qualified Storage.Hashed.Tree as Tree
import Storage.Hashed.AnchoredPath( anchorPath )

#include "impossible.h"

-- | Repository IO monad.  This monad-like datatype is responsible for
-- sequencing IO actions that modify the tentative recorded state of
-- the repository.
newtype RIO p C(r u t t1) a = RIO {
        unsafeUnRIO :: Repository p C(r u t) -> IO a -- ^ converts @RIO a@ to @IO a@.
   }

-- | This is just like @>>=@ from the Monad class except that it
-- respects type witness safe repository transformations.  Even so, it
-- only tracks modifications to the tentative recorded state.
(>>>=) :: RIO p C(r u t t1) a -> (a -> RIO p C(r u t1 t2) b) -> RIO p C(r u t t2) b
m >>>= k = RIO $ \ (Repo x y z w) ->
             do a <- unsafeUnRIO m (Repo x y z w)
                unsafeUnRIO (k a) (Repo x y z w)

-- | This corresponds to @>>@ from the Monad class.
(>>>) :: RIO p C(r u t t1) a -> RIO p C(r u t1 t2) b -> RIO p C(r u t t2) b
a >>> b = a >>>= (const b)

-- | This corresponds to @return@ from the Monad class.
returnR :: a -> RIO p C(r u t t) a
returnR = rIO . return

-- | This the @RIO@ equivalent of @liftIO@.
rIO :: IO a -> RIO p C(r u t t) a
rIO = RIO . const

instance Functor (RIO p C(r u t t)) where
    fmap f m = RIO $ \r -> fmap f (unsafeUnRIO m r)

-- | We have an instance of Monad so that IO actions that do not
-- change the tentative recorded state are convenient in the IO monad.
instance Monad (RIO p C(r u t t)) where
 (>>=) = (>>>=)
 (>>) = (>>>)
 return = returnR
 fail = rIO . fail

-- | Similar to the @ask@ function of the MonadReader class.
-- This allows actions in the RIO monad to get the current
-- repository.
-- FIXME: Don't export this.  If we don't export this
-- it makes it harder for arbitrary IO actions to access
-- the repository and hence our code is easier to audit.
getRepository :: RIO p C(r u t t) (Repository p C(r u t))
getRepository = RIO return

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

maybeIdentifyRepository :: [DarcsFlag] -> String -> IO (IdentifyRepo p C(r u t))
maybeIdentifyRepository opts "." =
    do darcs <- doesDirectoryExist darcsdir
       rf_or_e <- identifyRepoFormat "."
       here <- toPath `fmap` ioAbsoluteOrRemote "."
       case rf_or_e of
         Left err -> return $ NonRepository err
         Right rf ->
             case readProblem rf of
             Just err -> return $ BadRepository err
             Nothing -> if darcs then do pris <- identifyPristine
                                         cs <- getCaches opts here
                                         return $ GoodRepository $ Repo here opts rf (DarcsRepository pris cs)
                                 else return (NonRepository "Not a repository")
maybeIdentifyRepository opts url' =
 do url <- toPath `fmap` ioAbsoluteOrRemote url'
    rf_or_e <- identifyRepoFormat url
    case rf_or_e of
      Left e -> return $ NonRepository e
      Right rf -> case readProblem rf of
                  Just err -> return $ BadRepository err
                  Nothing ->  do cs <- getCaches opts url
                                 return $ GoodRepository $ Repo url opts rf (DarcsRepository nopristine cs)

identifyDarcs1Repository :: [DarcsFlag] -> String -> IO (Repository Patch C(r u t))
identifyDarcs1Repository opts url =
    do er <- maybeIdentifyRepository opts url
       case er of
         BadRepository s -> fail s
         NonRepository s -> fail s
         GoodRepository r -> return r

identifyRepositoryFor :: forall p C(r u t). RepoPatch p => Repository p C(r u t) -> String -> IO (Repository p C(r u t))
identifyRepositoryFor (Repo _ opts rf _) url =
    do Repo absurl _ rf_ t <- identifyDarcs1Repository opts url
       let t' = case t of DarcsRepository x c -> DarcsRepository x c
       case readfromAndWritetoProblem rf_ rf of
         Just e -> fail $ "Incompatibility with repository " ++ url ++ ":\n" ++ e
         Nothing -> return $ Repo absurl opts rf_ t'

amInRepository :: [DarcsFlag] -> IO (Either String ())
amInRepository (WorkRepoDir d:_) =
    do setCurrentDirectory d `catchall` (fail $ "can't set directory to "++d)
       status <- maybeIdentifyRepository [] "."
       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 (_:fs) = amInRepository fs
amInRepository [] =
    seekRepo (Left "You need to be in a repository directory to run this command.")

-- | 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.  $
-- WARNING this changes the current directory for good if matchFn succeeds
seekRepo :: Either String ()
            -- ^ what to return if we don't find a repository
         -> IO (Either String ())
seekRepo onFail = getCurrentDirectory >>= helper where
   helper startpwd = do
    status <- maybeIdentifyRepository [] "."
    case status of
      GoodRepository _ -> return (Right ())
      BadRepository e  -> return (Left e)
      NonRepository _ ->
            do cd <- toFilePath `fmap` getCurrentDirectory
               setCurrentDirectory ".."
               cd' <- toFilePath `fmap` getCurrentDirectory
               if cd' /= cd
                  then helper startpwd
                  else do setCurrentDirectory startpwd
                          return onFail

-- 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 :: [DarcsFlag] -> 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 []
amNotInRepository (_:f) = amNotInRepository f
amNotInRepository [] =
    do status <- maybeIdentifyRepository [] "."
       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 :: [DarcsFlag] -> IO (Either String ())
findRepository (WorkRepoUrl d:_) | isFile d =
    do setCurrentDirectory d `catchall` (fail $ "can't set directory to "++d)
       findRepository []
findRepository (WorkRepoDir d:_) =
    do setCurrentDirectory d `catchall` (fail $ "can't set directory to "++d)
       findRepository []
findRepository (_:fs) = findRepository fs
findRepository [] = seekRepo (Right ())

makeNewPending :: forall p C(r u t y). RepoPatch p
                 => Repository p C(r u t) -> FL Prim C(t y) -> IO ()
makeNewPending (Repo _ opts _ _) _ | NoUpdateWorking `elem` opts = return ()
makeNewPending repo@(Repo r _ _ tp) origp =
    withCurrentDirectory r $
    do let newname = pendingName tp ++ ".new"
       debugMessage $ "Writing new pending:  " ++ newname
       Sealed sfp <- return $ siftForPending origp
       writeSealedPatch newname $ seal $ fromPrims $ sfp
       cur <- readRecorded repo
       Sealed p <- readPendingfile newname
       catch (applyToTree p cur) $ \err -> do
         let buggyname = pendingName tp ++ "_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 tp)
       debugMessage $ "Finished writing new pending:  " ++ newname
    where writeSealedPatch :: FilePath -> Sealed (Patch C(x)) -> IO ()
          writeSealedPatch fp (Sealed p) = writePatch fp p

siftForPending :: FL Prim C(x y) -> Sealed (FL Prim C(x))
siftForPending simple_ps =
 let oldps = maybe simple_ps id $ tryShrinkingInverse $ crudeSift simple_ps
 in if allFL (\p -> primIsAddfile p || primIsAdddir p) $ oldps
    then seal oldps
    else fromJust $ do
      Sealed x <- return $ sfp NilFL $ reverseFL oldps
      return (case tryToShrink x of
              ps | lengthFL ps < lengthFL oldps -> siftForPending ps
                 | otherwise -> seal ps)
      where sfp :: FL Prim C(a b) -> RL Prim C(c a) -> Sealed (FL Prim C(c))
            sfp sofar NilRL = seal sofar
            sfp sofar (p:<:ps)
                | primIsHunk p || primIsBinary p
                    = case commuteFLorComplain (p :> sofar) of
                      Right (sofar' :> _) -> sfp sofar' ps
                      Left _ -> sfp (p:>:sofar) ps
            sfp sofar (p:<:ps) = sfp (p:>:sofar) 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 :: RepoPatch p => Repository p C(r u t) -> IO (PatchSet p C(Origin r))
readRepo repo@(Repo r opts rf _)
    | formatHas HashedInventory rf =  do ps <- HashedRepo.readRepo repo r
                                         return ps
    | otherwise = do Sealed ps <- DarcsRepo.readRepo opts r
                     return $ unsafeCoerceP ps

readTentativeRepo :: RepoPatch p => Repository p C(r u t) -> IO (PatchSet p C(Origin t))
readTentativeRepo repo@(Repo r opts rf _)
    | formatHas HashedInventory rf = do  ps <- HashedRepo.readTentativeRepo repo r
                                         return ps
    | otherwise = do Sealed ps <- DarcsRepo.readTentativeRepo opts r
                     return $ unsafeCoerceP ps

makePatchLazy :: RepoPatch p => Repository p C(r u t) -> PatchInfoAnd p C(x y) -> IO (PatchInfoAnd p C(x y))
makePatchLazy (Repo r opts rf (DarcsRepository _ c)) p
    | formatHas HashedInventory rf = withCurrentDirectory r $ HashedRepo.writeAndReadPatch c (compression opts) p
    | otherwise = withCurrentDirectory r $ DarcsRepo.writeAndReadPatch opts p

prefsUrl :: Repository p C(r u t) -> String
prefsUrl (Repo r _ _ (DarcsRepository _ _)) = r ++ "/"++darcsdir++"/prefs"

unrevertUrl :: Repository p C(r u t) -> String
unrevertUrl (Repo r _ _ (DarcsRepository _ _)) = r ++ "/"++darcsdir++"/patches/unrevert"

applyToWorking :: Patchy p => Repository p1 C(r u t) -> [DarcsFlag] -> p C(u y) -> IO (Repository p1 C(r y t))
applyToWorking (Repo r ropts rf (DarcsRepository t c)) opts patch =
    do withCurrentDirectory r $ if Quiet `elem` opts
                                then runSilently $ apply opts patch
                                else runTolerantly $ apply opts patch
       return (Repo r ropts rf (DarcsRepository t c))

handlePendForAdd :: forall p q C(r u t x y). (RepoPatch p, Effect q)
                    => Repository p C(r u t) -> q C(x y) -> IO ()
handlePendForAdd (Repo _ opts _ _) _ | NoUpdateWorking `elem` opts = return ()
handlePendForAdd (Repo _ _ _ rt) p =
    do let pn = pendingName rt ++ ".tentative"
       Sealed pend <- (readPrims `fmap` gzReadFilePS pn) `catchall` (return $ Sealed NilFL)
       let effectp = if allFL isSimple pend then crudeSift $ effect p
                                             else effect p
       Sealed newpend <- return $ rmpend (progressFL "Removing from pending:" effectp) pend
       writePatch pn $ fromPrims_ newpend
    where rmpend :: FL Prim C(a b) -> FL Prim C(a c) -> Sealed (FL Prim C(b))
          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.
          fromPrims_ :: FL Prim C(a b) -> Patch C(a b)
          fromPrims_ = fromPrims

isSimple :: Prim C(x y) -> Bool
isSimple x = primIsHunk x || primIsBinary x || primIsSetpref x

crudeSift :: FL Prim C(x y) -> FL Prim C(x y)
crudeSift xs = if allFL isSimple xs then filterFLFL ishunkbinary xs else xs
    where ishunkbinary :: Prim C(x y) -> EqCheck C(x y)
          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 :: String -> [DarcsFlag] -> FL Prim C(x y) -> IO Bool
announceMergeConflicts cmd opts resolved_pw =
    case nubsort $ listTouchedFiles $ resolved_pw of
    [] -> return False
    cfs -> if MarkConflicts `elem` opts || AllowConflicts `elem` opts
              || wantExternalMerge opts /= Nothing
           then do putStrLn "We have conflicts in the following files:"
                   putStrLn $ unwords cfs
                   return True
           else do putStrLn "There are conflicts in the following files:"
                   putStrLn $ unwords 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 p C(t y). RepoPatch p => [DarcsFlag] -> FL (Named p) C(t y) -> IO Bool
checkUnrecordedConflicts opts _ | NoUpdateWorking `elem` opts = return False
checkUnrecordedConflicts opts pc =
    do repository <- identifyDarcs1Repository opts "."
       cuc repository
    where cuc :: Repository Patch C(r u t) -> IO Bool
          cuc r = do Sealed mpend <- readPending r :: IO (Sealed (FL Prim C(t)))
                     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)
                                        yorn <- promptYorn "Proceed?"
                                        when (yorn /= 'y') $
                                             do putStrLn "Cancelled."
                                                exitWith ExitSuccess
                                        return True
          fromPrims_ :: FL Prim C(a b) -> p C(a b)
          fromPrims_ = fromPrims

tentativelyAddPatch :: RepoPatch p
                    => Repository p C(r u t) -> [DarcsFlag] -> PatchInfoAnd p C(t y) -> IO (Repository p C(r u y))
tentativelyAddPatch = tentativelyAddPatch_ UpdatePristine

data UpdatePristine = UpdatePristine | DontUpdatePristine deriving Eq

tentativelyAddPatch_ :: RepoPatch p
                     => UpdatePristine -> Repository p C(r u t) -> [DarcsFlag]
                     -> PatchInfoAnd p C(t y) -> IO (Repository p C(r u y))
tentativelyAddPatch_ _ _ opts _
    | DryRun `elem` opts = bug "tentativelyAddPatch_ called when --dry-run is specified"
tentativelyAddPatch_ up r@(Repo dir ropts rf (DarcsRepository t c)) opts p =
    withCurrentDirectory dir $
    do decideHashedOrNormal rf $ HvsO {
          hashed = HashedRepo.addToTentativeInventory c (compression opts) p,
          old = DarcsRepo.addToTentativeInventory opts (hopefully p) }
       when (up == UpdatePristine) $ do debugMessage "Applying to pristine cache..."
                                        applyToTentativePristine r p
                                        debugMessage "Updating pending..."
                                        handlePendForAdd r p
       return (Repo dir ropts rf (DarcsRepository t c))

applyToTentativePristine :: (Effect q, Patchy q) => Repository p C(r u t) -> q C(t y) -> IO ()
applyToTentativePristine (Repo dir opts rf (DarcsRepository _ c)) p =
    withCurrentDirectory dir $
    do when (Verbose `elem` opts) $ putDocLn $ text "Applying to pristine..." <+> description p
       decideHashedOrNormal rf $ HvsO {hashed = HashedRepo.applyToTentativePristine opts p,
                                       old = DarcsRepo.addToTentativePristine p}

-- | 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 p C(r u t x y). RepoPatch p
                        => Repository p C(r u t) -> [DarcsFlag] -> FL Prim C(x y) -> IO ()
tentativelyAddToPending (Repo _ opts _ _) _ _
    | NoUpdateWorking `elem` opts = return ()
    | DryRun `elem` opts = bug "tentativelyAddToPending called when --dry-run is specified"
tentativelyAddToPending (Repo dir _ _ rt) _ patch =
    withCurrentDirectory dir $ do
      let pn = pendingName rt
          tpn = pn ++ ".tentative"
      Sealed pend <- readPrims `liftM` (gzReadFilePS tpn `catchall` (return B.empty))
      FlippedSeal newpend_ <- return $ newpend (unsafeCoerceP pend :: FL Prim C(a x)) patch
      writePatch tpn $ fromPrims_ newpend_
      where newpend :: FL Prim C(a b) -> FL Prim C(b c) -> FlippedSeal (FL Prim) C(c)
            newpend NilFL patch_ = flipSeal patch_
            newpend p     patch_ = flipSeal $ p +>+ patch_
            fromPrims_ :: FL Prim C(a b) -> Patch C(a b)
            fromPrims_ = fromPrims

-- | setTentativePending is basically unsafe.  It overwrites the pending state with a new one, not related to
-- the repository state.
setTentativePending :: forall p C(r u t x y). RepoPatch p => Repository p C(r u t) -> FL Prim C(x y) -> IO ()
setTentativePending (Repo _ opts _ _) _ | NoUpdateWorking `elem` opts = return ()
setTentativePending (Repo dir _ _ rt) patch = do
    Sealed prims <- return $ siftForPending patch
    withCurrentDirectory dir $
      writePatch (pendingName rt ++ ".tentative") $ fromPrims_ prims
    where fromPrims_ :: FL Prim C(a b) -> Patch C(a b)
          fromPrims_ = fromPrims

-- | prepend is basically unsafe.  It overwrites the pending state
-- with a new one, not related to the repository state.
prepend :: forall p C(r u t x y). RepoPatch p =>
           Repository p C(r u t) -> FL Prim C(x y) -> IO ()
prepend (Repo _ opts _ _) _ | NoUpdateWorking `elem` opts = return ()
prepend (Repo _ _ _ rt) patch =
    do let pn = pendingName rt ++ ".tentative"
       Sealed pend <- readPrims `liftM` (gzReadFilePS pn `catchall` (return B.empty))
       Sealed newpend_ <- return $ newpend pend patch
       writePatch pn $ fromPrims_ (crudeSift newpend_)
      where newpend :: FL Prim C(b c) -> FL Prim C(a b) -> Sealed (FL Prim C(a))
            newpend NilFL patch_ = seal patch_
            newpend p     patch_ = seal $ patch_ +>+ p
            fromPrims_ :: FL Prim C(a b) -> Patch C(a b)
            fromPrims_ = fromPrims

tentativelyRemovePatches :: RepoPatch p => Repository p C(r u t) -> [DarcsFlag]
                         -> FL (PatchInfoAnd p) C(x t) -> IO (Repository p C(r u x))
tentativelyRemovePatches = tentativelyRemovePatches_ UpdatePristine

tentativelyRemovePatches_ :: forall p C(r u t x). RepoPatch p => UpdatePristine
                          -> Repository p C(r u t) -> [DarcsFlag]
                          -> FL (PatchInfoAnd p) C(x t) -> IO (Repository p C(r u x))
tentativelyRemovePatches_ up repository@(Repo dir ropts rf (DarcsRepository t c)) opts ps =
    withCurrentDirectory dir $ do
      when (up == UpdatePristine) $ do debugMessage "Adding changes to pending..."
                                       prepend repository $ effect ps
      removeFromUnrevertContext repository ps
      debugMessage "Removing changes from tentative inventory..."
      if formatHas HashedInventory rf
        then do HashedRepo.removeFromTentativeInventory repository (compression opts) ps
                when (up == UpdatePristine) $
                     HashedRepo.applyToTentativePristine opts $
                     progressFL "Applying inverse to pristine" $ invert ps
        else DarcsRepo.removeFromTentativeInventory (up==UpdatePristine) opts ps
      return (Repo dir ropts rf (DarcsRepository t c))

tentativelyReplacePatches :: forall p C(r u t x). RepoPatch p => Repository p C(r u t) -> [DarcsFlag]
                          -> FL (PatchInfoAnd p) C(x t) -> IO (Repository p C(r u t))
tentativelyReplacePatches repository opts ps =
    do repository' <- tentativelyRemovePatches_ DontUpdatePristine repository opts ps
       mapAdd repository' ps
  where mapAdd :: Repository p C(m l i) -> FL (PatchInfoAnd p) C(i j) -> IO (Repository p C(m l j))
        mapAdd r NilFL = return r
        mapAdd r (a:>:as) =
               do r' <- tentativelyAddPatch_ DontUpdatePristine r opts a
                  mapAdd r' as

finalizePending :: RepoPatch p => Repository p C(r u t) -> IO ()
finalizePending (Repo dir opts _ rt)
    | NoUpdateWorking `elem` opts =
        withCurrentDirectory dir $ removeFileMayNotExist $ (pendingName rt)
finalizePending repository@(Repo dir _ _ rt) = do
  withCurrentDirectory dir $ do let pn = pendingName rt
                                    tpn = pn ++ ".tentative"
                                tpfile <- gzReadFilePS tpn `catchall` (return B.empty)
                                Sealed tpend <- return $ readPrims tpfile
                                Sealed new_pending <- return $ siftForPending tpend
                                makeNewPending repository new_pending

finalizeRepositoryChanges :: RepoPatch p => Repository p C(r u t) -> IO ()
finalizeRepositoryChanges (Repo _ opts _ _)
    | DryRun `elem` opts = bug "finalizeRepositoryChanges called when --dry-run specified"
finalizeRepositoryChanges repository@(Repo dir opts rf _)
    | formatHas HashedInventory rf =
        withCurrentDirectory dir $ do debugMessage "Considering whether to test..."
                                      testTentative repository
                                      debugMessage "Finalizing changes..."
                                      withSignalsBlocked $ do HashedRepo.finalizeTentativeChanges repository (compression opts)
                                                              finalizePending repository
                                      debugMessage "Done finalizing changes..."
finalizeRepositoryChanges repository@(Repo dir _ _ (DarcsRepository _ _)) =
  withCurrentDirectory dir $ do debugMessage "Considering whether to test..."
                                testTentative repository
                                debugMessage "Finalizing changes..."
                                withSignalsBlocked $ do DarcsRepo.finalizePristineChanges
                                                        DarcsRepo.finalizeTentativeChanges
                                                        finalizePending repository

testTentative :: RepoPatch p => Repository p C(r u t) -> IO ()
testTentative = testAny withTentative

testRecorded :: RepoPatch p => Repository p C(r u t) -> IO ()
testRecorded = testAny withRecorded

testAny :: RepoPatch p => (Repository p C(r u t)
                               -> ((AbsolutePath -> IO ()) -> IO ())
                               -> (AbsolutePath -> IO ()) -> IO ())
        ->  Repository p C(r u t) -> IO ()
testAny withD repository@(Repo dir opts _ _) =
    when (Test `elem` opts) $ withCurrentDirectory dir $
    do let putInfo = if not $ Quiet `elem` opts then putStrLn else const (return ())
       debugMessage "About to run test if it exists."
       testline <- getPrefval "test"
       case testline of
         Nothing -> return ()
         Just testcode ->
             withD repository (wd "testing") $ \_ ->
             do putInfo "Running test...\n"
                when (SetScriptsExecutable `elem` opts) setScriptsExecutable
                ec <- system testcode
                if ec == ExitSuccess
                  then putInfo "Test ran successfully.\n"
                  else do putInfo "Test failed!\n"
                          exitWith ec
    where wd = if LeaveTestDir `elem` opts then withPermDir else withTempDir

revertRepositoryChanges :: RepoPatch p => Repository p C(r u t) -> IO ()
revertRepositoryChanges (Repo _ opts _ _)
    | DryRun `elem` opts = bug "revertRepositoryChanges called when --dry-run is specified"
revertRepositoryChanges r@(Repo dir opts rf dr@(DarcsRepository _ _)) =
    withCurrentDirectory dir $
    do removeFileMayNotExist (pendingName dr ++ ".tentative")
       Sealed x <- readPending r
       setTentativePending r $ effect x
       when (NoUpdateWorking `elem` opts) $ removeFileMayNotExist $ pendingName dr
       decideHashedOrNormal rf $ HvsO { hashed = HashedRepo.revertTentativeChanges,
                                        old = DarcsRepo.revertTentativeChanges }

patchSetToPatches :: RepoPatch p => PatchSet p C(x y) -> FL (Named p) C(x y)
patchSetToPatches patchSet = mapFL_FL hopefully $ newset2FL patchSet

getUMask :: [DarcsFlag] -> Maybe String
getUMask [] = Nothing
getUMask ((UMask u):_) = Just u
getUMask (_:l) = getUMask l

withGutsOf :: Repository p C(r u t) -> IO () -> IO ()
withGutsOf (Repo _ _ rf _) | formatHas HashedInventory rf = id
                           | otherwise = withSignalsBlocked

withRepository :: [DarcsFlag] -> (forall p C(r u). RepoPatch p => Repository p C(r u r) -> IO a) -> IO a
withRepository opts1 = withRepositoryDirectory opts1 "."

withRepositoryDirectory :: forall a. [DarcsFlag] -> String
                        -> (forall p C(r u). RepoPatch p => Repository p C(r u r) -> IO a) -> IO a
withRepositoryDirectory opts1 url job =
    do Repo dir opts rf rt <- identifyDarcs1Repository opts1 url
       let rt' = case rt of DarcsRepository t c -> DarcsRepository t c
       if formatHas Darcs2 rf
         then do debugMessage $ "Identified darcs-2 repo: " ++ dir
                 job1_ (Repo dir opts rf rt')
         else do debugMessage $ "Identified darcs-1 repo: " ++ dir
                 job2_ (Repo dir opts rf rt)
  where job1_ :: Repository (FL RealPatch) C(r u r) -> IO a
        job1_ = job
        job2_ :: Repository Patch C(r u r) -> IO a
        job2_ = job


-- RankNTypes
-- $- works around the lack of impredicative instantiation in GHC
($-) ::((forall p C(r u). RepoPatch p => Repository p C(r u r) -> IO a) -> IO a)
     -> (forall p C(r u). RepoPatch p => Repository p C(r u r) -> IO a) -> IO a
x $- y = x y

withRepoLock :: [DarcsFlag] -> (forall p C(r u). RepoPatch p => Repository p C(r u r) -> IO a) -> IO a
withRepoLock opts job =
    withRepository opts $- \repository@(Repo _ _ rf _) ->
    do case writeProblem rf of
         Nothing -> return ()
         Just err -> fail err
       let name = "./"++darcsdir++"/lock"
           wu = case (getUMask opts) of
                  Nothing -> id
                  Just u -> withUMask u
       wu $ if DryRun `elem` opts
            then job repository
            else withLock name (revertRepositoryChanges repository >> job repository)

withRepoReadLock :: [DarcsFlag] -> (forall p C(r u). RepoPatch p => Repository p C(r u r) -> IO a) -> IO a
withRepoReadLock opts job =
    withRepository opts $- \repository@(Repo _ _ rf _) ->
    do case writeProblem rf of
         Nothing -> return ()
         Just err -> fail err
       let name = "./"++darcsdir++"/lock"
           wu = case (getUMask opts) of Nothing -> id
                                        Just u -> withUMask u
       wu $ if formatHas HashedInventory rf || DryRun `elem` opts
            then job repository
            else withLock name (revertRepositoryChanges repository >> job repository)

removeFromUnrevertContext :: forall p C(r u t x). RepoPatch p
                             => Repository p C(r u t) -> FL (PatchInfoAnd p) C(x t) -> 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 yorn <- promptYorn "This operation will make unrevert impossible!\nProceed?"
               case yorn of
                 'n' -> fail "Cancelled."
                 'y' -> removeFileMayNotExist (unrevertUrl repository)
                 _ -> impossible
        unrevert_patch_bundle :: IO (SealedPatchSet p C(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 p C(Origin z) -> 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 C(xxx))
                            -> (FORALL(yyy) ppp C(xxx yyy) -> 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!"

-- | 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.
optimizeInventory :: RepoPatch p => Repository p C(r u t) -> IO ()
optimizeInventory repository@(Repo r opts rf (DarcsRepository _ c)) =
    do ps <- readRepo repository
       decideHashedOrNormal rf $
           HvsO { hashed = do revertRepositoryChanges repository
                              HashedRepo.writeTentativeInventory c (compression opts) $ deepOptimizePatchset ps
                              finalizeRepositoryChanges repository,
                  old = DarcsRepo.writeInventory r $ deepOptimizePatchset ps
                }

cleanRepository :: RepoPatch p => Repository p C(r u t) -> IO ()
cleanRepository repository@(Repo _ _ rf _) =
    decideHashedOrNormal rf $
    HvsO { hashed = HashedRepo.cleanPristine repository,
           old = return () }

createPristineDirectoryTree :: RepoPatch p => Repository p C(r u t) -> FilePath -> IO ()
createPristineDirectoryTree repo@(Repo r opts rf (DarcsRepository pris c)) reldir
    | formatHas HashedInventory rf =
        do createDirectoryIfMissing True reldir
           withCurrentDirectory reldir $ HashedRepo.copyPristine c (compression opts) r (darcsdir++"/hashed_inventory")
    | otherwise =
        do dir <- toPath `fmap` ioAbsoluteOrRemote reldir
           done <- withCurrentDirectory r $ easyCreatePristineDirectoryTree pris dir
           unless done $ do Sealed patches <- (seal . newset2FL) `liftM` readRepo repo
                            createDirectoryIfMissing True dir
                            withCurrentDirectory dir $ applyPatches [] patches

-- fp below really should be FileName
createPartialsPristineDirectoryTree :: (FilePathLike fp, RepoPatch p) => Repository p C(r u t) -> [fp] -> FilePath -> IO ()
createPartialsPristineDirectoryTree (Repo r opts rf (DarcsRepository _ c)) prefs dir
    | formatHas HashedInventory rf =
        do createDirectoryIfMissing True dir
           withCurrentDirectory dir $
               HashedRepo.copyPartialsPristine c (compression opts) r (darcsdir++"/hashed_inventory") prefs
createPartialsPristineDirectoryTree r@(Repo rdir _ _ (DarcsRepository pris _)) prefs dir
 = withCurrentDirectory rdir $
   do done <- easyCreatePartialsPristineDirectoryTree prefs pris dir
      unless done $ withRecorded r (withTempDir "recorded") $ \_ -> do
          clonePartialsTree "." dir (map toFilePath prefs)

withRecorded :: RepoPatch p => Repository p C(r u t)
             -> ((AbsolutePath -> IO a) -> IO a) -> (AbsolutePath -> IO a) -> IO a
withRecorded repository mk_dir f
    = mk_dir $ \d -> do createPristineDirectoryTree repository (toFilePath d)
                        f d

withTentative :: forall p a C(r u t). RepoPatch p =>
                 Repository p C(r u t) -> ((AbsolutePath -> IO a) -> IO a)
              -> (AbsolutePath -> IO a) -> IO a
withTentative (Repo dir opts rf (DarcsRepository _ c)) mk_dir f
    | formatHas HashedInventory rf =
        mk_dir $ \d -> do HashedRepo.copyPristine c (compression opts) dir (darcsdir++"/tentative_pristine")
                          f d
withTentative repository@(Repo dir opts _ _) mk_dir f =
    withRecorded repository mk_dir $ \d ->
    do Sealed ps <- read_patches (dir ++ "/"++darcsdir++"/tentative_pristine")
       apply opts $ joinPatches ps
       f d
    where read_patches :: FilePath -> IO (Sealed (FL p C(x)))
          read_patches fil = do ps <- B.readFile fil
                                return $ case readPatch ps of
                                           Just (x, _) -> x
                                           Nothing -> seal NilFL

getMarkedupFile :: RepoPatch p => Repository p C(r u t) -> PatchInfo -> FilePath -> IO MarkedUpFile
getMarkedupFile repository pinfo f = do
  Sealed (FlippedSeal patches) <- (seal . dropWhileFL ((/= pinfo) . info)
                                  . newset2FL) `liftM` readRepo repository
  return $ snd $ doMarkAll patches (f, emptyMarkedupFile)
  where dropWhileFL :: (FORALL(x y) a C(x y) -> Bool) -> FL a C(r v) -> FlippedSeal (FL a) C(v)
        dropWhileFL _ NilFL       = flipSeal NilFL
        dropWhileFL p xs@(x:>:xs')
              | p x       = dropWhileFL p xs'
              | otherwise = flipSeal xs
doMarkAll :: RepoPatch p => FL (PatchInfoAnd p) C(x y)
            -> (FilePath, MarkedUpFile) -> (FilePath, MarkedUpFile)
doMarkAll (hp:>:pps) (f, mk) =
    case hopefullyM hp of
    Just p -> doMarkAll pps $ markupFile (info hp) (patchcontents p) (f, mk)
    Nothing -> (f, [(BC.pack "Error reading a patch!",None)])
doMarkAll NilFL (f, mk) = (f, mk)

-- | Sets scripts in or below the current directory executable. A script is any file that starts
--   with the bytes '#!'. This is used sometimes for --set-scripts-executable, but at other times
--   --set-scripts-executable is handled by the hunk patch case of applyFL.
setScriptsExecutable :: IO ()
setScriptsExecutable = do
    debugMessage "Making scripts executable"
    myname <- getCurrentDirectory
    tree <- readWorking
    let paths = [ anchorPath "." p | (p, Tree.File _) <- Tree.list tree ]
        setExecutableIfScript f =
              do contents <- B.readFile f
                 when (BC.pack "#!" `B.isPrefixOf` contents) $ do
                   debugMessage ("Making executable: " ++ f)
                   setExecutable f True
    mapM_ setExecutableIfScript paths