| blob | 60d220171679bfe2653518c112ad056f90b7d067 |
1 % Copyright (C) 2002-2004,2007-2008 David Roundy
2 % Copyright (C) 2005 Juliusz Chroboczek
3 %
4 % This program is free software; you can redistribute it and/or modify
5 % it under the terms of the GNU General Public License as published by
6 % the Free Software Foundation; either version 2, or (at your option)
7 % any later version.
8 %
9 % This program is distributed in the hope that it will be useful,
10 % but WITHOUT ANY WARRANTY; without even the implied warranty of
11 % MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12 % GNU General Public License for more details.
13 %
14 % You should have received a copy of the GNU General Public License
15 % along with this program; see the file COPYING. If not, write to
16 % the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
17 % Boston, MA 02110-1301, USA.
19 \begin{code}
20 {-# OPTIONS_GHC -cpp -fglasgow-exts #-}
21 {-# LANGUAGE CPP, ScopedTypeVariables, Rank2Types, RankNTypes, PatternGuards #-}
23 #include "gadts.h"
25 module Darcs.Repository.Internal ( Repository(..), RepoType(..), RIO(unsafeUnRIO), ($-),
26 maybeIdentifyRepository, identifyDarcs1Repository, identifyRepositoryFor,
27 findRepository, amInRepository, amNotInRepository,
28 slurp_pending, pristineFromWorking, revertRepositoryChanges,
29 slurp_recorded, slurp_recorded_and_unrecorded,
30 withRecorded, checkPristineAgainstCwd,
31 checkPristineAgainstSlurpy,
32 get_unrecorded, get_unrecorded_unsorted, get_unrecorded_no_look_for_adds,
33 read_repo, sync_repo,
34 prefsUrl, makePatchLazy,
35 add_to_pending,
36 withRepoLock, withRepoReadLock,
37 withRepository, withRepositoryDirectory, withGutsOf,
38 tentativelyAddPatch, tentativelyRemovePatches, tentativelyAddToPending,
39 tentativelyReplacePatches,
40 tentativelyMergePatches, considerMergeToWorking,
41 finalizeRepositoryChanges,
42 unrevertUrl,
43 applyToWorking, patchSetToPatches,
44 createPristineDirectoryTree, createPartialsPristineDirectoryTree,
45 replacePristine, replacePristineFromSlurpy,
46 optimizeInventory, cleanRepository,
47 getMarkedupFile,
48 PatchSet, SealedPatchSet,
49 setScriptsExecutable,
50 getRepository, rIO,
51 testTentative
52 ) where
54 import Printer ( putDocLn, (<+>), text, ($$) )
56 import Data.Maybe ( isJust, isNothing )
57 import Darcs.Repository.Prefs ( get_prefval )
58 import Darcs.Resolution ( standard_resolution, external_resolution )
59 import System.Exit ( ExitCode(..), exitWith )
60 import System.Cmd ( system )
61 import Darcs.External ( backupByCopying, clonePartialsTree )
62 import Darcs.IO ( runTolerantly, runSilently )
63 import Darcs.Repository.Pristine ( identifyPristine, nopristine, checkPristine,
64 easyCreatePristineDirectoryTree, slurpPristine, syncPristine,
65 easyCreatePartialsPristineDirectoryTree,
66 createPristineFromWorking )
67 import qualified Darcs.Repository.Pristine as Pristine ( replacePristine,
68 replacePristineFromSlurpy )
69 import Data.List ( (\\) )
70 import Darcs.SignalHandler ( withSignalsBlocked )
71 import Darcs.Repository.Format ( RepoFormat, RepoProperty( Darcs2, HashedInventory ),
72 identifyRepoFormat, format_has,
73 write_problem, read_problem, readfrom_and_writeto_problem )
74 import System.Directory ( doesDirectoryExist, setCurrentDirectory, removeFile,
75 createDirectoryIfMissing )
76 import Control.Monad ( liftM, when, unless )
77 import Workaround ( getCurrentDirectory, renameFile, setExecutable )
79 import ByteStringUtils ( gzReadFilePS )
80 import qualified Data.ByteString as B (ByteString, empty, readFile, isPrefixOf)
81 import qualified Data.ByteString.Char8 as BC (pack)
83 import Darcs.Patch ( Patch, RealPatch, Effect, is_hunk, is_binary, description,
85 try_to_shrink, commuteFL, commute )
86 import Darcs.Patch.Prim ( try_shrinking_inverse, Conflict )
87 import Darcs.Patch.Bundle ( scan_bundle, make_bundle )
88 import Darcs.SlurpDirectory ( Slurpy, slurp_unboring, mmap_slurp, co_slurp,
89 slurp_has, list_slurpy_files )
90 import Darcs.Hopefully ( PatchInfoAnd, info, n2pia,
91 hopefully, hopefullyM )
92 import Darcs.Repository.ApplyPatches ( apply_patches )
93 import qualified Darcs.Repository.HashedRepo as HashedRepo
94 ( revert_tentative_changes, finalize_tentative_changes,
95 remove_from_tentative_inventory, sync_repo,
96 copy_pristine, copy_partials_pristine, slurp_pristine,
97 apply_to_tentative_pristine, pristine_from_working,
98 write_tentative_inventory, write_and_read_patch,
99 add_to_tentative_inventory,
100 read_repo, read_tentative_repo, clean_pristine,
101 replacePristine, replacePristineFromSlurpy,
102 slurp_all_but_darcs )
103 import qualified Darcs.Repository.DarcsRepo as DarcsRepo
104 import Darcs.Flags ( DarcsFlag(AnyOrder, Boring, LookForAdds, Verbose, Quiet,
105 MarkConflicts, AllowConflicts, NoUpdateWorking,
106 RepoDir, WorkDir, UMask, Test, LeaveTestDir,
107 SetScriptsExecutable, DryRun, IgnoreTimes ),
108 want_external_merge, compression )
109 import Darcs.Ordered ( FL(..), RL(..), EqCheck(..), unsafeCoerceP,
110 (:\/:)(..), (:/\:)(..), (:>)(..),
111 (+>+), lengthFL, nullFL,
112 allFL, filterFL,
113 reverseRL, reverseFL, concatRL, mapFL,
114 mapFL_FL, concatFL )
115 import Darcs.Patch ( RepoPatch, Patchy, Prim, merge,
116 joinPatches, sort_coalesceFL,
117 list_conflicted_files, list_touched_files,
118 Named, patchcontents, anonymous,
119 commuteRL, fromPrims,
120 patch2patchinfo, readPatch,
121 writePatch, effect, invert,
122 is_addfile, is_adddir,
123 is_setpref,
124 apply, apply_to_slurpy,
125 empty_markedup_file, MarkedUpFile
126 )
127 import Darcs.Patch.Patchy ( Invert(..) )
128 import Darcs.Patch.Permutations ( commuteWhatWeCanFL, removeFL )
129 import Darcs.Patch.Info ( PatchInfo )
130 import Darcs.Patch.Set ( PatchSet, SealedPatchSet )
131 import Darcs.Patch.Apply ( markup_file, LineMark(None) )
132 import Darcs.Patch.Depends ( get_common_and_uncommon, deep_optimize_patchset )
133 import Darcs.Diff ( unsafeDiff )
134 import Darcs.RepoPath ( FilePathLike, AbsolutePath, toFilePath )
135 import Darcs.Utils ( promptYorn, catchall, withCurrentDirectory, withUMask, nubsort )
136 import Darcs.Progress ( progressFL, debugMessage )
137 import Darcs.FilePathUtils ( absolute_dir )
138 import Darcs.URL ( is_file )
139 import Darcs.Repository.Prefs ( darcsdir_filter, boring_file_filter, filetype_function,
140 getCaches )
141 import Darcs.Lock ( withLock, writeDocBinFile, withDelayedDir, removeFileMayNotExist,
142 withTempDir, withPermDir )
143 import Darcs.Sealed ( Sealed(Sealed), seal, FlippedSeal(FlippedSeal), flipSeal )
144 import Darcs.Repository.InternalTypes( Repository(..), RepoType(..) )
145 import Darcs.Global ( darcsdir )
146 #include "impossible.h"
148 -- | Repository IO monad. This monad-like datatype is responsible for
149 -- sequencing IO actions that modify the tentative recorded state of
150 -- the repository.
151 newtype RIO p C(r u t t1) a = RIO {
152 unsafeUnRIO :: Repository p C(r u t) -> IO a -- ^ converts @RIO a@ to @IO a@.
153 }
155 -- | This is just like @>>=@ from the Monad class except that it
156 -- respects type witness safe repository transformations. Even so, it
157 -- only tracks modifications to the tentative recorded state.
158 (>>>=) :: 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
159 m >>>= k = RIO $ \ (Repo x y z w) ->
160 do a <- unsafeUnRIO m (Repo x y z w)
161 unsafeUnRIO (k a) (Repo x y z w)
163 -- | This corresponds to @>>@ from the Monad class.
164 (>>>) :: RIO p C(r u t t1) a -> RIO p C(r u t1 t2) b -> RIO p C(r u t t2) b
165 a >>> b = a >>>= (const b)
167 -- | This corresponds to @return@ from the Monad class.
168 returnR :: a -> RIO p C(r u t t) a
169 returnR = rIO . return
171 -- | This the @RIO@ equivalent of @liftIO@.
172 rIO :: IO a -> RIO p C(r u t t) a
173 rIO = RIO . const
175 instance Functor (RIO p C(r u t t)) where
176 fmap f m = RIO $ \r -> fmap f (unsafeUnRIO m r)
178 -- | We have an instance of Monad so that IO actions that do not
179 -- change the tentative recorded state are convenient in the IO monad.
180 instance Monad (RIO p C(r u t t)) where
181 (>>=) = (>>>=)
182 (>>) = (>>>)
183 return = returnR
184 fail = rIO . fail
186 -- | Similar to the @ask@ function of the MonadReader class.
187 -- This allows actions in the RIO monad to get the current
188 -- repository.
189 -- FIXME: Don't export this. If we don't export this
190 -- it makes it harder for arbitrary IO actions to access
191 -- the repository and hence our code is easier to audit.
192 getRepository :: RIO p C(r u t t) (Repository p C(r u t))
193 getRepository = RIO return
195 maybeIdentifyRepository :: [DarcsFlag] -> String -> IO (Either String (Repository p C(r u t)))
196 maybeIdentifyRepository opts "." =
197 do darcs <- doesDirectoryExist darcsdir
198 rf_or_e <- identifyRepoFormat "."
199 here <- absolute_dir "."
200 case rf_or_e of
201 Left err -> return $ Left err
202 Right rf ->
203 case read_problem rf of
204 Just err -> return $ Left err
205 Nothing -> if darcs then do pris <- identifyPristine
206 cs <- getCaches opts here
207 return $ Right $ Repo here opts rf (DarcsRepository pris cs)
208 else return (Left "Not a repository")
209 maybeIdentifyRepository opts url' =
210 do url <- absolute_dir url'
211 rf_or_e <- identifyRepoFormat url
212 case rf_or_e of
213 Left e -> return $ Left e
214 Right rf -> case read_problem rf of
215 Just err -> return $ Left err
216 Nothing -> do cs <- getCaches opts url
217 return $ Right $ Repo url opts rf (DarcsRepository nopristine cs)
219 identifyDarcs1Repository :: [DarcsFlag] -> String -> IO (Repository Patch C(r u t))
220 identifyDarcs1Repository opts url =
221 do er <- maybeIdentifyRepository opts url
222 case er of
223 Left s -> fail s
224 Right r -> return r
226 identifyRepositoryFor :: forall p C(r u t). RepoPatch p => Repository p C(r u t) -> String -> IO (Repository p C(r u t))
227 identifyRepositoryFor (Repo _ opts rf _) url =
228 do Repo absurl _ rf_ t <- identifyDarcs1Repository opts url
229 let t' = case t of DarcsRepository x c -> DarcsRepository x c
230 case readfrom_and_writeto_problem rf_ rf of
231 Just e -> fail $ "Incompatibility with repository " ++ url ++ ":\n" ++ e
232 Nothing -> return $ Repo absurl opts rf_ t'
234 isRight :: Either a b -> Bool
235 isRight (Right _) = True
236 isRight _ = False
238 currentDirIsRepository :: IO Bool
239 currentDirIsRepository = isRight `liftM` maybeIdentifyRepository [] "."
241 amInRepository :: [DarcsFlag] -> IO (Either String ())
242 amInRepository (WorkDir d:_) =
243 do setCurrentDirectory d `catchall` (fail $ "can't set directory to "++d)
244 air <- currentDirIsRepository
245 if air
246 then return (Right ())
247 else return (Left "You need to be in a repository directory to run this command.")
248 amInRepository (_:fs) = amInRepository fs
249 amInRepository [] =
250 seekRepo (Left "You need to be in a repository directory to run this command.")
252 -- | hunt upwards for the darcs repository
253 -- This keeps changing up one parent directory, testing at each
254 -- step if the current directory is a repository or not. $
255 -- WARNING this changes the current directory for good if matchFn succeeds
256 seekRepo :: Either String ()
257 -- ^ what to return if we don't find a repository
258 -> IO (Either String ())
259 seekRepo onFail = getCurrentDirectory >>= helper where
260 helper startpwd = do
261 air <- currentDirIsRepository
262 if air
263 then return (Right ())
264 else do cd <- toFilePath `fmap` getCurrentDirectory
265 setCurrentDirectory ".."
266 cd' <- toFilePath `fmap` getCurrentDirectory
267 if cd' /= cd
268 then helper startpwd
269 else do setCurrentDirectory startpwd
270 return onFail
272 amNotInRepository :: [DarcsFlag] -> IO (Either String ())
273 amNotInRepository (WorkDir d:_) = do createDirectoryIfMissing False d
274 -- note that the above could always fail
275 setCurrentDirectory d
276 amNotInRepository []
277 amNotInRepository (_:f) = amNotInRepository f
278 amNotInRepository [] =
279 do air <- currentDirIsRepository
280 if air then return (Left $ "You may not run this command in a repository.")
281 else return $ Right ()
283 findRepository :: [DarcsFlag] -> IO (Either String ())
284 findRepository (RepoDir d:_) | is_file d =
285 do setCurrentDirectory d `catchall` (fail $ "can't set directory to "++d)
286 findRepository []
287 findRepository (WorkDir d:_) =
288 do setCurrentDirectory d `catchall` (fail $ "can't set directory to "++d)
289 findRepository []
290 findRepository (_:fs) = findRepository fs
291 findRepository [] = seekRepo (Right ())
293 slurp_pending :: RepoPatch p => Repository p C(r u t) -> IO Slurpy
294 slurp_pending repo@(Repo _ _ _ rt) = do
295 cur <- slurp_recorded repo
296 Sealed pend <- read_pending repo
297 case apply_to_slurpy pend cur of
298 Just pendcur -> return pendcur
299 Nothing -> do putStrLn "Yikes, pending has conflicts. Renaming file as_darcs/patches/pending_buggy"
300 renameFile (pendingName rt) (pendingName rt++"_buggy")
301 return cur
303 slurp_recorded :: RepoPatch p => Repository p C(r u t) -> IO Slurpy
304 slurp_recorded (Repo dir opts rf (DarcsRepository _ c))
305 | format_has HashedInventory rf =
306 HashedRepo.slurp_pristine c (compression opts) dir $ darcsdir++"/hashed_inventory"
307 slurp_recorded repository@(Repo dir _ _ (DarcsRepository p _)) = do
308 mc <- withCurrentDirectory dir $ slurpPristine p
309 case mc of (Just slurpy) -> return slurpy
310 Nothing -> withDelayedDir "pristine.temp" $ \abscd ->
311 do let cd = toFilePath abscd
312 createPristineDirectoryTree repository cd
313 mmap_slurp cd
315 slurp_recorded_and_unrecorded :: RepoPatch p => Repository p C(r u t) -> IO (Slurpy, Slurpy)
316 slurp_recorded_and_unrecorded repo@(Repo r _ _ _) = do
317 cur <- slurp_recorded repo
318 Sealed pend <- read_pending repo
319 withCurrentDirectory r $
320 case apply_to_slurpy pend cur of
321 Nothing -> fail "Yikes, pending has conflicts!"
322 Just pendslurp -> do unrec <- co_slurp pendslurp "."
323 return (cur, unrec)
325 pendingName :: RepoType p -> String
326 pendingName (DarcsRepository _ _) = darcsdir++"/patches/pending"
328 read_pending :: RepoPatch p => Repository p C(r u t) -> IO (Sealed (FL Prim C(r)))
329 read_pending (Repo r _ _ tp) =
330 withCurrentDirectory r (read_pendingfile (pendingName tp))
332 add_to_pending :: RepoPatch p => Repository p C(r u t) -> FL Prim C(u y) -> IO ()
333 add_to_pending (Repo _ opts _ _) _ | NoUpdateWorking `elem` opts = return ()
334 add_to_pending repo p =
335 do pend <- get_unrecorded repo
336 make_new_pending repo (pend +>+ p)
338 readPrims :: B.ByteString -> Sealed (FL Prim C(x))
339 readPrims s = case readPatch s :: Maybe (Sealed (Patch C(x )), B.ByteString) of
340 Nothing -> Sealed NilFL
341 Just (Sealed p,_) -> Sealed (effect p)
343 read_pendingfile :: String -> IO (Sealed (FL Prim C(x)))
344 read_pendingfile name = do
345 pend <- gzReadFilePS name `catchall` return B.empty
346 return $ readPrims pend
348 make_new_pending :: forall p C(r u t y). RepoPatch p => Repository p C(r u t) -> FL Prim C(r y) -> IO ()
349 make_new_pending (Repo _ opts _ _) _ | NoUpdateWorking `elem` opts = return ()
350 make_new_pending repo@(Repo r _ _ tp) origp =
351 withCurrentDirectory r $
352 do let newname = pendingName tp ++ ".new"
353 debugMessage $ "Writing new pending: " ++ newname
354 Sealed sfp <- return $ sift_for_pending origp
355 writeSealedPatch newname $ seal $ fromPrims $ sfp
356 cur <- slurp_recorded repo
357 Sealed p <- read_pendingfile newname
358 when (isNothing $ apply_to_slurpy p cur) $ do
359 let buggyname = pendingName tp ++ "_buggy"
360 renameFile newname buggyname
361 bugDoc $ text "There was an attempt to write an invalid pending!"
362 $$ text "If possible, please send the contents of"
363 <+> text buggyname
364 $$ text "along with a bug report."
365 renameFile newname (pendingName tp)
366 debugMessage $ "Finished writing new pending: " ++ newname
367 where writeSealedPatch :: FilePath -> Sealed (Patch C(x)) -> IO ()
368 writeSealedPatch fp (Sealed p) = writePatch fp p
370 sift_for_pending :: FL Prim C(x y) -> Sealed (FL Prim C(x))
371 sift_for_pending simple_ps =
372 let oldps = maybe simple_ps id $ try_shrinking_inverse $ crude_sift simple_ps
373 in if allFL (\p -> is_addfile p || is_adddir p) $ oldps
374 then seal oldps
375 else fromJust $ do
376 Sealed x <- return $ sfp NilFL $ reverseFL oldps
377 return (case try_to_shrink x of
378 ps | lengthFL ps < lengthFL oldps -> sift_for_pending ps
379 | otherwise -> seal ps)
380 where sfp :: FL Prim C(a b) -> RL Prim C(c a) -> Sealed (FL Prim C(c))
381 sfp sofar NilRL = seal sofar
382 sfp sofar (p:<:ps)
383 | is_hunk p || is_binary p
384 = case commuteFL (p :> sofar) of
385 Right (sofar' :> _) -> sfp sofar' ps
386 Left _ -> sfp (p:>:sofar) ps
387 sfp sofar (p:<:ps) = sfp (p:>:sofar) ps
389 get_unrecorded_no_look_for_adds :: RepoPatch p => Repository p C(r u t) -> IO (FL Prim C(r y))
390 get_unrecorded_no_look_for_adds = get_unrecorded_private (filter (/= LookForAdds))
392 get_unrecorded_unsorted :: RepoPatch p => Repository p C(r u t) -> IO (FL Prim C(r u))
393 get_unrecorded_unsorted = get_unrecorded_private (AnyOrder:)
395 get_unrecorded :: RepoPatch p => Repository p C(r u t) -> IO (FL Prim C(r u))
396 get_unrecorded = get_unrecorded_private id
398 -- | The /unrecorded/ includes the pending and the working directory changes.
399 get_unrecorded_private :: RepoPatch p => ([DarcsFlag]->[DarcsFlag]) -> Repository p C(r u t) -> IO (FL Prim C(r y))
400 get_unrecorded_private _ (Repo _ opts _ _)
401 | NoUpdateWorking `elem` opts = return $ unsafeCoerceP NilFL
402 get_unrecorded_private modopts repository@(Repo r oldopts _ _) =
403 withCurrentDirectory r $ do
404 debugMessage "Looking for unrecorded changes..."
405 cur <- slurp_pending repository
406 work <- if LookForAdds `elem` opts
407 then do nboring <- if Boring `elem` opts
408 then return $ darcsdir_filter
409 else boring_file_filter
410 slurp_unboring (myfilt cur nboring) "."
411 else co_slurp cur "."
412 Sealed pend <- read_pending repository
413 debugMessage "diffing dir..."
414 ftf <- filetype_function
415 let dif = case unsafeDiff opts ftf cur work of
416 di -> if AnyOrder `elem` opts
417 then pend +>+ di
418 else sort_coalesceFL $ pend +>+ di
419 seq dif $ debugMessage "Found unrecorded changes."
420 return dif
421 where myfilt s nboring f = slurp_has f s || nboring [f] /= []
422 opts = modopts oldopts
424 -- @todo: we should not have to open the result of HashedRepo and
425 -- seal it. Instead, update this function to work with type witnesses
426 -- by fixing DarcsRepo to match HashedRepo in the handling of
427 -- Repository state.
428 read_repo :: RepoPatch p => Repository p C(r u t) -> IO (PatchSet p C(r))
429 read_repo repo@(Repo r opts rf _)
430 | format_has HashedInventory rf = do ps <- HashedRepo.read_repo repo r
431 return ps
432 | otherwise = do Sealed ps <- DarcsRepo.read_repo opts r
433 return $ unsafeCoerceP ps
435 readTentativeRepo :: RepoPatch p => Repository p C(r u t) -> IO (PatchSet p C(t))
436 readTentativeRepo repo@(Repo r opts rf _)
437 | format_has HashedInventory rf = do ps <- HashedRepo.read_tentative_repo repo r
438 return ps
439 | otherwise = do Sealed ps <- DarcsRepo.read_tentative_repo opts r
440 return $ unsafeCoerceP ps
442 makePatchLazy :: RepoPatch p => Repository p C(r u t) -> PatchInfoAnd p C(x y) -> IO (PatchInfoAnd p C(x y))
443 makePatchLazy (Repo r opts rf (DarcsRepository _ c)) p
444 | format_has HashedInventory rf = withCurrentDirectory r $ HashedRepo.write_and_read_patch c (compression opts) p
445 | otherwise = withCurrentDirectory r $ DarcsRepo.write_and_read_patch opts p
447 sync_repo :: Repository p C(r u t) -> IO ()
448 sync_repo (Repo r _ rf (DarcsRepository _ c))
449 | format_has HashedInventory rf = withCurrentDirectory r $ HashedRepo.sync_repo c
450 sync_repo (Repo r _ _ (DarcsRepository p _)) = withCurrentDirectory r $ syncPristine p
452 prefsUrl :: Repository p C(r u t) -> String
453 prefsUrl (Repo r _ _ (DarcsRepository _ _)) = r ++ "/"++darcsdir++"/prefs"
455 unrevertUrl :: Repository p C(r u t) -> String
456 unrevertUrl (Repo r _ _ (DarcsRepository _ _)) = r ++ "/"++darcsdir++"/patches/unrevert"
458 applyToWorking :: Patchy p => Repository p1 C(r u t) -> [DarcsFlag] -> p C(u y) -> IO ()
459 applyToWorking (Repo r _ _ (DarcsRepository _ _)) opts patch =
460 withCurrentDirectory r $ if Quiet `elem` opts
461 then runSilently $ apply opts patch
462 else runTolerantly $ apply opts patch
464 handle_pend_for_add :: forall p q C(r u t x y). (RepoPatch p, Effect q)
465 => Repository p C(r u t) -> q C(x y) -> IO ()
466 handle_pend_for_add (Repo _ opts _ _) _ | NoUpdateWorking `elem` opts = return ()
467 handle_pend_for_add (Repo _ _ _ rt) p =
468 do let pn = pendingName rt ++ ".tentative"
469 Sealed pend <- (readPrims `fmap` gzReadFilePS pn) `catchall` (return $ Sealed NilFL)
470 let effectp = if allFL is_simple pend then crude_sift $ effect p
471 else effect p
472 Sealed newpend <- return $ rmpend (progressFL "Removing from pending:" effectp) pend
473 writePatch pn $ fromPrims_ newpend
474 where rmpend :: FL Prim C(a b) -> FL Prim C(a c) -> Sealed (FL Prim C(b))
475 rmpend NilFL x = Sealed x
476 rmpend _ NilFL = Sealed NilFL
477 rmpend (x:>:xs) xys | Just ys <- removeFL x xys = rmpend xs ys
478 rmpend (x:>:xs) ys =
479 case commuteWhatWeCanFL (x:>xs) of
480 a:>x':>b -> case rmpend a ys of
481 Sealed ys' -> case commute (invert (x':>:b) :> ys') of
482 Just (ys'' :> _) -> seal ys''
483 Nothing -> seal $ invert (x':>:b)+>+ys'
484 -- DJR: I don't think this
485 -- last case should be
486 -- reached, but it also
487 -- shouldn't lead to
488 -- corruption.
489 fromPrims_ :: FL Prim C(a b) -> Patch C(a b)
490 fromPrims_ = fromPrims
492 is_simple :: Prim C(x y) -> Bool
493 is_simple x = is_hunk x || is_binary x || is_setpref x
495 crude_sift :: FL Prim C(x y) -> FL Prim C(x y)
496 crude_sift xs = if allFL is_simple xs then filterFL ishunkbinary xs else xs
497 where ishunkbinary :: Prim C(x y) -> EqCheck C(x y)
498 ishunkbinary x | is_hunk x || is_binary x = unsafeCoerceP IsEq
499 | otherwise = NotEq
501 data HashedVsOld a = HvsO { old, hashed :: a }
503 decideHashedOrNormal :: Monad m => RepoFormat -> HashedVsOld (m a) -> m a
504 decideHashedOrNormal rf (HvsO { hashed = h, old = o })
505 | format_has HashedInventory rf = h
506 | otherwise = o
509 tentativelyMergePatches :: RepoPatch p
510 => Repository p C(r u t) -> String -> [DarcsFlag]
511 -> FL (PatchInfoAnd p) C(x r) -> FL (PatchInfoAnd p) C(x y)
512 -> IO (Sealed (FL Prim C(u)))
513 tentativelyMergePatches = tentativelyMergePatches_ MakeChanges
515 considerMergeToWorking :: RepoPatch p
516 => Repository p C(r u t) -> String -> [DarcsFlag]
517 -> FL (PatchInfoAnd p) C(x r) -> FL (PatchInfoAnd p) C(x y)
518 -> IO (Sealed (FL Prim C(u)))
519 considerMergeToWorking = tentativelyMergePatches_ DontMakeChanges
521 data MakeChanges = MakeChanges | DontMakeChanges deriving ( Eq )
523 tentativelyMergePatches_ :: forall p C(r u t y x). RepoPatch p
524 => MakeChanges
525 -> Repository p C(r u t) -> String -> [DarcsFlag]
526 -> FL (PatchInfoAnd p) C(x r) -> FL (PatchInfoAnd p) C(x y)
527 -> IO (Sealed (FL Prim C(u)))
528 tentativelyMergePatches_ mc r cmd opts usi themi =
529 do let us = mapFL_FL hopefully usi
530 them = mapFL_FL hopefully themi
531 _ :/\: pc <- return $ merge (progressFL "Merging them" them :\/: progressFL "Merging us" us)
532 pend <- get_unrecorded_unsorted r -- we don't care if it looks pretty...
533 anonpend <- anonymous (fromPrims pend)
534 pend' :/\: pw <- return $ merge (pc :\/: anonpend :>: NilFL)
535 let pwprim = joinPatches $ progressFL "Examining patches for conflicts" $ mapFL_FL patchcontents pw
536 Sealed standard_resolved_pw <- return $ standard_resolution pwprim
537 debugMessage "Checking for conflicts..."
538 mapM_ backupByCopying $ list_touched_files standard_resolved_pw
539 debugMessage "Announcing conflicts..."
540 have_conflicts <- announce_merge_conflicts cmd opts standard_resolved_pw
541 debugMessage "Checking for unrecorded conflicts..."
542 have_unrecorded_conflicts <- check_unrecorded_conflicts opts pc
543 debugMessage "Reading working directory..."
544 (_, working) <- slurp_recorded_and_unrecorded r
545 debugMessage "Working out conflicts in actual working directory..."
546 Sealed pw_resolution <-
547 case (want_external_merge opts, have_conflicts || have_unrecorded_conflicts) of
548 (Nothing,_) -> return $ if AllowConflicts `elem` opts
549 then seal NilFL
550 else seal standard_resolved_pw
551 (_,False) -> return $ seal standard_resolved_pw
552 (Just c, True) -> external_resolution working c
553 (effect us +>+ pend)
554 (effect them) pwprim
555 debugMessage "Applying patches to the local directories..."
556 when (mc == MakeChanges) $
557 do case usi of
558 NilFL -> applyps r themi
559 _ -> applyps r (mapFL_FL n2pia pc)
560 setTentativePending r (effect pend' +>+ pw_resolution)
561 return $ seal (effect pwprim +>+ pw_resolution)
562 where mapAdd :: Repository p C(i l m) -> FL (PatchInfoAnd p) C(i j) -> [IO ()]
563 mapAdd _ NilFL = []
564 mapAdd r'@(Repo dir df rf dr) (a:>:as) =
565 -- we construct a new Repository object on the recursive case so that the
566 -- recordedstate of the repository can match the fact that we just wrote a patch
567 tentativelyAddPatch_ DontUpdatePristine r' opts a : mapAdd (Repo dir df rf dr) as
568 applyps :: Repository p C(i l m) -> FL (PatchInfoAnd p) C(i j) -> IO ()
569 applyps repo ps = do debugMessage "Adding patches to inventory..."
570 sequence_ $ mapAdd repo ps
571 debugMessage "Applying patches to pristine..."
572 applyToTentativePristine repo ps
574 announce_merge_conflicts :: String -> [DarcsFlag] -> FL Prim C(x y) -> IO Bool
575 announce_merge_conflicts cmd opts resolved_pw =
576 case nubsort $ list_touched_files $ resolved_pw of
577 [] -> return False
578 cfs -> if MarkConflicts `elem` opts || AllowConflicts `elem` opts
579 || want_external_merge opts /= Nothing
580 then do putStrLn "We have conflicts in the following files:"
581 putStrLn $ unwords cfs
582 return True
583 else do putStrLn "There are conflicts in the following files:"
584 putStrLn $ unwords cfs
585 fail $ "Refusing to "++cmd++" patches leading to conflicts.\n"++
586 "If you would rather apply the patch and mark the conflicts,\n"++
587 "use the --mark-conflicts or --allow-conflicts options to "++cmd++"\n"++
588 "These can set as defaults by adding\n"++
589 " "++cmd++" mark-conflicts\n"++
590 "to "++darcsdir++"/prefs/defaults in the target repo. "
592 check_unrecorded_conflicts :: forall p C(r y). RepoPatch p => [DarcsFlag] -> FL (Named p) C(r y) -> IO Bool
593 check_unrecorded_conflicts opts _ | NoUpdateWorking `elem` opts = return False
594 check_unrecorded_conflicts opts pc =
595 do repository <- identifyDarcs1Repository opts "."
596 cuc repository
597 where cuc :: Repository Patch C(r u t) -> IO Bool
598 cuc r = do Sealed mpend <- read_pending r :: IO (Sealed (FL Prim C(r)))
599 case mpend of
600 NilFL -> return False
601 pend ->
602 case merge (fromPrims_ pend :\/: fromPrims_ (concatFL $ mapFL_FL effect pc)) of
603 _ :/\: pend' ->
604 case list_conflicted_files pend' of
605 [] -> return False
606 fs -> do yorn <- promptYorn
607 ("You have conflicting local changes to:\n"
608 ++ unwords fs++"\nProceed?")
609 when (yorn /= 'y') $
610 do putStrLn "Cancelled."
611 exitWith ExitSuccess
612 return True
613 fromPrims_ :: FL Prim C(a b) -> p C(a b)
614 fromPrims_ = fromPrims
616 tentativelyAddPatch :: RepoPatch p
617 => Repository p C(r u t) -> [DarcsFlag] -> PatchInfoAnd p C(r y) -> IO ()
618 tentativelyAddPatch = tentativelyAddPatch_ UpdatePristine
620 data UpdatePristine = UpdatePristine | DontUpdatePristine deriving Eq
622 tentativelyAddPatch_ :: RepoPatch p
623 => UpdatePristine -> Repository p C(r u t) -> [DarcsFlag]
624 -> PatchInfoAnd p C(r y) -> IO ()
625 tentativelyAddPatch_ _ _ opts _
626 | DryRun `elem` opts = bug "tentativelyAddPatch_ called when --dry-run is specified"
627 tentativelyAddPatch_ up r@(Repo dir _ rf (DarcsRepository _ c)) opts p =
628 withCurrentDirectory dir $
629 do decideHashedOrNormal rf $ HvsO {
630 hashed = HashedRepo.add_to_tentative_inventory c (compression opts) p,
631 old = DarcsRepo.add_to_tentative_inventory opts (hopefully p) }
632 when (up == UpdatePristine) $ do debugMessage "Applying to pristine cache..."
633 applyToTentativePristine r p
634 debugMessage "Updating pending..."
635 handle_pend_for_add r p
637 applyToTentativePristine :: (Effect q, Patchy q) => Repository p C(r u t) -> q C(r y) -> IO ()
638 applyToTentativePristine (Repo dir opts rf (DarcsRepository _ c)) p =
639 withCurrentDirectory dir $
640 do when (Verbose `elem` opts) $ putDocLn $ text "Applying to pristine..." <+> description p
641 decideHashedOrNormal rf $ HvsO {hashed = HashedRepo.apply_to_tentative_pristine c opts p,
642 old = DarcsRepo.add_to_tentative_pristine p}
644 -- | This fuction is unsafe because it accepts a patch that works on the tentative
645 -- pending and we don't currently track the state of the tentative pending.
646 tentativelyAddToPending :: forall p C(r u t x y). RepoPatch p
647 => Repository p C(r u t) -> [DarcsFlag] -> FL Prim C(x y) -> IO ()
648 tentativelyAddToPending (Repo _ opts _ _) _ _
649 | NoUpdateWorking `elem` opts = return ()
650 | DryRun `elem` opts = bug "tentativelyAddToPending called when --dry-run is specified"
651 tentativelyAddToPending (Repo dir _ _ rt) _ patch =
652 withCurrentDirectory dir $ do
653 let pn = pendingName rt
654 tpn = pn ++ ".tentative"
655 Sealed pend <- readPrims `liftM` (gzReadFilePS tpn `catchall` (return B.empty))
656 FlippedSeal newpend_ <- return $ newpend (unsafeCoerceP pend :: FL Prim C(a x)) patch
657 writePatch tpn $ fromPrims_ newpend_
658 where newpend :: FL Prim C(a b) -> FL Prim C(b c) -> FlippedSeal (FL Prim) C(c)
659 newpend NilFL patch_ = flipSeal patch_
660 newpend p patch_ = flipSeal $ p +>+ patch_
661 fromPrims_ :: FL Prim C(a b) -> Patch C(a b)
662 fromPrims_ = fromPrims
664 -- | setTentativePending is basically unsafe. It overwrites the pending state with a new one, not related to
665 -- the repository state.
666 setTentativePending :: forall p C(r u t x y). RepoPatch p => Repository p C(r u t) -> FL Prim C(x y) -> IO ()
667 setTentativePending (Repo _ opts _ _) _ | NoUpdateWorking `elem` opts = return ()
668 setTentativePending (Repo dir _ _ rt) patch = do
669 Sealed prims <- return $ sift_for_pending patch
670 withCurrentDirectory dir $
671 writePatch (pendingName rt ++ ".tentative") $ fromPrims_ prims
672 where fromPrims_ :: FL Prim C(a b) -> Patch C(a b)
673 fromPrims_ = fromPrims
675 -- | prepend is basically unsafe. It overwrites the pending state
676 -- with a new one, not related to the repository state.
677 prepend :: forall p C(r u t x y). RepoPatch p =>
678 Repository p C(r u t) -> FL Prim C(x y) -> IO ()
679 prepend (Repo _ opts _ _) _ | NoUpdateWorking `elem` opts = return ()
680 prepend (Repo _ _ _ rt) patch =
681 do let pn = pendingName rt ++ ".tentative"
682 Sealed pend <- readPrims `liftM` (gzReadFilePS pn `catchall` (return B.empty))
683 Sealed newpend_ <- return $ newpend pend patch
684 writePatch pn $ fromPrims_ (crude_sift newpend_)
685 where newpend :: FL Prim C(b c) -> FL Prim C(a b) -> Sealed (FL Prim C(a))
686 newpend NilFL patch_ = seal patch_
687 newpend p patch_ = seal $ patch_ +>+ p
688 fromPrims_ :: FL Prim C(a b) -> Patch C(a b)
689 fromPrims_ = fromPrims
691 tentativelyRemovePatches :: RepoPatch p => Repository p C(r u t) -> [DarcsFlag]
692 -> FL (Named p) C(x t) -> IO ()
693 tentativelyRemovePatches = tentativelyRemovePatches_ UpdatePristine
695 tentativelyRemovePatches_ :: forall p C(r u t x). RepoPatch p => UpdatePristine
696 -> Repository p C(r u t) -> [DarcsFlag]
697 -> FL (Named p) C(x t) -> IO ()
698 tentativelyRemovePatches_ up repository@(Repo dir _ rf (DarcsRepository _ c)) opts ps =
699 withCurrentDirectory dir $ do
700 when (up == UpdatePristine) $ do debugMessage "Adding changes to pending..."
701 prepend repository $ effect ps
702 remove_from_unrevert_context repository ps
703 debugMessage "Removing changes from tentative inventory..."
704 if format_has HashedInventory rf
705 then do HashedRepo.remove_from_tentative_inventory repository (compression opts) ps
706 when (up == UpdatePristine) $
707 HashedRepo.apply_to_tentative_pristine c opts $
708 progressFL "Applying inverse to pristine" $ invert ps
709 else DarcsRepo.remove_from_tentative_inventory (up==UpdatePristine) opts ps
711 tentativelyReplacePatches :: forall p C(r u t x). RepoPatch p => Repository p C(r u t) -> [DarcsFlag]
712 -> FL (Named p) C(x t) -> IO ()
713 tentativelyReplacePatches repository@(Repo x y z w) opts ps =
714 -- tentativelyRemovePatches_ leaves the repository in state C(x u t)
715 do tentativelyRemovePatches_ DontUpdatePristine repository opts ps
716 -- Now we add the patches back so that the repo again has state C(r u t)
717 sequence_ $ mapAdd ((Repo x y z w) :: Repository p C(x u t)) ps
718 where mapAdd :: Repository p C(i l m) -> FL (Named p) C(i j) -> [IO ()]
719 mapAdd _ NilFL = []
720 mapAdd r@(Repo dir df rf dr) (a:>:as) =
721 -- we construct a new Repository object on the recursive case so that the
722 -- recordedstate of the repository can match the fact that we just wrote a patch
723 tentativelyAddPatch_ DontUpdatePristine r opts (n2pia a) : mapAdd (Repo dir df rf dr) as
725 finalize_pending :: RepoPatch p => Repository p C(r u t) -> IO ()
726 finalize_pending (Repo dir opts _ rt)
727 | NoUpdateWorking `elem` opts =
728 withCurrentDirectory dir $ removeFileMayNotExist $ (pendingName rt)
729 finalize_pending repository@(Repo dir _ _ rt) = do
730 withCurrentDirectory dir $ do let pn = pendingName rt
731 tpn = pn ++ ".tentative"
732 tpfile <- gzReadFilePS tpn `catchall` (return B.empty)
733 Sealed tpend <- return $ readPrims tpfile
734 Sealed new_pending <- return $ sift_for_pending tpend
735 make_new_pending repository new_pending
737 finalizeRepositoryChanges :: RepoPatch p => Repository p C(r u t) -> IO ()
738 finalizeRepositoryChanges (Repo _ opts _ _)
739 | DryRun `elem` opts = bug "finalizeRepositoryChanges called when --dry-run specified"
740 finalizeRepositoryChanges repository@(Repo dir opts rf _)
741 | format_has HashedInventory rf =
742 withCurrentDirectory dir $ do debugMessage "Considering whether to test..."
743 testTentative repository
744 debugMessage "Finalizing changes..."
745 withSignalsBlocked $ do HashedRepo.finalize_tentative_changes repository (compression opts)
746 finalize_pending repository
747 debugMessage "Done finalizing changes..."
748 finalizeRepositoryChanges repository@(Repo dir _ _ (DarcsRepository _ _)) =
749 withCurrentDirectory dir $ do debugMessage "Considering whether to test..."
750 testTentative repository
751 debugMessage "Finalizing changes..."
752 withSignalsBlocked $ do DarcsRepo.finalize_pristine_changes
753 DarcsRepo.finalize_tentative_changes
754 finalize_pending repository
756 testTentative :: RepoPatch p => Repository p C(r u t) -> IO ()
757 testTentative repository@(Repo dir opts _ _) =
758 when (Test `elem` opts) $ withCurrentDirectory dir $
759 do let putInfo = if not $ Quiet `elem` opts then putStrLn else const (return ())
760 debugMessage "About to run test if it exists."
761 testline <- get_prefval "test"
762 case testline of
763 Nothing -> return ()
764 Just testcode ->
765 withTentative repository (wd "testing") $ \_ ->
766 do putInfo "Running test...\n"
767 when (SetScriptsExecutable `elem` opts) setScriptsExecutable
768 ec <- system testcode
769 if ec == ExitSuccess
770 then putInfo "Test ran successfully.\n"
771 else do putInfo "Test failed!\n"
772 exitWith ec
773 where wd = if LeaveTestDir `elem` opts then withPermDir else withTempDir
775 revertRepositoryChanges :: RepoPatch p => Repository p C(r u t) -> IO ()
776 revertRepositoryChanges (Repo _ opts _ _)
777 | DryRun `elem` opts = bug "revertRepositoryChanges called when --dry-run is specified"
778 revertRepositoryChanges r@(Repo dir opts rf dr@(DarcsRepository _ _)) =
779 withCurrentDirectory dir $
780 do removeFileMayNotExist (pendingName dr ++ ".tentative")
781 Sealed x <- read_pending r
782 setTentativePending r $ effect x
783 when (NoUpdateWorking `elem` opts) $ removeFileMayNotExist $ pendingName dr
784 decideHashedOrNormal rf $ HvsO { hashed = HashedRepo.revert_tentative_changes,
785 old = DarcsRepo.revert_tentative_changes }
787 patchSetToPatches :: RepoPatch p => RL (RL (PatchInfoAnd p)) C(x y) -> FL (Named p) C(x y)
788 patchSetToPatches patchSet = mapFL_FL hopefully $ reverseRL $ concatRL patchSet
790 getUMask :: [DarcsFlag] -> Maybe String
791 getUMask [] = Nothing
792 getUMask ((UMask u):_) = Just u
793 getUMask (_:l) = getUMask l
795 withGutsOf :: Repository p C(r u t) -> IO () -> IO ()
796 withGutsOf (Repo _ _ rf _) | format_has HashedInventory rf = id
797 | otherwise = withSignalsBlocked
799 withRepository :: [DarcsFlag] -> (forall p C(r u). RepoPatch p => Repository p C(r u r) -> IO a) -> IO a
800 withRepository opts1 = withRepositoryDirectory opts1 "."
802 withRepositoryDirectory :: forall a. [DarcsFlag] -> String
803 -> (forall p C(r u). RepoPatch p => Repository p C(r u r) -> IO a) -> IO a
804 withRepositoryDirectory opts1 url job =
805 do Repo dir opts rf rt <- identifyDarcs1Repository opts1 url
806 let rt' = case rt of DarcsRepository t c -> DarcsRepository t c
807 if format_has Darcs2 rf
808 then do debugMessage $ "Identified darcs-2 repo: " ++ dir
809 job1_ (Repo dir opts rf rt')
810 else do debugMessage $ "Identified darcs-1 repo: " ++ dir
811 job2_ (Repo dir opts rf rt)
812 where job1_ :: Repository (FL RealPatch) C(r u r) -> IO a
813 job1_ = job
814 job2_ :: Repository Patch C(r u r) -> IO a
815 job2_ = job
818 -- RankNTypes
819 -- $- works around the lack of impredicative instantiation in GHC
820 ($-) ::((forall p C(r u). RepoPatch p => Repository p C(r u r) -> IO a) -> IO a)
821 -> (forall p C(r u). RepoPatch p => Repository p C(r u r) -> IO a) -> IO a
822 x $- y = x y
824 withRepoLock :: [DarcsFlag] -> (forall p C(r u). RepoPatch p => Repository p C(r u r) -> IO a) -> IO a
825 withRepoLock opts job =
826 withRepository opts $- \repository@(Repo _ _ rf _) ->
827 do case write_problem rf of
828 Nothing -> return ()
829 Just err -> fail err
830 let name = "./"++darcsdir++"/lock"
831 wu = case (getUMask opts) of
832 Nothing -> id
833 Just u -> withUMask u
834 wu $ if DryRun `elem` opts
835 then job repository
836 else withLock name (revertRepositoryChanges repository >> job repository)
838 withRepoReadLock :: [DarcsFlag] -> (forall p C(r u). RepoPatch p => Repository p C(r u r) -> IO a) -> IO a
839 withRepoReadLock opts job =
840 withRepository opts $- \repository@(Repo _ _ rf _) ->
841 do case write_problem rf of
842 Nothing -> return ()
843 Just err -> fail err
844 let name = "./"++darcsdir++"/lock"
845 wu = case (getUMask opts) of Nothing -> id
846 Just u -> withUMask u
847 wu $ if format_has HashedInventory rf || DryRun `elem` opts
848 then job repository
849 else withLock name (revertRepositoryChanges repository >> job repository)
850 \end{code}
852 \begin{code}
853 remove_from_unrevert_context :: forall p C(r u t x). RepoPatch p
854 => Repository p C(r u t) -> FL (Named p) C(x t) -> IO ()
855 remove_from_unrevert_context repository ps = do
856 Sealed bundle <- unrevert_patch_bundle `catchall` (return $ seal (NilRL:<:NilRL))
857 remove_from_unrevert_context_ bundle
858 where unrevert_impossible unrevert_loc =
859 do yorn <- promptYorn "This operation will make unrevert impossible!\nProceed?"
860 case yorn of
861 'n' -> fail "Cancelled."
862 'y' -> removeFile unrevert_loc `catchall` return ()
863 _ -> impossible
864 pis = mapFL patch2patchinfo ps
865 unrevert_patch_bundle :: IO (SealedPatchSet p)
866 unrevert_patch_bundle = do pf <- B.readFile (unrevertUrl repository)
867 case scan_bundle pf of
868 Right foo -> return foo
869 Left err -> fail $ "Couldn't parse unrevert patch:\n" ++ err
870 remove_from_unrevert_context_ :: PatchSet p C(z) -> IO ()
871 remove_from_unrevert_context_ (NilRL :<: NilRL) = return ()
872 remove_from_unrevert_context_ bundle = do
873 let unrevert_loc = unrevertUrl repository
874 debugMessage "Adjusting the context of the unrevert changes..."
875 ref <- readTentativeRepo repository
876 case get_common_and_uncommon (bundle, ref) of
877 (common,(h_us:<:NilRL):<:NilRL :\/: NilRL:<:NilRL) ->
878 case commuteRL (reverseFL ps :> hopefully h_us) of
879 Nothing -> unrevert_impossible unrevert_loc
880 Just (us' :> _) -> do
881 s <- slurp_recorded repository
882 writeDocBinFile unrevert_loc $
883 make_bundle [] s
884 (common \\ pis) (us':>:NilFL)
885 (common,(x:<:NilRL):<:NilRL:\/:_)
886 | isr && any (`elem` common) pis -> unrevert_impossible unrevert_loc
887 | isr -> return ()
888 where isr = isJust $ hopefullyM x
889 _ -> unrevert_impossible unrevert_loc
890 \end{code}
892 \begin{code}
893 optimizeInventory :: RepoPatch p => Repository p C(r u t) -> IO ()
894 optimizeInventory repository@(Repo r opts rf (DarcsRepository _ c)) =
895 do ps <- read_repo repository
896 decideHashedOrNormal rf $
897 HvsO { hashed = do revertRepositoryChanges repository
898 HashedRepo.write_tentative_inventory c (compression opts) $ deep_optimize_patchset ps
899 finalizeRepositoryChanges repository,
900 old = DarcsRepo.write_inventory r $ deep_optimize_patchset ps
901 }
903 cleanRepository :: RepoPatch p => Repository p C(r u t) -> IO ()
904 cleanRepository repository@(Repo _ _ rf _) =
905 decideHashedOrNormal rf $
906 HvsO { hashed = HashedRepo.clean_pristine repository,
907 old = return () }
909 replacePristine :: Repository p C(r u t) -> FilePath -> IO ()
910 replacePristine (Repo r opts rf (DarcsRepository pris c)) d
911 | format_has HashedInventory rf = withCurrentDirectory r $ HashedRepo.replacePristine c (compression opts) d
912 | otherwise = withCurrentDirectory r $ Pristine.replacePristine d pris
914 replacePristineFromSlurpy :: Repository p C(r u t) -> Slurpy -> IO ()
915 replacePristineFromSlurpy (Repo r opts rf (DarcsRepository pris c)) s
916 | format_has HashedInventory rf = withCurrentDirectory r $ HashedRepo.replacePristineFromSlurpy c (compression opts) s
917 | otherwise = withCurrentDirectory r $ Pristine.replacePristineFromSlurpy s pris
919 createPristineDirectoryTree :: RepoPatch p => Repository p C(r u t) -> FilePath -> IO ()
920 createPristineDirectoryTree repo@(Repo r opts rf (DarcsRepository pris c)) reldir
921 | format_has HashedInventory rf =
922 do createDirectoryIfMissing True reldir
923 withCurrentDirectory reldir $ HashedRepo.copy_pristine c (compression opts) r (darcsdir++"/hashed_inventory")
924 | otherwise =
925 do dir <- absolute_dir reldir
926 done <- withCurrentDirectory r $ easyCreatePristineDirectoryTree pris dir
927 unless done $ do Sealed patches <- (seal . reverseRL . concatRL) `liftM` read_repo repo
928 createDirectoryIfMissing True dir
929 withCurrentDirectory dir $ apply_patches [] patches
931 -- fp below really should be FileName
932 createPartialsPristineDirectoryTree :: (FilePathLike fp, RepoPatch p) => Repository p C(r u t) -> [fp] -> FilePath -> IO ()
933 createPartialsPristineDirectoryTree (Repo r opts rf (DarcsRepository _ c)) prefs dir
934 | format_has HashedInventory rf =
935 do createDirectoryIfMissing True dir
936 withCurrentDirectory dir $
937 HashedRepo.copy_partials_pristine c (compression opts) r (darcsdir++"/hashed_inventory") prefs
938 createPartialsPristineDirectoryTree r@(Repo rdir _ _ (DarcsRepository pris _)) prefs dir
939 = withCurrentDirectory rdir $
940 do done <- easyCreatePartialsPristineDirectoryTree prefs pris dir
941 unless done $ withRecorded r (withTempDir "recorded") $ \_ -> do
942 clonePartialsTree "." dir (map toFilePath prefs)
944 pristineFromWorking :: RepoPatch p => Repository p C(r u t) -> IO ()
945 pristineFromWorking (Repo dir opts rf (DarcsRepository _ c))
946 | format_has HashedInventory rf =
947 withCurrentDirectory dir $ HashedRepo.pristine_from_working c (compression opts)
948 pristineFromWorking (Repo dir _ _ (DarcsRepository p _)) =
949 withCurrentDirectory dir $ createPristineFromWorking p
951 withRecorded :: RepoPatch p => Repository p C(r u t)
952 -> ((AbsolutePath -> IO a) -> IO a) -> (AbsolutePath -> IO a) -> IO a
953 withRecorded repository mk_dir f
954 = mk_dir $ \d -> do createPristineDirectoryTree repository (toFilePath d)
955 f d
957 checkPristineAgainstCwd :: RepoPatch p => Repository p C(r u t) -> IO Bool
958 checkPristineAgainstCwd (Repo dir _ rf (DarcsRepository p _))
959 | not $ format_has HashedInventory rf = do here <- absolute_dir "."
960 withCurrentDirectory dir $ checkPristine here p
961 checkPristineAgainstCwd r =
962 do s <- mmap_slurp "."
963 checkPristineAgainstSlurpy r s
965 checkPristineAgainstSlurpy :: RepoPatch p => Repository p C(r u t) -> Slurpy -> IO Bool
966 checkPristineAgainstSlurpy repository@(Repo _ opts _ _) s2 =
967 do s1 <- slurp_recorded repository
968 ftf <- filetype_function
969 return $ nullFL $ unsafeDiff (LookForAdds:IgnoreTimes:opts) ftf s1 s2
971 withTentative :: forall p a C(r u t). RepoPatch p =>
972 Repository p C(r u t) -> ((AbsolutePath -> IO a) -> IO a)
973 -> (AbsolutePath -> IO a) -> IO a
974 withTentative (Repo dir opts rf (DarcsRepository _ c)) mk_dir f
975 | format_has HashedInventory rf =
976 mk_dir $ \d -> do HashedRepo.copy_pristine c (compression opts) dir (darcsdir++"/tentative_pristine")
977 f d
978 withTentative repository@(Repo dir opts _ _) mk_dir f =
979 withRecorded repository mk_dir $ \d ->
980 do Sealed ps <- read_patches (dir ++ "/"++darcsdir++"/tentative_pristine")
981 apply opts $ joinPatches ps
982 f d
983 where read_patches :: FilePath -> IO (Sealed (FL p C(x)))
984 read_patches fil = do ps <- B.readFile fil
985 return $ case readPatch ps of
986 Just (x, _) -> x
987 Nothing -> seal NilFL
988 \end{code}
990 \begin{code}
991 getMarkedupFile :: RepoPatch p => Repository p C(r u t) -> PatchInfo -> FilePath -> IO MarkedUpFile
992 getMarkedupFile repository pinfo f = do
993 Sealed (FlippedSeal patches) <- (seal . dropWhileFL ((/= pinfo) . info)
994 . reverseRL . concatRL) `liftM` read_repo repository
995 return $ snd $ do_mark_all patches (f, empty_markedup_file)
996 where dropWhileFL :: (FORALL(x y) a C(x y) -> Bool) -> FL a C(r v) -> FlippedSeal (FL a) C(v)
997 dropWhileFL _ NilFL = flipSeal NilFL
998 dropWhileFL p xs@(x:>:xs')
999 | p x = dropWhileFL p xs'
1000 | otherwise = flipSeal xs
1001 do_mark_all :: RepoPatch p => FL (PatchInfoAnd p) C(x y)
1002 -> (FilePath, MarkedUpFile) -> (FilePath, MarkedUpFile)
1003 do_mark_all (hp:>:pps) (f, mk) =
1004 case hopefullyM hp of
1005 Just p -> do_mark_all pps $ markup_file (info hp) (patchcontents p) (f, mk)
1006 Nothing -> (f, [(BC.pack "Error reading a patch!",None)])
1007 do_mark_all NilFL (f, mk) = (f, mk)
1008 \end{code}
1010 \begin{code}
1011 -- | Sets scripts in or below the current directory executable. A script is any file that starts
1012 -- with the bytes '#!'. This is used sometimes for --set-scripts-executable, but at other times
1013 -- --set-scripts-executable is handled by the hunk patch case of applyFL.
1014 setScriptsExecutable :: IO ()
1015 setScriptsExecutable = do
1016 debugMessage "Making scripts executable"
1017 myname <- getCurrentDirectory
1018 c <- list_slurpy_files `fmap` (HashedRepo.slurp_all_but_darcs myname)
1019 let setExecutableIfScript f =
1020 do contents <- B.readFile f
1021 when (BC.pack "#!" `B.isPrefixOf` contents) $ do
1022 debugMessage ("Making executable: " ++ f)
1023 setExecutable f True
1024 mapM_ setExecutableIfScript c
1025 \end{code}