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 <[email protected]>**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 <[email protected]>**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,
_______________________________________________ darcs-users mailing list [email protected] http://lists.osuosl.org/mailman/listinfo/darcs-users
