-- 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, putVerbose , 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 ( fileArgs, prefArgs, noArgs ) import Darcs.UI.Flags ( DarcsFlag , externalMerge, allowConflicts , compress, diffingOpts , dryRun, reorder, verbosity, verbose , useCache, wantGuiPause , umask, changesReverse , diffAlgorithm, isInteractive , selectDeps, hasXmlOutput ) import qualified Darcs.UI.Flags as Flags ( getAuthor ) import Darcs.UI.Options ( (^), oid, odesc, ocheck , defaultFlags, (?) ) import qualified Darcs.UI.Options.All as O import Darcs.UI.PatchHeader ( HijackT, HijackOptions(..), runHijackT , getAuthor , updatePatchHeader, AskAboutDeps(..) ) import Darcs.Repository ( Repository, RepoJob(..), withRepoLock, withRepository , tentativelyAddPatch, finalizeRepositoryChanges , invalidateIndex , tentativelyRemovePatches, readRepo , tentativelyAddToPending, unrecordedChanges, applyToWorking , revertRepositoryChanges ) import Darcs.Repository.Flags ( UpdatePending(..), ExternalMerge(..) ) import Darcs.Repository.Hashed ( upgradeOldStyleRebase ) import Darcs.Repository.Merge ( tentativelyMergePatches ) import Darcs.Repository.Rebase ( readRebase , readTentativeRebase , writeTentativeRebase ) import Darcs.Repository.Resolution ( StandardResolution(..) , standardResolution , announceConflicts ) import Darcs.Patch ( invert, effect, commute, RepoPatch, displayPatch ) import Darcs.Patch.Apply ( ApplyState ) import Darcs.Patch.CommuteFn ( commuterIdFL ) import Darcs.Patch.Info ( displayPatchInfo ) import Darcs.Patch.Match ( secondMatch, splitSecondFL ) import Darcs.Patch.Named ( 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 , toRebaseChanges , simplifyPush, simplifyPushes ) import Darcs.Patch.Rebase.Fixup ( RebaseFixup(..), flToNamesPrims ) import Darcs.Patch.Rebase.Name ( RebaseName(..), commuteNameNamed ) import Darcs.Patch.Rebase.Suspended ( Suspended(..), addToEditsToSuspended ) import Darcs.Patch.Permutations ( partitionConflictingFL ) import Darcs.Patch.Progress ( progressRL ) import Darcs.Patch.RepoType ( RepoType(..), RebaseType(..) ) 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.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 , FlippedSeal(..) , Sealed2(..) ) import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP ) import Darcs.Util.English ( englishNum, Noun(Noun) ) import Darcs.Util.Printer ( text, ($$), redText , simplePrinters , renderString , formatWords , formatText , ($+$) ) import Darcs.Util.Printer.Color ( fancyPrinters ) import Darcs.Util.Progress ( debugMessage ) import Darcs.Util.Path ( AbsolutePath ) import Darcs.Util.SignalHandler ( withSignalsBlocked ) import Darcs.Util.Tree ( Tree ) import Darcs.Util.Exception ( die ) import Control.Monad ( when, void ) import Control.Monad.Trans ( liftIO ) import System.Exit ( exitSuccess ) rebase :: DarcsCommand rebase = SuperCommand { commandProgramName = "darcs" , commandName = "rebase" , commandHelp = rebaseHelp , commandDescription = rebaseDescription , commandPrereq = amInHashedRepository , commandSubCommands = [ normalCommand pull , normalCommand apply , normalCommand suspend , normalCommand unsuspend , 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 , commandAdvancedOptions = odesc suspendAdvancedOpts , commandBasicOptions = odesc suspendBasicOpts , commandDefaults = defaultFlags suspendOpts , commandCheckOptions = ocheck suspendOpts } where suspendBasicOpts = O.notInRemote ^ O.matchSeveralOrLast ^ O.selectDeps ^ O.interactive ^ O.withSummary ^ O.diffAlgorithm suspendAdvancedOpts = O.changesReverse ^ O.useIndex ^ 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 (dryRun ? opts) (useCache ? opts) YesUpdatePending (umask ? opts) $ StartRebaseJob $ \_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 <- doSuspend opts _repository suspended psToSuspend _repository <- finalizeRepositoryChanges _repository YesUpdatePending (compress ? opts) return () doSuspend :: forall p wR wU wX . (RepoPatch p, ApplyState p ~ Tree) => [DarcsFlag] -> Repository ('RepoType 'IsRebase) p wR wU wR -> Suspended p wR wR -> FL (PatchInfoAnd ('RepoType 'IsRebase) p) wX wR -> IO (Repository ('RepoType 'IsRebase) p wR wU wX) doSuspend opts _repository suspended psToSuspend = do let (_, _, da) = diffingOpts opts pend <- unrecordedChanges (diffingOpts opts) O.NoLookForMoves O.NoLookForReplaces _repository Nothing FlippedSeal psAfterPending <- let effectPsToSuspend = effect psToSuspend in case commute (effectPsToSuspend :> pend) of Just (_ :> res) -> return (FlippedSeal res) Nothing -> do putVerbose opts $ let invPsEffect = invert effectPsToSuspend in case (partitionConflictingFL invPsEffect pend, partitionConflictingFL pend invPsEffect) of (_ :> invSuspendedConflicts, _ :> pendConflicts) -> let suspendedConflicts = invert invSuspendedConflicts in redText "These changes in the suspended patches:" $$ displayPatch suspendedConflicts $$ redText "...conflict with these local changes:" $$ displayPatch pendConflicts fail $ "Can't suspend selected patches without reverting some unrecorded change." ++ if (verbose opts) then "" else " Use --verbose to see the details." invalidateIndex _repository _repository <- tentativelyRemovePatches _repository (compress ? opts) YesUpdatePending psToSuspend tentativelyAddToPending _repository $ invert $ effect psToSuspend new_suspended <- addToEditsToSuspended da (mapFL_FL hopefully psToSuspend) suspended writeTentativeRebase _repository new_suspended withSignalsBlocked $ void $ applyToWorking _repository (verbosity ? opts) (invert psAfterPending) return _repository 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 , commandAdvancedOptions = odesc unsuspendAdvancedOpts , commandBasicOptions = odesc unsuspendBasicOpts , commandDefaults = defaultFlags unsuspendOpts , commandCheckOptions = ocheck unsuspendOpts } where unsuspendBasicOpts = O.conflictsYes ^ O.matchSeveralOrFirst ^ O.interactive ^ O.withSummary ^ O.externalMerge ^ O.keepDate ^ O.author ^ O.diffAlgorithm unsuspendAdvancedOpts = O.useIndex unsuspendOpts = unsuspendBasicOpts `withStdOpts` unsuspendAdvancedOpts 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 , commandAdvancedOptions = [] , commandBasicOptions = odesc reifyBasicOpts , commandDefaults = defaultFlags reifyOpts , commandCheckOptions = ocheck reifyOpts } where reifyBasicOpts = O.matchSeveralOrFirst ^ O.interactive ^ 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 (dryRun ? opts) (useCache ? opts) YesUpdatePending (umask ? opts) $ RebaseJob $ \_repository -> do IsEq <- requireNoUnrecordedChanges _repository Items selects <- readTentativeRebase _repository let matchFlags = O.matchSeveralOrFirst ? opts inRange :> outOfRange <- return $ if secondMatch matchFlags then splitSecondFL rcToPia matchFlags selects else selects :> 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 "unsuspend" (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 da = diffAlgorithm ? opts ps_to_keep = simplifyPushes da chosen_fixups $ keep +>+ reverseRL dontoffer +>+ outOfRange context <- readRepo _repository let conflicts = standardResolution (patchSet2RL context) $ progressRL "Examining patches for conflicts" $ mapRL_RL (n2pia . wddPatch) $ reverseFL ps_to_unsuspend have_conflicts <- announceConflicts "unsuspend" (allowConflicts opts) (externalMerge ? opts) conflicts Sealed resolved_p <- case (externalMerge ? opts, have_conflicts) of (NoExternalMerge, _) -> case O.conflictsYes ? opts of Just O.YesAllowConflicts -> return $ seal NilFL -- i.e. don't mark them _ -> return $ mangled conflicts (_, False) -> return $ mangled conflicts (YesExternalMerge _, True) -> error "external resolution for unsuspend not implemented yet" let effect_to_apply = concatFL (mapFL_FL effect ps_to_unsuspend) +>+ resolved_p invalidateIndex _repository -- TODO should catch logfiles (fst value from updatePatchHeader) and clean them up as in AmendRecord tentativelyAddToPending _repository effect_to_apply -- we can just let hijack attempts through here because we already asked about them on suspend time (_repository, renames) <- runHijackT IgnoreHijack $ doAdd _repository ps_to_unsuspend case unseal (simplifyPushes da (mapFL_FL NameFixup renames)) ps_to_keep of Sealed new_ps -> writeTentativeRebase _repository (Items new_ps) withSignalsBlocked $ do _repository <- finalizeRepositoryChanges _repository YesUpdatePending (compress ? opts) void $ applyToWorking _repository (verbosity ? opts) effect_to_apply where doAdd :: (RepoPatch p, ApplyState p ~ Tree) => Repository ('RepoType 'IsRebase) p wR wU wT -> FL (WDDNamed p) wT wT2 -> HijackT IO (Repository ('RepoType 'IsRebase) p wR wU wT2, FL RebaseName wT2 wT2) doAdd _repo NilFL = return (_repo, NilFL) doAdd _repo ((p :: WDDNamed p wT wU) :>:ps) = 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 putStr $ "Warning: dropping the following explicit " ++ englishNum (length deps) (Noun "dependency") ":\n\n" let printIndented n = mapM_ (putStrLn . (replicate n ' '++)) . lines . renderString . displayPatchInfo putStrLn . renderString . displayPatchInfo . patch2patchinfo $ wddPatch p putStr " depended on:\n" mapM_ (printIndented 2) deps putStr "\n" -- TODO should catch logfiles (fst value from updatePatchHeader) -- and clean them up as in AmendRecord p' <- snd <$> updatePatchHeader "unsuspend" NoAskAboutDeps (patchSelOpts True opts) (diffAlgorithm ? opts) (O.keepDate ? opts) (O.selectAuthor ? opts) (O.author ? opts) (O.patchname ? opts) (O.askLongComment ? opts) (fmapFL_Named effect (wddPatch p)) NilFL _repo <- liftIO $ tentativelyAddPatch _repo (compress ? opts) (verbosity ? opts) YesUpdatePending p' -- create a rename that undoes the change we just made, so the contexts match up let rename :: RebaseName wU wU rename = Rename (info p') (patch2patchinfo (wddPatch p)) -- push it through the remaining patches to fix them up Just (ps2 :> (rename2 :: RebaseName wV wT2)) <- return (commuterIdFL (commuterIdWDD commuteNameNamed) (rename :> ps)) -- assert that the rename still has a null effect on the context after commuting IsEq <- return (unsafeCoerceP IsEq :: EqCheck wV wT2) (_repo, renames) <- doAdd _repo ps2 -- return the renames so that the suspended patch can be fixed up return (_repo, rename2 :>: renames) requireNoUnrecordedChanges :: (RepoPatch p, ApplyState p ~ Tree) => Repository rt p wR wU wR -> IO (EqCheck wR wU) requireNoUnrecordedChanges repo = do pend <- unrecordedChanges (diffingOpts opts) O.NoLookForMoves O.NoLookForReplaces repo Nothing case pend of NilFL -> return IsEq _ -> die $ "Can't "++cmd++" when there are unrecorded changes." inject :: DarcsCommand inject = DarcsCommand { commandProgramName = "darcs" , commandName = "inject" , commandHelp = text injectDescription , commandDescription = injectDescription , commandPrereq = amInHashedRepository , commandExtraArgs = 0 , commandExtraArgHelp = [] , commandCommand = injectCmd , commandCompleteArgs = noArgs , commandArgdefaults = nodefaults , commandAdvancedOptions = [] , commandBasicOptions = odesc injectBasicOpts , commandDefaults = defaultFlags injectOpts , commandCheckOptions = ocheck 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 (dryRun ? opts) (useCache ? opts) YesUpdatePending (umask ? opts) $ RebaseJob $ \(_repository :: Repository ('RepoType 'IsRebase) p wR wU wR) -> do 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 (chosens :> rest_selects) <- runSelection selects selection_config let extractSingle :: FL (RebaseChange prim) wX wY -> (FL (RebaseFixup prim) :> Named prim) wX wY extractSingle (RC fixups toedit :>: NilFL) = fixups :> toedit extractSingle _ = error "You must select precisely one patch!" fixups :> toedit <- return $ extractSingle chosens name_fixups :> prim_fixups <- return $ flToNamesPrims fixups let prim_selection_config = selectionConfigPrim Last "inject" (patchSelOpts True opts) (Just (primSplitter (diffAlgorithm ? opts))) Nothing Nothing (rest_fixups :> injects) <- runInvertibleSelection prim_fixups prim_selection_config when (nullFL injects) $ do putStrLn "No changes selected!" exitSuccess -- Don't bother to update patch header since unsuspend will do that later let da = diffAlgorithm ? opts toeditNew = fmapFL_Named (canonizeFL da . (injects +>+)) toedit case unseal (simplifyPushes da (mapFL_FL NameFixup name_fixups)) $ simplifyPushes da (mapFL_FL PrimFixup rest_fixups) $ RC NilFL toeditNew :>: rest_selects of Sealed new_ps -> writeTentativeRebase _repository (Items new_ps) _repository <- finalizeRepositoryChanges _repository YesUpdatePending (compress ? opts) return () obliterate :: DarcsCommand obliterate = DarcsCommand { commandProgramName = "darcs" , commandName = "obliterate" , commandHelp = text obliterateDescription , commandDescription = obliterateDescription , commandPrereq = amInHashedRepository , commandExtraArgs = 0 , commandExtraArgHelp = [] , commandCommand = obliterateCmd , commandCompleteArgs = noArgs , commandArgdefaults = nodefaults , commandAdvancedOptions = [] , commandBasicOptions = odesc obliterateBasicOpts , commandDefaults = defaultFlags obliterateOpts , commandCheckOptions = ocheck 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 (dryRun ? opts) (useCache ? opts) YesUpdatePending (umask ? opts) $ RebaseJob $ \(_repository :: Repository ('RepoType 'IsRebase) p wR wU wR) -> (do 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 da = diffAlgorithm ? opts do_obliterate :: PrimPatch prim => FL (RebaseChange prim) wX wY -> FL (RebaseChange prim) wY wZ -> Sealed (FL (RebaseChange prim) wX) do_obliterate NilFL = Sealed do_obliterate (RC fs e :>: qs) = 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))) . do_obliterate qs let ps_to_keep = do_obliterate chosen keep case ps_to_keep of Sealed new_ps -> writeTentativeRebase _repository (Items new_ps) _repository <- finalizeRepositoryChanges _repository YesUpdatePending (compress ? opts) return () ) :: IO () 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 , commandAdvancedOptions = odesc pullAdvancedOpts , commandBasicOptions = odesc pullBasicOpts , commandDefaults = defaultFlags pullOpts , commandCheckOptions = ocheck pullOpts } where pullBasicOpts = O.matchSeveral ^ O.reorder ^ O.interactive ^ O.conflictsYes ^ O.externalMerge ^ O.runTest ^ O.dryRunXml ^ O.withSummary ^ O.selectDeps ^ O.repoDir ^ O.allowUnrelatedRepos ^ O.diffAlgorithm pullAdvancedOpts = O.repoCombinator ^ O.compress ^ O.useIndex ^ O.remoteRepos ^ O.setScriptsExecutable ^ O.umask ^ O.changesReverse ^ O.network 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 , commandAdvancedOptions = odesc applyAdvancedOpts , commandBasicOptions = odesc applyBasicOpts , commandDefaults = defaultFlags applyOpts , commandCheckOptions = ocheck applyOpts } where applyBasicOpts = O.verify ^ O.reorder ^ O.interactive ^ O.dryRunXml ^ O.matchSeveral ^ O.repoDir ^ O.diffAlgorithm applyAdvancedOpts = O.useIndex ^ O.compress ^ 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 type ApplierRepoTypeConstraint RebasePatchApplier rt = rt ~ 'RepoType 'IsRebase repoJob RebasePatchApplier f = StartRebaseJob (f PatchProxy) applyPatches RebasePatchApplier PatchProxy = applyPatchesForRebaseCmd applyPatchesForRebaseCmd :: forall p wR wU wZ . ( RepoPatch p, ApplyState p ~ Tree ) => String -> [DarcsFlag] -> Repository ('RepoType 'IsRebase) p wR wU wR -> Fork (PatchSet ('RepoType 'IsRebase) p) (FL (PatchInfoAnd ('RepoType 'IsRebase) p)) (FL (PatchInfoAnd ('RepoType 'IsRebase) 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 <- doSuspend opts _repository suspended usToSuspend -- the new rebase patch containing the suspended patches is now in the repo -- and the suspended patches have been removed -- TODO This is a nasty hack, caused by the fact that most functions -- in Darcs.Repository.State require the recorded state to be equal to the -- tentative state and thus must not be called after the repo was changed. _repository <- finalizeRepositoryChanges _repository YesUpdatePending (compress ? opts) _repository <- revertRepositoryChanges _repository YesUpdatePending Sealed pw <- tentativelyMergePatches _repository cmdName (allowConflicts opts) (externalMerge ? opts) (wantGuiPause opts) (compress ? opts) (verbosity ? opts) (reorder ? opts) (diffingOpts opts) (Fork common (usOk +>+ usKeep) to_be_applied) invalidateIndex _repository applyPatchesFinish cmdName opts _repository pw (nullFL to_be_applied) -- TODO I doubt this is right, e.g. withContext should be inherited 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 , S.withContext = O.NoContext } 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 , S.withContext = O.NoContext } log :: DarcsCommand log = DarcsCommand { commandProgramName = "darcs" , commandName = "log" , commandHelp = text logDescription , commandDescription = logDescription , commandPrereq = amInHashedRepository , commandExtraArgs = 0 , commandExtraArgHelp = [] , commandCommand = logCmd , commandCompleteArgs = noArgs , commandArgdefaults = nodefaults , commandAdvancedOptions = odesc logAdvancedOpts , commandBasicOptions = odesc logBasicOpts , commandDefaults = defaultFlags logOpts , commandCheckOptions = ocheck 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) $ RebaseJob $ \_repository -> do Items ps <- readRebase _repository let psToShow = toRebaseChanges 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 , commandAdvancedOptions = [] , commandBasicOptions = odesc basicOpts , commandDefaults = defaultFlags opts , commandCheckOptions = ocheck 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 (dryRun ? opts) (useCache ? opts) YesUpdatePending (umask ? opts) $ OldRebaseJob $ \(_repo :: Repository ('RepoType 'IsRebase) p wR wU wR) -> upgradeOldStyleRebase _repo (compress ? opts) {- 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 needs more UI work - automatically answer yes re suspension - offer all patches (so they can be kept in order) - or perhaps rebase suspend --complement? - make unsuspend actually display the patch helpfully like normal selection - 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 - warning message on suspend about not being able to unsuspend with unrecorded changes - aborting during a rebase pull or rebase suspend causes it to leave the repo marked for rebase - patch count: get English right in suspended patch(es) - darcs check should check integrity of rebase patch - review existence of reify and inject commands - bit of an internals hack -}