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

\begin{code}
{-# OPTIONS_GHC -cpp -fglasgow-exts #-}
#include "gadts.h"
module Darcs.Repository.Internal ( Repository(..), RepoType(..), RIO(unsafeUnRIO), ($-),
                    maybeIdentifyRepository, identifyDarcs1Repository, identifyRepositoryFor,
                    findRepository, amInRepository, amNotInRepository,
                    slurp_pending, pristineFromWorking, revertRepositoryChanges,
                    slurp_recorded, slurp_recorded_and_unrecorded,
                    withRecorded, checkPristineAgainstCwd,
                    checkPristineAgainstSlurpy,
                    get_unrecorded, get_unrecorded_unsorted, get_unrecorded_no_look_for_adds,
                    read_repo, sync_repo,
                    prefsUrl, makePatchLazy,
                    read_pending, add_to_pending,
                    withRepoLock, withRepoReadLock,
                    withRepository, withRepositoryDirectory, withGutsOf,
                    tentativelyAddPatch, tentativelyRemovePatches, tentativelyAddToPending,
                    tentativelyReplacePatches,
                    tentativelyMergePatches, considerMergeToWorking,
                    finalizeRepositoryChanges,
                    unrevertUrl,
                    applyToWorking, patchSetToPatches,
                    createPristineDirectoryTree, createPartialsPristineDirectoryTree,
                    replacePristine, replacePristineFromSlurpy,
                    optimizeInventory, cleanRepository,
                    getMarkedupFile,
                    PatchSet, SealedPatchSet,
                    setScriptsExecutable,
                    getRepository, rIO
                  ) where

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

import Data.Maybe ( isJust, isNothing )
import Darcs.Repository.Prefs ( get_prefval )
import Darcs.Resolution ( standard_resolution, external_resolution )
import System.Exit ( ExitCode(..), exitWith )
import System.Cmd ( system )
import Darcs.External ( backupByCopying, clonePartialsTree )
import Darcs.IO ( runTolerantly, runSilently )
import Darcs.Repository.Pristine ( identifyPristine, nopristine, checkPristine,
                                   easyCreatePristineDirectoryTree, slurpPristine, syncPristine,
                                   easyCreatePartialsPristineDirectoryTree,
                                   createPristineFromWorking )
import qualified Darcs.Repository.Pristine as Pristine ( replacePristine,
                                                         replacePristineFromSlurpy )
import Data.List ( (\\) )
import Darcs.SignalHandler ( withSignalsBlocked )
import Darcs.Repository.Format ( RepoFormat, RepoProperty( Darcs2, HashedInventory ),
                                 identifyRepoFormat, format_has,
                                 write_problem, read_problem, readfrom_and_writeto_problem )
import System.Directory ( doesDirectoryExist, setCurrentDirectory, removeFile )
import Control.Monad ( liftM, when, unless )
import Workaround ( createDirectoryIfMissing, getCurrentDirectory, renameFile, setExecutable )
import FastPackedString ( PackedString, readFilePS, gzReadFilePS, nilPS, packString, takePS )
import Darcs.Patch ( Patch, RealPatch, Effect, is_hunk, is_binary, description,
                     try_to_shrink, commuteFL, commute )
import Darcs.Patch.Prim ( try_shrinking_inverse, Conflict )
import Darcs.Patch.Bundle ( scan_bundle, make_bundle )
import Darcs.SlurpDirectory ( Slurpy, slurp_unboring, mmap_slurp, co_slurp,
                              slurp_has, 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, sync_repo,
                              copy_pristine, copy_partials_pristine, slurp_pristine,
                              apply_to_tentative_pristine, pristine_from_working,
                              write_tentative_inventory, write_and_read_patch,
                              add_to_tentative_inventory,
                              read_repo, read_tentative_repo, clean_pristine,
                              replacePristine, replacePristineFromSlurpy,
                              slurp_all_but_darcs )
import qualified Darcs.Repository.DarcsRepo as DarcsRepo
import Darcs.Flags ( DarcsFlag(AnyOrder, Boring, LookForAdds, Verbose, Quiet,
                               MarkConflicts, AllowConflicts, NoUpdateWorking,
                               RepoDir, WorkDir, UMask, Test, LeaveTestDir,
                               SetScriptsExecutable, DryRun, IgnoreTimes ),
                     want_external_merge, compression )
import Darcs.Ordered ( FL(..), RL(..), EqCheck(..), unsafeCoerceP,
                             (:\/:)(..), (:/\:)(..), (:>)(..),
                             (+>+), lengthFL, nullFL,
                             allFL, filterFL,
                             reverseRL, reverseFL, concatRL, mapFL,
                             mapFL_FL, concatFL )
import Darcs.Patch ( RepoPatch, Patchy, Prim, merge,
                     joinPatches, sort_coalesceFL,
                     list_conflicted_files, list_touched_files,
                     Named, patchcontents, anonymous,
                     commuteRL, fromPrims,
                     patch2patchinfo, readPatch,
                     writePatch, effect, invert,
                     is_addfile, is_adddir,
                     is_setpref,
                     apply, apply_to_slurpy,
                     empty_markedup_file, 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 ( markup_file, LineMark(None) )
import Darcs.Patch.Depends ( get_common_and_uncommon, deep_optimize_patchset )
import Darcs.Diff ( smart_diff )
import Darcs.RepoPath ( AbsolutePath, toFilePath )
import Darcs.Utils ( promptYorn, catchall, withCurrentDirectory, withUMask, nubsort )
import Darcs.Progress ( progressFL, debugMessage )
import Darcs.FilePathUtils ( absolute_dir )
import Darcs.URL ( is_file )
import Darcs.Repository.Prefs ( darcsdir_filter, boring_file_filter, filetype_function,
                                getCaches )
import Darcs.Lock ( withLock, writeDocBinFile, withDelayedDir, removeFileMayNotExist,
                    withTempDir, withPermDir )
import Darcs.Sealed ( Sealed(Sealed), seal, FlippedSeal(FlippedSeal), flipSeal )
import Darcs.Repository.InternalTypes( Repository(..), RepoType(..) )
import Darcs.Global ( darcsdir )
#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 <- absolute_dir "."
       case rf_or_e of
         Left err -> return $ Left err
         Right rf ->
             case read_problem 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 <- absolute_dir url'
    rf_or_e <- identifyRepoFormat url
    case rf_or_e of
      Left e -> return $ Left e
      Right rf -> case read_problem 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 readfrom_and_writeto_problem 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 (WorkDir 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

amNotInRepository :: [DarcsFlag] -> IO (Either String ())
amNotInRepository (WorkDir d:_) = do 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 (RepoDir d:_) | is_file d =
    do setCurrentDirectory d `catchall` (fail $ "can't set directory to "++d)
       findRepository []
findRepository (WorkDir 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 apply_to_slurpy 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))
    | format_has 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 apply_to_slurpy pend cur of
      Nothing -> fail "Yikes, pending has conflicts!"
      Just pendslurp -> do unrec <- co_slurp pendslurp "."
                           return (cur, unrec)

pendingName :: RepoType p -> String
pendingName (DarcsRepository _ _) = darcsdir++"/patches/pending"

read_pending :: RepoPatch p => Repository p C(r u t) -> IO (Sealed (FL Prim C(r)))
read_pending (Repo r _ _ tp) =
    withCurrentDirectory r (read_pendingfile (pendingName tp))

add_to_pending :: RepoPatch p => Repository p C(r u t) -> FL Prim C(u y) -> IO ()
add_to_pending (Repo _ opts _ _) _ | NoUpdateWorking `elem` opts = return ()
add_to_pending repo p =
    do pend <- get_unrecorded repo
       make_new_pending repo (pend +>+ p)

readPrims :: PackedString -> Sealed (FL Prim C(x))
readPrims s = case readPatch s :: Maybe (Sealed (Patch C(x )), PackedString) of
              Nothing -> Sealed NilFL
              Just (Sealed p,_) -> Sealed (effect p)

read_pendingfile :: String -> IO (Sealed (FL Prim C(x)))
read_pendingfile name = do
  pend <- gzReadFilePS name `catchall` return nilPS
  return $ readPrims pend

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 $ apply_to_slurpy 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 -> is_addfile p || is_adddir p) $ oldps
    then seal oldps
    else fromJust $ do
      Sealed x <- return $ sfp NilFL $ reverseFL oldps
      return (case try_to_shrink 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)
                | is_hunk p || is_binary p
                    = case commuteFL (p :> sofar) of
                      Right (sofar' :> _) -> sfp sofar' ps
                      Left _ -> sfp (p:>:sofar) ps
            sfp sofar (p:<:ps) = sfp (p:>:sofar) ps

get_unrecorded_no_look_for_adds :: RepoPatch p => Repository p C(r u t) -> IO (FL Prim C(r y))
get_unrecorded_no_look_for_adds = get_unrecorded_private (filter (/= LookForAdds))

get_unrecorded_unsorted :: RepoPatch p => Repository p C(r u t) -> IO (FL Prim C(r u))
get_unrecorded_unsorted = get_unrecorded_private (AnyOrder:)

get_unrecorded :: RepoPatch p => Repository p C(r u t) -> IO (FL Prim C(r u))
get_unrecorded = get_unrecorded_private id

-- | The /unrecorded/ includes the pending and the working directory changes.
get_unrecorded_private :: RepoPatch p => ([DarcsFlag]->[DarcsFlag]) -> Repository p C(r u t) -> IO (FL Prim C(r y))
get_unrecorded_private _ (Repo _ opts _ _)
    | NoUpdateWorking `elem` opts = return $ unsafeCoerceP NilFL
get_unrecorded_private modopts repository@(Repo r oldopts _ _) =
  withCurrentDirectory r $ do
    debugMessage "Looking for unrecorded changes..."
    cur <- slurp_pending repository
    work <- if LookForAdds `elem` opts
            then do nboring <- if Boring `elem` opts
                               then return $ darcsdir_filter
                               else boring_file_filter
                    slurp_unboring (myfilt cur nboring) "."
            else co_slurp cur "."
    Sealed pend <- read_pending repository
    debugMessage "diffing dir..."
    ftf <- filetype_function
    let dif = case smart_diff opts ftf cur work of
              di -> if AnyOrder `elem` opts
                    then pend +>+ di
                    else sort_coalesceFL $ pend +>+ di
    seq dif $ debugMessage "Found unrecorded changes."
    return dif
    where myfilt s nboring f = slurp_has f s || nboring [f] /= []
          opts = modopts oldopts

-- @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 _)
    | format_has 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 _)
    | format_has 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
    | format_has HashedInventory rf = withCurrentDirectory r $ HashedRepo.write_and_read_patch c (compression opts) p
    | otherwise = withCurrentDirectory r $ DarcsRepo.write_and_read_patch opts p

