[darcs-users] [patch39] Refactor Darcs.Commands.Pull (and 1 more)

Jason Dagit dagitj at gmail.com
Tue Nov 24 17:19:34 UTC 2009


Florent,

I've done the review.  Please see my comments inline below.  Sorry this took
me so long.

Two side notes for everyone:
* Please try to keep your refactorings to separate (dedicated) patches.
That makes life easier for the reviewers because we can glance over those
changes more quickly.
* Don't be shy about changing to camelCase.

Florent:  I know you did both for about half of your changes, so I hope the
above don't sound like nagging.

As for status:  I'd like to see what Florent can address before we apply
this.  Particularly, I'm interested to know if some of the functions can be
reused (or why not).  Amend record is not necessary.  New patches on top of
these are fine with me.

I apologize that my comments and the patch contents are not more clearly
separated.  I'm trying a new workflow and it has still got some bugs.

Thanks!
Jason


New patches:

[Refactor Darcs.Commands.Pull
Florent Becker <florent.becker at ens-lyon.org>**20091102165551
hunk ./src/Darcs/Commands/Pull.lhs 109
                                               working_repo_dir,
                                               allow_unrelated_repos]}

+merge_opts :: [DarcsFlag] -> [DarcsFlag]
+merge_opts opts | NoAllowConflicts `elem` opts = opts
+                | AllowConflicts   `elem` opts = opts
+                | otherwise                    = MarkConflicts : opts
+

Looks good, but should be camelCase.  It was moved here from somewhere
else, and the refactor looks like a copy&paste, which makes sense
here.

 pull_cmd :: [DarcsFlag] -> [String] -> IO ()
hunk ./src/Darcs/Commands/Pull.lhs 115
-pull_cmd opts unfixedrepodirs@(_:_) = withRepoLock opts $- \repository ->
do
+pull_cmd opts repos =
+    withRepoLock opts $- \repository ->
+        fetchPatches opts' repos "pull" repository >>= applyPatches opts'
repository
+    where
+      opts' = merge_opts opts
+
+fetchPatches :: FORALL(p r u t) (RepoPatch p) => [DarcsFlag] -> [String] ->
String ->
+               Repository p C(r u t) ->
+                   IO ( [PatchInfo], Sealed ((RL (PatchInfoAnd p)  :\/: FL
(PatchInfoAnd p)) C(r)))
+fetchPatches opts unfixedrepodirs@(_:_) jobname repository = do

Factored fetchPatches into its own function.  Seems wise.  CamelCase,
which is good.  I think the witness types make sense, and it looks
like the use of C/FORALL is correct.

   here <- getCurrentDirectory
   repodirs <- (nub . filter (/= here)) `fmap` mapM (fixUrl opts)
unfixedrepodirs
   -- Test to make sure we aren't trying to pull from the current repo
hunk ./src/Darcs/Commands/Pull.lhs 143
   (_     ,   _ :\/: compl') <- return $ get_common_and_uncommon (us, compl)
   checkUnrelatedRepos opts common us them
   let avoided = mapRL info compl'
-  ps :> _ <- return $ partitionFL (not . (`elem` avoided) . info) $
reverseRL them''
-  do when (Verbose `elem` opts) $
-          do case us' of
-               (x@(_:<:_)) -> putDocLn $ text "We have the following new
(to them) patches:"
-                                         $$ (vcat $ mapRL description x)
-               _ -> return ()
-             when (not $ nullFL ps) $ putDocLn $ text "They have the
following patches to pull:"
-                      $$ (vcat $ mapFL description ps)
-     (hadConflicts, Sealed psFiltered) <- filterOutConflicts merge_opts us'
repository ps
-     when hadConflicts $ putStrLn "Skipping some patches which would cause
conflicts."
-     when (nullFL psFiltered)
-                      $ do putInfo opts $ text "No remote changes to pull
in!"
-                           definePatches psFiltered
-                           exitWith ExitSuccess
-     with_selected_changes "pull" opts Nothing psFiltered $
-      \ (to_be_pulled:>_) ->
+  (ps :> _) <- return $ partitionFL (not . (`elem` avoided) . info) $
reverseRL them''

Nit-pick: The parens around "ps :> _" shouldn't be necessary.

+              -- using "… <- return $ …" instead of "let (…) = …" to
prevent GHC's brain from exploding

We probably don't need this comment, as that is such a common
occurence in the darcs source code.  It needs to be well-documented
and known outside of just this use.

+  when (Verbose `elem` opts) $

Removed extra 'do', that's good.

+       do case us' of
+            (x@(_:<:_)) -> putDocLn $ text "We have the following new (to
them) patches:"
+                                                             $$ (vcat $
mapRL description x)
+            _ -> return ()
+          when (not $ nullFL ps) $ putDocLn $ text "They have the following
patches to pull:"
+                                                             $$ (vcat $
mapFL description ps)

