darcs-cabalized-2.0.2: src/Darcs/Repository/Internal.lhs
% 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}