sync_repo :: Repository p C(r u t) -> IO ()
sync_repo (Repo r _ rf (DarcsRepository _ c))
    | format_has HashedInventory rf = withCurrentDirectory r $ HashedRepo.sync_repo c
sync_repo (Repo r _ _ (DarcsRepository p _)) = withCurrentDirectory r $ syncPristine 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 = is_hunk x || is_binary x || is_setpref 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 | is_hunk x || is_binary 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 })
    | format_has HashedInventory rf = h
    | otherwise = o


tentativelyMergePatches :: RepoPatch p
                        => Repository p C(r u t) -> String -> [DarcsFlag]
                        -> FL (PatchInfoAnd p) C(x r) -> FL (PatchInfoAnd p) C(x y)
                        -> IO (Sealed (FL Prim C(u)))
tentativelyMergePatches = tentativelyMergePatches_ MakeChanges

considerMergeToWorking :: RepoPatch p
                       => Repository p C(r u t) -> String -> [DarcsFlag]
                       -> FL (PatchInfoAnd p) C(x r) -> FL (PatchInfoAnd p) C(x y)
                       -> IO (Sealed (FL Prim C(u)))
considerMergeToWorking = tentativelyMergePatches_ DontMakeChanges

data MakeChanges = MakeChanges | DontMakeChanges deriving ( Eq )

