#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"
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
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.")
seekRepo :: Either String ()
-> 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 (WorkRepoDir d:_) = do createDirectoryIfMissing False d
`catchall` (performGC >> createDirectoryIfMissing False d)
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
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'
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}
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 $ 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 :: 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 =
do tentativelyRemovePatches_ DontUpdatePristine repository opts ps
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) =
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
($-) ::((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
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
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)
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