#include "gadts.h"
module Darcs.Repository.Internal ( Repository(..), RepoType(..), RIO(unsafeUnRIO), ($-),
maybeIdentifyRepository, identifyDarcs1Repository, identifyRepositoryFor,
IdentifyRepo(..),
findRepository, amInRepository, amNotInRepository,
revertRepositoryChanges,
announceMergeConflicts, setTentativePending,
checkUnrecordedConflicts,
withRecorded,
readRepo, readTentativeRepo,
prefsUrl, makePatchLazy,
withRepoLock, withRepoReadLock,
withRepository, withRepositoryDirectory, withGutsOf,
tentativelyAddPatch, tentativelyRemovePatches, tentativelyAddToPending,
tentativelyAddPatch_,
tentativelyReplacePatches,
finalizeRepositoryChanges,
unrevertUrl,
applyToWorking, patchSetToPatches,
createPristineDirectoryTree, createPartialsPristineDirectoryTree,
optimizeInventory, cleanRepository,
getMarkedupFile,
PatchSet, SealedPatchSet,
setScriptsExecutable,
getRepository, rIO,
testTentative, testRecorded,
UpdatePristine(..), MakeChanges(..), applyToTentativePristine,
makeNewPending
) where
import Printer ( putDocLn, (<+>), text, ($$) )
import Darcs.Repository.Prefs ( getPrefval )
import Darcs.Repository.State ( readRecorded, readWorking )
import Darcs.Repository.LowLevel ( readPending, pendingName, readPrims, readPendingfile )
import System.Exit ( ExitCode(..), exitWith )
import System.Cmd ( system )
import Darcs.External ( clonePartialsTree )
import Darcs.IO ( runTolerantly, runSilently )
import Darcs.Repository.Pristine ( identifyPristine, nopristine,
easyCreatePristineDirectoryTree,
easyCreatePartialsPristineDirectoryTree )
import Darcs.SignalHandler ( withSignalsBlocked )
import Darcs.Repository.Format ( RepoFormat, RepoProperty( Darcs2, HashedInventory ),
identifyRepoFormat, formatHas,
writeProblem, readProblem, readfromAndWritetoProblem )
import System.Directory ( doesDirectoryExist, setCurrentDirectory,
createDirectoryIfMissing )
import Control.Monad ( liftM, when, unless )
import Workaround ( getCurrentDirectory, renameFile, setExecutable )
import ByteStringUtils ( gzReadFilePS )
import qualified Data.ByteString as B ( empty, readFile, isPrefixOf )
import qualified Data.ByteString.Char8 as BC (pack)
import Darcs.Patch ( Patch, RealPatch, Effect, primIsHunk, primIsBinary, description,
tryToShrink, commuteFLorComplain, commute )
import Darcs.Patch.Prim ( tryShrinkingInverse )
import Darcs.Patch.Bundle ( scanBundle, makeBundleN )
import Darcs.Hopefully ( PatchInfoAnd, info,
hopefully, hopefullyM )
import Darcs.Repository.ApplyPatches ( applyPatches )
import qualified Darcs.Repository.HashedRepo as HashedRepo
( revertTentativeChanges, finalizeTentativeChanges,
removeFromTentativeInventory,
copyPristine, copyPartialsPristine,
applyToTentativePristine,
writeTentativeInventory, writeAndReadPatch,
addToTentativeInventory,
readRepo, readTentativeRepo, cleanPristine )
import qualified Darcs.Repository.DarcsRepo as DarcsRepo
import Darcs.Flags ( DarcsFlag(Verbose, Quiet,
MarkConflicts, AllowConflicts, NoUpdateWorking,
WorkRepoUrl, WorkRepoDir, UMask, Test, LeaveTestDir,
SetScriptsExecutable, DryRun ),
wantExternalMerge, compression )
import Darcs.Witnesses.Ordered ( FL(..), RL(..), EqCheck(..), unsafeCoerceP,
(:\/:)(..), (:/\:)(..), (:>)(..),
(+>+), lengthFL,
allFL, filterFLFL,
reverseFL, mapFL_FL, concatFL )
import Darcs.Patch ( RepoPatch, Patchy, Prim, merge,
joinPatches,
listConflictedFiles, listTouchedFiles,
Named, patchcontents,
commuteRL, fromPrims,
readPatch,
writePatch, effect, invert,
primIsAddfile, primIsAdddir,
primIsSetpref,
apply, applyToTree,
emptyMarkedupFile, MarkedUpFile
)
import Darcs.Patch.Permutations ( commuteWhatWeCanFL, removeFL )
import Darcs.Patch.Info ( PatchInfo )
import Darcs.Patch.Set ( PatchSet(..), SealedPatchSet, newset2FL )
#ifdef GADT_WITNESSES
import Darcs.Patch.Set ( Origin )
#endif
import Darcs.Patch.Apply ( markupFile, LineMark(None) )
import Darcs.Patch.Depends ( deepOptimizePatchset, removeFromPatchSet, mergeThem )
import Darcs.RepoPath ( FilePathLike, AbsolutePath, toFilePath,
ioAbsoluteOrRemote, toPath )
import Darcs.Utils ( promptYorn, catchall, withCurrentDirectory, withUMask, nubsort )
import Progress ( debugMessage )
import Darcs.ProgressPatches (progressFL)
import Darcs.URL ( isFile )
import Darcs.Repository.Prefs ( getCaches )
import Darcs.Lock ( withLock, writeDocBinFile, removeFileMayNotExist,
withTempDir, withPermDir )
import Darcs.Witnesses.Sealed ( Sealed(Sealed), seal, FlippedSeal(FlippedSeal), flipSeal )
import Darcs.Repository.InternalTypes( Repository(..), RepoType(..) )
import Darcs.Global ( darcsdir )
import System.Mem( performGC )
import qualified Storage.Hashed.Tree as Tree
import Storage.Hashed.AnchoredPath( anchorPath )
#include "impossible.h"
newtype RIO p C(r u t t1) a = RIO {
unsafeUnRIO :: Repository p C(r u t) -> IO a
}
(>>>=) :: 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)
(>>>) :: 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)
returnR :: a -> RIO p C(r u t t) a
returnR = rIO . return
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)
instance Monad (RIO p C(r u t t)) where
(>>=) = (>>>=)
(>>) = (>>>)
return = returnR
fail = rIO . fail
getRepository :: RIO p C(r u t t) (Repository p C(r u t))
getRepository = RIO return
data IdentifyRepo p C(r u t) = BadRepository String
| NonRepository String
| GoodRepository (Repository p C(r u t))
maybeIdentifyRepository :: [DarcsFlag] -> String -> IO (IdentifyRepo p C(r u t))
maybeIdentifyRepository opts "." =
do darcs <- doesDirectoryExist darcsdir
rf_or_e <- identifyRepoFormat "."
here <- toPath `fmap` ioAbsoluteOrRemote "."
case rf_or_e of
Left err -> return $ NonRepository err
Right rf ->
case readProblem rf of
Just err -> return $ BadRepository err
Nothing -> if darcs then do pris <- identifyPristine
cs <- getCaches opts here
return $ GoodRepository $ Repo here opts rf (DarcsRepository pris cs)
else return (NonRepository "Not a repository")
maybeIdentifyRepository opts url' =
do url <- toPath `fmap` ioAbsoluteOrRemote url'
rf_or_e <- identifyRepoFormat url
case rf_or_e of
Left e -> return $ NonRepository e
Right rf -> case readProblem rf of
Just err -> return $ BadRepository err
Nothing -> do cs <- getCaches opts url
return $ GoodRepository $ Repo url opts rf (DarcsRepository nopristine cs)
identifyDarcs1Repository :: [DarcsFlag] -> String -> IO (Repository Patch C(r u t))
identifyDarcs1Repository opts url =
do er <- maybeIdentifyRepository opts url
case er of
BadRepository s -> fail s
NonRepository s -> fail s
GoodRepository r -> return r
identifyRepositoryFor :: forall p C(r u t). RepoPatch p => Repository p C(r u t) -> String -> IO (Repository p C(r u t))
identifyRepositoryFor (Repo _ opts rf _) url =
do Repo absurl _ rf_ t <- identifyDarcs1Repository opts url
let t' = case t of DarcsRepository x c -> DarcsRepository x c
case readfromAndWritetoProblem rf_ rf of
Just e -> fail $ "Incompatibility with repository " ++ url ++ ":\n" ++ e
Nothing -> return $ Repo absurl opts rf_ t'
amInRepository :: [DarcsFlag] -> IO (Either String ())
amInRepository (WorkRepoDir d:_) =
do setCurrentDirectory d `catchall` (fail $ "can't set directory to "++d)
status <- maybeIdentifyRepository [] "."
case status of
GoodRepository _ -> return (Right ())
BadRepository e -> return (Left $ "While " ++ d ++ " looks like a repository directory, we have a problem with it:\n" ++ e)
NonRepository _ -> return (Left "You need to be in a repository directory to run this command.")
amInRepository (_:fs) = amInRepository fs
amInRepository [] =
seekRepo (Left "You need to be in a repository directory to run this command.")
seekRepo :: Either String ()
-> IO (Either String ())
seekRepo onFail = getCurrentDirectory >>= helper where
helper startpwd = do
status <- maybeIdentifyRepository [] "."
case status of
GoodRepository _ -> return (Right ())
BadRepository e -> return (Left e)
NonRepository _ ->
do cd <- toFilePath `fmap` getCurrentDirectory
setCurrentDirectory ".."
cd' <- toFilePath `fmap` getCurrentDirectory
if cd' /= cd
then helper startpwd
else do setCurrentDirectory startpwd
return onFail
amNotInRepository :: [DarcsFlag] -> IO (Either String ())
amNotInRepository (WorkRepoDir d:_) = do createDirectoryIfMissing False d
`catchall` (performGC >> createDirectoryIfMissing False d)
setCurrentDirectory d
amNotInRepository []
amNotInRepository (_:f) = amNotInRepository f
amNotInRepository [] =
do status <- maybeIdentifyRepository [] "."
case status of
GoodRepository _ -> return (Left $ "You may not run this command in a repository.")
BadRepository e -> return (Left $ "You may not run this command in a repository.\nBy the way, we have a problem with it:\n" ++ e)
NonRepository _ -> return (Right ())
findRepository :: [DarcsFlag] -> IO (Either String ())
findRepository (WorkRepoUrl d:_) | isFile d =
do setCurrentDirectory d `catchall` (fail $ "can't set directory to "++d)
findRepository []
findRepository (WorkRepoDir d:_) =
do setCurrentDirectory d `catchall` (fail $ "can't set directory to "++d)
findRepository []
findRepository (_:fs) = findRepository fs
findRepository [] = seekRepo (Right ())
makeNewPending :: forall p C(r u t y). RepoPatch p
=> Repository p C(r u t) -> FL Prim C(t y) -> IO ()
makeNewPending (Repo _ opts _ _) _ | NoUpdateWorking `elem` opts = return ()
makeNewPending repo@(Repo r _ _ tp) origp =
withCurrentDirectory r $
do let newname = pendingName tp ++ ".new"
debugMessage $ "Writing new pending: " ++ newname
Sealed sfp <- return $ siftForPending origp
writeSealedPatch newname $ seal $ fromPrims $ sfp
cur <- readRecorded repo
Sealed p <- readPendingfile newname
catch (applyToTree p cur) $ \err -> do
let buggyname = pendingName tp ++ "_buggy"
renameFile newname buggyname
bugDoc $ text ("There was an attempt to write an invalid pending! " ++ show err)
$$ text "If possible, please send the contents of"
<+> text buggyname
$$ text "along with a bug report."
renameFile newname (pendingName tp)
debugMessage $ "Finished writing new pending: " ++ newname
where writeSealedPatch :: FilePath -> Sealed (Patch C(x)) -> IO ()
writeSealedPatch fp (Sealed p) = writePatch fp p
siftForPending :: FL Prim C(x y) -> Sealed (FL Prim C(x))
siftForPending simple_ps =
let oldps = maybe simple_ps id $ tryShrinkingInverse $ crudeSift simple_ps
in if allFL (\p -> primIsAddfile p || primIsAdddir p) $ oldps
then seal oldps
else fromJust $ do
Sealed x <- return $ sfp NilFL $ reverseFL oldps
return (case tryToShrink x of
ps | lengthFL ps < lengthFL oldps -> siftForPending ps
| otherwise -> seal ps)
where sfp :: FL Prim C(a b) -> RL Prim C(c a) -> Sealed (FL Prim C(c))
sfp sofar NilRL = seal sofar
sfp sofar (p:<:ps)
| primIsHunk p || primIsBinary p
= case commuteFLorComplain (p :> sofar) of
Right (sofar' :> _) -> sfp sofar' ps
Left _ -> sfp (p:>:sofar) ps
sfp sofar (p:<:ps) = sfp (p:>:sofar) ps
readRepo :: RepoPatch p => Repository p C(r u t) -> IO (PatchSet p C(Origin r))
readRepo repo@(Repo r opts rf _)
| formatHas HashedInventory rf = do ps <- HashedRepo.readRepo repo r
return ps
| otherwise = do Sealed ps <- DarcsRepo.readRepo opts r
return $ unsafeCoerceP ps
readTentativeRepo :: RepoPatch p => Repository p C(r u t) -> IO (PatchSet p C(Origin t))
readTentativeRepo repo@(Repo r opts rf _)
| formatHas HashedInventory rf = do ps <- HashedRepo.readTentativeRepo repo r
return ps
| otherwise = do Sealed ps <- DarcsRepo.readTentativeRepo opts r
return $ unsafeCoerceP ps
makePatchLazy :: RepoPatch p => Repository p C(r u t) -> PatchInfoAnd p C(x y) -> IO (PatchInfoAnd p C(x y))
makePatchLazy (Repo r opts rf (DarcsRepository _ c)) p
| formatHas HashedInventory rf = withCurrentDirectory r $ HashedRepo.writeAndReadPatch c (compression opts) p
| otherwise = withCurrentDirectory r $ DarcsRepo.writeAndReadPatch opts p
prefsUrl :: Repository p C(r u t) -> String
prefsUrl (Repo r _ _ (DarcsRepository _ _)) = r ++ "/"++darcsdir++"/prefs"
unrevertUrl :: Repository p C(r u t) -> String
unrevertUrl (Repo r _ _ (DarcsRepository _ _)) = r ++ "/"++darcsdir++"/patches/unrevert"
applyToWorking :: Patchy p => Repository p1 C(r u t) -> [DarcsFlag] -> p C(u y) -> IO (Repository p1 C(r y t))
applyToWorking (Repo r ropts rf (DarcsRepository t c)) opts patch =
do withCurrentDirectory r $ if Quiet `elem` opts
then runSilently $ apply opts patch
else runTolerantly $ apply opts patch
return (Repo r ropts rf (DarcsRepository t c))
handlePendForAdd :: forall p q C(r u t x y). (RepoPatch p, Effect q)
=> Repository p C(r u t) -> q C(x y) -> IO ()
handlePendForAdd (Repo _ opts _ _) _ | NoUpdateWorking `elem` opts = return ()
handlePendForAdd (Repo _ _ _ rt) p =
do let pn = pendingName rt ++ ".tentative"
Sealed pend <- (readPrims `fmap` gzReadFilePS pn) `catchall` (return $ Sealed NilFL)
let effectp = if allFL isSimple pend then crudeSift $ effect p
else effect p
Sealed newpend <- return $ rmpend (progressFL "Removing from pending:" effectp) pend
writePatch pn $ fromPrims_ newpend
where rmpend :: FL Prim C(a b) -> FL Prim C(a c) -> Sealed (FL Prim C(b))
rmpend NilFL x = Sealed x
rmpend _ NilFL = Sealed NilFL
rmpend (x:>:xs) xys | Just ys <- removeFL x xys = rmpend xs ys
rmpend (x:>:xs) ys =
case commuteWhatWeCanFL (x:>xs) of
a:>x':>b -> case rmpend a ys of
Sealed ys' -> case commute (invert (x':>:b) :> ys') of
Just (ys'' :> _) -> seal ys''
Nothing -> seal $ invert (x':>:b)+>+ys'
fromPrims_ :: FL Prim C(a b) -> Patch C(a b)
fromPrims_ = fromPrims
isSimple :: Prim C(x y) -> Bool
isSimple x = primIsHunk x || primIsBinary x || primIsSetpref x
crudeSift :: FL Prim C(x y) -> FL Prim C(x y)
crudeSift xs = if allFL isSimple xs then filterFLFL ishunkbinary xs else xs
where ishunkbinary :: Prim C(x y) -> EqCheck C(x y)
ishunkbinary x | primIsHunk x || primIsBinary x = unsafeCoerceP IsEq
| otherwise = NotEq
data HashedVsOld a = HvsO { old, hashed :: a }
decideHashedOrNormal :: Monad m => RepoFormat -> HashedVsOld (m a) -> m a
decideHashedOrNormal rf (HvsO { hashed = h, old = o })
| formatHas HashedInventory rf = h
| otherwise = o
data MakeChanges = MakeChanges | DontMakeChanges deriving ( Eq )
announceMergeConflicts :: String -> [DarcsFlag] -> FL Prim C(x y) -> IO Bool
announceMergeConflicts cmd opts resolved_pw =
case nubsort $ listTouchedFiles $ resolved_pw of
[] -> return False
cfs -> if MarkConflicts `elem` opts || AllowConflicts `elem` opts
|| wantExternalMerge opts /= Nothing
then do putStrLn "We have conflicts in the following files:"
putStrLn $ unwords cfs
return True
else do putStrLn "There are conflicts in the following files:"
putStrLn $ unwords cfs
fail $ "Refusing to "++cmd++" patches leading to conflicts.\n"++
"If you would rather apply the patch and mark the conflicts,\n"++
"use the --mark-conflicts or --allow-conflicts options to "++cmd++"\n"++
"These can set as defaults by adding\n"++
" "++cmd++" mark-conflicts\n"++
"to "++darcsdir++"/prefs/defaults in the target repo. "
checkUnrecordedConflicts :: forall p C(t y). RepoPatch p => [DarcsFlag] -> FL (Named p) C(t y) -> IO Bool
checkUnrecordedConflicts opts _ | NoUpdateWorking `elem` opts = return False
checkUnrecordedConflicts opts pc =
do repository <- identifyDarcs1Repository opts "."
cuc repository
where cuc :: Repository Patch C(r u t) -> IO Bool
cuc r = do Sealed mpend <- readPending r :: IO (Sealed (FL Prim C(t)))
case mpend of
NilFL -> return False
pend ->
case merge (fromPrims_ pend :\/: fromPrims_ (concatFL $ mapFL_FL effect pc)) of
_ :/\: pend' ->
case listConflictedFiles pend' of
[] -> return False
fs -> do putStrLn ("You have conflicting local changes to:\n"
++ unwords fs)
yorn <- promptYorn "Proceed?"
when (yorn /= 'y') $
do putStrLn "Cancelled."
exitWith ExitSuccess
return True
fromPrims_ :: FL Prim C(a b) -> p C(a b)
fromPrims_ = fromPrims
tentativelyAddPatch :: RepoPatch p
=> Repository p C(r u t) -> [DarcsFlag] -> PatchInfoAnd p C(t y) -> IO (Repository p C(r u y))
tentativelyAddPatch = tentativelyAddPatch_ UpdatePristine
data UpdatePristine = UpdatePristine | DontUpdatePristine deriving Eq
tentativelyAddPatch_ :: RepoPatch p
=> UpdatePristine -> Repository p C(r u t) -> [DarcsFlag]
-> PatchInfoAnd p C(t y) -> IO (Repository p C(r u y))
tentativelyAddPatch_ _ _ opts _
| DryRun `elem` opts = bug "tentativelyAddPatch_ called when --dry-run is specified"
tentativelyAddPatch_ up r@(Repo dir ropts rf (DarcsRepository t c)) opts p =
withCurrentDirectory dir $
do decideHashedOrNormal rf $ HvsO {
hashed = HashedRepo.addToTentativeInventory c (compression opts) p,
old = DarcsRepo.addToTentativeInventory opts (hopefully p) }
when (up == UpdatePristine) $ do debugMessage "Applying to pristine cache..."
applyToTentativePristine r p
debugMessage "Updating pending..."
handlePendForAdd r p
return (Repo dir ropts rf (DarcsRepository t c))
applyToTentativePristine :: (Effect q, Patchy q) => Repository p C(r u t) -> q C(t y) -> IO ()
applyToTentativePristine (Repo dir opts rf (DarcsRepository _ c)) p =
withCurrentDirectory dir $
do when (Verbose `elem` opts) $ putDocLn $ text "Applying to pristine..." <+> description p
decideHashedOrNormal rf $ HvsO {hashed = HashedRepo.applyToTentativePristine opts p,
old = DarcsRepo.addToTentativePristine p}
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 :: forall p C(r u t x y). RepoPatch p => Repository p C(r u t) -> FL Prim C(x y) -> IO ()
setTentativePending (Repo _ opts _ _) _ | NoUpdateWorking `elem` opts = return ()
setTentativePending (Repo dir _ _ rt) patch = do
Sealed prims <- return $ siftForPending patch
withCurrentDirectory dir $
writePatch (pendingName rt ++ ".tentative") $ fromPrims_ prims
where fromPrims_ :: FL Prim C(a b) -> Patch C(a b)
fromPrims_ = fromPrims
prepend :: forall p C(r u t x y). RepoPatch p =>
Repository p C(r u t) -> FL Prim C(x y) -> IO ()
prepend (Repo _ opts _ _) _ | NoUpdateWorking `elem` opts = return ()
prepend (Repo _ _ _ rt) patch =
do let pn = pendingName rt ++ ".tentative"
Sealed pend <- readPrims `liftM` (gzReadFilePS pn `catchall` (return B.empty))
Sealed newpend_ <- return $ newpend pend patch
writePatch pn $ fromPrims_ (crudeSift newpend_)
where newpend :: FL Prim C(b c) -> FL Prim C(a b) -> Sealed (FL Prim C(a))
newpend NilFL patch_ = seal patch_
newpend p patch_ = seal $ patch_ +>+ p
fromPrims_ :: FL Prim C(a b) -> Patch C(a b)
fromPrims_ = fromPrims
tentativelyRemovePatches :: RepoPatch p => Repository p C(r u t) -> [DarcsFlag]
-> FL (PatchInfoAnd p) C(x t) -> IO (Repository p C(r u x))
tentativelyRemovePatches = tentativelyRemovePatches_ UpdatePristine
tentativelyRemovePatches_ :: forall p C(r u t x). RepoPatch p => UpdatePristine
-> Repository p C(r u t) -> [DarcsFlag]
-> FL (PatchInfoAnd p) C(x t) -> IO (Repository p C(r u x))
tentativelyRemovePatches_ up repository@(Repo dir ropts rf (DarcsRepository t c)) opts ps =
withCurrentDirectory dir $ do
when (up == UpdatePristine) $ do debugMessage "Adding changes to pending..."
prepend repository $ effect ps
removeFromUnrevertContext repository ps
debugMessage "Removing changes from tentative inventory..."
if formatHas HashedInventory rf
then do HashedRepo.removeFromTentativeInventory repository (compression opts) ps
when (up == UpdatePristine) $
HashedRepo.applyToTentativePristine opts $
progressFL "Applying inverse to pristine" $ invert ps
else DarcsRepo.removeFromTentativeInventory (up==UpdatePristine) opts ps
return (Repo dir ropts rf (DarcsRepository t c))
tentativelyReplacePatches :: forall p C(r u t x). RepoPatch p => Repository p C(r u t) -> [DarcsFlag]
-> FL (PatchInfoAnd p) C(x t) -> IO (Repository p C(r u t))
tentativelyReplacePatches repository opts ps =
do repository' <- tentativelyRemovePatches_ DontUpdatePristine repository opts ps
mapAdd repository' ps
where mapAdd :: Repository p C(m l i) -> FL (PatchInfoAnd p) C(i j) -> IO (Repository p C(m l j))
mapAdd r NilFL = return r
mapAdd r (a:>:as) =
do r' <- tentativelyAddPatch_ DontUpdatePristine r opts a
mapAdd r' as
finalizePending :: RepoPatch p => Repository p C(r u t) -> IO ()
finalizePending (Repo dir opts _ rt)
| NoUpdateWorking `elem` opts =
withCurrentDirectory dir $ removeFileMayNotExist $ (pendingName rt)
finalizePending repository@(Repo dir _ _ rt) = do
withCurrentDirectory dir $ do let pn = pendingName rt
tpn = pn ++ ".tentative"
tpfile <- gzReadFilePS tpn `catchall` (return B.empty)
Sealed tpend <- return $ readPrims tpfile
Sealed new_pending <- return $ siftForPending tpend
makeNewPending repository new_pending
finalizeRepositoryChanges :: RepoPatch p => Repository p C(r u t) -> IO ()
finalizeRepositoryChanges (Repo _ opts _ _)
| DryRun `elem` opts = bug "finalizeRepositoryChanges called when --dry-run specified"
finalizeRepositoryChanges repository@(Repo dir opts rf _)
| formatHas HashedInventory rf =
withCurrentDirectory dir $ do debugMessage "Considering whether to test..."
testTentative repository
debugMessage "Finalizing changes..."
withSignalsBlocked $ do HashedRepo.finalizeTentativeChanges repository (compression opts)
finalizePending repository
debugMessage "Done finalizing changes..."
finalizeRepositoryChanges repository@(Repo dir _ _ (DarcsRepository _ _)) =
withCurrentDirectory dir $ do debugMessage "Considering whether to test..."
testTentative repository
debugMessage "Finalizing changes..."
withSignalsBlocked $ do DarcsRepo.finalizePristineChanges
DarcsRepo.finalizeTentativeChanges
finalizePending repository
testTentative :: RepoPatch p => Repository p C(r u t) -> IO ()
testTentative = testAny withTentative
testRecorded :: RepoPatch p => Repository p C(r u t) -> IO ()
testRecorded = testAny withRecorded
testAny :: RepoPatch p => (Repository p C(r u t)
-> ((AbsolutePath -> IO ()) -> IO ())
-> (AbsolutePath -> IO ()) -> IO ())
-> Repository p C(r u t) -> IO ()
testAny withD repository@(Repo dir opts _ _) =
when (Test `elem` opts) $ withCurrentDirectory dir $
do let putInfo = if not $ Quiet `elem` opts then putStrLn else const (return ())
debugMessage "About to run test if it exists."
testline <- getPrefval "test"
case testline of
Nothing -> return ()
Just testcode ->
withD repository (wd "testing") $ \_ ->
do putInfo "Running test...\n"
when (SetScriptsExecutable `elem` opts) setScriptsExecutable
ec <- system testcode
if ec == ExitSuccess
then putInfo "Test ran successfully.\n"
else do putInfo "Test failed!\n"
exitWith ec
where wd = if LeaveTestDir `elem` opts then withPermDir else withTempDir
revertRepositoryChanges :: RepoPatch p => Repository p C(r u t) -> IO ()
revertRepositoryChanges (Repo _ opts _ _)
| DryRun `elem` opts = bug "revertRepositoryChanges called when --dry-run is specified"
revertRepositoryChanges r@(Repo dir opts rf dr@(DarcsRepository _ _)) =
withCurrentDirectory dir $
do removeFileMayNotExist (pendingName dr ++ ".tentative")
Sealed x <- readPending r
setTentativePending r $ effect x
when (NoUpdateWorking `elem` opts) $ removeFileMayNotExist $ pendingName dr
decideHashedOrNormal rf $ HvsO { hashed = HashedRepo.revertTentativeChanges,
old = DarcsRepo.revertTentativeChanges }
patchSetToPatches :: RepoPatch p => PatchSet p C(x y) -> FL (Named p) C(x y)
patchSetToPatches patchSet = mapFL_FL hopefully $ newset2FL patchSet
getUMask :: [DarcsFlag] -> Maybe String
getUMask [] = Nothing
getUMask ((UMask u):_) = Just u
getUMask (_:l) = getUMask l
withGutsOf :: Repository p C(r u t) -> IO () -> IO ()
withGutsOf (Repo _ _ rf _) | formatHas HashedInventory rf = id
| otherwise = withSignalsBlocked
withRepository :: [DarcsFlag] -> (forall p C(r u). RepoPatch p => Repository p C(r u r) -> IO a) -> IO a
withRepository opts1 = withRepositoryDirectory opts1 "."
withRepositoryDirectory :: forall a. [DarcsFlag] -> String
-> (forall p C(r u). RepoPatch p => Repository p C(r u r) -> IO a) -> IO a
withRepositoryDirectory opts1 url job =
do Repo dir opts rf rt <- identifyDarcs1Repository opts1 url
let rt' = case rt of DarcsRepository t c -> DarcsRepository t c
if formatHas Darcs2 rf
then do debugMessage $ "Identified darcs-2 repo: " ++ dir
job1_ (Repo dir opts rf rt')
else do debugMessage $ "Identified darcs-1 repo: " ++ dir
job2_ (Repo dir opts rf rt)
where job1_ :: Repository (FL RealPatch) C(r u r) -> IO a
job1_ = job
job2_ :: Repository Patch C(r u r) -> IO a
job2_ = job
($-) ::((forall p C(r u). RepoPatch p => Repository p C(r u r) -> IO a) -> IO a)
-> (forall p C(r u). RepoPatch p => Repository p C(r u r) -> IO a) -> IO a
x $- y = x y
withRepoLock :: [DarcsFlag] -> (forall p C(r u). RepoPatch p => Repository p C(r u r) -> IO a) -> IO a
withRepoLock opts job =
withRepository opts $- \repository@(Repo _ _ rf _) ->
do case writeProblem rf of
Nothing -> return ()
Just err -> fail err
let name = "./"++darcsdir++"/lock"
wu = case (getUMask opts) of
Nothing -> id
Just u -> withUMask u
wu $ if DryRun `elem` opts
then job repository
else withLock name (revertRepositoryChanges repository >> job repository)
withRepoReadLock :: [DarcsFlag] -> (forall p C(r u). RepoPatch p => Repository p C(r u r) -> IO a) -> IO a
withRepoReadLock opts job =
withRepository opts $- \repository@(Repo _ _ rf _) ->
do case writeProblem rf of
Nothing -> return ()
Just err -> fail err
let name = "./"++darcsdir++"/lock"
wu = case (getUMask opts) of Nothing -> id
Just u -> withUMask u
wu $ if formatHas HashedInventory rf || DryRun `elem` opts
then job repository
else withLock name (revertRepositoryChanges repository >> job repository)
removeFromUnrevertContext :: forall p C(r u t x). RepoPatch p
=> Repository p C(r u t) -> FL (PatchInfoAnd p) C(x t) -> IO ()
removeFromUnrevertContext repository ps = do
Sealed bundle <- unrevert_patch_bundle `catchall` (return $ seal (PatchSet NilRL NilRL))
remove_from_unrevert_context_ bundle
where unrevert_impossible =
do yorn <- promptYorn "This operation will make unrevert impossible!\nProceed?"
case yorn of
'n' -> fail "Cancelled."
'y' -> removeFileMayNotExist (unrevertUrl repository)
_ -> impossible
unrevert_patch_bundle :: IO (SealedPatchSet p C(Origin))
unrevert_patch_bundle = do pf <- B.readFile (unrevertUrl repository)
case scanBundle pf of
Right foo -> return foo
Left err -> fail $ "Couldn't parse unrevert patch:\n" ++ err
remove_from_unrevert_context_ :: PatchSet p C(Origin z) -> IO ()
remove_from_unrevert_context_ (PatchSet NilRL NilRL) = return ()
remove_from_unrevert_context_ bundle =
do debugMessage "Adjusting the context of the unrevert changes..."
debugMessage $ "Removing "++ show (lengthFL ps) ++
" patches in removeFromUnrevertContext!"
ref <- readTentativeRepo repository
let withSinglet :: Sealed (FL ppp C(xxx))
-> (FORALL(yyy) ppp C(xxx yyy) -> IO ()) -> IO ()
withSinglet (Sealed (x :>: NilFL)) j = j x
withSinglet _ _ = return ()
withSinglet (mergeThem ref bundle) $ \h_us ->
case commuteRL (reverseFL ps :> h_us) of
Nothing -> unrevert_impossible
Just (us' :> _) ->
case removeFromPatchSet ps ref of
Nothing -> unrevert_impossible
Just common ->
do debugMessage "Have now found the new context..."
bundle <- makeBundleN Nothing common (hopefully us':>:NilFL)
writeDocBinFile (unrevertUrl repository) bundle
debugMessage "Done adjusting the context of the unrevert changes!"
optimizeInventory :: RepoPatch p => Repository p C(r u t) -> IO ()
optimizeInventory repository@(Repo r opts rf (DarcsRepository _ c)) =
do ps <- readRepo repository
decideHashedOrNormal rf $
HvsO { hashed = do revertRepositoryChanges repository
HashedRepo.writeTentativeInventory c (compression opts) $ deepOptimizePatchset ps
finalizeRepositoryChanges repository,
old = DarcsRepo.writeInventory r $ deepOptimizePatchset ps
}
cleanRepository :: RepoPatch p => Repository p C(r u t) -> IO ()
cleanRepository repository@(Repo _ _ rf _) =
decideHashedOrNormal rf $
HvsO { hashed = HashedRepo.cleanPristine repository,
old = return () }
createPristineDirectoryTree :: RepoPatch p => Repository p C(r u t) -> FilePath -> IO ()
createPristineDirectoryTree repo@(Repo r opts rf (DarcsRepository pris c)) reldir
| formatHas HashedInventory rf =
do createDirectoryIfMissing True reldir
withCurrentDirectory reldir $ HashedRepo.copyPristine c (compression opts) r (darcsdir++"/hashed_inventory")
| otherwise =
do dir <- toPath `fmap` ioAbsoluteOrRemote reldir
done <- withCurrentDirectory r $ easyCreatePristineDirectoryTree pris dir
unless done $ do Sealed patches <- (seal . newset2FL) `liftM` readRepo repo
createDirectoryIfMissing True dir
withCurrentDirectory dir $ applyPatches [] patches
createPartialsPristineDirectoryTree :: (FilePathLike fp, RepoPatch p) => Repository p C(r u t) -> [fp] -> FilePath -> IO ()
createPartialsPristineDirectoryTree (Repo r opts rf (DarcsRepository _ c)) prefs dir
| formatHas HashedInventory rf =
do createDirectoryIfMissing True dir
withCurrentDirectory dir $
HashedRepo.copyPartialsPristine c (compression opts) r (darcsdir++"/hashed_inventory") prefs
createPartialsPristineDirectoryTree r@(Repo rdir _ _ (DarcsRepository pris _)) prefs dir
= withCurrentDirectory rdir $
do done <- easyCreatePartialsPristineDirectoryTree prefs pris dir
unless done $ withRecorded r (withTempDir "recorded") $ \_ -> do
clonePartialsTree "." dir (map toFilePath prefs)
withRecorded :: RepoPatch p => Repository p C(r u t)
-> ((AbsolutePath -> IO a) -> IO a) -> (AbsolutePath -> IO a) -> IO a
withRecorded repository mk_dir f
= mk_dir $ \d -> do createPristineDirectoryTree repository (toFilePath d)
f d
withTentative :: forall p a C(r u t). RepoPatch p =>
Repository p C(r u t) -> ((AbsolutePath -> IO a) -> IO a)
-> (AbsolutePath -> IO a) -> IO a
withTentative (Repo dir opts rf (DarcsRepository _ c)) mk_dir f
| formatHas HashedInventory rf =
mk_dir $ \d -> do HashedRepo.copyPristine c (compression opts) dir (darcsdir++"/tentative_pristine")
f d
withTentative repository@(Repo dir opts _ _) mk_dir f =
withRecorded repository mk_dir $ \d ->
do Sealed ps <- read_patches (dir ++ "/"++darcsdir++"/tentative_pristine")
apply opts $ joinPatches ps
f d
where read_patches :: FilePath -> IO (Sealed (FL p C(x)))
read_patches fil = do ps <- B.readFile fil
return $ case readPatch ps of
Just (x, _) -> x
Nothing -> seal NilFL
getMarkedupFile :: RepoPatch p => Repository p C(r u t) -> PatchInfo -> FilePath -> IO MarkedUpFile
getMarkedupFile repository pinfo f = do
Sealed (FlippedSeal patches) <- (seal . dropWhileFL ((/= pinfo) . info)
. newset2FL) `liftM` readRepo repository
return $ snd $ doMarkAll patches (f, emptyMarkedupFile)
where dropWhileFL :: (FORALL(x y) a C(x y) -> Bool) -> FL a C(r v) -> FlippedSeal (FL a) C(v)
dropWhileFL _ NilFL = flipSeal NilFL
dropWhileFL p xs@(x:>:xs')
| p x = dropWhileFL p xs'
| otherwise = flipSeal xs
doMarkAll :: RepoPatch p => FL (PatchInfoAnd p) C(x y)
-> (FilePath, MarkedUpFile) -> (FilePath, MarkedUpFile)
doMarkAll (hp:>:pps) (f, mk) =
case hopefullyM hp of
Just p -> doMarkAll pps $ markupFile (info hp) (patchcontents p) (f, mk)
Nothing -> (f, [(BC.pack "Error reading a patch!",None)])
doMarkAll NilFL (f, mk) = (f, mk)
setScriptsExecutable :: IO ()
setScriptsExecutable = do
debugMessage "Making scripts executable"
myname <- getCurrentDirectory
tree <- readWorking
let paths = [ anchorPath "." p | (p, Tree.File _) <- Tree.list tree ]
setExecutableIfScript f =
do contents <- B.readFile f
when (BC.pack "#!" `B.isPrefixOf` contents) $ do
debugMessage ("Making executable: " ++ f)
setExecutable f True
mapM_ setExecutableIfScript paths