[darcs-users] [patch304] Reduce DarcsFlag usage in Darcs.Patch and Darcs.Repository
Eric Kow
kowey at darcs.net
Fri Jul 16 18:23:10 UTC 2010
Note to Kevin Quick:
I'm CC'ing you to give you the heads up that the the --nolinks flag likely to
go away. See the second patch below. I'd like you to comment before I push
this particular patch, if you would be so kind
So the name of the game is to banish DarcsFlag from the Darcs.Patch and
Darcs.Repository layer (starting from the inside)
See http://bugs.darcs.net/issue1157
and the IRC discussion on
http://irclog.perlgeek.de/darcs/2010-07-14#i_2553121
I am really happy to see Petr start to chip away at this opts argument ::
[DarcsFlag] that we've been threading through all our functions. Future is
slightly uncertain (maybe this will get messy), but rah in principle.
Casual observers may note that this as more evidence that the Darcs Team moving
out of the short-term MUST IMPROVE PERFORMANCE territory and into the
medium-term MUST MAKE DARCS BETTER territory. Still very much on the
clean-the-code up level, but such is the multi-day construction of Rome.
> Wed Jul 14 17:50:59 CEST 2010 Petr Rockai <me at mornfall.net>
> * Remove [DarcsFlag] argument from unrecordedChanges.
Applied, thanks!
> Thu Jul 15 02:08:22 CEST 2010 Petr Rockai <me at mornfall.net>
> * Remove --nolinks, since its scope and usefulness is very limited.
Waiting for comments from Kevin.
> Thu Jul 15 02:22:49 CEST 2010 Petr Rockai <me at mornfall.net>
> * Remove [DarcsFlag] parameters from apply.
Clarification requested, see comments
> Thu Jul 15 02:33:20 CEST 2010 Petr Rockai <me at mornfall.net>
> * Replace some [DarcsFlag] uses with newly introduced RemoteDarcs.
>
> Thu Jul 15 14:31:40 CEST 2010 Petr Rockai <me at mornfall.net>
> * Fix "head: empty list" bug in Darcs.Flags.RemoteDarcs.
Applied, thanks! (There's a potential future cleanup requested.
If you agree with said cleanup, feel free to just push it in)
> Thu Jul 15 02:34:49 CEST 2010 Petr Rockai <me at mornfall.net>
> * Use Compression more widely, suppressing further [DarcsFlag] uses.
>
> Thu Jul 15 10:19:08 CEST 2010 Petr Rockai <me at mornfall.net>
> * Remove [DarcsFlag] usage from Darcs.Patch.Bundle.
Not yet reviewed.
I think I might personally lean a bit more towards breaking this up into
separate patch bundles (by theme)
Remove [DarcsFlag] argument from unrecordedChanges.
---------------------------------------------------
This seems straightforward enough.
Basically:
--ignore-times = UseIndex
--no-ignore-times = IgnoreIndex [DEFAULT]
--look-for-adds = ScanAll
--dont-look-for-adds = ScanKnown [DEFAULT]
On the Darcs.Arguments level, it would also be good to change these to
mutually exclusive options.
> hunk ./src/Darcs/Commands/Changes.lhs 49
> - else Sealed `fmap` unrecordedChanges opts repository files
> + else Sealed `fmap` unrecordedChanges (UseIndex, ScanKnown) repository files
More interesting cases here we're not using diffingOpts
This is because the darcs changes command provides neither the
--ignore-times nor the --look-for-adds flags because they aren't
relevant to the command. However that does not change the fact that in
some code used by the changes command has expectations that you made an
implicit choice in your [DarcsFlag]
This is the sort of thing that makes Darcs code hard to reason about,
so win! Here is a case where getting rid of [DarcsFlag] in the core
means that we have a better understanding of how Darcs works.
Explicit beats implicit.
It's also a sign of why we should be a bit careful when making these
kinds of changes. I imagine that just passing in (diffingOpts opts)
would have had the same effect.
> hunk ./src/Darcs/Commands/Unrecord.lhs 41
> genericObliterateCmd cmdname opts _ = withRepoLock opts $- \repository -> do
> - pend <- unrecordedChanges opts repository []
> + -- FIXME we may need to honour --ignore-times here, although this command
> + -- does not take that option (yet)
> + pend <- unrecordedChanges (UseIndex, ScanKnown) repository []
Same comment as above.
> hunk ./src/Darcs/Commands/Revert.lhs 26
> - changes <- unrecordedChanges opts repository files
> + changes <- unrecordedChanges (diffingOpts opts {- always ScanKnown here -}) repository files
> hunk ./src/Darcs/Commands/Unrevert.lhs 30
> - unrec <- unrecordedChanges opts repository []
> + unrec <- unrecordedChanges (diffingOpts opts {- always ScanKnown here -}) repository []
Other slightly interesting cases. The revert and unrevert take
--ignore-times (for directory diffing), but not --look-for-adds
> hunk ./src/Darcs/Commands/MarkConflicts.lhs 83
> - pend <- unrecordedChanges opts repository []
> + pend <- unrecordedChanges (diffingOpts opts) repository []
> hunk ./src/Darcs/Commands/Record.lhs 72
> - changes <- unrecordedChanges opts repository files
> + changes <- unrecordedChanges (diffingOpts opts) repository files
> hunk ./src/Darcs/Commands/WhatsNew.lhs 37
> - choosePreTouching (map toFilePath files) `fmap` unrecordedChanges opts repo files
> + choosePreTouching (map toFilePath files) `fmap` unrecordedChanges (diffingOpts opts) repo files
(fst (diffingOpts opts), ScanKnown)?
(second (const ScanKnown) (diffingOpts opts))?
> hunk ./src/Darcs/Flags.hs 111
> +-- ADTs for selecting specific behaviour... FIXME These should be eventually
> +-- moved out from this module, closer to where they are actually used
> +
> data Compression = NoCompression | GzipCompression
> compression :: [DarcsFlag] -> Compression
> compression f | NoCompress `elem` f = NoCompression
> hunk ./src/Darcs/Flags.hs 119
> | otherwise = GzipCompression
>
> +data UseIndex = UseIndex | IgnoreIndex
> +data ScanKnown = ScanKnown | ScanAll
> +diffingOpts :: [DarcsFlag] -> (UseIndex, ScanKnown)
> +diffingOpts opts = (if willIgnoreTimes opts then IgnoreIndex else UseIndex,
> + if LookForAdds `elem` opts then ScanAll else ScanKnown)
As you might imagine, I don't have any strong feelings on the matter,
but I thought it would be useful for me to make a note of the choices
you made here
* Would naming the ADTs after one of the mutually exclusive choices
would lead to confused Darcs hackers? Imagine if we had
data True = True | False
instead of
data Bool = True | False
* Also either --ignoretimes or UseIndex may be misleading names.
Which is it? What is the effect of UseIndex when the repository
does not have an index (say it's old-fashioned)? Then again, I
suppose the idea is that for hashed repositories, all repositories
have an index; they just don't know it yet.
* I notice that you chose an core-facing implementation-oriented
name (talking about indexes) and not a user-oriented name
(ignores the times on files)
> hunk ./src/Darcs/Repository.hs 392
> addToPending :: RepoPatch p => Repository p C(r u t) -> FL Prim C(u y) -> IO ()
> addToPending (Repo _ opts _ _) _ | NoUpdateWorking `elem` opts = return ()
> addToPending repo@(Repo _ opts _ _) p =
> - do pend <- unrecordedChanges opts repo []
> + do pend <- unrecordedChanges (UseIndex, ScanKnown) repo []
Again, here's a potential win from not relying on opts (I'm not sure
where the opts that are baked into a repo come from. Are they limited
to some repository-specific preferences like the pristine type?)
I'm trusting Petr here that the explicit UseIndex, ScanKnown is what
we want here.
> hunk ./src/Darcs/Repository/Merge.hs 31
> - pend <- unrecordedChanges opts r []
> + pend <- unrecordedChanges (diffingOpts opts) r []
I'm guessing this is used for things like darcs pull and apply where
patch effects have to be merged into the working directory
> hunk ./src/Darcs/Repository/State.hs 33
> unrecordedChanges :: FORALL(p r u t) (RepoPatch p)
> - => [DarcsFlag] -> Repository p C(r u t)
> + => (UseIndex, ScanKnown) -> Repository p C(r u t)
> hunk ./src/Darcs/Repository/State.hs 140
> -unrecordedChanges opts repo paths = do
> +unrecordedChanges (useidx, scan) repo paths = do
> (all_current, Sealed (pending :: FL Prim C(t x))) <- readPending repo
And here's the main change.
> - working <- case (LookForAdds `elem` opts, willIgnoreTimes opts) of
> - (False, False) -> getIndex
> - (False, True) -> do
> + working <- case (scan, useidx) of
> + (ScanKnown, UseIndex) -> getIndex
> + (ScanKnown, IgnoreIndex) -> do
Grabbing a bit more context, the new Darcs.Repository.State.unrecordedChanges
looks like this:
working <- case (scan, useidx) of
(ScanKnown, UseIndex) -> getIndex
(ScanKnown, IgnoreIndex) -> do
guide <- expand current
applyTreeFilter relevant <$> restrict guide <$> readPlainTree "."
(ScanAll, _) -> do
index <- getIndex
nonboring <- restrictBoring index
plain <- applyTreeFilter relevant <$> applyTreeFilter nonboring <$> readPlainTree "."
return $ case useidx of
UseIndex -> plain `overlay` index
IgnoreIndex -> plain
Which seems unchanged.
> hunk ./src/Darcs/SelectChanges.hs 861
> - unrec <- fmap n2pia . (anonymous . fromPrims) =<< unrecordedChanges [] repository []
> + unrec <- fmap n2pia . (anonymous . fromPrims)
> + =<< unrecordedChanges (UseIndex, ScanKnown) repository []
Replacing the one sort of default [] with another.
Makes me wonder if we need to store the pair (UseIndex, ScanKnown) in some sort of common
variables.
Remove --nolinks, since its scope and usefulness is very limited.
-----------------------------------------------------------------
Kevin: This patch is motivated by code-cleanup work to get rid of
[DarcsFlag] (opts) in the Darcs.Repository layer. Rather
than try to support NoLinks in this fashion, Petr decided
that it would make more sense to just remove it.
See http://irclog.perlgeek.de/darcs/2010-07-16#i_2560752
for discussion on --nolinks
Unfortunately, I have not yet gotten around to re-understanding
the motivation behind --nolinks (there are cases where you really
want to use a copy operation instead of a hard link, perhaps related to
permissions)
* http://lists.osuosl.org/pipermail/darcs-devel/2007-July/005891.html
* http://lists.osuosl.org/pipermail/darcs-devel/2007-July/005899.html
But the basic argument in the chat above is that (A) --nolinks does
not work with hashed repositories (B) old-fashioned repositories should
be treated as deprecated and features which are only used by a minority
of users for the deprecated format should be pruned away (sorry!)
You might be able to make the case that --nolinks should simply be
made to work with hashed repositories. My natural inclination is,
in case of doubt, to prune and simplify but I think it would only be
fair if Kevin had a chance to weigh in first.
> - copyFileOrUrl [NoLinks] (repodir </> prefsRelPath)
> - prefsRelPath Uncachable `catchall` return ()
> + (fetchFilePS (repodir </> prefsRelPath) Uncachable >>= B.writeFile prefsRelPath)
> + `catchall` return ()
Wouldn't some sort of cloneFileOrUrl be generally useful instead?
(following the convention that copy is maybe-link and clone is no-link?)
> -copyLocal :: [DarcsFlag] -> String -> FilePath -> IO ()
> -copyLocal opts fou out | NoLinks `elem` opts = cloneFile fou out
> - | otherwise = createLink fou out `catchall` cloneFile fou out
> +copyLocal :: String -> FilePath -> IO ()
> +copyLocal fou out = createLink fou out `catchall` cloneFile fou out
Just the general case
> -copyLocals :: [DarcsFlag] -> String -> [String] -> FilePath -> IO ()
> -copyLocals opts u ns d =
> - doWithPatches (\n -> copyLocal opts (u++"/"++n) (d++"/"++n)) ns
> +copyLocals :: String -> [String] -> FilePath -> IO ()
> +copyLocals u ns d =
> + doWithPatches (\n -> copyLocal (u++"/"++n) (d++"/"++n)) ns
Since we no longer have the option to pass NoLinks down the chain, we remove
the extra argument.
When the darcs library becomes more stable, we'll no longer be able to be so
quick about ripping things apart like this.
Interestingly, in the 2007 threads I remarked that Kevin's work introduced a
lot of splatter (functions that had to be updated to thread opts through).
And in this patch, we only remove a very small amount of the splatter. Why?
It seems that we still need the threading of [DarcsFlag] so that we can keep
track of the new --remote-darcs option that we later introduced. Hmm!
Remove [DarcsFlag] parameters from apply.
-----------------------------------------
The --set-scripts-executable flag is used as a sort of workaround for
the fact that Darcs does not do any sort of permissions or metadata
tracking.
Commands which apply patches (get, pull, apply) etc could be instructed
to look for files that start with a shebang and set those to executable.
It's not a very exact way of doing things but gets the job done for some
folks (limitations: no obliterate/rollback support, and perhaps no
support for eg. adding a shebang line to a file that wasn't a script
before)
We have two ways of implementing this. For get/put, we had this
setScriptsExecutable function which just traverses the working directory
and hunts for scripts. For apply/pull, we had an apply function which
inspects hunk patches affecting the first line of a file.
Petr's patch switch everything to the first approach. From the user
perspective, one small change is that now applying any file which
affects a shebang file will cause that file to be set executable
(whereas previously it was just patches that added a shebang first
line). I think this is the sort of change that nobody is actually going
to notice and is more consistent anyway.
From the code perspective, now when you apply patches to the working
directory, you have to make a conscious effort to call
setScriptsExecutable. I'm guessing this is acceptable because the
number of places where we actually apply patches to the working
directory is small?
Clarification requested
~~~~~~~~~~~~~~~~~~~~~~~
1. I think you may be missing a makeScriptsExecutable in Darcs.Commands.Convert
2. Does copyPackedRepository in Darcs.Repository need this too?
3. repoRepo stuff?
> -readRepo :: RepoPatch p => [DarcsFlag] -> String -> IO (SealedPatchSet p C(Origin))
> -readRepo _ d = do
> +readRepo :: RepoPatch p => String -> IO (SealedPatchSet p C(Origin))
> +readRepo d = do
> -readTentativeRepo :: RepoPatch p => [DarcsFlag] -> String -> IO (SealedPatchSet p C(Origin))
> -readTentativeRepo _ d = do
> +readTentativeRepo :: RepoPatch p => String -> IO (SealedPatchSet p C(Origin))
> +readTentativeRepo d = do
While this and its consequences look good, I wonder: is this related to the
apply stuff in any way? Perhaps this change should be made in a separate
patch?
4. irrelevant changes?
> -trackBisect :: (Invert p, ShowPatch p, Apply p) => [DarcsFlag] -> IO ExitCode -> RL p C(x y) -> IO ()
> +trackBisect :: (Patchy p) => [DarcsFlag] -> IO ExitCode -> RL p C(x y) -> IO ()
> -patchTreeFromRL :: (Invert p, ShowPatch p, Apply p) => RL p C(x y) -> PatchTree p C(x y)
> +patchTreeFromRL :: (Patchy p) => RL p C(x y) -> PatchTree p C(x y)
> -patchTree2RL :: (Invert p) => PatchTree p C(x y) -> RL p C(x y)
> +patchTree2RL :: (Patchy p) => PatchTree p C(x y) -> RL p C(x y)
> -trackNextBisect :: (Invert p, ShowPatch p, Apply p) => [DarcsFlag] -> BisectState -> IO ExitCode -> BisectDir -> PatchTree p C(x y) -> IO ()
> +trackNextBisect :: (Patchy p) => [DarcsFlag] -> BisectState -> IO ExitCode -> BisectDir -> PatchTree p C(x y) -> IO ()
Do these changes really belong in the patch? Also do we really want to
effectively increase the number of constraints on the patch types?
Since this high-level code, I guess it doesn't really matter and simpler
is better..
5. question about trackdown --bisect
> -jumpHalfOnRight :: (Invert p, ShowPatch p, Apply p) => [DarcsFlag] -> PatchTree p C(x y) -> IO ()
> -jumpHalfOnRight opts l = unapplyRL opts (patchTree2RL l)
> +jumpHalfOnRight :: (Patchy p) => [DarcsFlag] -> PatchTree p C(x y) -> IO ()
> +jumpHalfOnRight opts l = unapplyRL ps -- >> makeScriptsExecutable opts ps
> + where ps = patchTree2RL l
> hunk ./src/Darcs/Commands/TrackDown.lhs 173
> -jumpHalfOnLeft :: (Invert p, ShowPatch p, Apply p) => [DarcsFlag] -> PatchTree p C(x y) -> IO ()
> -jumpHalfOnLeft opts r = applyRL opts (patchTree2RL r)
> +jumpHalfOnLeft :: (Patchy p) => [DarcsFlag] -> PatchTree p C(x y) -> IO ()
> +jumpHalfOnLeft opts r = applyRL p -- >> makeScriptsExecutable opts p
> + where p = patchTree2RL r
Why aren't we calling makeScriptsExecutable here? Petr definitely noticed that
we ought to do it and we did seem to be threading the opts through in the past.
The general approach
~~~~~~~~~~~~~~~~~~~~~
> +setScriptsExecutable :: IO ()
> +setScriptsExecutable = setScriptsExecutable_ (Nothing :: Maybe (FL Patch C(x y)))
> +
> +setScriptsExecutablePatches :: Patchy p => p C(x y) -> IO ()
> +setScriptsExecutablePatches = setScriptsExecutable_ . Just
> hunk ./src/Darcs/Repository/Internal.hs 845
> -- | 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
> +setScriptsExecutable_ :: Patchy p => Maybe (p C(x y)) -> IO ()
> +setScriptsExecutable_ pw = do
> debugMessage "Making scripts executable"
> myname <- getCurrentDirectory
> tree <- readWorking
> hunk ./src/Darcs/Repository/Internal.hs 850
> - let paths = [ anchorPath "." p | (p, Tree.File _) <- Tree.list tree ]
> - setExecutableIfScript f =
> + paths <- case pw of
> + Just ps -> filterM doesFileExist $ listTouchedFiles ps
> + Nothing -> return [ anchorPath "." p | (p, Tree.File _) <- Tree.list tree ]
> + let setExecutableIfScript f =
We extend the working directory hunter to accept an optional list of patches as
an argument. Give me some patches and I only look in the files touched by them;
otherwise I look through the whole directory.
> hunk ./src/Darcs/Arguments.lhs 1806
> +makeScriptsExecutable :: Patchy p => [DarcsFlag] -> p C(x y) -> IO ()
> +makeScriptsExecutable opts p =
> + when (SetScriptsExecutable `elem` opts) $ setScriptsExecutablePatches p
Expose the Darcs.Repository functionality via Darcs.Arguments (which also
does the business of toggling the behaviour depending on flag value)
> instance Apply p => Apply (PatchInfoAnd p) where
> - apply opts p = apply opts $ hopefully p
> + apply p = apply $ hopefully p
> hunk ./src/Darcs/Patch/Apply.lhs 118
> - apply opts (NamedP _ _ p) = apply opts p
> + apply (NamedP _ _ p) = apply p
> hunk ./src/Darcs/Patch/Apply.lhs 122
> - apply opts p = applyFL opts $ effect p
> + apply p = applyFL $ effect p
> hunk ./src/Darcs/Patch/Apply.lhs 130
> instance Apply Prim where
> - apply opts (Split ps) = applyFL opts ps
> - apply _ Identity = return ()
> - apply _ (FP f RmFile) = mRemoveFile f
> - apply _ (FP f AddFile) = mCreateFile f
> - apply opts p@(FP _ (Hunk _ _ _)) = applyFL opts (p :>: NilFL)
> - apply _ (FP f (TokReplace t o n)) = mModifyFilePSs f doreplace
> + apply (Split ps) = applyFL ps
> + apply Identity = return ()
> + apply (FP f RmFile) = mRemoveFile f
> + apply (FP f AddFile) = mCreateFile f
> + apply p@(FP _ (Hunk _ _ _)) = applyFL (p :>: NilFL)
> + apply (FP f (TokReplace t o n)) = mModifyFilePSs f doreplace
Fantastic, no [DarcsFlag] in the Darcs.Patch.Apply.
One less cause for uncertainty
> hunk ./src/Darcs/Patch/Apply.lhs 169
> mModifyFilePS f $ hunkmod foo
> - case h of
> - (Hunk 1 _ (n:_)) | BC.pack "#!" `B.isPrefixOf` n &&
> - SetScriptsExecutable `elem` opts
> - -> mSetFileExecutable f True
> - _ -> return ()
> - applyFL opts ps'
> + applyFL ps'
This is the old implementation which checks every prim patch to see if
it's adds a shebang to the first line of a file. Bye.
Back to work
~~~~~~~~~~~~
> hunk ./src/Darcs/Commands/Apply.lhs 200
> withSignalsBlocked $ do finalizeRepositoryChanges repository
> applyToWorking repository opts pw `catch` \(e :: SomeException) ->
> fail ("Error applying patch to working dir:\n" ++ show e)
> + makeScriptsExecutable opts pw
> hunk ./src/Darcs/Commands/Get.lhs 298
> do tentativelyRemovePatches repository opts us'
> tentativelyAddToPending repository opts $ invert $ effect us'
> finalizeRepositoryChanges repository
> - apply opts (invert $ effect ps) `catch` \e ->
> + apply (invert $ effect ps) `catch` \e ->
...
> + makeScriptsExecutable opts (invert $ effect ps)
This must the case where we're getting --to-match and unapplying patches.
> - Sealed local_patches <- DR.readRepo opts "." :: IO (SealedPatchSet Patch C(Origin))
> + Sealed local_patches <- DR.readRepo "." :: IO (SealedPatchSet Patch C(Origin))
> hunk ./src/Darcs/Commands/Get.lhs 348
> - apply opts p_ch `catch`
> + apply p_ch `catch`
> \e -> fail ("Bad checkpoint!!!\n" ++ prettyError e)
> hunk ./src/Darcs/Commands/Get.lhs 350
> - applyPatches opts (reverseRL needed_patches)
> - else applyPatches opts $ reverseRL $ newset2RL local_patches
> + applyPatches (reverseRL needed_patches)
> + when (SetScriptsExecutable `elem` opts) setScriptsExecutable
> + else applyPatches $ reverseRL $ newset2RL local_patches
This block of code pertains to applying patches after fetching the
partial repository checkpoint.
> hunk ./src/Darcs/Commands/Pull.lhs 258
> invalidateIndex repository
> withGutsOf repository $ do finalizeRepositoryChanges repository
> revertable $ applyToWorking repository opts pw
> + makeScriptsExecutable opts pw
> return ()
> hunk ./src/Darcs/Commands/TrackDown.lhs 104
> - else do apply opts (invert p) `catch` \e -> fail ("Bad patch:\n" ++ show e)
> + else do apply (invert p) `catch` \e -> fail ("Bad patch:\n" ++ show e)
> + makeScriptsExecutable opts (invert p)
More commands which offer --set-scripts-executable as a flag
> hunk ./src/Darcs/Repository/Pristine.hs 124
> - mWithCurrentDirectory (fp2fn n) $ apply [] p
> + mWithCurrentDirectory (fp2fn n) $ apply p
[snip lots of instances of s/apply []/apply, yay!]
> hunk ./src/Darcs/Patch/Apply.lhs 515
> -applyToTree patch t = snd `fmap` virtualTreeIO (apply [] patch) t
> +applyToTree patch t = snd `fmap` virtualTreeIO (apply patch) t
These bits of code make me happy. Now that we've gotten rid of the argument, no more
need to pass in the default argument (or worry about what we should be passing in).
There's more examples, but I've snipped them out
In the rest of the review, I snipped away lots of code that's just dealing with
the consequence of this change (getting rid of opts threading for apply)
Replace some [DarcsFlag] uses with newly introduced RemoteDarcs.
----------------------------------------------------------------
Request for future work?
~~~~~~~~~~~~~~~~~~~~~~~~
> hunk ./src/Ssh.hs 4
> -copySSH :: String -> String -> FilePath -> IO ()
> -copySSH rdarcs uRaw f = withSSHConnection rdarcs uRaw (\c -> grabSSH uRaw c >>= B.writeFile f) $
> +copySSH :: RemoteDarcs -> String -> FilePath -> IO ()
> +copySSH remote uRaw f | rdarcs <- remoteDarcs remote =
> -copySSHs :: String -> String -> [String] -> FilePath -> IO ()
> -copySSHs rdarcs u ns d =
> +copySSHs :: RemoteDarcs -> String -> [String] -> FilePath -> IO ()
> +copySSHs remote u ns d | rdarcs <- remoteDarcs remote =
Nice, but why use this pattern guard syntax when we could just as easily have
written where rdarcs = remoteDarcs remote?
Seems like the former needlessly introduces the possibility that there
may be an alternative.
Also, how about changing applyViaSsh to take RemoteDarcs?
The basic change
~~~~~~~~~~~~~~~~
> hunk ./src/Darcs/Flags.hs 61
> - | RemoteDarcs String
> + | RemoteDarcsOpt String
Rename the surface level flag so that we can re-use the RemoteDarcs name
for the deeper stuff.
Note that it'd be good to keep an eye out for consistency and friendliness in
naming the ADTs and the flags. This particular case seems friendly enough.
> +remoteDarcs :: [DarcsFlag] -> RemoteDarcs
> +remoteDarcs f | (x:_) <- [ c | RemoteDarcsOpt c <- f ] = RemoteDarcs x
> + | otherwise = DefaultRemoteDarcs
(For review, I pasted in your later version from 'Fix "head: empty list" bug in
Darcs.Flags.RemoteDarcs.')
> +data RemoteDarcs = RemoteDarcs String | DefaultRemoteDarcs
Makes sense.
> -getContent (RemoteDarcs s) = StringContent s
> +getContent (RemoteDarcsOpt s) = StringContent s
It's fine to make these changes, but we may want to think a little bit about
adopting consistent conventions for how we name things.
See my comments about the ADTs in the first patch
> hunk ./src/Ssh.hs
> +remoteDarcs :: RemoteDarcs -> String
> +remoteDarcs DefaultRemoteDarcs = "darcs"
> +remoteDarcs (RemoteDarcs x) = x
> hunk ./src/Darcs/RemoteApply.hs 12
> applyViaSsh :: [DarcsFlag] -> String -> Doc -> IO ExitCode
> applyViaSsh opts repo bundle =
> - pipeDocSSH addr [remoteDarcsCmd opts++" apply --all "++unwords (applyopts opts)++
> + pipeDocSSH addr [Ssh.remoteDarcs (remoteDarcs opts) ++" apply --all "++unwords (applyopts opts)++
> applyViaSshAndSudo :: [DarcsFlag] -> String -> String -> Doc -> IO ExitCode
> applyViaSshAndSudo opts repo username bundle =
> - pipeDocSSH addr ["sudo -u "++username++" "++remoteDarcsCmd opts++
> + pipeDocSSH addr ["sudo -u "++username++" "++Ssh.remoteDarcs (remoteDarcs opts)++
These looked tricky until I realised it was a refactor
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> +copyAndReadFile :: (FilePath -> IO a) -> String -> Cachable -> IO a
> +copyAndReadFile readfn fou _ | isFile fou = readfn fou
> +copyAndReadFile readfn fou cache = withTemp $ \t -> do copyFileOrUrl DefaultRemoteDarcs fou t cache
> + readfn t
>
> +fetchFilePS = copyAndReadFile B.readFile
> +fetchFileLazyPS = copyAndReadFile BL.readFile
> +gzFetchFilePS = copyAndReadFile gzReadFilePS
Nice little refactor of fetchFilePS, fetchFileLazyPS, and gzFetchFilePS
Higher order functions are your friends.
This made it a bit easier to take the RemoteDarcs stuff into account
and perhaps extend it in the future for issue1736
May be worth adding a comment to copyAndReadFile just marking it as
a helper function
> +-- | @fetchFile fileOrUrl cache@ returns the content of its argument (either a
> +-- file or an URL). If it has to download an url, then it will use a cache as
> +-- required by its second argument.
> +--
> +-- We always use default remote darcs, since it is not fatal if the remote
> +-- darcs does not exist or is too old -- anything that supports transfer-mode
> +-- should do, and if not, we will fall back to SFTP or SCP.
It's not fatal, but slightly unfortunate.
See http://bugs.darcs.net/issue1736
> -remoteDarcsCmd :: [DarcsFlag] -> String
> -remoteDarcsCmd flags = head $ [ c | (RemoteDarcs c) <- flags ] ++ ["darcs"]
Basically not needed now that we are doing this on the Darcs.Flag level
See the Ssh module.
> hunk ./src/Darcs/External.hs 143
> --- | @fetchFileLazyPS fileOrUrl cache@ lazily reads the content of
> --- its argument (either a file or an URL). Warning: this function may
> --- constitute a fd leak; make sure to force consumption of file contents
> --- to avoid that.
> +-- | @fetchFileLazyPS fileOrUrl cache@ lazily reads the content of its argument
> +-- (either a file or an URL). Warning: this function may constitute a fd leak;
> +-- make sure to force consumption of file contents to avoid that. See
> +-- "fetchFilePS" for details.
Minor grumble about minimal patches: the whitespace changes were not really
necessary were they?
The extra comment is added to hopefully point users at the remote darcs stuff
in the comment Petr added about always using default remote darcs
> hunk ./src/Darcs/External.hs 153
> -copyFileOrUrl :: [DarcsFlag] -> FilePath -> FilePath -> Cachable -> IO ()
> +copyFileOrUrl :: RemoteDarcs -> FilePath -> FilePath -> Cachable -> IO ()
> -copyFilesOrUrls :: [DarcsFlag]->FilePath->[String]->FilePath->Cachable->IO ()
> +copyFilesOrUrls :: RemoteDarcs -> FilePath -> [String] -> FilePath -> Cachable -> IO ()
Yay! One more [DarcsFlag] gone!
Use Compression more widely, suppressing further [DarcsFlag] uses.
------------------------------------------------------------------
> Petr Rockai <me at mornfall.net>**20100715003449
> Ignore-this: d582d3bc381e73a964127aa3b87d0ffb
> ] hunk ./src/Darcs/Commands/AmendRecord.lhs 28
> import Control.Monad ( when )
>
> import Darcs.Flags ( DarcsFlag(Author, LogFile, PatchName, AskDeps,
> - EditLongComment, PromptLongComment, KeepDate), diffingOpts )
> + EditLongComment, PromptLongComment, KeepDate)
> + , diffingOpts, compression )
> import Darcs.Lock ( worldReadableTemp )
> import Darcs.RepoPath ( toFilePath )
> import Darcs.Hopefully ( PatchInfoAnd, n2pia, hopefully, info )
> hunk ./src/Darcs/Commands/AmendRecord.lhs 151
> else do
> invalidateIndex repository
> withGutsOf repository $ do
> - repository' <- tentativelyRemovePatches repository opts (oldp :>: NilFL)
> + repository' <- tentativelyRemovePatches repository (compression opts)
> + (oldp :>: NilFL)
> (mlogf, newp) <- updatePatchHeader opts repository' oldp chs
> defineChanges newp
> hunk ./src/Darcs/Commands/AmendRecord.lhs 155
> - repository'' <- tentativelyAddPatch repository' opts newp
> + repository'' <- tentativelyAddPatch repository' (compression opts) newp
> let failmsg = maybe "" (\lf -> "\nLogfile left in "++lf++".") mlogf
> finalizeRepositoryChanges repository'' `clarifyErrors` failmsg
> maybe (return ()) removeFile mlogf
> hunk ./src/Darcs/Commands/Get.lhs 32
> import Control.Monad ( when )
>
> import Darcs.Commands ( DarcsCommand(..), nodefaults, commandAlias, putInfo )
> -import Darcs.Flags( remoteDarcs )
> +import Darcs.Flags( compression, remoteDarcs )
> import Darcs.Arguments ( DarcsFlag( NewRepo, Partial, Lazy,
> UseFormat2, UseOldFashionedInventory, UseHashedInventory,
> SetScriptsExecutable, OnePattern ),
> hunk ./src/Darcs/Commands/Get.lhs 296
> (englishNum (lengthFL ps) (Noun "patch") "")
> invalidateIndex repository
> withRepoLock opts $- \_ ->
> - do tentativelyRemovePatches repository opts us'
> + do tentativelyRemovePatches repository (compression opts) us'
> tentativelyAddToPending repository opts $ invert $ effect us'
> finalizeRepositoryChanges repository
> apply (invert $ effect ps) `catch` \e ->
> hunk ./src/Darcs/Commands/Optimize.lhs 298
> doReorder opts repository = do
> debugMessage "Reordering the inventory."
> PatchSet ps _ <- chooseOrder `fmap` readRepo repository
> - withGutsOf repository $ do tentativelyReplacePatches repository opts $ reverseRL ps
> + withGutsOf repository $ do tentativelyReplacePatches repository (compression opts) $ reverseRL ps
> finalizeRepositoryChanges repository
> debugMessage "Done reordering the inventory."
>
> hunk ./src/Darcs/Commands/Record.lhs 72
> author, patchnameOption, umaskOption, ignoretimes,
> nocompress, rmlogfile, logfile, listRegisteredFiles,
> setScriptsExecutableOption )
> -import Darcs.Flags (willRemoveLogFile, diffingOpts)
> +import Darcs.Flags (willRemoveLogFile, diffingOpts, compression)
> import Darcs.Utils ( askUser, promptYorn, editFile, clarifyErrors )
> import Progress ( debugMessage)
> import Darcs.ProgressPatches( progressFL)
> hunk ./src/Darcs/Commands/Record.lhs 210
> do debugMessage "Writing the patch file..."
> mypatch <- namepatch date name my_author my_log $
> fromPrims $ progressFL "Writing changes:" chs
> - tentativelyAddPatch repository opts $ n2pia $ adddeps mypatch deps
> + tentativelyAddPatch repository (compression opts) $ n2pia $ adddeps mypatch deps
> invalidateIndex repository
> debugMessage "Applying to pristine..."
> withGutsOf repository (finalizeRepositoryChanges repository)
> hunk ./src/Darcs/Commands/Tag.lhs 43
> import Darcs.Commands.Record ( getDate, getLog )
> import Darcs.Witnesses.Ordered ( FL(..) )
> import Darcs.Lock ( worldReadableTemp )
> -import Darcs.Flags ( DarcsFlag(..) )
> +import Darcs.Flags ( DarcsFlag(..), compression )
> import System.IO ( hPutStr, stderr )
>
> tagDescription :: String
> hunk ./src/Darcs/Commands/Tag.lhs 97
> (name, long_comment, mlogf) <- get_name_log opts args
> myinfo <- patchinfo date name the_author long_comment
> let mypatch = infopatch myinfo identity
> - tentativelyAddPatch repository opts $ n2pia $ adddeps mypatch deps
> + tentativelyAddPatch repository (compression opts) $ n2pia $ adddeps mypatch deps
> finalizeRepositoryChanges repository
> maybe (return ()) removeFile mlogf
> putStrLn $ "Finished tagging patch '"++name++"'"
> hunk ./src/Darcs/Commands/Unrecord.lhs 41
> allInteractive, umaskOption, summary, dryRun,
> printDryRunMessageAndExit, changesReverse
> )
> -import Darcs.Flags ( doReverse, UseIndex(..), ScanKnown(..) )
> +import Darcs.Flags ( doReverse, UseIndex(..), ScanKnown(..), compression )
> import Darcs.Match ( firstMatch, matchFirstPatchset, matchAPatchread )
> import Darcs.Repository ( PatchInfoAnd, withGutsOf,
> withRepoLock, ($-),
> hunk ./src/Darcs/Commands/Unrecord.lhs 183
> "About to write out (potentially) modified patches..."
> definePatches to_unrecord
> invalidateIndex repository
> - withGutsOf repository $ do tentativelyRemovePatches repository opts to_unrecord
> + withGutsOf repository $ do tentativelyRemovePatches repository (compression opts) to_unrecord
> finalizeRepositoryChanges repository
> putStrLn "Finished unrecording."
>
> hunk ./src/Darcs/Commands/Unrecord.lhs 328
> savetoBundle opts kept removed
> invalidateIndex repository
> withGutsOf repository $
> - do tentativelyRemovePatches repository opts removed
> + do tentativelyRemovePatches repository (compression opts) removed
> tentativelyAddToPending repository opts $ invert $ effect removed
> finalizeRepositoryChanges repository
> debugMessage "Applying patches to working directory..."
> hunk ./src/Darcs/Repository.hs 180
> toRepo2 = Repo toDir opts' toFormat $ DarcsRepository toPristine toCache2
> copyHashedHashed = HashedRepo.copyRepo toRepo2 (remoteDarcs opts) fromDir
> copyAnyToOld r = withCurrentDirectory toDir $ readRepo r >>=
> - DarcsRepo.writeInventoryAndPatches opts
> + DarcsRepo.writeInventoryAndPatches (compression opts)
> case repoSort fromFormat of
> Hashed -> case repoSort toFormat of
> Hashed -> copyHashedHashed
> hunk ./src/Darcs/Repository.hs 335
> if formatHas HashedInventory rf2
> then do HashedRepo.writeTentativeInventory c (compression opts) patchset
> HashedRepo.finalizeTentativeChanges repo (compression opts)
> - else DarcsRepo.writeInventoryAndPatches opts patchset
> + else DarcsRepo.writeInventoryAndPatches (compression opts) patchset
> return repo
>
> -- | patchSetToRepository takes a patch set, and writes a new repository in the current directory
> hunk ./src/Darcs/Repository/DarcsRepo.lhs 100
> import Darcs.External ( gzFetchFilePS, fetchFilePS, copyFilesOrUrls, Cachable(..),
> cloneFile )
> import Darcs.Lock ( writeBinFile, writeDocBinFile, appendDocBinFile, appendBinFile )
> -import Darcs.Flags ( DarcsFlag( NoCompress ), RemoteDarcs )
> +import Darcs.Flags ( Compression(..), RemoteDarcs )
> import Darcs.Patch.Depends ( slightlyOptimizePatchset, commuteToEnd, deepOptimizePatchset )
> import Darcs.Repository.Pristine ( identifyPristine, applyPristine )
> import Darcs.Global ( darcsdir )
> hunk ./src/Darcs/Repository/DarcsRepo.lhs 119
> Similarly, token replaces are stored in pending until they are recorded.
>
> \begin{code}
> -writePatch :: RepoPatch p => [DarcsFlag] -> Named p C(x y) -> IO FilePath
> -writePatch opts p =
> - do let writeFun = if NoCompress `elem` opts
> - then Patch.writePatch
> - else Patch.gzWritePatch
> +writePatch :: RepoPatch p => Compression -> Named p C(x y) -> IO FilePath
> +writePatch compr p =
> + do let writeFun = case compr of
> + NoCompression -> Patch.writePatch
> + GzipCompression -> Patch.gzWritePatch
> pname = darcsdir++"/patches/"++makeFilename (patch2patchinfo p)
> writeFun pname p
> return pname
> hunk ./src/Darcs/Repository/DarcsRepo.lhs 128
>
> -writeAndReadPatch :: RepoPatch p => [DarcsFlag] -> PatchInfoAnd p C(x y)
> +writeAndReadPatch :: RepoPatch p => Compression -> PatchInfoAnd p C(x y)
> -> IO (PatchInfoAnd p C(x y))
> hunk ./src/Darcs/Repository/DarcsRepo.lhs 130
> -writeAndReadPatch opts p =
> - do fn <- writePatch opts $ hopefully p
> +writeAndReadPatch compr p =
> + do fn <- writePatch compr $ hopefully p
> unsafeInterleaveIO $ parse fn
> where parse fn = do debugMessage ("Reading patch file: "++ fn)
> ps <- gzReadFilePS fn
> hunk ./src/Darcs/Repository/DarcsRepo.lhs 177
> text "Starting with tag:" $$
> formatInventory (mapFL info $ t2 :>: reverseRL ps)
>
> -writeInventoryAndPatches :: RepoPatch p => [DarcsFlag] -> PatchSet p C(Origin x) -> IO ()
> -writeInventoryAndPatches opts ps = do writeInventory "." ps
> - sequence_ $ mapRL (writePatch opts . hopefully) $ newset2RL ps
> +writeInventoryAndPatches :: RepoPatch p => Compression -> PatchSet p C(Origin x) -> IO ()
> +writeInventoryAndPatches compr ps = do writeInventory "." ps
> + sequence_ $ mapRL (writePatch compr . hopefully) $ newset2RL ps
>
> addToInventory :: FilePath -> [PatchInfo] -> IO ()
> addToInventory dir pinfos =
> hunk ./src/Darcs/Repository/DarcsRepo.lhs 188
> pidocs [] = text ""
> pidocs (p:ps) = showPatchInfo p $$ pidocs ps
>
> -addToTentativeInventory :: forall p C(x y). RepoPatch p => [DarcsFlag] -> Named p C(x y) -> IO FilePath
> -addToTentativeInventory opts p =
> +addToTentativeInventory :: forall p C(x y). RepoPatch p => Compression -> Named p C(x y) -> IO FilePath
> +addToTentativeInventory compr p =
> do appendDocBinFile (darcsdir++"/tentative_inventory") $ text "\n"
> <> showPatchInfo (patch2patchinfo p)
> when (isTag $ patch2patchinfo p) $
> hunk ./src/Darcs/Repository/DarcsRepo.lhs 200
> Sealed ps <- readRepoPrivate k realdir "tentative_inventory"
> :: IO (SealedPatchSet p C(Origin) )
> simplyWriteInventory "tentative_inventory" "." $ slightlyOptimizePatchset ps
> - writePatch opts p
> + writePatch compr p
>
> addToTentativePristine :: Effect p => p C(x y) -> IO ()
> addToTentativePristine p =
> hunk ./src/Darcs/Repository/DarcsRepo.lhs 208
> appendDocBinFile (darcsdir++"/tentative_pristine") $ showPatch (effect p) -- FIXME: this is inefficient!
> appendBinFile (darcsdir++"/tentative_pristine") "\n"
>
> -removeFromTentativeInventory :: RepoPatch p => Bool -> [DarcsFlag]
> +removeFromTentativeInventory :: RepoPatch p => Bool -> Compression
> -> FL (PatchInfoAnd p) C(x y) -> IO ()
> hunk ./src/Darcs/Repository/DarcsRepo.lhs 210
> -removeFromTentativeInventory update_pristine opts to_remove =
> +removeFromTentativeInventory update_pristine compr to_remove =
> do finalizeTentativeChanges
> Sealed allpatches <- readRepo "."
> unmodified :>> skipped <- return $ commuteToEnd
> hunk ./src/Darcs/Repository/DarcsRepo.lhs 215
> (reverseFL $ unsafeCoerceP to_remove) allpatches
> - sequence_ $ mapRL (writePatch opts . hopefully) skipped
> + sequence_ $ mapRL (writePatch compr . hopefully) skipped
> let newpatches = case unmodified of
> PatchSet ps ts -> PatchSet (skipped+<+ps) ts
> writeInventory "." $ deepOptimizePatchset newpatches
> hunk ./src/Darcs/Repository/Internal.hs 100
> MarkConflicts, AllowConflicts, NoUpdateWorking,
> WorkRepoUrl, WorkRepoDir, UMask, Test, LeaveTestDir,
> SetScriptsExecutable, DryRun ),
> - wantExternalMerge, compression )
> + wantExternalMerge, compression, Compression )
> import Darcs.Witnesses.Ordered ( FL(..), RL(..), EqCheck(..), unsafeCoerceP,
> (:\/:)(..), (:/\:)(..), (:>)(..),
> (+>+), lengthFL,
> hunk ./src/Darcs/Repository/Internal.hs 362
> makePatchLazy :: RepoPatch p => Repository p C(r u t) -> PatchInfoAnd p C(x y) -> IO (PatchInfoAnd p C(x y))
> makePatchLazy (Repo r opts rf (DarcsRepository _ c)) p
> | formatHas HashedInventory rf = withCurrentDirectory r $ HashedRepo.writeAndReadPatch c (compression opts) p
> - | otherwise = withCurrentDirectory r $ DarcsRepo.writeAndReadPatch opts p
> + | otherwise = withCurrentDirectory r $ DarcsRepo.writeAndReadPatch (compression opts) p
>
> prefsUrl :: Repository p C(r u t) -> String
> prefsUrl (Repo r _ _ (DarcsRepository _ _)) = r ++ "/"++darcsdir++"/prefs"
> hunk ./src/Darcs/Repository/Internal.hs 466
> fromPrims_ = fromPrims
>
> tentativelyAddPatch :: RepoPatch p
> - => Repository p C(r u t) -> [DarcsFlag] -> PatchInfoAnd p C(t y) -> IO (Repository p C(r u y))
> + => Repository p C(r u t) -> Compression -> PatchInfoAnd p C(t y) -> IO (Repository p C(r u y))
> tentativelyAddPatch = tentativelyAddPatch_ UpdatePristine
>
> data UpdatePristine = UpdatePristine | DontUpdatePristine deriving Eq
> hunk ./src/Darcs/Repository/Internal.hs 471
>
> +-- TODO re-add a safety catch for --dry-run? Maybe using a global, like dryRun
> +-- :: Bool, with dryRun = unsafePerformIO $ readIORef ...
> tentativelyAddPatch_ :: RepoPatch p
> hunk ./src/Darcs/Repository/Internal.hs 474
> - => UpdatePristine -> Repository p C(r u t) -> [DarcsFlag]
> + => UpdatePristine -> Repository p C(r u t) -> Compression
> -> PatchInfoAnd p C(t y) -> IO (Repository p C(r u y))
> hunk ./src/Darcs/Repository/Internal.hs 476
> -tentativelyAddPatch_ _ _ opts _
> - | DryRun `elem` opts = bug "tentativelyAddPatch_ called when --dry-run is specified"
> -tentativelyAddPatch_ up r@(Repo dir ropts rf (DarcsRepository t c)) opts p =
> +tentativelyAddPatch_ up r@(Repo dir ropts rf (DarcsRepository t c)) compr p =
> withCurrentDirectory dir $
> do decideHashedOrNormal rf $ HvsO {
> hunk ./src/Darcs/Repository/Internal.hs 479
> - hashed = HashedRepo.addToTentativeInventory c (compression opts) p,
> - old = DarcsRepo.addToTentativeInventory opts (hopefully p) }
> + hashed = HashedRepo.addToTentativeInventory c compr p,
> + old = DarcsRepo.addToTentativeInventory compr (hopefully p) }
> when (up == UpdatePristine) $ do debugMessage "Applying to pristine cache..."
> applyToTentativePristine r p
> debugMessage "Updating pending..."
> hunk ./src/Darcs/Repository/Internal.hs 541
> fromPrims_ :: FL Prim C(a b) -> Patch C(a b)
> fromPrims_ = fromPrims
>
> -tentativelyRemovePatches :: RepoPatch p => Repository p C(r u t) -> [DarcsFlag]
> +tentativelyRemovePatches :: RepoPatch p => Repository p C(r u t) -> Compression
> -> FL (PatchInfoAnd p) C(x t) -> IO (Repository p C(r u x))
> tentativelyRemovePatches = tentativelyRemovePatches_ UpdatePristine
>
> hunk ./src/Darcs/Repository/Internal.hs 546
> tentativelyRemovePatches_ :: forall p C(r u t x). RepoPatch p => UpdatePristine
> - -> Repository p C(r u t) -> [DarcsFlag]
> + -> Repository p C(r u t) -> Compression
> -> FL (PatchInfoAnd p) C(x t) -> IO (Repository p C(r u x))
> hunk ./src/Darcs/Repository/Internal.hs 548
> -tentativelyRemovePatches_ up repository@(Repo dir ropts rf (DarcsRepository t c)) opts ps =
> +tentativelyRemovePatches_ up repository@(Repo dir ropts rf (DarcsRepository t c)) compr ps =
> withCurrentDirectory dir $ do
> when (up == UpdatePristine) $ do debugMessage "Adding changes to pending..."
> prepend repository $ effect ps
> hunk ./src/Darcs/Repository/Internal.hs 555
> removeFromUnrevertContext repository ps
> debugMessage "Removing changes from tentative inventory..."
> if formatHas HashedInventory rf
> - then do HashedRepo.removeFromTentativeInventory repository (compression opts) ps
> + then do HashedRepo.removeFromTentativeInventory repository compr ps
> when (up == UpdatePristine) $
> HashedRepo.applyToTentativePristine $
> progressFL "Applying inverse to pristine" $ invert ps
> hunk ./src/Darcs/Repository/Internal.hs 559
> - else DarcsRepo.removeFromTentativeInventory (up==UpdatePristine) opts ps
> + else DarcsRepo.removeFromTentativeInventory (up==UpdatePristine) compr ps
> return (Repo dir ropts rf (DarcsRepository t c))
>
> hunk ./src/Darcs/Repository/Internal.hs 562
> -tentativelyReplacePatches :: forall p C(r u t x). RepoPatch p => Repository p C(r u t) -> [DarcsFlag]
> +tentativelyReplacePatches :: forall p C(r u t x). RepoPatch p => Repository p C(r u t) -> Compression
> -> FL (PatchInfoAnd p) C(x t) -> IO (Repository p C(r u t))
> hunk ./src/Darcs/Repository/Internal.hs 564
> -tentativelyReplacePatches repository opts ps =
> - do repository' <- tentativelyRemovePatches_ DontUpdatePristine repository opts ps
> +tentativelyReplacePatches repository compr ps =
> + do repository' <- tentativelyRemovePatches_ DontUpdatePristine repository compr ps
> mapAdd repository' ps
> where mapAdd :: Repository p C(m l i) -> FL (PatchInfoAnd p) C(i j) -> IO (Repository p C(m l j))
> mapAdd r NilFL = return r
> hunk ./src/Darcs/Repository/Internal.hs 570
> mapAdd r (a:>:as) =
> - do r' <- tentativelyAddPatch_ DontUpdatePristine r opts a
> + do r' <- tentativelyAddPatch_ DontUpdatePristine r compr a
> mapAdd r' as
>
> finalizePending :: RepoPatch p => Repository p C(r u t) -> IO ()
> hunk ./src/Darcs/Repository/Merge.hs 31
> import Darcs.Patch ( Effect )
> import Darcs.Hopefully ( PatchInfoAnd, n2pia, hopefully )
> import Darcs.Flags
> - ( DarcsFlag( AllowConflicts, NoAllowConflicts ), wantExternalMerge, diffingOpts )
> + ( DarcsFlag( AllowConflicts, NoAllowConflicts ), wantExternalMerge, diffingOpts, compression )
> import Darcs.Witnesses.Ordered
> ( FL(..), (:\/:)(..), (:/\:)(..), (+>+), mapFL_FL )
> import Darcs.Patch
> hunk ./src/Darcs/Repository/Merge.hs 95
> where mapAdd :: Repository p C(m l i) -> FL (PatchInfoAnd p) C(i j) -> IO (Repository p C(m l j))
> mapAdd repo NilFL = return repo
> mapAdd repo (a:>:as) =
> - do repo' <- tentativelyAddPatch_ DontUpdatePristine repo opts a
> + do repo' <- tentativelyAddPatch_ DontUpdatePristine repo (compression opts) a
> mapAdd repo' as
> applyps :: Repository p C(m l i) -> FL (PatchInfoAnd p) C(i j) -> IO ()
> applyps repo ps = do debugMessage "Adding patches to inventory..."
Remove [DarcsFlag] usage from Darcs.Patch.Bundle.
-------------------------------------------------
> Petr Rockai <me at mornfall.net>**20100715081908
> Ignore-this: 62297671dea56fdc0a1cac42f79d6d29
> ] hunk ./src/Darcs/Commands/Pull.lhs 268
> -> IO ()
> makeBundle opts (common, Sealed (_ :\/: to_be_fetched)) =
> do
> - bundle <- PatchBundle.makeBundle opts undefined common $
> + bundle <- PatchBundle.makeBundle Nothing common $
> mapFL_FL hopefully to_be_fetched
> let fname = case to_be_fetched of
> (x:>:_)-> PatchBundle.patchFilename $ patchDesc x
> hunk ./src/Darcs/Commands/Push.lhs 166
> putInfo opts $
> text "You don't want to push any patches, and that's fine with me!"
> exitWith ExitSuccess
> - bundle <- makeBundleN []
> - (bug "using slurpy in makeBundle called from Push")
> + bundle <- makeBundleN Nothing
> common (mapFL_FL hopefully to_be_pushed)
> return (bundle)
>
> hunk ./src/Darcs/Commands/Put.lhs 117
> when (nullFL patches) $ do
> putInfo opts $ text "No patches were selected to put. Nothing to be done."
> exitWith ExitSuccess
> - bundle <- makeBundle2 opts emptyTree [] patches patches2
> + bundle <- makeBundle2 Nothing [] patches patches2
> let message = if isFile req_absolute_repo_dir
> then bundle
> else makeEmail req_absolute_repo_dir [] Nothing bundle Nothing
> hunk ./src/Darcs/Commands/Send.lhs 204
> -> IO Doc
> prepareBundle opts common pristine (us' :\/: to_be_sent) = do
> pristine' <- applyToTree (invert $ mapFL_FL hopefully us') pristine
> - unsig_bundle <- makeBundleN (Unified:opts) pristine' (unsafeCoerceP common) (mapFL_FL hopefully to_be_sent)
> + unsig_bundle <- makeBundleN (Just pristine') (unsafeCoerceP common) (mapFL_FL hopefully to_be_sent)
> signString opts unsig_bundle
>
> sendBundle :: forall p C(x y) . (RepoPatch p) => [DarcsFlag] -> FL (PatchInfoAnd p) C(x y)
> hunk ./src/Darcs/Commands/Unrecord.lhs 349
> -> FL (PatchInfoAnd p) C(x y) -> FL (PatchInfoAnd p) C(z t)
> -> IO ()
> savetoBundle opts kept removed@(x :>: _) = do
> - bundle <- makeBundle opts undefined (mapFL info kept)
> + bundle <- makeBundle Nothing (mapFL info kept)
> (mapFL_FL hopefully removed)
> let filename = patchFilename $ patchDesc x
> Just outname = getOutput opts filename
> hunk ./src/Darcs/Commands/Unrevert.lhs 123
> rep <- readRepo repository
> date <- getIsoDateTime
> np <- namepatch date "unrevert" "anon" [] (fromRepoPrims repository p')
> - bundle <- makeBundleN [Unified] rec rep (np :>: NilFL)
> + bundle <- makeBundleN (Just rec) rep (np :>: NilFL)
> writeDocBinFile (unrevertUrl repository) bundle
> where fromRepoPrims :: RepoPatch p => Repository p C(r u t) -> FL Prim C(r y) -> p C(r y)
> fromRepoPrims _ xs = fromPrims xs
> hunk ./src/Darcs/Patch/Bundle.hs 28
> ) where
>
> import Data.Char ( isAlpha, toLower, isDigit, isSpace )
> -import Darcs.Flags ( DarcsFlag, isUnified )
> import Darcs.Hopefully ( PatchInfoAnd, piap,
> patchInfoAndPatch,
> unavailable, hopefully )
> hunk ./src/Darcs/Patch/Bundle.hs 57
> hashBundle _ to_be_sent = sha1PS $ renderPS
> $ vcat (mapFL showPatch to_be_sent) <> newline
>
> -makeBundleN :: RepoPatch p => [DarcsFlag] -> Tree IO
> +makeBundleN :: RepoPatch p => Maybe (Tree IO)
> -> PatchSet p C(start x) -> FL (Named p) C(x y) -> IO Doc
> hunk ./src/Darcs/Patch/Bundle.hs 59
> -makeBundleN opts the_s (PatchSet ps (Tagged t _ _ :<: _)) to_be_sent =
> - makeBundle2 opts the_s (mapRL info ps ++ [info t]) to_be_sent to_be_sent
> -makeBundleN opts the_s (PatchSet ps NilRL) to_be_sent =
> - makeBundle2 opts the_s (mapRL info ps) to_be_sent to_be_sent
> +makeBundleN the_s (PatchSet ps (Tagged t _ _ :<: _)) to_be_sent =
> + makeBundle2 the_s (mapRL info ps ++ [info t]) to_be_sent to_be_sent
> +makeBundleN the_s (PatchSet ps NilRL) to_be_sent =
> + makeBundle2 the_s (mapRL info ps) to_be_sent to_be_sent
>
> hunk ./src/Darcs/Patch/Bundle.hs 64
> -makeBundle :: RepoPatch p => [DarcsFlag] -> Tree IO -> [PatchInfo] -> FL (Named p) C(x y) -> IO Doc
> -makeBundle opts the_s common to_be_sent = makeBundle2 opts the_s common to_be_sent to_be_sent
> +makeBundle :: RepoPatch p => Maybe (Tree IO) -> [PatchInfo] -> FL (Named p) C(x y) -> IO Doc
> +makeBundle the_s common to_be_sent = makeBundle2 the_s common to_be_sent to_be_sent
>
> -- | In makeBundle2, it is presumed that the two patch sequences are
> -- identical, but that they may be lazily generated. If two different
> hunk ./src/Darcs/Patch/Bundle.hs 72
> -- patch sequences are passed, a bundle with a mismatched hash will be
> -- generated, which is not the end of the world, but isn't very useful
> -- either.
> -makeBundle2 :: RepoPatch p => [DarcsFlag] -> Tree IO -> [PatchInfo]
> +makeBundle2 :: RepoPatch p => Maybe (Tree IO) -> [PatchInfo]
> -> FL (Named p) C(x y) -> FL (Named p) C(x y) -> IO Doc
> hunk ./src/Darcs/Patch/Bundle.hs 74
> -makeBundle2 opts the_s common to_be_sent to_be_sent2 =
> - do patches <- case (isUnified opts) of
> - True -> fst `fmap` virtualTreeIO (showContextPatch to_be_sent) the_s
> - False -> return (vsep $ mapFL showPatch to_be_sent)
> +makeBundle2 the_s common to_be_sent to_be_sent2 =
> + do patches <- case the_s of
> + Just tree -> fst `fmap` virtualTreeIO (showContextPatch to_be_sent) tree
> + Nothing -> return (vsep $ mapFL showPatch to_be_sent)
> return $ format patches
> where format the_new = text ""
> $$ text "New patches:"
> hunk ./src/Darcs/Repository/Internal.hs 743
> Nothing -> unrevert_impossible
> Just common ->
> do debugMessage "Have now found the new context..."
> - s <- readRecorded repository
> - bundle <- makeBundleN [] s common (hopefully us':>:NilFL)
> + bundle <- makeBundleN Nothing common (hopefully us':>:NilFL)
> writeDocBinFile (unrevertUrl repository) bundle
> debugMessage "Done adjusting the context of the unrevert changes!"
>
--
Eric Kow <http://www.nltg.brighton.ac.uk/home/Eric.Kow>
For a faster response, please try +44 (0)1273 64 2905.
-------------- next part --------------
A non-text attachment was scrubbed...
Name: not available
Type: application/pgp-signature
Size: 198 bytes
Desc: Digital signature
URL: <http://lists.osuosl.org/pipermail/darcs-users/attachments/20100716/e8f2808a/attachment-0001.pgp>
More information about the darcs-users
mailing list