-- Copyright (C) 2009 Ganesh Sittampalam -- -- BSD3 module Darcs.UI.Commands.Rebase ( rebase ) where import Darcs.Prelude import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts , normalCommand, hiddenCommand , commandAlias , defaultRepo, nodefaults , putInfo , amInHashedRepository ) import Darcs.UI.Commands.Apply ( applyCmd ) import Darcs.UI.Commands.Log ( changelog, logInfoFL ) import Darcs.UI.Commands.Pull ( pullCmd ) import Darcs.UI.Commands.Util ( historyEditHelp, preselectPatches ) import Darcs.UI.Completion ( Pref(Repos), fileArgs, prefArgs, noArgs ) import Darcs.UI.Flags ( DarcsFlag , allowConflicts , diffingOpts , reorder, verbosity , useCache, wantGuiPause , umask, changesReverse , diffAlgorithm, isInteractive , selectDeps, hasXmlOutput ) import qualified Darcs.UI.Flags as Flags ( getAuthor ) import Darcs.UI.Options ( oid, (?), (^) ) import qualified Darcs.UI.Options.All as O import Darcs.UI.PatchHeader ( AskAboutDeps(..) , HijackOptions(..) , HijackT , editLog , getAuthor , patchHeaderConfig , runHijackT , updatePatchHeader ) import Darcs.Repository ( Repository, RepoJob(..), AccessType(..), withRepoLock, withRepository , tentativelyAddPatches, finalizeRepositoryChanges , tentativelyRemovePatches, readPatches , setTentativePending, unrecordedChanges, applyToWorking ) import Darcs.Repository.Flags ( AllowConflicts(..) , ResolveConflicts(..) , UpdatePending(..) ) import Darcs.Repository.Merge ( tentativelyMergePatches ) import Darcs.Repository.Rebase ( checkHasRebase , readRebase , readTentativeRebase , writeTentativeRebase ) import Darcs.Repository.Resolution ( StandardResolution(..) , rebaseResolution , announceConflicts ) import Darcs.Repository.State ( updateIndex ) import Darcs.Repository.Transaction ( upgradeOldStyleRebase ) import Darcs.Patch ( PrimOf, invert, effect, commute, RepoPatch ) import Darcs.Patch.Apply ( ApplyState ) import Darcs.Patch.CommuteFn ( commuterFLId, commuterIdFL ) import Darcs.Patch.Info ( displayPatchInfo, piName ) import Darcs.Patch.Match ( secondMatch, splitSecondFL ) import Darcs.Patch.Merge ( cleanMerge ) import Darcs.Patch.Named ( fmapFL_Named, patchcontents, patch2patchinfo ) import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, hopefully, info, n2pia ) import Darcs.Patch.Prim ( canonizeFL, PrimPatch ) import Darcs.Patch.Rebase.Change ( RebaseChange(RC), rcToPia , extractRebaseChange, reifyRebaseChange , partitionUnconflicted , WithDroppedDeps(..), WDDNamed, commuterIdWDD , simplifyPush, simplifyPushes ) import Darcs.Patch.Rebase.Fixup ( RebaseFixup(..) , commuteNamedFixup , flToNamesPrims ) import Darcs.Patch.Rebase.Name ( RebaseName(..), commuteNameNamed ) import Darcs.Patch.Rebase.Suspended ( Suspended(..), addToEditsToSuspended ) import qualified Darcs.Patch.Rebase.Suspended as S ( simplifyPush ) import Darcs.Patch.Permutations ( genCommuteWhatWeCanFL, partitionConflictingFL ) import Darcs.Patch.Progress ( progressRL ) import Darcs.Patch.Set ( PatchSet, Origin, patchSet2RL ) import Darcs.Patch.Split ( primSplitter ) import Darcs.UI.ApplyPatches ( PatchApplier(..) , PatchProxy(..) , applyPatchesStart , applyPatchesFinish ) import Darcs.UI.External ( viewDocWith ) import Darcs.UI.PrintPatch ( printContent , printContentWithPager , printFriendly , printSummary ) import Darcs.UI.Prompt ( PromptChoice(..), PromptConfig(..), runPrompt ) import Darcs.UI.SelectChanges ( runSelection, runInvertibleSelection , selectionConfig, selectionConfigGeneric, selectionConfigPrim , WhichChanges(First, Last, LastReversed) , viewChanges ) import qualified Darcs.UI.SelectChanges as S ( PatchSelectionOptions (..) ) import Darcs.Patch.Witnesses.Eq ( EqCheck(..) ) import Darcs.Patch.Witnesses.Ordered ( FL(..), (+>+), mapFL_FL , concatFL, mapFL, nullFL, lengthFL, reverseFL , (:>)(..) , (:\/:)(..) , (:/\:)(..) , RL(..), reverseRL, mapRL_RL , Fork(..) , (+>>+) ) import Darcs.Patch.Witnesses.Sealed ( Sealed(..), seal, unseal , Sealed2(..) ) import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP ) import Darcs.Util.English ( englishNum, Noun(Noun) ) import Darcs.Util.Printer ( text, redText , putDocLnWith, prefix , simplePrinters , formatWords , formatText , vcat , ($+$), ($$) ) import Darcs.Util.Printer.Color ( fancyPrinters ) import Darcs.Util.Progress ( debugMessage ) import Darcs.Util.Prompt ( promptYorn ) import Darcs.Util.Path ( AbsolutePath ) import Darcs.Util.SignalHandler ( withSignalsBlocked ) import Darcs.Util.Tree ( Tree ) import Control.Exception ( throwIO, try ) import Control.Monad ( unless, when, void ) import Control.Monad.Trans ( liftIO ) import System.Exit ( ExitCode(ExitSuccess), exitSuccess ) rebase :: DarcsCommand rebase = SuperCommand { commandProgramName = "darcs" , commandName = "rebase" , commandHelp = rebaseHelp , commandDescription = rebaseDescription , commandPrereq = amInHashedRepository , commandSubCommands = [ normalCommand pull , normalCommand apply , normalCommand suspend , normalCommand unsuspend , normalCommand edit , hiddenCommand reify , hiddenCommand inject , normalCommand obliterate , normalCommand log , hiddenCommand changes , normalCommand upgrade ] } where rebaseDescription = "Edit several patches at once." rebaseHelp = formatText 80 [ "The `darcs rebase' command is used to edit a collection of darcs patches." , "The basic idea is that you can suspend patches from the end of\ \ a repository. These patches are no longer part of the history and\ \ have no effect on the working tree. Suspended patches are invisible\ \ to commands that access the repository from the outside, such as\ \ push, pull, clone, send, etc." , "The sequence of suspended patches can be manipulated in ways that are\ \ not allowed for normal patches. For instance, `darcs rebase obliterate`\ \ allows you to remove a patch in this sequence, even if other suspended\ \ patches depend on it. These other patches will as a result become\ \ conflicted." , "You can also operate on the normal patches in the usual way. If you add\ \ or remove normal patches, the suspended patches will be automatically\ \ adapted to still apply to the pristine state, possibly becoming\ \ conflicted in the course." , "Note that as soon as a patch gets suspended, it will irrevocably loose\ \ its identity. This means that suspending a patch is subject to the\ \ usual warnings about editing the history of your project." , "The opposite of suspending a patch is to unsuspend it.\ \ This turns it back into a normal patch.\ \ If the patch is conflicted as a result of previous operations on\ \ either the normal patches or the suspended patches, unsuspending\ \ will create appropriate conflict markup. Note, however, that the\ \ unsuspended patch itself WILL NOT BE CONFLICTED itself. This means\ \ that there is no way to re-generate the conflict markup. Once you\ \ removed it, by editing files or using `darcs revert`, any information\ \ about the conflict is lost." , "As long as you have suspended patches, darcs will display a short\ \ message after each command to remind you that your patch editing\ \ operation is still in progress." ] suspend :: DarcsCommand suspend = DarcsCommand { commandProgramName = "darcs" , commandName = "suspend" , commandHelp = text suspendDescription $+$ historyEditHelp , commandDescription = suspendDescription , commandPrereq = amInHashedRepository , commandExtraArgs = 0 , commandExtraArgHelp = [] , commandCommand = suspendCmd , commandCompleteArgs = noArgs , commandArgdefaults = nodefaults , commandOptions = suspendOpts } where suspendBasicOpts = O.notInRemote ^ O.matchSeveralOrLast ^ O.selectDeps ^ O.interactive ^ O.withSummary ^ O.diffAlgorithm suspendAdvancedOpts = O.changesReverse ^ O.umask suspendOpts = suspendBasicOpts `withStdOpts` suspendAdvancedOpts suspendDescription = "Select patches to move into a suspended state at the end of the repo." suspendCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () suspendCmd _ opts _args = withRepoLock (useCache ? opts) (umask ? opts) $ RepoJob $ \_repository -> do suspended <- readTentativeRebase _repository (_ :> candidates) <- preselectPatches opts _repository let direction = if changesReverse ? opts then Last else LastReversed selection_config = selectionConfig direction "suspend" (patchSelOpts True opts) Nothing Nothing (_ :> psToSuspend) <- runSelection candidates selection_config when (nullFL psToSuspend) $ do putStrLn "No patches selected!" exitSuccess -- test all patches for hijacking and abort if rejected runHijackT RequestHijackPermission $ mapM_ (getAuthor "suspend" False Nothing) $ mapFL info psToSuspend (_repository, Sealed toWorking) <- doSuspend "suspend" opts _repository suspended psToSuspend withSignalsBlocked $ do void $ finalizeRepositoryChanges _repository (O.dryRun ? opts) unless (O.yes (O.dryRun ? opts)) $ void $ applyToWorking _repository (verbosity ? opts) toWorking doSuspend :: (RepoPatch p, ApplyState p ~ Tree) => String -> [DarcsFlag] -> Repository 'RW p wU wR -> Suspended p wR -> FL (PatchInfoAnd p) wX wR -> IO (Repository 'RW p wU wX, Sealed (FL (PrimOf p) wU)) doSuspend cmdname opts _repository suspended to_suspend = do unrecorded <- unrecordedChanges (diffingOpts opts) _repository Nothing case genCommuteWhatWeCanFL (commuterFLId commute) (effect to_suspend :> unrecorded) of unrecorded' :> to_suspend_after_unrecorded :> to_revert -> do effect_to_suspend <- case to_revert of NilFL -> return to_suspend_after_unrecorded _ -> if isInteractive True opts then do putStrLn $ "These unrecorded changes conflict with the " ++ cmdname ++ ":" printFriendly O.Verbose O.NoSummary to_revert yes <- promptYorn "Do you want to revert these changes?" if yes then return $ to_suspend_after_unrecorded +>+ to_revert else do putStrLn $ "Okay, " ++ cmdname ++ " cancelled." exitSuccess else fail $ "Can't suspend these patches without reverting some unrecorded changes." _repository <- tentativelyRemovePatches _repository NoUpdatePending to_suspend -- rely on sifting to commute out prims not belonging in pending: setTentativePending _repository unrecorded' new_suspended <- addToEditsToSuspended (O.diffAlgorithm ? opts) (mapFL_FL hopefully to_suspend) suspended writeTentativeRebase _repository new_suspended return (_repository, Sealed (invert effect_to_suspend)) unsuspend :: DarcsCommand unsuspend = DarcsCommand { commandProgramName = "darcs" , commandName = "unsuspend" , commandHelp = text unsuspendDescription , commandDescription = unsuspendDescription , commandPrereq = amInHashedRepository , commandExtraArgs = 0 , commandExtraArgHelp = [] , commandCommand = unsuspendCmd "unsuspend" False , commandCompleteArgs = noArgs , commandArgdefaults = nodefaults , commandOptions = unsuspendOpts } where unsuspendBasicOpts = O.conflictsYes ^ O.matchSeveralOrFirst ^ O.interactive ^ O.withSummary ^ O.author ^ O.selectAuthor ^ O.patchname ^ O.askDeps ^ O.askLongComment ^ O.keepDate ^ O.diffAlgorithm unsuspendOpts = unsuspendBasicOpts `withStdOpts` oid unsuspendDescription = "Select suspended patches to restore to the end of the repo." reify :: DarcsCommand reify = DarcsCommand { commandProgramName = "darcs" , commandName = "reify" , commandHelp = text reifyDescription , commandDescription = reifyDescription , commandPrereq = amInHashedRepository , commandExtraArgs = 0 , commandExtraArgHelp = [] , commandCommand = unsuspendCmd "reify" True , commandCompleteArgs = noArgs , commandArgdefaults = nodefaults , commandOptions = reifyOpts } where reifyBasicOpts = O.matchSeveralOrFirst ^ O.interactive ^ O.withSummary ^ O.keepDate ^ O.author ^ O.diffAlgorithm reifyOpts = reifyBasicOpts `withStdOpts` O.umask reifyDescription = "Select suspended patches to restore to the end of the repo,\ \ reifying any fixup patches." unsuspendCmd :: String -> Bool -> (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () unsuspendCmd cmd reifyFixups _ opts _args = withRepoLock (useCache ? opts) (umask ? opts) $ RepoJob $ \_repository -> do checkHasRebase _repository Items suspended <- readTentativeRebase _repository let matchFlags = O.matchSeveralOrFirst ? opts inRange :> outOfRange <- return $ if secondMatch matchFlags then splitSecondFL rcToPia matchFlags suspended else suspended :> NilFL offer :> dontoffer <- return $ case O.conflictsYes ? opts of Nothing -> partitionUnconflicted inRange -- skip conflicts Just _ -> inRange :> NilRL let warnSkip NilRL = return () warnSkip _ = putStrLn "Skipping some patches which would cause conflicts." warnSkip dontoffer let selection_config = selectionConfigGeneric rcToPia First cmd (patchSelOpts True opts) Nothing (chosen :> keep) <- runSelection offer selection_config when (nullFL chosen) $ do putStrLn "No patches selected!" exitSuccess ps_to_unsuspend :> chosen_fixups <- if reifyFixups then do author <- Flags.getAuthor (O.author ? opts) False reifyRebaseChange author chosen else return $ extractRebaseChange (diffAlgorithm ? opts) chosen let ps_to_keep = simplifyPushes da chosen_fixups $ keep +>+ reverseRL dontoffer +>+ outOfRange context <- readPatches _repository let conflicts = rebaseResolution (patchSet2RL context) $ progressRL "Examining patches for conflicts" $ mapRL_RL wddPatch $ reverseFL ps_to_unsuspend have_conflicts <- announceConflicts cmd (allowConflicts opts) conflicts debugMessage "Working out conflict markup..." Sealed resolution <- if have_conflicts then case O.conflictsYes ? opts of Just (YesAllowConflicts (ExternalMerge _)) -> error $ "external resolution for "++cmd++" not implemented yet" Just (YesAllowConflicts NoResolveConflicts) -> return $ seal NilFL Just (YesAllowConflicts MarkConflicts) -> return $ mangled conflicts Just NoAllowConflicts -> error "impossible" -- was handled in announceConflicts Nothing -> error "impossible" else return $ seal NilFL unrec <- unrecordedChanges (diffingOpts opts) _repository Nothing -- TODO should catch logfiles (fst value from updatePatchHeader) and -- clean them up as in AmendRecord -- Note: we can allow hijack attempts here without warning the user -- because we already asked about that on suspend time (unsuspended_ps, ps_to_keep') <- runHijackT IgnoreHijack $ handleUnsuspend ps_to_unsuspend (unseal Items ps_to_keep) _repository <- tentativelyAddPatches _repository NoUpdatePending unsuspended_ps let effect_unsuspended = concatFL (mapFL_FL effect unsuspended_ps) case cleanMerge (effect_unsuspended :\/: unrec) of Nothing -> fail $ "Can't "++cmd++" because there are conflicting unrecorded changes." Just (unrec' :/\: effect_unsuspended') -> case cleanMerge (resolution :\/: unrec') of Nothing -> fail $ "Can't "++cmd++" because there are conflicting unrecorded changes." Just (unrec'' :/\: resolution') -> do let effect_to_apply = effect_unsuspended' +>+ resolution' setTentativePending _repository (resolution +>+ unrec'') writeTentativeRebase _repository ps_to_keep' withSignalsBlocked $ do _repository <- finalizeRepositoryChanges _repository (O.dryRun ? opts) unless (O.yes (O.dryRun ? opts)) $ void $ applyToWorking _repository (verbosity ? opts) effect_to_apply where da = diffAlgorithm ? opts handleUnsuspend :: forall p wR wT. (RepoPatch p, ApplyState p ~ Tree) => FL (WDDNamed p) wR wT -> Suspended p wT -> HijackT IO (FL (PatchInfoAnd p) wR wT, Suspended p wT) handleUnsuspend NilFL to_keep = return (NilFL, to_keep) handleUnsuspend (p :>: ps) to_keep = do case wddDependedOn p of [] -> return () deps -> liftIO $ do -- It might make sense to only print out this message -- once, but we might find that the dropped dependencies -- are interspersed with other output, e.g. if running -- with --ask-deps let indent n = prefix (replicate n ' ') putDocLnWith fancyPrinters $ redText ("Dropping the following explicit " ++ englishNum (length deps) (Noun "dependency") ":") $$ displayPatchInfo (patch2patchinfo (wddPatch p)) $$ indent 1 (redText "depended on:") $$ indent 2 (vcat (map displayPatchInfo deps)) -- TODO should catch logfiles (fst value from updatePatchHeader) -- and clean them up as in AmendRecord -- TODO should also ask user to supply explicit dependencies as -- replacements for those that have been lost (if any, see above) p' <- snd <$> updatePatchHeader @p cmd NoAskAboutDeps (patchSelOpts True opts) (patchHeaderConfig opts) (fmapFL_Named effect (wddPatch p)) NilFL -- Create a rename that undoes the change we just made, so that the -- context of patch names match up in the following sequence. We don't -- track patch names properly in witnesses yet and so the rename appears -- to have a null effect on the context. -- p' :: WDDNamed p wR wR2 -- rename :: RebaseName wR2 wR2 -- ps :: FL (WDDNamed p) wR2 wT let rename :: RebaseName wR2 wR2 rename = Rename (info p') (patch2patchinfo (wddPatch p)) -- push it through the remaining patches to fix them up, which should leave -- us with -- p' :: WDDNamed p wR wR2 -- ps2 :: FL (WDDNamed p) wR2 wT2 -- rename2 :: RebaseName wT2 wT2 Just (ps2 :> (rename2 :: RebaseName wT2 wT2')) <- return $ commuterIdFL (commuterIdWDD commuteNameNamed) (rename :> ps) -- However the commute operation loses the information that the rename2 has -- a null effect on the context so we have to assert it manually. IsEq <- return (unsafeCoerceP IsEq :: EqCheck wT2 wT2') to_keep' <- return $ S.simplifyPush da (NameFixup rename2) to_keep (converted, to_keep'') <- handleUnsuspend ps2 to_keep' return (p' :>: converted, to_keep'') inject :: DarcsCommand inject = DarcsCommand { commandProgramName = "darcs" , commandName = "inject" , commandHelp = text injectDescription , commandDescription = injectDescription , commandPrereq = amInHashedRepository , commandExtraArgs = 0 , commandExtraArgHelp = [] , commandCommand = injectCmd , commandCompleteArgs = noArgs , commandArgdefaults = nodefaults , commandOptions = injectOpts } where injectBasicOpts = O.keepDate ^ O.author ^ O.diffAlgorithm injectOpts = injectBasicOpts `withStdOpts` O.umask injectDescription = "Merge a change from the fixups of a patch into the patch itself." injectCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () injectCmd _ opts _args = withRepoLock (useCache ? opts) (umask ? opts) $ RepoJob $ \(_repository :: Repository 'RW p wU wR) -> do checkHasRebase _repository Items selects <- readTentativeRebase _repository -- TODO this selection doesn't need to respect dependencies -- TODO we only want to select one patch: generalise withSelectedPatchFromList let selection_config = selectionConfigGeneric rcToPia First "inject into" (patchSelOpts True opts) Nothing (to_inject :> keep) <- runSelection selects selection_config let extractSingle :: FL (RebaseChange prim) wX wY -> RebaseChange prim wX wY extractSingle (rc :>: NilFL) = rc extractSingle _ = error "You must select precisely one patch!" rc <- return $ extractSingle to_inject Sealed new <- injectOne opts rc keep writeTentativeRebase _repository $ Items new void $ finalizeRepositoryChanges _repository (O.dryRun ? opts) -- | Inject fixups into a 'RebaseChange' and update the remainder of the rebase -- state. This is in 'IO' because it involves interactive selection of the -- fixups to inject. -- TODO: We currently offer only prim fixups, not name fixups, for injection. I -- think it would make sense to extend this to name fixups, so the user can -- explicitly resolve a lost dependency in cases where is clear that it won't -- re-appear. injectOne :: (PrimPatch prim, ApplyState prim ~ Tree) => [DarcsFlag] -> RebaseChange prim wX wY -> FL (RebaseChange prim) wY wZ -> IO (Sealed (FL (RebaseChange prim) wX)) injectOne opts (RC fixups toedit) rest_suspended = do name_fixups :> prim_fixups <- return $ flToNamesPrims fixups let prim_selection_config = selectionConfigPrim Last "inject" (patchSelOpts True opts) (Just (primSplitter (diffAlgorithm ? opts))) Nothing (rest_fixups :> injects) <- runInvertibleSelection prim_fixups prim_selection_config let da = diffAlgorithm ? opts toeditNew = fmapFL_Named (canonizeFL da . (injects +>+)) toedit return $ unseal (simplifyPushes da (mapFL_FL NameFixup name_fixups)) $ simplifyPushes da (mapFL_FL PrimFixup rest_fixups) $ RC NilFL toeditNew :>: rest_suspended obliterate :: DarcsCommand obliterate = DarcsCommand { commandProgramName = "darcs" , commandName = "obliterate" , commandHelp = text obliterateDescription , commandDescription = obliterateDescription , commandPrereq = amInHashedRepository , commandExtraArgs = 0 , commandExtraArgHelp = [] , commandCommand = obliterateCmd , commandCompleteArgs = noArgs , commandArgdefaults = nodefaults , commandOptions = obliterateOpts } where obliterateBasicOpts = O.diffAlgorithm obliterateOpts = obliterateBasicOpts `withStdOpts` O.umask obliterateDescription = "Obliterate a patch that is currently suspended." obliterateCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () obliterateCmd _ opts _args = withRepoLock (useCache ? opts) (umask ? opts) $ RepoJob $ \_repository -> do checkHasRebase _repository Items selects <- readTentativeRebase _repository -- TODO this selection doesn't need to respect dependencies let selection_config = selectionConfigGeneric rcToPia First "obliterate" (obliteratePatchSelOpts opts) Nothing (chosen :> keep) <- runSelection selects selection_config when (nullFL chosen) $ do putStrLn "No patches selected!" exitSuccess let ps_to_keep = foldSealedFL (obliterateOne (diffAlgorithm ? opts)) chosen (Sealed keep) writeTentativeRebase _repository (unseal Items ps_to_keep) void $ finalizeRepositoryChanges _repository (O.dryRun ? opts) -- TODO: move to Darcs.Patch.Witnesses.Ordered ? -- | Map a cons-like operation that may change the end state over an 'FL'. -- Unfortunately this can't be generalized to 'foldrwFL', even though it has -- exactly the same definition, because 'Sealed' doesn't have the right kind. -- We could play with a newtype wrapper to fix this but the ensuing wrapping -- and unwrapping would hardly make it clearer what's going on. foldSealedFL :: (forall wA wB . p wA wB -> Sealed (q wB) -> Sealed (q wA)) -> FL p wX wY -> Sealed (q wY) -> Sealed (q wX) -- kind error: foldSealedFL = foldrwFL foldSealedFL _ NilFL acc = acc foldSealedFL f (p :>: ps) acc = f p (foldSealedFL f ps acc) obliterateOne :: PrimPatch prim => O.DiffAlgorithm -> RebaseChange prim wX wY -> Sealed (FL (RebaseChange prim) wY) -> Sealed (FL (RebaseChange prim) wX) obliterateOne da (RC fs e) = unseal (simplifyPushes da fs) . -- since Named doesn't have any witness context for the -- patch names, the AddName here will be inferred to be wX wX unseal (simplifyPush da (NameFixup (AddName (patch2patchinfo e)))) . unseal (simplifyPushes da (mapFL_FL PrimFixup (patchcontents e))) edit :: DarcsCommand edit = DarcsCommand { commandProgramName = "darcs" , commandName = "edit" , commandHelp = text description , commandDescription = description , commandPrereq = amInHashedRepository , commandExtraArgs = 0 , commandExtraArgHelp = [] , commandCommand = editCmd , commandCompleteArgs = noArgs , commandArgdefaults = nodefaults , commandOptions = opts } where basicOpts = O.diffAlgorithm ^ O.withSummary opts = basicOpts `withStdOpts` O.umask description = "Edit suspended patches." data EditState prim wX = EditState { count :: Int , index :: Int , patches :: Sealed ((RL (RebaseChange prim) :> FL (RebaseChange prim)) wX) } data Edit prim wX = Edit { eWhat :: String , eState :: EditState prim wX } editCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () editCmd _ opts _args = withRepoLock (useCache ? opts) (umask ? opts) $ RepoJob $ \_repository -> do checkHasRebase _repository Items items <- readTentativeRebase _repository let initial_state = EditState { count = lengthFL items , index = 0 , patches = Sealed (NilRL :> items) } Sealed items' <- interactiveEdit opts [] initial_state [] writeTentativeRebase _repository (Items items') void $ finalizeRepositoryChanges _repository (O.dryRun ? opts) interactiveEdit :: (PrimPatch prim, ApplyState prim ~ Tree) => [DarcsFlag] -> [Edit prim wR] -- ^ stack of undone edits, for redo -> EditState prim wR -- ^ current state -> [Edit prim wR] -- ^ stack of past edits, for undo -> IO (Sealed (FL (RebaseChange prim) wR)) interactiveEdit opts redos s@EditState{..} undos = -- invariants: -- * the "todo" patches are empty only if the "done" patches are; formally: -- case patches of Sealed (done :> todo) -> nullFL todo ==> nullRL done case patches of Sealed (_ :> NilFL) -> prompt Sealed (_ :> p :>: _) -> defaultPrintFriendly p >> prompt where da = diffAlgorithm ? opts -- helper functions defaultPrintFriendly = liftIO . printFriendly (O.verbosity ? opts) (O.withSummary ? opts) -- common actions undo = case undos of [] -> error "impossible" e : undos' -> -- pop last state from undos, push current state onto redos interactiveEdit opts (Edit (eWhat e) s : redos) (eState e) undos' redo = case redos of [] -> error "impossible" e : redos' -> -- pop last state from redos, push current state onto undos interactiveEdit opts redos' (eState e) (Edit (eWhat e) s : undos) quit = do putInfo opts $ text "Okay, rebase edit cancelled." exitSuccess commit = case patches of Sealed (done :> todo) -> return $ Sealed (done +>>+ todo) list = mapM_ (putStrLn . eWhat) (reverse undos) >> prompt choicesCommon = [ PromptChoice 'q' True quit "quit, discard all edits" , PromptChoice 'd' True commit "done editing, commit" , PromptChoice 'l' True list "list edits made so far" , PromptChoice 'u' (not (null undos)) undo "undo previous edit" , PromptChoice 'r' (not (null redos)) redo "redo previously undone edit" ] prompt = case patches of Sealed (_ :> NilFL) -> -- empty rebase state runPrompt PromptConfig { pPrompt = "No more suspended patches. What shall I do?" , pVerb = "rebase edit" , pChoices = [choicesCommon] , pDefault = Nothing } Sealed (done :> todo@(p :>: todo')) -> -- non-empty rebase state runPrompt PromptConfig { pPrompt = "What shall I do with this patch? " ++ "(" ++ show (index + 1) ++ "/" ++ show count ++ ")" , pVerb = "rebase edit" , pChoices = [choicesEdit, choicesCommon, choicesView, choicesNav] , pDefault = Nothing } where choicesEdit = [ PromptChoice 'o' True dropit "drop (obliterate, dissolve into fixups)" , PromptChoice 'e' True reword "edit name and/or long comment (log)" , PromptChoice 's' (index > 0) squash "squash with previous patch" , PromptChoice 'i' can_inject inject' "inject fixups" -- TODO -- , PromptChoice 'c' True ??? "select individual changes for editing" ] choicesView = [ PromptChoice 'v' True view "view this patch in full" , PromptChoice 'p' True pager "view this patch in full with pager" , PromptChoice 'y' True display "view this patch" , PromptChoice 'x' can_summarize summary "view a summary of this patch" ] choicesNav = [ PromptChoice 'n' (index + 1 < count) next "skip to next patch" , PromptChoice 'k' (index > 0) prev "back up to previous patch" , PromptChoice 'g' (index > 0) first "start over from the first patch" ] -- helper functions edit' op s' = do let what = case p of RC _ np -> op ++ " " ++ piName (patch2patchinfo np) -- set new state s' and push the current one onto the undo stack -- discarding the redo stack interactiveEdit opts [] s' (Edit what s : undos) navigate s' = -- set new state s' with no undo or redo stack modification interactiveEdit opts redos s' undos can_summarize = not (O.yes (O.withSummary ? opts)) can_inject = case p of (RC NilFL _) -> False; _ -> True -- editing dropit = do Sealed todo'' <- return $ obliterateOne da p (Sealed todo') edit' "drop " s { count = count - 1 , patches = Sealed (done :> todo'') } inject' = do result <- try $ injectOne opts p todo' case result of Left ExitSuccess -> prompt Left e -> throwIO e Right (Sealed todo'') -> edit' "inject" s { patches = Sealed (done :> todo'') } reword = do Sealed todo'' <- rewordOne da p todo' edit' "reword" s { patches = Sealed (done :> todo'') } squash = case done of NilRL -> error "impossible" done' :<: q -> case squashOne da q p todo' of Just (Sealed todo'') -> -- this moves back by one so the new squashed patch is -- selected; useful in case you now want to edit the -- comment or look at the result edit' "squash" s { count = count - 1 , index = index - 1 , patches = Sealed (done' :> todo'') } Nothing -> do putStrLn "Failed to commute fixups backward, try inject first." prompt -- viewing view = printContent p >> prompt pager = printContentWithPager p >> prompt display = defaultPrintFriendly p >> prompt summary = printSummary p >> prompt -- navigation next = case todo' of NilFL -> error "impossible" _ -> navigate s { index = index + 1, patches = Sealed (done :<: p :> todo') } prev = case done of NilRL -> error "impossible" done' :<: p' -> navigate s { index = index - 1, patches = Sealed (done' :> p' :>: todo) } first = navigate s { index = 0, patches = Sealed (NilRL :> done +>>+ todo) } -- | Squash second patch with first, updating the rest of the rebase state. -- This can fail if the second patch has fixups that don't commute with the -- contents of the first patch. squashOne :: PrimPatch prim => O.DiffAlgorithm -> RebaseChange prim wX wY -> RebaseChange prim wY wZ -> FL (RebaseChange prim) wZ wW -> Maybe (Sealed (FL (RebaseChange prim) wX)) squashOne da (RC fs1 e1) (RC fs2 e2) rest = do fs2' :> e1' <- commuterIdFL commuteNamedFixup (e1 :> fs2) let e1'' = fmapFL_Named (canonizeFL da . (+>+ patchcontents e2)) e1' e2_name_fixup = NameFixup (AddName (patch2patchinfo e2)) return $ case simplifyPush da e2_name_fixup rest of Sealed rest' -> simplifyPushes da (fs1 +>+ fs2') (RC NilFL e1'' :>: rest') rewordOne :: (PrimPatch prim, ApplyState prim ~ Tree) => O.DiffAlgorithm -> RebaseChange prim wX wY -> FL (RebaseChange prim) wY wZ -> IO (Sealed (FL (RebaseChange prim) wX)) rewordOne da (RC fs e) rest = do e' <- editLog e let rename = NameFixup $ Rename (patch2patchinfo e') (patch2patchinfo e) case simplifyPush da rename rest of Sealed rest' -> return $ Sealed $ RC fs e' :>: rest' pull :: DarcsCommand pull = DarcsCommand { commandProgramName = "darcs" , commandName = "pull" , commandHelp = text pullDescription , commandDescription = pullDescription , commandExtraArgs = -1 , commandExtraArgHelp = ["[REPOSITORY]..."] , commandCommand = pullCmd RebasePatchApplier , commandPrereq = amInHashedRepository , commandCompleteArgs = prefArgs Repos , commandArgdefaults = defaultRepo , commandOptions = pullOpts } where pullBasicOpts = O.matchSeveral ^ O.reorder ^ O.interactive ^ O.conflictsYes ^ O.testChanges ^ O.dryRunXml ^ O.withSummary ^ O.selectDeps ^ O.repoDir ^ O.allowUnrelatedRepos ^ O.diffAlgorithm pullAdvancedOpts = O.repoCombinator ^ O.setScriptsExecutable ^ O.umask ^ O.changesReverse ^ O.remoteDarcs pullOpts = pullBasicOpts `withStdOpts` pullAdvancedOpts pullDescription = "Copy and apply patches from another repository,\ \ suspending any local patches that conflict." stdindefault :: a -> [String] -> IO [String] stdindefault _ [] = return ["-"] stdindefault _ x = return x apply :: DarcsCommand apply = DarcsCommand { commandProgramName = "darcs" , commandName = "apply" , commandHelp = text applyDescription , commandDescription = applyDescription , commandExtraArgs = 1 , commandExtraArgHelp = [""] , commandCommand = applyCmd RebasePatchApplier , commandPrereq = amInHashedRepository , commandCompleteArgs = fileArgs , commandArgdefaults = const stdindefault , commandOptions = applyOpts } where applyBasicOpts = O.verify ^ O.reorder ^ O.interactive ^ O.dryRunXml ^ O.matchSeveral ^ O.repoDir ^ O.diffAlgorithm applyAdvancedOpts = O.setScriptsExecutable ^ O.umask ^ O.changesReverse ^ O.pauseForGui applyOpts = applyBasicOpts `withStdOpts` applyAdvancedOpts applyDescription = "Apply a patch bundle, suspending any local patches that conflict." data RebasePatchApplier = RebasePatchApplier instance PatchApplier RebasePatchApplier where repoJob RebasePatchApplier f = RepoJob (f PatchProxy) applyPatches RebasePatchApplier PatchProxy = applyPatchesForRebaseCmd applyPatchesForRebaseCmd :: forall p wR wU wZ . ( RepoPatch p, ApplyState p ~ Tree ) => String -> [DarcsFlag] -> Repository 'RW p wU wR -> Fork (PatchSet p) (FL (PatchInfoAnd p)) (FL (PatchInfoAnd p)) Origin wR wZ -> IO () applyPatchesForRebaseCmd cmdName opts _repository (Fork common us' to_be_applied) = do applyPatchesStart cmdName opts to_be_applied usOk :> usConflicted <- return $ partitionConflictingFL us' to_be_applied when (lengthFL usConflicted > 0) $ putInfo opts $ text "The following local patches are in conflict:" -- TODO: we assume the options apply only to the main -- command, review if there are any we should keep let selection_config = selectionConfig LastReversed "suspend" applyPatchSelOpts Nothing Nothing (usKeep :> usToSuspend) <- runSelection usConflicted selection_config -- test all patches for hijacking and abort if rejected runHijackT RequestHijackPermission $ mapM_ (getAuthor "suspend" False Nothing) $ mapFL info usToSuspend suspended <- readTentativeRebase _repository (_repository, Sealed toWorking) <- doSuspend cmdName opts _repository suspended usToSuspend -- the new rebase patch containing the suspended patches is now in the repo -- and the suspended patches have been removed -- We must apply the suspend to working because tentativelyMergePatches -- calls unrecordedChanges. We also have to update the index, since that is -- used to filter the working tree (unless --ignore-times is in effect). updateIndex _repository _repository <- withSignalsBlocked $ do applyToWorking _repository (verbosity ? opts) toWorking Sealed pw <- tentativelyMergePatches _repository cmdName (allowConflicts opts) (wantGuiPause opts) (reorder ? opts) (diffingOpts opts) (Fork common (usOk +>+ usKeep) to_be_applied) applyPatchesFinish cmdName opts _repository pw (nullFL to_be_applied) applyPatchSelOpts :: S.PatchSelectionOptions applyPatchSelOpts = S.PatchSelectionOptions { S.verbosity = O.NormalVerbosity , S.matchFlags = [] , S.interactive = True , S.selectDeps = O.PromptDeps -- option not supported, use default , S.withSummary = O.NoSummary } obliteratePatchSelOpts :: [DarcsFlag] -> S.PatchSelectionOptions obliteratePatchSelOpts opts = (patchSelOpts True opts) { S.selectDeps = O.NoDeps } patchSelOpts :: Bool -> [DarcsFlag] -> S.PatchSelectionOptions patchSelOpts defInteractive flags = S.PatchSelectionOptions { S.verbosity = verbosity ? flags , S.matchFlags = O.matchSeveralOrLast ? flags , S.interactive = isInteractive defInteractive flags , S.selectDeps = selectDeps ? flags , S.withSummary = O.withSummary ? flags } log :: DarcsCommand log = DarcsCommand { commandProgramName = "darcs" , commandName = "log" , commandHelp = text logDescription , commandDescription = logDescription , commandPrereq = amInHashedRepository , commandExtraArgs = 0 , commandExtraArgHelp = [] , commandCommand = logCmd , commandCompleteArgs = noArgs , commandArgdefaults = nodefaults , commandOptions = logOpts } where logBasicOpts = O.withSummary ^ O.interactive -- False logAdvancedOpts = oid logOpts = logBasicOpts `withStdOpts` logAdvancedOpts logDescription = "List the currently suspended changes." logCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () logCmd _ opts _files = withRepository (useCache ? opts) $ RepoJob $ \_repository -> do checkHasRebase _repository Items ps <- readRebase _repository let psToShow = mapFL_FL n2pia ps if isInteractive False opts then viewChanges (patchSelOpts False opts) (mapFL Sealed2 psToShow) else do debugMessage "About to print the changes..." let printers = if hasXmlOutput opts then simplePrinters else fancyPrinters let logDoc = changelog opts (reverseFL psToShow) (logInfoFL psToShow) viewDocWith printers logDoc -- | changes is an alias for log changes :: DarcsCommand changes = commandAlias "changes" Nothing log upgrade :: DarcsCommand upgrade = DarcsCommand { commandProgramName = "darcs" , commandName = "upgrade" , commandHelp = help , commandDescription = desc , commandPrereq = amInHashedRepository , commandExtraArgs = 0 , commandExtraArgHelp = [] , commandCommand = upgradeCmd , commandCompleteArgs = noArgs , commandArgdefaults = nodefaults , commandOptions = opts } where basicOpts = oid opts = basicOpts `withStdOpts` O.umask desc = "Upgrade a repo with an old-style rebase in progress." help = text desc $+$ formatWords [ "Doing this means you won't be able to use darcs version < 2.15" , "with this repository until the rebase is finished." ] upgradeCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () upgradeCmd _ opts _args = withRepoLock (useCache ? opts) (umask ? opts) $ OldRebaseJob $ \repo -> upgradeOldStyleRebase repo {- TODO: - amend-record shows the diff between the conflicted state and the resolution, which is unhelpful - make aggregate commands - argument handling - what should happen to patch comment on unsuspend? - warn about suspending conflicts - indication of expected conflicts on unsuspend - why isn't ! when you do x accurate? - rebase pull/apply should suspend patches such that their order is not changed - amended patches will often be in both the target repo and in the rebase context, detect? - can we be more intelligent about conflict resolutions? - --all option to unsuspend - review other conflict options for unsuspend - darcs check should check integrity of rebase patch - review existence of reify and inject commands - bit of an internals hack -}