None of this was actually changed, just moved.

+  (hadConflicts, Sealed psFiltered) <- filterOutConflicts opts us'
repository ps
+  when hadConflicts $ putStrLn "Skipping some patches which would cause
conflicts."
+  when  (nullFL psFiltered) $ do putInfo opts $ text "No remote changes to
pull in!"
+                                 definePatches ps

Shouldn't that be "definePatches psFiltered"?  Or maybe it's not
because you have yet to ask the user to select changes?

+                                 exitWith ExitSuccess
+  with_selected_changes jobname opts Nothing psFiltered
+                            $ \(to_be_pulled :> _ ) -> return (common, seal
$ us' :\/: to_be_pulled)

Looks okay.

+
+fetchPatches _ [] jobname _ = fail $ "No default repository to " ++ jobname
++
+                                " from, please specify one"
+
+applyPatches ::
+    forall p C(r u t). (RepoPatch p) => [DarcsFlag] -> Repository p C(r u
t) ->
+    ([PatchInfo], Sealed ((RL (PatchInfoAnd p) :\/: FL (PatchInfoAnd p))
C(r)))
+    -> IO ()
+applyPatches opts repository (_, Sealed (us' :\/: to_be_pulled)) =

Look okay to me.

          do
            print_dry_run_message_and_exit "pull" opts to_be_pulled
            definePatches to_be_pulled
hunk ./src/Darcs/Commands/Pull.lhs 177
            check_paths opts to_be_pulled
            putVerbose opts $ text "Getting and merging the following
patches:"
            putVerbose opts $ vcat $ mapFL description to_be_pulled
-           Sealed pw <- tentativelyMergePatches repository "pull"
merge_opts
+           Sealed pw <- tentativelyMergePatches repository "pull" opts

At first I was confused that this wasn't opts', but now I see what you did.

                        (reverseRL us') to_be_pulled
            invalidateIndex repository
            withGutsOf repository $ do finalizeRepositoryChanges repository
hunk ./src/Darcs/Commands/Pull.lhs 184
                                       revertable $ applyToWorking
repository opts pw
            putInfo opts $ text "Finished pulling and applying."

-pull_cmd _ [] = fail "No default repository to pull from, please specify
one"

 revertable :: IO a -> IO a
 revertable x =
[Add a fetch command to get remote patches into a bundle
Florent Becker <florent.becker at ens-lyon.org>**20091102170947
 Ignore-this: ad8b91712c23fbdc10aba6d4609a10da
] hunk ./src/Darcs/Arguments.lhs 44
                          patchname_option, distname_option,
                          logfile, rmlogfile, from_opt, subject,
get_subject,
                          in_reply_to, get_in_reply_to,
-                         target, cc_send, cc_apply, get_cc, output,
output_auto_name,
+                         target, cc_send, cc_apply, get_cc, output,
output_auto_name, get_output,
                          recursive, inventory_choices,
get_inventory_choices,
                          upgradeFormat,
                          askdeps, ignoretimes, lookforadds,
hunk ./src/Darcs/Arguments.lhs 916
 output_auto_name = DarcsOptAbsPathOption ['O'] ["output-auto-name"] "."
OutputAutoName "DIRECTORY"
                    "output to automatically named file in DIRECTORY,
default: current directory"

+get_output :: [DarcsFlag] -> FilePath -> Maybe AbsolutePathOrStd
+get_output (Output a:_) _ = return a
+get_output (OutputAutoName a:_) f = return $ makeAbsoluteOrStd a f
+get_output (_:flags) f = get_output flags f
+get_output [] _ = Nothing

I wish we had a more general pattern for these.  If you made any more
changes to this, please camelCase it.

+
+
 edit_description =
     DarcsMultipleChoiceOption
     [DarcsNoArgOption [] ["edit-description"] EditDescription
hunk ./src/Darcs/Arguments.lhs 1661
 --   Otherwise, -1.
 number_string :: String -> Int
 number_string s = if and (map isDigit s) then read s else (-1)
+
 \end{code}
hunk ./src/Darcs/Commands.lhs 40
                        extract_commands,
                        super_name,
                        nodefaults,
-                       putInfo, putVerbose, putWarning, abortRun
+                       putInfo, putVerbose, putWarning, abortRun,
+                       patchFilename
                      ) where

 import System.Console.GetOpt( OptDescr, usageInfo )
hunk ./src/Darcs/Commands.lhs 47
 import Control.Monad (when, unless)

+import Data.Char ( isAlpha, isDigit, isSpace, toLower )
 import Data.List ( sort, isPrefixOf )
 import Darcs.Arguments ( DarcsFlag(Quiet,Verbose, DryRun), DarcsOption,
disable, help,
                          any_verbosity, posthook_cmd, posthook_prompt,
hunk ./src/Darcs/Commands.lhs 311
 abortRun opts msg = if DryRun `elem` opts
                     then putInfo opts $ text "NOTE:" <+> msg
                     else errorDoc msg
+
+
+safeFileChar :: Char -> Char
+safeFileChar c | isAlpha c = toLower c
+               | isDigit c = c
+               | isSpace c = '-'
+safeFileChar _ = '_'

Why did this need to be defined here?  Surely we have code for this
elsewhere?  If not, I'm still not convinced this is the right place to
put the definition.  I certainly wouldn't think to look in
Darcs.Commands for such a function.  The code for creating a bundle to
send probably has something you can use.

+
+patchFilename :: String -> String
+patchFilename the_summary = name ++ ".dpatch"
+    where name = map safeFileChar the_summary

Seems reasonable, but again I'd be surprised if this code doesn't already
exist elsewhere.

+
 \end{code}
hunk ./src/Darcs/Commands/Pull.lhs 23
 {-# OPTIONS_GHC -cpp #-}
 {-# LANGUAGE CPP, TypeOperators #-}

-module Darcs.Commands.Pull ( pull ) where
+module Darcs.Commands.Pull ( pull, fetch ) where
 import System.Exit ( ExitCode(..), exitWith )
 import Workaround ( getCurrentDirectory )
 import Control.Monad ( when )
hunk ./src/Darcs/Commands/Pull.lhs 28
 import Data.List ( nub )
+import Data.Maybe ( fromMaybe )

hunk ./src/Darcs/Commands/Pull.lhs 30
-import Darcs.Commands ( DarcsCommand(..), putVerbose, putInfo )
+import Darcs.Commands ( DarcsCommand(..), putVerbose, putInfo,
patchFilename )
 import Darcs.CommandsAux ( check_paths )
 import Darcs.Arguments ( DarcsFlag( Verbose, DryRun, MarkConflicts,
                                    Intersection, Complement,
AllowConflicts,
hunk ./src/Darcs/Commands/Pull.lhs 43
                          test, dry_run,
                          set_default, summary, working_repo_dir,
remote_repo,
                          set_scripts_executable, nolinks,
-                         network_options, umask_option,
allow_unrelated_repos, restrict_paths
+                         network_options, umask_option,
allow_unrelated_repos, restrict_paths,
+                         get_output, output
                       )
 import Darcs.Repository ( Repository, SealedPatchSet,
identifyRepositoryFor, withGutsOf,
                           amInRepository, withRepoLock, ($-),
tentativelyMergePatches,
hunk ./src/Darcs/Commands/Pull.lhs 52
                           read_repo, checkUnrelatedRepos, invalidateIndex )
 import Darcs.Hopefully ( info, PatchInfoAnd, hopefully )
 import Darcs.Patch ( RepoPatch, description )
-import Darcs.Patch.Info (PatchInfo)
+import Darcs.Patch.Info (PatchInfo, just_name)
 import Darcs.Patch.Bundle (make_bundle)
 import Darcs.Ordered ( (:>)(..), (:\/:)(..), RL(..), FL(..),
                              mapFL, nullFL, reverseRL, mapRL, mapFL_FL )
hunk ./src/Darcs/Commands/Pull.lhs 64
 import Darcs.SelectChanges ( with_selected_changes, filterOutConflicts )
 import Darcs.Utils ( clarifyErrors, formatPath )
 import Darcs.Sealed ( Sealed(..), seal )
-import Printer ( putDocLn, vcat, ($$), text )
+import Printer ( putDocLn, vcat, ($$), text, putDoc )
+import Darcs.Lock ( writeDocBinFile )
+import Darcs.RepoPath ( toFilePath, useAbsoluteOrStd, stdOut )
 #include "impossible.h"

 #include "gadts.h"
hunk ./src/Darcs/Commands/Pull.lhs 75
 pull_description =
  "Copy and apply patches from another repository to this one."

+fetch_description :: String
+fetch_description =
+ "Fetch patches from another repository, but don't apply them."
+
 pull_help :: String
 pull_help =
  "Pull is used to bring changes made in another repository into the
current\n"++
hunk ./src/Darcs/Commands/Pull.lhs 89
  "without an argument, pull will use the repository from which you have
most\n"++
  "recently either pushed or pulled.\n"

+fetch_help :: String
+fetch_help =
+ "fetch is used to bring changes made in another repository\n" ++
+ "into the current repository without actually applying\n"++
+ "them. Fetch allows you to bring over all or\n"++
+ "some of the patches that are in that repository but not in this one.
Fetch\n"++
+ "accepts arguments, which are URLs from which to fetch, and when
called\n"++
+ "without an argument, fetch will use the repository from which you have
most\n"++
+ "recently either pushed or pulled.\n"++
+ "The fetched patches are stored into a patch bundle, to be later\n" ++
+ "applied using \"darcs apply\"."

I assume this is part of the discussion on darcs-users, so I'm ignoring it
in this review.

+
+
+fetch :: DarcsCommand
+fetch = DarcsCommand {
+         command_name = "fetch",
+         command_help = fetch_help,
+         command_description = fetch_description,
+         command_extra_args = -1,
+         command_extra_arg_help = ["[REPOSITORY]..."],
+         command_command = fetch_cmd,
+         command_prereq = amInRepository,
+         command_get_arg_possibilities = get_preflist "repos",
+         command_argdefaults = defaultrepo,
+         command_advanced_options = [repo_combinator,
+                                     nocompress, nolinks,
+                                     ignoretimes,
+                                     remote_repo] ++
+                                    network_options,
+         command_basic_options = [match_several,
+                                  all_interactive,
+                                  pull_conflict_options]
+                                 ++dry_run++
+                                 [summary,
+                                  deps_sel,
+                                  set_default,
+                                  working_repo_dir,
+                                  output,
+                                  allow_unrelated_repos]}
+

I don't see anything missing in this definition, but that doesn't mean
much :)

 pull :: DarcsCommand
 pull = DarcsCommand {command_name = "pull",
                      command_help = pull_help,
hunk ./src/Darcs/Commands/Pull.lhs 169
     where
       opts' = merge_opts opts

+fetch_cmd :: [DarcsFlag] -> [String] -> IO ()
+fetch_cmd opts repos =
+    withRepoLock opts $- \ repository ->
+        fetchPatches opts' repos "fetch" repository >>= bundlePatches opts'
+    where
+      opts' = merge_opts opts
+
 fetchPatches :: FORALL(p r u t) (RepoPatch p) => [DarcsFlag] -> [String] ->
String ->
                Repository p C(r u t) ->
                    IO ( [PatchInfo], Sealed ((RL (PatchInfoAnd p)  :\/: FL
(PatchInfoAnd p)) C(r)))
hunk ./src/Darcs/Commands/Pull.lhs 218
 fetchPatches _ [] jobname _ = fail $ "No default repository to " ++ jobname
++
                                 " from, please specify one"

+bundlePatches :: forall p C(x). RepoPatch p => [DarcsFlag] ->
+                ([PatchInfo], Sealed ((RL (PatchInfoAnd p) :\/: FL
(PatchInfoAnd p)) C(x)))
+              -> IO ()
+bundlePatches opts (common, Sealed (_ :\/: to_be_fetched)) =
+    do
+      definePatches to_be_fetched
+      print_dry_run_message_and_exit "fetch" opts to_be_fetched
+      when (nullFL to_be_fetched) $ do
+          putInfo opts $
+            text "You don't want to fetch any patches, and that's fine with
me!"
+          exitWith ExitSuccess
+      bundle <- make_bundle []
+                     (bug "using slurpy in make_bundle called from Fetch")
+                     common (mapFL_FL hopefully to_be_fetched)
+      let make_fname (tb:>:_) = patchFilename . just_name . info $ tb
+          make_fname _ = impossible
+          outname = fromMaybe stdOut (get_output opts $ make_fname
to_be_fetched)
+          putabs a = do writeDocBinFile a bundle
+                        putStrLn $ "Wrote patch to " ++ toFilePath a ++ "."
+          putstd = putDoc bundle
+      useAbsoluteOrStd putabs putstd outname
+

As far as I can tell the above is good, but I'm a little surprised it
needed to be written.  Shouldn't we have similar code where we send
patches?

 applyPatches ::
     forall p C(r u t). (RepoPatch p) => [DarcsFlag] -> Repository p C(r u
t) ->
     ([PatchInfo], Sealed ((RL (PatchInfoAnd p) :\/: FL (PatchInfoAnd p))
C(r)))
hunk ./src/Darcs/Commands/Send.lhs 24
 {-# LANGUAGE CPP #-}

 module Darcs.Commands.Send ( send ) where
-import Data.Char ( isAlpha, isDigit, isSpace, toLower )
 import System.Exit ( exitWith, ExitCode( ExitSuccess ) )
 import System.IO.Error ( ioeGetErrorString )
 import System.IO ( hClose )
hunk ./src/Darcs/Commands/Send.lhs 30
 import Control.Monad ( when, unless, forM_ )
 import Data.Maybe ( isJust, isNothing )

-import Darcs.Commands ( DarcsCommand(..), putInfo, putVerbose )
+import Darcs.Commands ( DarcsCommand(..), putInfo, putVerbose,
patchFilename )
 import Darcs.Arguments ( DarcsFlag( EditDescription, LogFile, RmLogFile,
hunk ./src/Darcs/Commands/Send.lhs 32
-                                    Target, OutputAutoName, Output,
Context,
+                                    Target, Context,
                                     DryRun, Quiet, Unified
                                   ),
                          fixUrl, definePatches,
hunk ./src/Darcs/Commands/Send.lhs 45
                          all_interactive, get_sendmail_cmd,
                          print_dry_run_message_and_exit,
                          summary, allow_unrelated_repos,
-                         from_opt, dry_run, send_to_context,
+                         from_opt, dry_run, send_to_context, get_output
                        )
 import Darcs.Hopefully ( PatchInfoAnd, hopefully, info )
 import Darcs.Repository ( PatchSet, Repository,
hunk ./src/Darcs/Commands/Send.lhs 68
 import Darcs.Email ( make_email )
 import Printer ( Doc, vsep, vcat, text, ($$), putDoc )
 import Darcs.RepoPath ( FilePathLike, toFilePath, AbsolutePath,
AbsolutePathOrStd,
-                        getCurrentDirectory, makeAbsoluteOrStd,
useAbsoluteOrStd )
+                        getCurrentDirectory, useAbsoluteOrStd )
 import HTTP ( postUrl )
 #include "impossible.h"

hunk ./src/Darcs/Commands/Send.lhs 186
       pristine' <- applyToTree (invert $ mapRL_RL hopefully us') pristine
       unsig_bundle <- make_bundle (Unified:opts) pristine' common (mapFL_FL
hopefully to_be_sent)
       bundle <- signString opts unsig_bundle
-      let make_fname (tb:>:_) = patch_filename $ patchDesc tb
+      let make_fname (tb:>:_) = patchFilename . patchDesc $ tb

Harmless refactor.

           make_fname _ = impossible
           fname = make_fname to_be_sent
           outname = get_output opts fname
hunk ./src/Darcs/Commands/Send.lhs 268
            putstd = putDoc (d $$ bundle)
        useAbsoluteOrStd putabs putstd fname
        cleanup opts f
-
-safeFileChar :: Char -> Char
-safeFileChar c | isAlpha c = toLower c
-               | isDigit c = c
-               | isSpace c = '-'
-safeFileChar _ = '_'
-
-patch_filename :: String -> String
-patch_filename the_summary = name ++ ".dpatch"
-    where name = map safeFileChar the_summary

Ah ha!  So we did have those things defined already.  So, the question
that remains is, where do they belong now?


 \end{code}

 \begin{options}
hunk ./src/Darcs/Commands/Send.lhs 362
             else when (null the_targets) $
                  putInfo opts . text $ "Patch bundle will be sent to:
"++unwords (map pn emails)

-get_output :: [DarcsFlag] -> FilePath -> Maybe AbsolutePathOrStd
-get_output (Output a:_) _ = return a
-get_output (OutputAutoName a:_) f = return $ makeAbsoluteOrStd a f
-get_output (_:flags) f = get_output flags f
-get_output [] _ = Nothing
-

Okay, now I see where the previous definition came from.

 get_targets :: [WhatToDo] -> IO [WhatToDo]
 get_targets [] = do fmap ((:[]) . SendMail) $ askUser "What is the target
email address? "
 get_targets wtds = return wtds
hunk ./src/Darcs/Patch/Bundle.hs 216
             scan_context $ filter_gpg_dashes rest
     (_,rest) -> scan_context rest

+
hunk ./src/Darcs/RepoPath.hs 33
   makeAbsoluteOrStd,
   ioAbsoluteOrStd,
   useAbsoluteOrStd,
+  stdOut,
   -- * AbsoluteOrRemotePath
   AbsoluteOrRemotePath,
   ioAbsoluteOrRemote,
hunk ./src/Darcs/RepoPath.hs 186
 makeAbsoluteOrStd _ "-" = APStd
 makeAbsoluteOrStd a p = AP $ makeAbsolute a p

+stdOut :: AbsolutePathOrStd
+stdOut = APStd
+
 ioAbsoluteOrStd :: String -> IO AbsolutePathOrStd
 ioAbsoluteOrStd "-" = return APStd
 ioAbsoluteOrStd p = AP `fmap` ioAbsolute p
hunk ./src/Darcs/TheCommands.hs 38
 import Darcs.Commands.MarkConflicts ( markconflicts, resolve )
 import Darcs.Commands.Move ( move, mv )
 import Darcs.Commands.Optimize ( optimize )
-import Darcs.Commands.Pull ( pull )
+import Darcs.Commands.Pull ( pull, fetch )
 import Darcs.Commands.Push ( push )
 import Darcs.Commands.Put ( put )
 import Darcs.Commands.Record ( record, commit )
hunk ./src/Darcs/TheCommands.hs 87
                 Hidden_command transfer_mode,
                 Group_name "Copying patches between repositories with
working copy update:",
                 Command_data pull,
+                Command_data fetch,
                 Command_data obliterate, Hidden_command unpull,
                 Command_data rollback,
                 Command_data push,
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://lists.osuosl.org/pipermail/darcs-users/attachments/20091124/5f064613/attachment-0001.htm>


More information about the darcs-users mailing list