darcs-2.18.1: src/Darcs/UI/Commands/Rebase.hs
-- 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 = ["<PATCHFILE>"]
, 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
-}