    -- 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,
                        findRepository, amInRepository, amNotInRepository,
                        slurp_pending, revertRepositoryChanges,
                        slurp_recorded, slurp_recorded_and_unrecorded,
                        announce_merge_conflicts, setTentativePending,
                        check_unrecorded_conflicts,
                        withRecorded,
                        read_repo,
                        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,
                        make_new_pending
                      ) where

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

    import Data.Maybe ( isJust, isNothing )
    import Darcs.Repository.Prefs ( getPrefval )
    import Darcs.Repository.State ( readRecorded )
    import Darcs.Repository.LowLevel ( read_pending, pendingName, readPrims, read_pendingfile )
    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, slurpPristine,
                                       easyCreatePartialsPristineDirectoryTree )

    import Data.List ( (\\) )
    import Darcs.SignalHandler ( withSignalsBlocked )
    import Darcs.Repository.Format ( RepoFormat, RepoProperty( Darcs2, HashedInventory ),
                                     identifyRepoFormat, formatHas,
                                     writeProblem, readProblem, readfromAndWritetoProblem )
    import System.Directory ( doesDirectoryExist, setCurrentDirectory, removeFile,
                              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, commuteFL, commute )
    import Darcs.Patch.Prim ( try_shrinking_inverse, Conflict )
    import Darcs.Patch.Bundle ( scan_bundle, make_bundle )
    import Darcs.SlurpDirectory ( Slurpy, mmap_slurp, co_slurp, list_slurpy_files )
    import Darcs.Hopefully ( PatchInfoAnd, info, n2pia,
                             hopefully, hopefullyM )
    import Darcs.Repository.ApplyPatches ( apply_patches )
    import qualified Darcs.Repository.HashedRepo as HashedRepo
                                ( revert_tentative_changes, finalize_tentative_changes,
                                  remove_from_tentative_inventory,
                                  copy_pristine, copy_partials_pristine, slurp_pristine,
                                  apply_to_tentative_pristine,
                                  write_tentative_inventory, write_and_read_patch,
                                  add_to_tentative_inventory,
                                  read_repo, read_tentative_repo, clean_pristine,
                                  slurp_all_but_darcs )
    import qualified Darcs.Repository.DarcsRepo as DarcsRepo
    import Darcs.Flags ( DarcsFlag(Verbose, Quiet,
                                   MarkConflicts, AllowConflicts, NoUpdateWorking,
                                   WorkRepoUrl, WorkRepoDir, UMask, Test, LeaveTestDir,
                                   SetScriptsExecutable, DryRun ),
                         want_external_merge, compression )
    import Darcs.Witnesses.Ordered ( FL(..), RL(..), EqCheck(..), unsafeCoerceP,
                                 (:\/:)(..), (:/\:)(..), (:>)(..),
                                 (+>+), lengthFL,
                                 allFL, filterFL,
                                 reverseRL, reverseFL, concatRL, mapFL,
                                 mapFL_FL, concatFL )
    import Darcs.Patch ( RepoPatch, Patchy, Prim, merge,
                         joinPatches,
                         listConflictedFiles, listTouchedFiles,
                         Named, patchcontents,
                         commuteRL, fromPrims,
                         patch2patchinfo, readPatch,
                         writePatch, effect, invert,
                         primIsAddfile, primIsAdddir,
                         primIsSetpref,
                         apply, applyToSlurpy,
                         emptyMarkedupFile, MarkedUpFile
                       )
    import Darcs.Patch.Patchy ( Invert(..) )
    import Darcs.Patch.Permutations ( commuteWhatWeCanFL, removeFL )
    import Darcs.Patch.Info ( PatchInfo )
    import Darcs.Patch.Set ( PatchSet, SealedPatchSet )
    import Darcs.Patch.Apply ( markupFile, LineMark(None) )
    import Darcs.Patch.Depends ( get_common_and_uncommon, deep_optimize_patchset )
    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 ( is_file )
    import Darcs.Repository.Prefs ( getCaches )
    import Darcs.Lock ( withLock, writeDocBinFile, withDelayedDir, 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 )

    #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

    maybeIdentifyRepository :: [DarcsFlag] -> String -> IO (Either String (Repository 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 $ Left err
             Right rf ->
                 case readProblem rf of
                 Just err -> return $ Left err
                 Nothing -> if darcs then do pris <- identifyPristine
                                             cs <- getCaches opts here
                                             return $ Right $ Repo here opts rf (DarcsRepository pris cs)
                                     else return (Left "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 $ Left e
          Right rf -> case readProblem rf of
                      Just err -> return $ Left err
                      Nothing ->  do cs <- getCaches opts url
                                     return $ Right $ 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
               Left s -> fail s
               Right 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'

    isRight :: Either a b -> Bool
    isRight (Right _) = True
    isRight _         = False

    currentDirIsRepository :: IO Bool
    currentDirIsRepository = isRight `liftM` maybeIdentifyRepository [] "."

    amInRepository :: [DarcsFlag] -> IO (Either String ())
    amInRepository (WorkRepoDir d:_) =
        do setCurrentDirectory d `catchall` (fail $ "can't set directory to "++d)
           air <- currentDirIsRepository
           if air
              then return (Right ())
              else 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
        air <- currentDirIsRepository
        if air
           then return (Right ())
           else 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 air <- currentDirIsRepository
           if air then return (Left $ "You may not run this command in a repository.")
                  else return $ Right ()

    findRepository :: [DarcsFlag] -> IO (Either String ())
    findRepository (WorkRepoUrl d:_) | is_file 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 ())

    slurp_pending :: RepoPatch p => Repository p C(r u t) -> IO Slurpy
    slurp_pending repo@(Repo _ _ _ rt) = do
      cur <- slurp_recorded repo
      Sealed pend <- read_pending repo
      case applyToSlurpy pend cur of
        Just pendcur -> return pendcur
        Nothing -> do putStrLn "Yikes, pending has conflicts.  Renaming file as_darcs/patches/pending_buggy"
                      renameFile (pendingName rt) (pendingName rt++"_buggy")
                      return cur

    slurp_recorded :: RepoPatch p => Repository p C(r u t) -> IO Slurpy
    slurp_recorded (Repo dir opts rf (DarcsRepository _ c))
        | formatHas HashedInventory rf =
            HashedRepo.slurp_pristine c (compression opts) dir $ darcsdir++"/hashed_inventory"
    slurp_recorded repository@(Repo dir _ _ (DarcsRepository p _)) = do
        mc <- withCurrentDirectory dir $ slurpPristine p
        case mc of (Just slurpy) -> return slurpy
                   Nothing -> withDelayedDir "pristine.temp" $ \abscd ->
                              do let cd = toFilePath abscd
                                 createPristineDirectoryTree repository cd
                                 mmap_slurp cd

    slurp_recorded_and_unrecorded :: RepoPatch p => Repository p C(r u t) -> IO (Slurpy, Slurpy)
    slurp_recorded_and_unrecorded repo@(Repo r _ _ _) = do
      cur <- slurp_recorded repo
      Sealed pend <- read_pending repo
      withCurrentDirectory r $
          case applyToSlurpy pend cur of
          Nothing -> fail "Yikes, pending has conflicts!"
          Just pendslurp -> do unrec <- co_slurp pendslurp "."
                               return (cur, unrec)

    make_new_pending :: forall p C(r u t y). RepoPatch p => Repository p C(r u t) -> FL Prim C(r y) -> IO ()
    make_new_pending (Repo _ opts _ _) _ | NoUpdateWorking `elem` opts = return ()
    make_new_pending repo@(Repo r _ _ tp) origp =
        withCurrentDirectory r $
        do let newname = pendingName tp ++ ".new"
           debugMessage $ "Writing new pending:  " ++ newname
           Sealed sfp <- return $ sift_for_pending origp
           writeSealedPatch newname $ seal $ fromPrims $ sfp
           cur <- slurp_recorded repo
           Sealed p <- read_pendingfile newname
           when (isNothing $ applyToSlurpy p cur) $ do
             let buggyname = pendingName tp ++ "_buggy"
             renameFile newname buggyname
             bugDoc $ text "There was an attempt to write an invalid pending!"
                        $$ 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

    sift_for_pending :: FL Prim C(x y) -> Sealed (FL Prim C(x))
    sift_for_pending simple_ps =
     let oldps = maybe simple_ps id $ try_shrinking_inverse $ crude_sift 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 -> sift_for_pending 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 commuteFL (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.
    read_repo :: RepoPatch p => Repository p C(r u t) -> IO (PatchSet p C(r))
    read_repo repo@(Repo r opts rf _)
        | formatHas HashedInventory rf =  do ps <- HashedRepo.read_repo repo r
                                             return ps
        | otherwise = do Sealed ps <- DarcsRepo.read_repo opts r
                         return $ unsafeCoerceP ps

    readTentativeRepo :: RepoPatch p => Repository p C(r u t) -> IO (PatchSet p C(t))
    readTentativeRepo repo@(Repo r opts rf _)
        | formatHas HashedInventory rf = do  ps <- HashedRepo.read_tentative_repo repo r
                                             return ps
        | otherwise = do Sealed ps <- DarcsRepo.read_tentative_repo 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.write_and_read_patch c (compression opts) p
        | otherwise = withCurrentDirectory r $ DarcsRepo.write_and_read_patch 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 ()
    applyToWorking (Repo r _ _ (DarcsRepository _ _)) opts patch =
        withCurrentDirectory r $ if Quiet `elem` opts
                                 then runSilently $ apply opts patch
                                 else runTolerantly $ apply opts patch

    handle_pend_for_add :: forall p q C(r u t x y). (RepoPatch p, Effect q)
                        => Repository p C(r u t) -> q C(x y) -> IO ()
    handle_pend_for_add (Repo _ opts _ _) _ | NoUpdateWorking `elem` opts = return ()
    handle_pend_for_add (Repo _ _ _ rt) p =
        do let pn = pendingName rt ++ ".tentative"
           Sealed pend <- (readPrims `fmap` gzReadFilePS pn) `catchall` (return $ Sealed NilFL)
           let effectp = if allFL is_simple pend then crude_sift $ 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

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

    crude_sift :: FL Prim C(x y) -> FL Prim C(x y)
    crude_sift xs = if allFL is_simple xs then filterFL 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 )

    announce_merge_conflicts :: String -> [DarcsFlag] -> FL Prim C(x y) -> IO Bool
    announce_merge_conflicts cmd opts resolved_pw =
        case nubsort $ listTouchedFiles $ resolved_pw of
        [] -> return False
        cfs -> if MarkConflicts `elem` opts || AllowConflicts `elem` opts
                  || want_external_merge 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. "

    check_unrecorded_conflicts :: forall p C(r y). RepoPatch p => [DarcsFlag] -> FL (Named p) C(r y) -> IO Bool
    check_unrecorded_conflicts opts _ | NoUpdateWorking `elem` opts = return False
    check_unrecorded_conflicts opts pc =
        do repository <- identifyDarcs1Repository opts "."
           cuc repository
        where cuc :: Repository Patch C(r u t) -> IO Bool
              cuc r = do Sealed mpend <- read_pending r :: IO (Sealed (FL Prim C(r)))
                         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(r y) -> IO ()
    tentativelyAddPatch = tentativelyAddPatch_ UpdatePristine

    data UpdatePristine = UpdatePristine | DontUpdatePristine deriving Eq

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

    applyToTentativePristine :: (Effect q, Patchy q) => Repository p C(r u t) -> q C(r 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.apply_to_tentative_pristine c opts p,
                                           old = DarcsRepo.add_to_tentative_pristine 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 $ sift_for_pending 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_ (crude_sift 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 (Named p) C(x t) -> IO ()
    tentativelyRemovePatches = tentativelyRemovePatches_ UpdatePristine

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

    tentativelyReplacePatches :: forall p C(r u t x). RepoPatch p => Repository p C(r u t) -> [DarcsFlag]
                              -> FL (Named p) C(x t) -> IO ()
    tentativelyReplacePatches repository@(Repo x y z w) opts ps =
        -- tentativelyRemovePatches_ leaves the repository in state C(x u t)
        do tentativelyRemovePatches_ DontUpdatePristine repository opts ps
           -- Now we add the patches back so that the repo again has state C(r u t)
           sequence_ $ mapAdd ((Repo x y z w) :: Repository p C(x u t)) ps
      where mapAdd :: Repository p C(i l m) -> FL (Named p) C(i j) -> [IO ()]
            mapAdd _ NilFL = []
            mapAdd r@(Repo dir df rf dr) (a:>:as) =
                   -- we construct a new Repository object on the recursive case so that the
                   -- recordedstate of the repository can match the fact that we just wrote a patch
                   tentativelyAddPatch_ DontUpdatePristine r opts (n2pia a) : mapAdd (Repo dir df rf dr) as

    finalize_pending :: RepoPatch p => Repository p C(r u t) -> IO ()
    finalize_pending (Repo dir opts _ rt)
        | NoUpdateWorking `elem` opts =
            withCurrentDirectory dir $ removeFileMayNotExist $ (pendingName rt)
    finalize_pending 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 $ sift_for_pending tpend
                                    make_new_pending 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.finalize_tentative_changes repository (compression opts)
                                                                  finalize_pending 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.finalize_pristine_changes
                                                            DarcsRepo.finalize_tentative_changes
                                                            finalize_pending 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 <- read_pending r
           setTentativePending r $ effect x
           when (NoUpdateWorking `elem` opts) $ removeFileMayNotExist $ pendingName dr
           decideHashedOrNormal rf $ HvsO { hashed = HashedRepo.revert_tentative_changes,
                                            old = DarcsRepo.revert_tentative_changes }

    patchSetToPatches :: RepoPatch p => RL (RL (PatchInfoAnd p)) C(x y) -> FL (Named p) C(x y)
    patchSetToPatches patchSet = mapFL_FL hopefully $ reverseRL $ concatRL 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)

    remove_from_unrevert_context :: forall p C(r u t x). RepoPatch p
                                 => Repository p C(r u t) -> FL (Named p) C(x t) -> IO ()
    remove_from_unrevert_context repository ps = do
      Sealed bundle <- unrevert_patch_bundle `catchall` (return $ seal (NilRL:<:NilRL))
      remove_from_unrevert_context_ bundle
      where unrevert_impossible unrevert_loc =
                do putStrLn "This operation will make unrevert impossible!"
                   yorn <- promptYorn "Proceed?"
                   case yorn of
                     'n' -> fail "Cancelled."
                     'y' -> removeFile unrevert_loc `catchall` return ()
                     _ -> impossible
            pis = mapFL patch2patchinfo ps
            unrevert_patch_bundle :: IO (SealedPatchSet p)
            unrevert_patch_bundle = do pf <- B.readFile (unrevertUrl repository)
                                       case scan_bundle pf of
                                         Right foo -> return foo
                                         Left err -> fail $ "Couldn't parse unrevert patch:\n" ++ err
            remove_from_unrevert_context_ :: PatchSet p C(z) -> IO ()
            remove_from_unrevert_context_ (NilRL :<: NilRL) = return ()
            remove_from_unrevert_context_ bundle = do
                let unrevert_loc = unrevertUrl repository
                debugMessage "Adjusting the context of the unrevert changes..."
                ref <- readTentativeRepo repository
                case get_common_and_uncommon (bundle, ref) of
                     (common,(h_us:<:NilRL) :\/: NilRL) ->
                        case commuteRL (reverseFL ps :> hopefully h_us) of
                        Nothing -> unrevert_impossible unrevert_loc
                        Just (us' :> _) -> do
                            s <- readRecorded repository
                            bundle' <- make_bundle [] s (common \\ pis) (us' :>: NilFL)
                            writeDocBinFile unrevert_loc bundle'
                     (common,(x:<:NilRL):\/:_)
                            | isr && any (`elem` common) pis -> unrevert_impossible unrevert_loc
                            | isr -> return ()
                            where isr = isJust $ hopefullyM x
                     _ -> unrevert_impossible unrevert_loc

    -- | 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 <- read_repo repository
           decideHashedOrNormal rf $
               HvsO { hashed = do revertRepositoryChanges repository
                                  HashedRepo.write_tentative_inventory c (compression opts) $ deep_optimize_patchset ps
                                  finalizeRepositoryChanges repository,
                      old = DarcsRepo.write_inventory r $ deep_optimize_patchset ps
                    }

    cleanRepository :: RepoPatch p => Repository p C(r u t) -> IO ()
    cleanRepository repository@(Repo _ _ rf _) =
        decideHashedOrNormal rf $
        HvsO { hashed = HashedRepo.clean_pristine 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.copy_pristine 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 . reverseRL . concatRL) `liftM` read_repo repo
                                createDirectoryIfMissing True dir
                                withCurrentDirectory dir $ apply_patches [] 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.copy_partials_pristine 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.copy_pristine 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)
                                      . reverseRL . concatRL) `liftM` read_repo repository
      return $ snd $ do_mark_all 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
    do_mark_all :: RepoPatch p => FL (PatchInfoAnd p) C(x y)
                -> (FilePath, MarkedUpFile) -> (FilePath, MarkedUpFile)
    do_mark_all (hp:>:pps) (f, mk) =
        case hopefullyM hp of
        Just p -> do_mark_all pps $ markupFile (info hp) (patchcontents p) (f, mk)
        Nothing -> (f, [(BC.pack "Error reading a patch!",None)])
    do_mark_all 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
        c <- list_slurpy_files `fmap` (HashedRepo.slurp_all_but_darcs myname)
        let setExecutableIfScript f =
                  do contents <- B.readFile f
                     when (BC.pack "#!" `B.isPrefixOf` contents) $ do
                       debugMessage ("Making executable: " ++ f)
                       setExecutable f True
        mapM_ setExecutableIfScript c