tentativelyMergePatches_ :: forall p C(r u t y x). RepoPatch p
                         => MakeChanges
                         -> Repository p C(r u t) -> String -> [DarcsFlag]
                         -> FL (PatchInfoAnd p) C(x r) -> FL (PatchInfoAnd p) C(x y)
                         -> IO (Sealed (FL Prim C(u)))
tentativelyMergePatches_ mc r cmd opts usi themi =
  do let us = mapFL_FL hopefully usi
         them = mapFL_FL hopefully themi
     _ :/\: pc <- return $ merge (progressFL "Merging them" them :\/: progressFL "Merging us" us)
     pend <- get_unrecorded_unsorted r -- we don't care if it looks pretty...
     pend' :/\: pw <- return $ merge (pc :\/: anonymous (fromPrims pend) :>: NilFL)
     let pwprim = joinPatches $ progressFL "Examining patches for conflicts" $ mapFL_FL patchcontents pw
     Sealed standard_resolved_pw <- return $ standard_resolution pwprim
     debugMessage "Checking for conflicts..."
     mapM_ backupByCopying $ list_touched_files standard_resolved_pw
     debugMessage "Announcing conflicts..."
     have_conflicts <- announce_merge_conflicts cmd opts standard_resolved_pw
     debugMessage "Checking for unrecorded conflicts..."
     have_unrecorded_conflicts <- check_unrecorded_conflicts opts pc
     debugMessage "Reading working directory..."
     (_, working) <- slurp_recorded_and_unrecorded r
     debugMessage "Working out conflicts in actual working directory..."
     Sealed pw_resolution <-
          case (want_external_merge opts, have_conflicts || have_unrecorded_conflicts) of
          (Nothing,_) -> return $ if AllowConflicts `elem` opts
                                  then seal NilFL
                                  else seal standard_resolved_pw
          (_,False) -> return $ seal standard_resolved_pw
          (Just c, True) -> external_resolution working c
                                                    (effect us +>+ pend)
                                                    (effect them) pwprim
     debugMessage "Applying patches to the local directories..."
     when (mc == MakeChanges) $
          do case usi of
              NilFL -> applyps r themi
              _     -> applyps r (mapFL_FL n2pia pc)
             setTentativePending r (effect pend' +>+ pw_resolution)
     return $ seal (effect pwprim +>+ pw_resolution)
  where mapAdd :: Repository p C(i l m) -> FL (PatchInfoAnd 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 a : mapAdd (Repo dir df rf dr) as
        applyps :: Repository p C(i l m) -> FL (PatchInfoAnd p) C(i j) -> IO ()
        applyps repo ps = do debugMessage "Adding patches to inventory..."
                             sequence_ $ mapAdd repo ps
                             debugMessage "Applying patches to pristine..."
                             applyToTentativePristine repo ps

announce_merge_conflicts :: String -> [DarcsFlag] -> FL Prim C(x y) -> IO Bool
announce_merge_conflicts cmd opts resolved_pw =
    case nubsort $ list_touched_files $ 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 list_conflicted_files pend' of
                               [] -> return False
                               fs -> do yorn <- promptYorn
                                                ("You have conflicting local changes to:\n"
                                                 ++ unwords fs++"\nProceed?")
                                        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 nilPS))
      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 nilPS))
       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 format_has 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 nilPS)
                                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 _)
    | format_has 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 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 <- get_prefval "test"
       case testline of
         Nothing -> return ()
         Just testcode ->
             withTentative 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 _) | format_has 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 format_has 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


