% 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(..), ($-), maybeIdentifyRepository, identifyDarcs1Repository, identifyRepositoryFor, findRepository, amInRepository, amNotInRepository, slurp_pending, pristineFromWorking, revertRepositoryChanges, slurp_recorded, slurp_recorded_and_unrecorded, withRecorded, checkPristineAgainstCwd, 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, optimizeInventory, cleanRepository, getMarkedupFile, PatchSet, SealedPatchSet, setScriptsExecutable ) 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 ) 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 ( Effect, is_hunk, is_binary, description, try_to_shrink, commuteFL ) import Darcs.Patch.Prim ( try_shrinking_inverse ) 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, clean_pristine, replacePristine, 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), want_external_merge ) import Darcs.Patch.Ordered ( FL(..), RL(..), EqCheck(..), unsafeCoerceP, (:\/:)(..), (:/\:)(..), (:>)(..), (+>+), lengthFL, unsafeUnFL, allFL, filterFL, reverseRL, reverseFL, concatRL, mapFL, mapFL_FL, concatFL ) import Darcs.Patch ( RepoPatch, Patchy, Prim, RealPatch, Patch, 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_addrmfile, is_addrmdir, is_setpref, apply, apply_to_slurpy, empty_markedup_file, MarkedUpFile ) 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.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), mapSeal, unsafeUnseal, liftSM, seal ) import Darcs.Repository.InternalTypes( Repository(..), RepoType(..) ) import Darcs.Global ( darcsdir ) #include "impossible.h" maybeIdentifyRepository :: [DarcsFlag] -> String -> IO (Either String (Repository p)) 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) identifyDarcs1Repository opts url = do er <- maybeIdentifyRepository opts url case er of Left s -> fail s Right r -> return r identifyRepositoryFor :: RepoPatch p => Repository p -> String -> IO (Repository p) 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 FilePath) 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 FilePath -- ^ what to return if we don't find a repository -> IO (Either String FilePath) seekRepo onFail = getCurrentDirectory >>= helper "" where helper dir startpwd = do air <- currentDirIsRepository if air then return (Right dir) else do cd <- getCurrentDirectory setCurrentDirectory ".." cd' <- getCurrentDirectory if cd' /= cd then helper (reverse (takeWhile (/='/') $ reverse cd)///dir) startpwd else do setCurrentDirectory startpwd return onFail where ""///b = b a///"" = a a///b = a ++ "/" ++ b amNotInRepository :: [DarcsFlag] -> IO (Either String FilePath) 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 FilePath) 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 -> IO Slurpy slurp_pending repo = do cur <- slurp_recorded repo pend <- read_pending repo case apply_to_slurpy pend cur of Just pendcur -> return pendcur Nothing -> do putStrLn "Yikes, pending has conflicts!" return cur slurp_recorded :: RepoPatch p => Repository p -> IO Slurpy slurp_recorded (Repo dir opts rf (DarcsRepository _ c)) | format_has HashedInventory rf = HashedRepo.slurp_pristine c 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" $ \cd -> do createPristineDirectoryTree repository cd mmap_slurp cd slurp_recorded_and_unrecorded :: RepoPatch p => Repository p -> IO (Slurpy, Slurpy) slurp_recorded_and_unrecorded repo@(Repo r _ _ _) = do cur <- slurp_recorded repo 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 -> IO (FL Prim) read_pending (Repo r _ _ tp) = withCurrentDirectory r (read_pendingfile (pendingName tp)) add_to_pending :: RepoPatch p => Repository p -> FL Prim -> 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 of Nothing -> Sealed NilFL Just (Sealed p,_) -> Sealed (effect (p :: Patch C(x y))) read_pendingfile :: String -> IO (FL Prim) read_pendingfile name = do pend <- gzReadFilePS name `catchall` return nilPS case readPrims pend of Sealed p -> return p make_new_pending :: RepoPatch p => Repository p -> FL Prim -> 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 writePatch newname (fromPrims $ sift_for_pending origp :: Patch) cur <- slurp_recorded repo 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 sift_for_pending :: FL Prim -> FL Prim 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 oldps else case try_to_shrink $ sfp NilFL $ reverseFL oldps of ps | lengthFL ps < lengthFL oldps -> sift_for_pending ps | otherwise -> ps where sfp :: FL Prim C(x y) -> RL Prim C(y z) -> FL Prim C(x z) sfp sofar NilRL = sofar sfp sofar (p:<:ps) | is_hunk p || is_binary p = case commuteFL (p :> sofar) of Just (sofar' :> _) -> sfp sofar' ps Nothing -> sfp (p:>:sofar) ps sfp sofar (p:<:ps) = sfp (p:>:sofar) ps get_unrecorded_no_look_for_adds :: RepoPatch p => Repository p -> IO (FL Prim) get_unrecorded_no_look_for_adds = get_unrecorded_private (filter (/= LookForAdds)) get_unrecorded_unsorted :: RepoPatch p => Repository p -> IO (FL Prim) get_unrecorded_unsorted = get_unrecorded_private (AnyOrder:) get_unrecorded :: RepoPatch p => Repository p -> IO (FL Prim) get_unrecorded = get_unrecorded_private id get_unrecorded_private :: RepoPatch p => ([DarcsFlag]->[DarcsFlag]) -> Repository p -> IO (FL Prim) get_unrecorded_private _ (Repo _ opts _ _) | NoUpdateWorking `elem` opts = return 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 "." pend <- read_pending repository when (Verbose `elem` opts) $ putStrLn "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 -> IO (SealedPatchSet p) read_repo repo@(Repo r opts rf _) | format_has HashedInventory rf = do ps <- HashedRepo.read_repo repo opts r return $ seal ps | otherwise = DarcsRepo.read_repo opts r makePatchLazy :: RepoPatch p => Repository p -> PatchInfoAnd p -> IO (PatchInfoAnd p) makePatchLazy (Repo r opts rf (DarcsRepository _ c)) p | format_has HashedInventory rf = withCurrentDirectory r $ HashedRepo.write_and_read_patch c opts p | otherwise = withCurrentDirectory r $ DarcsRepo.write_and_read_patch opts p sync_repo :: Repository p -> 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 -> String prefsUrl (Repo r _ _ (DarcsRepository _ _)) = r ++ "/"++darcsdir++"/prefs" unrevertUrl :: Repository p -> String unrevertUrl (Repo r _ _ (DarcsRepository _ _)) = r ++ "/"++darcsdir++"/patches/unrevert" applyToWorking :: Patchy p => Repository p1 -> [DarcsFlag] -> p -> 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 :: (RepoPatch p, Effect q) => Repository p -> q -> 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 :: Patch) where rmpend :: FL Prim C(x y) -> FL Prim C(x z) -> Sealed (FL Prim) C(y) 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 -> (invert (x':>:b) +>+) `mapSeal` rmpend a ys is_simple :: Prim C(x y) -> Bool is_simple x = is_hunk x || is_binary x || is_setpref x || is_addrmfile x || is_addrmdir 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 -> String -> [DarcsFlag] -> FL (PatchInfoAnd p) -> FL (PatchInfoAnd p) -> IO (FL Prim) tentativelyMergePatches = tentativelyMergePatches_ MakeChanges considerMergeToWorking :: RepoPatch p => Repository p -> String -> [DarcsFlag] -> FL (PatchInfoAnd p) -> FL (PatchInfoAnd p) -> IO (FL Prim) considerMergeToWorking = tentativelyMergePatches_ DontMakeChanges data MakeChanges = MakeChanges | DontMakeChanges deriving ( Eq ) tentativelyMergePatches_ :: RepoPatch p => MakeChanges -> Repository p -> String -> [DarcsFlag] -> FL (PatchInfoAnd p) -> FL (PatchInfoAnd p) -> IO (FL Prim) tentativelyMergePatches_ mc r cmd opts usi themi = do let us = mapFL_FL hopefully usi them = mapFL_FL hopefully themi pc = case merge (progressFL "Merging them" them :\/: progressFL "Merging us" us) of _ :/\: x -> x 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 = 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..." pw_resolution <- case (want_external_merge opts, have_conflicts || have_unrecorded_conflicts) of (Nothing,_) -> return $ if AllowConflicts `elem` opts then NilFL else standard_resolved_pw (_,False) -> return standard_resolved_pw (Just c, True) -> unsafeUnseal `fmap` external_resolution working c (effect us +>+ pend) (effect them) pwprim debugMessage "Applying patches to the local directories..." when (mc == MakeChanges) $ do let themi' = case usi of NilFL -> themi _ -> mapFL_FL n2pia pc debugMessage "Adding patches to inventory..." sequence_ $ mapFL (tentativelyAddPatch_ DontUpdatePristine r opts) themi' debugMessage "Applying patches to pristine..." applyToTentativePristine r themi' debugMessage "Updating pending..." setTentativePending r (effect pend' +>+ pw_resolution) return (effect pwprim +>+ pw_resolution) announce_merge_conflicts :: String -> [DarcsFlag] -> FL Prim -> 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. RepoPatch p => [DarcsFlag] -> FL (Named p) -> IO Bool check_unrecorded_conflicts opts _ | NoUpdateWorking `elem` opts = return False check_unrecorded_conflicts opts pc = do repository <- identifyDarcs1Repository opts "." mpend <- read_pending repository case mpend of NilFL -> return False pend -> case merge (fromPrims pend :\/: fromPrims (concatFL $ mapFL_FL effect pc)) of _ :/\: (pend' :: p) -> 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 putStr "Cancelled." exitWith ExitSuccess return True tentativelyAddPatch :: RepoPatch p => Repository p -> [DarcsFlag] -> PatchInfoAnd p -> IO () tentativelyAddPatch = tentativelyAddPatch_ UpdatePristine data UpdatePristine = UpdatePristine | DontUpdatePristine deriving Eq tentativelyAddPatch_ :: RepoPatch p => UpdatePristine -> Repository p -> [DarcsFlag] -> PatchInfoAnd p -> 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 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 -> q -> 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. RepoPatch p => Repository p -> [DarcsFlag] -> FL Prim -> 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" pend <- gzReadFilePS tpn `catchall` (return nilPS) let newpend = case readPrims pend of Sealed NilFL -> patch Sealed p -> p +>+ patch writePatch tpn $ (fromPrims newpend :: Patch) setTentativePending :: forall p. RepoPatch p => Repository p -> FL Prim -> IO () setTentativePending (Repo _ opts _ _) _ | NoUpdateWorking `elem` opts = return () setTentativePending (Repo dir _ _ rt) patch = withCurrentDirectory dir $ writePatch (pendingName rt ++ ".tentative") $ (fromPrims (sift_for_pending patch) :: Patch) prepend :: forall p. RepoPatch p => Repository p -> FL Prim -> IO () prepend (Repo _ opts _ _) _ | NoUpdateWorking `elem` opts = return () prepend (Repo _ _ _ rt) patch = do let pn = pendingName rt ++ ".tentative" pend <- gzReadFilePS pn `catchall` (return nilPS) let newpend = case readPrims pend of Sealed NilFL -> patch Sealed p -> patch +>+ p writePatch pn $ (fromPrims (crude_sift newpend) :: Patch) tentativelyRemovePatches :: RepoPatch p => Repository p -> [DarcsFlag] -> FL (Named p) -> IO () tentativelyRemovePatches = tentativelyRemovePatches_ UpdatePristine tentativelyRemovePatches_ :: RepoPatch p => UpdatePristine -> Repository p -> [DarcsFlag] -> FL (Named p) -> 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 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 updarcspris opts ps where updarcspris = up==UpdatePristine && not (format_has HashedInventory rf) tentativelyReplacePatches :: RepoPatch p => Repository p -> [DarcsFlag] -> FL (Named p) -> IO () tentativelyReplacePatches repository opts ps = do tentativelyRemovePatches_ DontUpdatePristine repository opts ps sequence_ $ mapFL (tentativelyAddPatch_ DontUpdatePristine repository opts . n2pia) ps finalize_pending :: RepoPatch p => Repository p -> 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) let tpend = unsafeUnseal $ readPrims tpfile new_pending = sift_for_pending tpend make_new_pending repository new_pending finalizeRepositoryChanges :: RepoPatch p => Repository p -> 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 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 -> 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 -> 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") 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 => PatchSet p -> FL (Named p) 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 -> IO () -> IO () withGutsOf (Repo _ _ rf _) | format_has HashedInventory rf = id | otherwise = withSignalsBlocked withRepository :: [DarcsFlag] -> (forall p. RepoPatch p => Repository p -> IO a) -> IO a withRepository opts1 = withRepositoryDirectory opts1 "." withRepositoryDirectory :: [DarcsFlag] -> String -> (forall p. RepoPatch p => Repository p -> 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 job (Repo dir opts rf rt' :: Repository (FL RealPatch)) else do debugMessage $ "Identified darcs-1 repo: " ++ dir job (Repo dir opts rf rt :: Repository Patch) ($-) :: ((forall p. RepoPatch p => Repository p -> IO a) -> IO a) -> (forall p. RepoPatch p => Repository p -> IO a) -> IO a x $- y = x y withRepoLock :: [DarcsFlag] -> (forall p. RepoPatch p => Repository p -> 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. RepoPatch p => Repository p -> 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 :: RepoPatch p => Repository p -> FL (Named p) -> IO () remove_from_unrevert_context repository ps = do bundle <- unrevert_patch_bundle `catchall` return (NilRL:<:NilRL) case bundle of NilRL:<:NilRL -> return () _ -> do let unrevert_loc = unrevertUrl repository debugMessage "Adjusting the context of the unrevert changes..." Sealed ref <- read_repo 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 where unrevert_impossible unrevert_loc = do yorn <- promptYorn "This operation will make unrevert impossible!\nProceed?" case yorn of 'n' -> fail "Cancelled to avoid unrevert catastrophe!" 'y' -> removeFile unrevert_loc `catchall` return () _ -> impossible pis = mapFL patch2patchinfo ps unrevert_patch_bundle :: RepoPatch p => IO (PatchSet p) unrevert_patch_bundle = do pf <- readFilePS (unrevertUrl repository) case scan_bundle pf of Right (Sealed foo) -> return foo Left err -> fail $ "Couldn't parse unrevert patch:\n" ++ err \end{code} \begin{code} optimizeInventory :: RepoPatch p => Repository p -> IO () optimizeInventory repository@(Repo r opts rf (DarcsRepository _ c)) = do Sealed ps <- read_repo repository decideHashedOrNormal rf $ HvsO { hashed = do revertRepositoryChanges repository HashedRepo.write_tentative_inventory c opts $ deep_optimize_patchset ps finalizeRepositoryChanges repository, old = DarcsRepo.write_inventory r $ deep_optimize_patchset ps } cleanRepository :: RepoPatch p => Repository p -> IO () cleanRepository repository@(Repo _ _ rf _) = decideHashedOrNormal rf $ HvsO { hashed = HashedRepo.clean_pristine repository, old = return () } replacePristine :: Repository p -> FilePath -> IO () replacePristine (Repo r opts rf (DarcsRepository pris c)) d | format_has HashedInventory rf = withCurrentDirectory r $ HashedRepo.replacePristine c opts d | otherwise = withCurrentDirectory r $ Pristine.replacePristine d pris createPristineDirectoryTree :: RepoPatch p => Repository p -> 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 opts r (darcsdir++"/hashed_inventory") | otherwise = do dir <- absolute_dir reldir done <- withCurrentDirectory r $ easyCreatePristineDirectoryTree pris dir unless done $ do patches <- (reverseRL . concatRL) `liftSM` read_repo repo createDirectoryIfMissing True dir withCurrentDirectory dir $ apply_patches [] patches createPartialsPristineDirectoryTree :: RepoPatch p => Repository p -> [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 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 -> IO () pristineFromWorking (Repo dir opts rf (DarcsRepository _ c)) | format_has HashedInventory rf = withCurrentDirectory dir $ HashedRepo.pristine_from_working c opts pristineFromWorking (Repo dir _ _ (DarcsRepository p _)) = withCurrentDirectory dir $ createPristineFromWorking p withRecorded :: RepoPatch p => Repository p -> ((FilePath -> IO a) -> IO a) -> (FilePath -> IO a) -> IO a withRecorded repository mk_dir f = mk_dir $ \d -> do createPristineDirectoryTree repository d f d checkPristineAgainstCwd :: RepoPatch p => Repository p -> IO Bool checkPristineAgainstCwd (Repo dir _ rf (DarcsRepository p _)) | not $ format_has HashedInventory rf = do here <- absolute_dir "." withCurrentDirectory dir $ checkPristine here p checkPristineAgainstCwd repository@(Repo _ opts _ _) = do s2 <- mmap_slurp "." s1 <- slurp_recorded repository ftf <- filetype_function case smart_diff opts ftf s1 s2 of NilFL -> return True _ -> return False withTentative :: forall p a. RepoPatch p => Repository p -> ((FilePath -> IO a) -> IO a) -> (FilePath -> 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 opts dir (darcsdir++"/tentative_pristine") f d withTentative repository@(Repo dir opts _ _) mk_dir f = withRecorded repository mk_dir $ \d -> do ps <- read_patches (dir ++ "/"++darcsdir++"/tentative_pristine") apply opts $ joinPatches ps f d where read_patches :: FilePath -> IO (FL p) read_patches fil = do ps <- readFilePS fil return $ case readPatch ps of Just (Sealed x, _) -> x Nothing -> NilFL \end{code} \begin{code} getMarkedupFile :: RepoPatch p => Repository p -> PatchInfo -> FilePath -> IO MarkedUpFile getMarkedupFile repository pinfo f = do patches <- (dropWhile ((/= pinfo) . info) . unsafeUnFL . reverseRL . concatRL) `liftSM` read_repo repository return $ snd $ do_mark_all patches (f, empty_markedup_file) do_mark_all :: RepoPatch p => [PatchInfoAnd p] -> (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 [] (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}