($-) ::((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 write_problem 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 write_problem 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 format_has HashedInventory rf || DryRun `elem` opts
            then job repository
            else withLock name (revertRepositoryChanges repository >> job repository)
\end{code}

\begin{code}
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 yorn <- promptYorn "This operation will make unrevert impossible!\nProceed?"
               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 <- readFilePS (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 :\/: NilRL:<:NilRL) ->
                    case commuteRL (reverseFL ps :> hopefully h_us) of
                    Nothing -> unrevert_impossible unrevert_loc
                    Just (us' :> _) -> do
                        s <- slurp_recorded repository
                        writeDocBinFile unrevert_loc $
                             make_bundle [] s
                             (common \\ pis) (us':>:NilFL)
                 (common,(x:<:NilRL):<:NilRL:\/:_)
                        | isr && any (`elem` common) pis -> unrevert_impossible unrevert_loc
                        | isr -> return ()
                        where isr = isJust $ hopefullyM x
                 _ -> unrevert_impossible unrevert_loc
\end{code}

\begin{code}
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 () }

replacePristine :: Repository p C(r u t) -> FilePath -> IO ()
replacePristine (Repo r opts rf (DarcsRepository pris c)) d
    | format_has HashedInventory rf = withCurrentDirectory r $ HashedRepo.replacePristine c (compression opts) d
    | otherwise = withCurrentDirectory r $ Pristine.replacePristine d pris

replacePristineFromSlurpy :: Repository p C(r u t) -> Slurpy -> IO ()
replacePristineFromSlurpy (Repo r opts rf (DarcsRepository pris c)) s
    | format_has HashedInventory rf = withCurrentDirectory r $ HashedRepo.replacePristineFromSlurpy c (compression opts) s
    | otherwise = withCurrentDirectory r $ Pristine.replacePristineFromSlurpy s pris

createPristineDirectoryTree :: RepoPatch p => Repository p C(r u t) -> FilePath -> IO ()
createPristineDirectoryTree repo@(Repo r opts rf (DarcsRepository pris c)) reldir
    | format_has HashedInventory rf =
        do createDirectoryIfMissing True reldir
           withCurrentDirectory reldir $ HashedRepo.copy_pristine c (compression opts) r (darcsdir++"/hashed_inventory")
    | otherwise =
        do dir <- absolute_dir 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

createPartialsPristineDirectoryTree :: RepoPatch p => Repository p C(r u t) -> [FilePath] -> FilePath -> IO ()
createPartialsPristineDirectoryTree (Repo r opts rf (DarcsRepository _ c)) prefs dir
    | format_has 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 prefs

pristineFromWorking :: RepoPatch p => Repository p C(r u t) -> IO ()
pristineFromWorking (Repo dir opts rf (DarcsRepository _ c))
    | format_has HashedInventory rf =
        withCurrentDirectory dir $ HashedRepo.pristine_from_working c (compression opts)
pristineFromWorking (Repo dir _ _ (DarcsRepository p _)) =
  withCurrentDirectory dir $ createPristineFromWorking p

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

checkPristineAgainstCwd :: RepoPatch p => Repository p C(r u t) -> IO Bool
checkPristineAgainstCwd (Repo dir _ rf (DarcsRepository p _))
    | not $ format_has HashedInventory rf = do here <- absolute_dir "."
                                               withCurrentDirectory dir $ checkPristine here p
checkPristineAgainstCwd r =
    do s <- mmap_slurp "."
       checkPristineAgainstSlurpy r s

checkPristineAgainstSlurpy :: RepoPatch p => Repository p C(r u t) -> Slurpy -> IO Bool
checkPristineAgainstSlurpy repository@(Repo _ opts _ _) s2 =
    do s1 <- slurp_recorded repository
       ftf <- filetype_function
       return $ nullFL $ smart_diff (LookForAdds:IgnoreTimes:opts) ftf s1 s2

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
    | format_has 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 <- readFilePS fil
                                return $ case readPatch ps of
                                           Just (x, _) -> x
                                           Nothing -> seal NilFL
\end{code}

\begin{code}
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, empty_markedup_file)
  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 $ markup_file (info hp) (patchcontents p) (f, mk)
    Nothing -> (f, [(packString "Error reading a patch!",None)])
do_mark_all NilFL (f, mk) = (f, mk)
\end{code}

\begin{code}
-- | 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 <- readFilePS f
                 when (takePS 2 contents == packString "#!") $ do
                   debugMessage ("Making executable: " ++ f)
                   setExecutable f True
    mapM_ setExecutableIfScript c
\end{code}

