--  Copyright (C) 2009 Ganesh Sittampalam
--
--  BSD3

{-# LANGUAGE TypeOperators #-}

module Darcs.UI.Commands.Rebase ( rebase ) where

import Prelude ()
import Darcs.Prelude

import Darcs.UI.Commands
    ( DarcsCommand(..), withStdOpts
    , normalCommand, hiddenCommand
    , commandAlias
    , defaultRepo, nodefaults
    , putInfo, putVerbose
    , setEnvDarcsPatches
    , amInHashedRepository
    )
import Darcs.UI.Commands.Util ( printDryRunMessageAndExit )
import Darcs.UI.Commands.Apply ( applyCmd )
import Darcs.UI.Commands.Log ( changelog, getLogInfo )
import Darcs.UI.Commands.Pull ( pullCmd, revertable )
import Darcs.UI.Commands.Unrecord ( getLastPatches, matchingHead )
import Darcs.UI.CommandsAux ( checkPaths )
import Darcs.UI.Completion ( fileArgs, prefArgs, noArgs )
import Darcs.UI.Flags
    ( DarcsFlag
    , externalMerge, allowConflicts
    , compress, diffingOpts
    , dryRun, reorder, verbosity, verbose
    , useCache, wantGuiPause
    , umask, matchAny, changesReverse
    , onlyToFiles
    , diffAlgorithm, maxCount, isInteractive
    , selectDeps, xmlOutput, hasXmlOutput
    )
import Darcs.UI.Options
    ( (^), oid, odesc, ocheck, onormalise
    , defaultFlags, parseFlags, (?)
    )
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
    , RebaseJobFlags(..)
    , tentativelyAddPatch, finalizeRepositoryChanges
    , invalidateIndex
    , tentativelyRemovePatches, readRepo
    , tentativelyAddToPending, unrecordedChanges, applyToWorking
    , revertRepositoryChanges
    , setScriptsExecutablePatches
    )
import Darcs.Repository.Flags ( UpdateWorking(..), ExternalMerge(..) )
import Darcs.Repository.Merge ( tentativelyMergePatches, announceMergeConflicts )
import Darcs.Repository.Resolution ( standardResolution )
import Darcs.Patch ( invert, effect, commute, RepoPatch, description )
import Darcs.Patch.Apply ( ApplyState )
import Darcs.Patch.Commute ( selfCommuter )
import Darcs.Patch.CommuteFn ( commuterIdFL )
import Darcs.Patch.Info ( displayPatchInfo )
import Darcs.Patch.Match ( firstMatch, secondMatch, splitSecondFL )
import Darcs.Patch.Named ( Named, fmapFL_Named, patchcontents, patch2patchinfo )
import Darcs.Patch.Named.Wrapped ( mkRebase, toRebasing, fromRebasing )
import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, info, n2pia, hopefully )
import Darcs.Patch.Prim ( PrimOf, canonizeFL, fromPrim )
import Darcs.Patch.Rebase ( takeHeadRebase, takeHeadRebaseFL )
import Darcs.Patch.Rebase.Container ( Suspended(..) )
import Darcs.Patch.Rebase.Fixup ( RebaseFixup(..), flToNamesPrims )
import Darcs.Patch.Rebase.Item ( RebaseItem(..), simplifyPush, simplifyPushes )
import Darcs.Patch.Rebase.Name ( RebaseName(..), commuteNameNamed )
import Darcs.Patch.Rebase.Viewing
    ( RebaseSelect(RSFwd), rsToPia
    , toRebaseSelect, fromRebaseSelect, extractRebaseSelect, reifyRebaseSelect
    , partitionUnconflicted
    , WithDroppedDeps(..), WDDNamed, commuterIdWDD
    , toRebaseChanges
    )
import Darcs.Patch.Permutations ( partitionConflictingFL )
import Darcs.Patch.Progress ( progressFL )
import Darcs.Patch.RepoType ( RepoType(..), RebaseType(..) )
import Darcs.Patch.Set ( PatchSet(..), appendPSFL )
import Darcs.Patch.Show ( showNicely )
import Darcs.Patch.Split ( primSplitter )
import Darcs.UI.ApplyPatches ( PatchApplier(..), PatchProxy(..) )
import Darcs.UI.SelectChanges
    ( runSelection
    , selectionContext, selectionContextGeneric, selectionContextPrim
    , 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
    , (:>)(..)
    , RL(..), reverseRL
    )
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
    ( vcat, text, ($$), redText
    , putDocLnWith, simplePrinters
    , renderString
    )
import Darcs.Util.Printer.Color ( fancyPrinters )
import Darcs.Util.Progress ( debugMessage )
import Darcs.Util.Path ( AbsolutePath )

import Darcs.Util.Tree ( Tree )

import Control.Exception ( catch, IOException )
import Control.Monad ( when )
import Control.Monad.Trans ( liftIO )
import System.Exit ( exitSuccess )

rebaseDescription :: String
rebaseDescription = "Edit several patches at once."

rebaseHelp :: String
rebaseHelp =
 "The `darcs rebase' command is used to edit a collection of darcs patches.\n"

rebase :: DarcsCommand [DarcsFlag]
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
        ]
    }

suspend :: DarcsCommand [DarcsFlag]
suspend = DarcsCommand
    { commandProgramName = "darcs"
    , commandName = "suspend"
    , commandHelp = "Select patches to move into a suspended state at the end of the repo.\n"
    , commandDescription = "Select patches to move into a suspended state at the end of the repo."
    , commandPrereq = amInHashedRepository
    , commandExtraArgs = 0
    , commandExtraArgHelp = []
    , commandCommand = suspendCmd
    , commandCompleteArgs = noArgs
    , commandArgdefaults = nodefaults
    , commandAdvancedOptions = odesc suspendAdvancedOpts
    , commandBasicOptions = odesc suspendBasicOpts
    , commandDefaults = defaultFlags suspendOpts
    , commandCheckOptions = ocheck suspendOpts
    , commandParseOptions = onormalise suspendOpts
    }
  where
    suspendBasicOpts
      = O.matchSeveralOrLast
      ^ O.selectDeps
      ^ O.interactive
      ^ O.summary
      ^ O.diffAlgorithm
    suspendAdvancedOpts
      = O.changesReverse
      ^ O.useIndex
    suspendOpts = suspendBasicOpts `withStdOpts` suspendAdvancedOpts

suspendCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
suspendCmd _ opts _args =
    withRepoLock (dryRun ? opts) (useCache ? opts) YesUpdateWorking (umask ? opts) $
    StartRebaseJob (RebaseJobFlags (compress ? opts) (verbosity ? opts) YesUpdateWorking) $
    \repository -> do
    allpatches <- readRepo repository
    (rOld, suspended, allpatches_tail) <- return $ takeHeadRebase allpatches
    (_ :> patches) <-
        return $ if firstMatch (parseFlags O.matchSeveralOrLast opts)
                 then getLastPatches (parseFlags O.matchSeveralOrLast opts) allpatches_tail
                 else matchingHead (parseFlags O.matchSeveralOrLast opts) allpatches_tail
    let direction = if changesReverse ? opts then Last else LastReversed
        patches_context = selectionContext direction "suspend" (patchSelOpts True opts) Nothing Nothing
    (_ :> psToSuspend) <-
        runSelection
            patches
            patches_context
    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 rOld psToSuspend
    finalizeRepositoryChanges repository' YesUpdateWorking (compress ? opts)
    return ()

doSuspend
    :: forall p wR wU wT wX
     . (RepoPatch p, ApplyState p ~ Tree)
    => [DarcsFlag]
    -> Repository ('RepoType 'IsRebase) p wR wU wT
    -> Suspended p wT wT
    -> PatchInfoAnd ('RepoType 'IsRebase) p wT wT
    -> FL (PatchInfoAnd ('RepoType 'IsRebase) p) wX wT
    -> IO (Repository ('RepoType 'IsRebase) p wR wU wX)
doSuspend opts repository (Items qs) rOld psToSuspend = do
    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
                        doPartition = partitionConflictingFL (commuterIdFL selfCommuter)
                    in
                    case (doPartition invPsEffect pend, doPartition pend invPsEffect) of
                        (_ :> invSuspendedConflicts, _ :> pendConflicts) ->
                            let suspendedConflicts = invert invSuspendedConflicts in
                            redText "These changes in the suspended patches:" $$
                            showNicely suspendedConflicts $$
                            redText "...conflict with these local changes:" $$
                            showNicely pendConflicts
                fail $ "Can't suspend selected patches without reverting some unrecorded change."
                    ++ if (verbose opts) then "" else " Use --verbose to see the details."


    rNew <- mkRebase (Items (mapFL_FL (ToEdit . fromRebasing . hopefully) psToSuspend +>+ qs))
    invalidateIndex repository
    -- remove the old rebase patch and the patches to suspend
    repository' <- tentativelyRemovePatches repository (compress ? opts) YesUpdateWorking (psToSuspend +>+ (rOld :>: NilFL))
    tentativelyAddToPending repository' YesUpdateWorking $ invert $ effect psToSuspend
    -- add the new rebase patch
    repository'' <- tentativelyAddPatch repository' (compress ? opts) (unVerbose (verbosity ? opts)) YesUpdateWorking (n2pia rNew)
    _ <- applyToWorking repository'' (verbosity ? opts) (invert psAfterPending)
            `catch` \(e :: IOException) -> fail ("Couldn't undo patch in working dir.\n" ++ show e)
    return repository''

-- Certain repository functions will display the rebase patch in verbose mode
-- so we use this function to suppress it when passing the verbosity.
unVerbose :: O.Verbosity -> O.Verbosity
unVerbose O.Verbose = O.NormalVerbosity
unVerbose x = x

unsuspend :: DarcsCommand [DarcsFlag]
unsuspend = DarcsCommand
    { commandProgramName = "darcs"
    , commandName = "unsuspend"
    , commandHelp = "Selected patches to restore from a suspended state to the end of the repo.\n"
    , commandDescription = "Select suspended patches to restore to the end of the repo."
    , commandPrereq = amInHashedRepository
    , commandExtraArgs = 0
    , commandExtraArgHelp = []
    , commandCommand = unsuspendCmd False
    , commandCompleteArgs = noArgs
    , commandArgdefaults = nodefaults
    , commandAdvancedOptions = odesc unsuspendAdvancedOpts
    , commandBasicOptions = odesc unsuspendBasicOpts
    , commandDefaults = defaultFlags unsuspendOpts
    , commandCheckOptions = ocheck unsuspendOpts
    , commandParseOptions = onormalise unsuspendOpts
    }
  where
    unsuspendBasicOpts
      = O.conflictsYes
      ^ O.matchSeveralOrFirst
      ^ O.interactive
      ^ O.summary
      ^ O.externalMerge
      ^ O.keepDate
      ^ O.author
      ^ O.diffAlgorithm
    unsuspendAdvancedOpts = O.useIndex
    unsuspendOpts = unsuspendBasicOpts `withStdOpts` unsuspendAdvancedOpts

reify :: DarcsCommand [DarcsFlag]
reify = DarcsCommand
    { commandProgramName = "darcs"
    , commandName = "reify"
    , commandHelp = "Select suspended patches to restore to the end of the repo, reifying any fixup patches.\n"
    , commandDescription = "Select suspended patches to restore to the end of the repo, reifying any fixup patches."
    , commandPrereq = amInHashedRepository
    , commandExtraArgs = 0
    , commandExtraArgHelp = []
    , commandCommand = unsuspendCmd True
    , commandCompleteArgs = noArgs
    , commandArgdefaults = nodefaults
    , commandAdvancedOptions = []
    , commandBasicOptions = odesc reifyBasicOpts
    , commandDefaults = defaultFlags reifyOpts
    , commandCheckOptions = ocheck reifyOpts
    , commandParseOptions = onormalise reifyOpts
    }
  where
    reifyBasicOpts
      = O.matchSeveralOrFirst
      ^ O.interactive
      ^ O.keepDate
      ^ O.author
      ^ O.diffAlgorithm
    reifyOpts = reifyBasicOpts `withStdOpts` oid

unsuspendCmd :: Bool -> (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
unsuspendCmd reifyFixups _ opts _args =
    withRepoLock (dryRun ? opts) (useCache ? opts) YesUpdateWorking (umask ? opts) $
    RebaseJob (RebaseJobFlags (compress ? opts) (verbosity ? opts) YesUpdateWorking) $
    \(repository :: Repository ('RepoType 'IsRebase) p wR wU wR) -> (do
    patches <- readRepo repository
    pend <- unrecordedChanges (diffingOpts opts)
      O.NoLookForMoves O.NoLookForReplaces
      repository Nothing
    let checkChanges :: FL (PrimOf p) wA wB -> IO (EqCheck wA wB)
        checkChanges NilFL = return IsEq
        checkChanges _ = error "can't unsuspend when there are unrecorded changes"
    IsEq <- checkChanges pend :: IO (EqCheck wR wU)
    (rOld, Items ps, _) <- return $ takeHeadRebase patches

    let selects = toRebaseSelect ps

    let matchFlags = matchAny ? opts
    inRange :> outOfRange <-
        return $
            if secondMatch matchFlags then
            splitSecondFL rsToPia matchFlags selects
            else selects :> NilFL

    offer :> dontoffer <-
        return $
            case O.conflictsYes ? opts of
              Nothing -> partitionUnconflicted inRange -- skip conflicts
              Just _ -> inRange :> NilRL

    let warnSkip :: RL q wX wY -> IO ()
        warnSkip NilRL = return ()
        warnSkip _ = putStrLn "Skipping some patches which would cause conflicts."

    warnSkip dontoffer

    let patches_context = selectionContextGeneric rsToPia First "unsuspend" (patchSelOpts True opts) Nothing
    (chosen :> keep) <- runSelection offer patches_context
    when (nullFL chosen) $ do putStrLn "No patches selected!"
                              exitSuccess

    (ps_to_unsuspend :: FL (WDDNamed p) wR wZ) :> chosen_fixups
           <- (if reifyFixups then reifyRebaseSelect else return . extractRebaseSelect) chosen

    let da = diffAlgorithm ? opts
        ps_to_keep = simplifyPushes da chosen_fixups .
                     fromRebaseSelect $
                     keep +>+ reverseRL dontoffer +>+ outOfRange

    Sealed standard_resolved_p <- return $ standardResolution $ concatFL
                                         $ progressFL "Examining patches for conflicts"
                                         $ mapFL_FL (patchcontents . wddPatch) ps_to_unsuspend
                                    :: IO (Sealed (FL (PrimOf p) wZ))

    have_conflicts <- announceMergeConflicts "unsuspend"
        (allowConflicts opts) (externalMerge ? opts) standard_resolved_p
    Sealed (resolved_p  :: FL (PrimOf p) wA wB) <-
        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 $ seal standard_resolved_p
            (_, False) -> return $ seal standard_resolved_p
            (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
    repository' <- tentativelyRemovePatches repository (compress ? opts) YesUpdateWorking (rOld :>: NilFL)
    -- TODO should catch logfiles (fst value from updatePatchHeader) and clean them up as in AmendRecord
    tentativelyAddToPending repository' YesUpdateWorking 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
    rNew <- unseal (mkRebase . Items) . unseal (simplifyPushes da (mapFL_FL NameFixup renames)) $ ps_to_keep
    repository''' <- tentativelyAddPatch repository'' (compress ? opts) (verbosity ? opts) YesUpdateWorking (n2pia rNew)
    finalizeRepositoryChanges repository''' YesUpdateWorking (compress ? opts)
    _ <- applyToWorking repository''' (verbosity ? opts) effect_to_apply `catch` \(e :: IOException) ->
        fail ("couldn't apply patch in working dir.\n" ++ show e)
    return ()
   ) :: IO ()
    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 p) 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)
                      (parseFlags O.keepDate opts)
                      (parseFlags O.selectAuthor opts)
                      (parseFlags O.author opts)
                      (parseFlags O.patchname opts)
                      (parseFlags O.askLongComment opts)
                      (n2pia (toRebasing (wddPatch p))) NilFL
              repo' <- liftIO $ tentativelyAddPatch repo (compress ? opts) (verbosity ? opts) YesUpdateWorking p'
              -- create a rename that undoes the change we just made, so the contexts match up
              let rename :: RebaseName p wU wU
                  rename = Rename (info p') (patch2patchinfo (wddPatch p))
              -- push it through the remaining patches to fix them up
              Just (ps2 :> (rename2 :: RebaseName p 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)


inject :: DarcsCommand [DarcsFlag]
inject = DarcsCommand
    { commandProgramName = "darcs"
    , commandName = "inject"
    , commandHelp = "Merge a change from the fixups of a patch into the patch itself.\n"
    , commandDescription = "Merge a change from the fixups of a patch into the patch itself."
    , commandPrereq = amInHashedRepository
    , commandExtraArgs = 0
    , commandExtraArgHelp = []
    , commandCommand = injectCmd
    , commandCompleteArgs = noArgs
    , commandArgdefaults = nodefaults
    , commandAdvancedOptions = []
    , commandBasicOptions = odesc injectBasicOpts
    , commandDefaults = defaultFlags injectOpts
    , commandCheckOptions = ocheck injectOpts
    , commandParseOptions = onormalise injectOpts
    }
  where
    injectBasicOpts = O.keepDate ^ O.author ^ O.diffAlgorithm
    injectOpts = injectBasicOpts `withStdOpts` oid

injectCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
injectCmd _ opts _args =
    withRepoLock (dryRun ? opts) (useCache ? opts) YesUpdateWorking (umask ? opts) $
    RebaseJob (RebaseJobFlags (compress ? opts) (verbosity ? opts) YesUpdateWorking) $
    \(repository :: Repository ('RepoType 'IsRebase) p wR wU wR) -> do
    patches <- readRepo repository

    (rOld, Items ps, _) <- return $ takeHeadRebase patches

    let selects = toRebaseSelect ps

    -- TODO this selection doesn't need to respect dependencies
    -- TODO we only want to select one patch: generalise withSelectedPatchFromRepo
    let patches_context = selectionContextGeneric rsToPia First "inject into" (patchSelOpts True opts) Nothing
    (chosens :> rest_selects) <- runSelection selects patches_context

    let extractSingle :: FL (RebaseSelect p) wX wY -> (FL (RebaseFixup p) :> Named p) wX wY
        extractSingle (RSFwd fixups toedit :>: NilFL) = fixups :> toedit
        extractSingle (_ :>: NilFL) = impossible
        extractSingle _ = error "You must select precisely one patch!"

    fixups :> toedit <- return $ extractSingle chosens

    name_fixups :> prim_fixups <- return $ flToNamesPrims fixups

    let changes_context = selectionContextPrim Last "inject" (patchSelOpts True opts) (Just (primSplitter (diffAlgorithm ? opts))) Nothing Nothing
    (rest_fixups :> injects) <- runSelection prim_fixups changes_context

    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 (mapFL_FL fromPrim . canonizeFL da . (injects +>+) . effect) toedit
    rNew <- unseal (mkRebase . Items)
                               $ unseal (simplifyPushes da (mapFL_FL NameFixup name_fixups))
                               $ simplifyPushes da (mapFL_FL PrimFixup rest_fixups)
                               $ ToEdit toeditNew :>: fromRebaseSelect rest_selects

    repository' <- tentativelyRemovePatches repository (compress ? opts) YesUpdateWorking (rOld :>: NilFL)
    repository'' <- tentativelyAddPatch repository' (compress ? opts) (verbosity ? opts) YesUpdateWorking (n2pia rNew)
    finalizeRepositoryChanges repository'' YesUpdateWorking (compress ? opts)
    return ()

obliterate :: DarcsCommand [DarcsFlag]
obliterate = DarcsCommand
    { commandProgramName = "darcs"
    , commandName = "obliterate"
    , commandHelp = "Obliterate a patch that is currently suspended.\n"
    , commandDescription = "Obliterate a patch that is currently suspended.\n"
    , commandPrereq = amInHashedRepository
    , commandExtraArgs = 0
    , commandExtraArgHelp = []
    , commandCommand = obliterateCmd
    , commandCompleteArgs = noArgs
    , commandArgdefaults = nodefaults
    , commandAdvancedOptions = []
    , commandBasicOptions = odesc obliterateBasicOpts
    , commandDefaults = defaultFlags obliterateOpts
    , commandCheckOptions = ocheck obliterateOpts
    , commandParseOptions = onormalise obliterateOpts
    }
  where
    obliterateBasicOpts = O.diffAlgorithm
    obliterateOpts = obliterateBasicOpts `withStdOpts` oid

obliterateCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
obliterateCmd _ opts _args =
    withRepoLock (dryRun ? opts) (useCache ? opts) YesUpdateWorking (umask ? opts) $
    RebaseJob (RebaseJobFlags (compress ? opts) (verbosity ? opts) YesUpdateWorking) $
    \(repository :: Repository ('RepoType 'IsRebase) p wR wU wR) -> (do
    patches <- readRepo repository

    (rOld, Items ps, _) <- return $ takeHeadRebase patches

    let selects = toRebaseSelect ps

    -- TODO this selection doesn't need to respect dependencies
    let patches_context = selectionContextGeneric rsToPia First "obliterate" (obliteratePatchSelOpts opts) Nothing
    (chosen :> keep) <- runSelection selects patches_context
    when (nullFL chosen) $ do putStrLn "No patches selected!"
                              exitSuccess

    let da = diffAlgorithm ? opts
        do_obliterate :: FL (RebaseItem p) wX wY -> FL (RebaseItem p) wY wZ -> Sealed (FL (RebaseItem p) wX)
        do_obliterate NilFL = Sealed
        do_obliterate (Fixup f :>: qs) = unseal (simplifyPush da f) . do_obliterate qs
        do_obliterate (ToEdit e :>: qs) = -- 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 (effect (patchcontents e)))) .
                                          do_obliterate qs

    let ps_to_keep = do_obliterate (fromRebaseSelect chosen) (fromRebaseSelect keep)
    rNew <- unseal (mkRebase . Items) ps_to_keep

    repository' <- tentativelyRemovePatches repository (compress ? opts) YesUpdateWorking (rOld :>: NilFL)
    repository'' <- tentativelyAddPatch repository' (compress ? opts) (verbosity ? opts) YesUpdateWorking (n2pia rNew)
    finalizeRepositoryChanges repository'' YesUpdateWorking (compress ? opts)
    return ()
   ) :: IO ()


pullDescription :: String
pullDescription =
 "Copy and apply patches from another repository, suspending any local patches that conflict."

pullHelp :: String
pullHelp =
 "Copy and apply patches from another repository, suspending any local patches that conflict."

pull :: DarcsCommand [DarcsFlag]
pull = DarcsCommand
    { commandProgramName = "darcs"
    , commandName = "pull"
    , commandHelp = pullHelp
    , 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
    , commandParseOptions = onormalise pullOpts
    }
  where
    pullBasicOpts
      = O.matchSeveral
      ^ O.reorder
      ^ O.interactive
      ^ O.conflictsYes
      ^ O.externalMerge
      ^ O.runTest
      ^ O.dryRunXml
      ^ O.summary
      ^ O.selectDeps
      ^ O.setDefault
      ^ O.repoDir
      ^ O.allowUnrelatedRepos
      ^ O.diffAlgorithm
    pullAdvancedOpts
      = O.repoCombinator
      ^ O.compress
      ^ O.useIndex
      ^ O.remoteRepos
      ^ O.setScriptsExecutable
      ^ O.umask
      ^ O.restrictPaths
      ^ O.changesReverse
      ^ O.network
    pullOpts = pullBasicOpts `withStdOpts` pullAdvancedOpts

applyDescription :: String
applyDescription = "Apply a patch bundle, suspending any local patches that conflict."

applyHelp :: String
applyHelp = "Apply a patch bundle, suspending any local patches that conflict."

stdindefault :: a -> [String] -> IO [String]
stdindefault _ [] = return ["-"]
stdindefault _ x = return x

apply :: DarcsCommand [DarcsFlag]
apply = DarcsCommand
    { commandProgramName = "darcs"
    , commandName = "apply"
    , commandHelp = applyHelp
    , commandDescription = applyDescription
    , commandExtraArgs = 1
    , commandExtraArgHelp = ["<PATCHFILE>"]
    , commandCommand = applyCmd RebasePatchApplier
    , commandPrereq = amInHashedRepository
    , commandCompleteArgs = fileArgs
    , commandArgdefaults = const stdindefault
    , commandAdvancedOptions = odesc applyAdvancedOpts
    , commandBasicOptions = odesc applyBasicOpts
    , commandDefaults = defaultFlags applyOpts
    , commandCheckOptions = ocheck applyOpts
    , commandParseOptions = onormalise applyOpts
    }
  where
    applyBasicOpts
      = O.verify
      ^ O.reorder
      ^ O.interactive
      ^ O.dryRunXml
      ^ O.matchSeveral
      ^ O.repoDir
      ^ O.diffAlgorithm
    applyAdvancedOpts
      = O.reply
      ^ O.ccApply
      ^ O.happyForwarding
      ^ O.sendmail
      ^ O.useIndex
      ^ O.compress
      ^ O.setScriptsExecutable
      ^ O.umask
      ^ O.restrictPaths
      ^ O.changesReverse
      ^ O.pauseForGui
    applyOpts = applyBasicOpts `withStdOpts` applyAdvancedOpts

data RebasePatchApplier = RebasePatchApplier

instance PatchApplier RebasePatchApplier where
    type ApplierRepoTypeConstraint RebasePatchApplier rt = rt ~ 'RepoType 'IsRebase

    repoJob RebasePatchApplier opts f =
        StartRebaseJob
          (RebaseJobFlags (compress ? opts) (verbosity ? opts) YesUpdateWorking)
          (f PatchProxy)
    applyPatches RebasePatchApplier PatchProxy = applyPatchesForRebaseCmd

applyPatchesForRebaseCmd
    :: forall p wR wU wX wT wZ
     . ( RepoPatch p, ApplyState p ~ Tree )
    => String
    -> [DarcsFlag]
    -> String
    -> Repository ('RepoType 'IsRebase) p wR wU wT
    -> FL (PatchInfoAnd ('RepoType 'IsRebase) p) wX wT
    -> FL (PatchInfoAnd ('RepoType 'IsRebase) p) wX wZ
    -> IO ()
applyPatchesForRebaseCmd cmdName opts _from_whom repository us' to_be_applied = do
    printDryRunMessageAndExit cmdName
        (verbosity ? opts)
        (O.summary ? opts)
        (dryRun ? opts)
        (xmlOutput ? opts)
        (isInteractive True opts)
        to_be_applied
    setEnvDarcsPatches to_be_applied
    when (nullFL to_be_applied) $ do
        putStrLn $ "You don't want to " ++ cmdName ++ " any patches, and that's fine with me!"
        exitSuccess
    checkPaths opts to_be_applied
    putVerbose opts $ text $ "Will " ++ cmdName ++ " the following patches:"
    putVerbose opts $ vcat $ mapFL description to_be_applied
    usOk :> usConflicted <- return $ partitionConflictingFL (commuterIdFL selfCommuter) 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 patches_context = selectionContext LastReversed "suspend" applyPatchSelOpts Nothing Nothing

    (usKeep :> usToSuspend) <- runSelection usConflicted patches_context

    -- test all patches for hijacking and abort if rejected
    runHijackT RequestHijackPermission
        $ mapM_ (getAuthor "suspend" False Nothing)
        $ mapFL info usToSuspend

    (rOld, suspended, _) <- return $ takeHeadRebaseFL us'
    repository' <- doSuspend opts repository suspended rOld 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 readUnrecorded
    -- claims to read the tentative state but actual reads the committed state
    -- as a result we have to commit here so that tentativelyMergePatches does
    -- the right thing.
    finalizeRepositoryChanges repository' YesUpdateWorking (compress ? opts)
        >> revertRepositoryChanges repository' YesUpdateWorking

    Sealed pw <-
        tentativelyMergePatches
            repository' cmdName
            (allowConflicts opts) YesUpdateWorking
            (externalMerge ? opts)
            (wantGuiPause opts) (compress ? opts) (verbosity ? opts)
            (reorder ? opts) (diffingOpts opts)
            (usOk +>+ usKeep) to_be_applied

    invalidateIndex repository
    finalizeRepositoryChanges repository' YesUpdateWorking (compress ? opts)
    _ <- revertable $ applyToWorking repository' (verbosity ? opts) pw
    when (O.setScriptsExecutable ? opts == O.YesSetScriptsExecutable) $
      setScriptsExecutablePatches pw
    putInfo opts $ text $ "Finished " ++ cmdName ++ "ing."

-- 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.summary = 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 = parseFlags O.matchSeveralOrLast flags
    , S.interactive = isInteractive defInteractive flags
    , S.selectDeps = selectDeps ? flags
    , S.summary = O.summary ? flags
    , S.withContext = O.NoContext
    }

log :: DarcsCommand [DarcsFlag]
log = DarcsCommand
    { commandProgramName = "darcs"
    , commandName = "log"
    , commandHelp = "List the currently suspended changes.\n"
    , commandDescription = "List the currently suspended changes"
    , commandPrereq = amInHashedRepository
    , commandExtraArgs = 0
    , commandExtraArgHelp = []
    , commandCommand = logCmd
    , commandCompleteArgs = noArgs
    , commandArgdefaults = nodefaults
    , commandAdvancedOptions = odesc logAdvancedOpts
    , commandBasicOptions = odesc logBasicOpts
    , commandDefaults = defaultFlags logOpts
    , commandCheckOptions = ocheck logOpts
    , commandParseOptions = onormalise logOpts
    }
  where
    logBasicOpts = O.summary ^ O.interactive -- False
    logAdvancedOpts = oid
    logOpts = logBasicOpts `withStdOpts` logAdvancedOpts

logCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
logCmd _ opts _files =
    withRepository (useCache ? opts) $
    RebaseJob (RebaseJobFlags (compress ? opts) (verbosity ? opts) YesUpdateWorking) $ \repository -> do
        patches <- readRepo repository
        (_, Items ps, _) <- return $ takeHeadRebase patches
        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
                    emptyPatchSet = PatchSet NilRL NilRL
                    patchSet = appendPSFL emptyPatchSet psToShow
                logInfo <-
                    getLogInfo
                         (maxCount ? opts)
                         (matchAny ? opts)
                         (onlyToFiles ? opts)
                         Nothing
                         (\_ qs -> return qs)
                         patchSet
                let logDoc = changelog opts patchSet logInfo
                putDocLnWith printers logDoc

-- | changes is an alias for log
changes :: DarcsCommand [DarcsFlag]
changes = commandAlias "changes" Nothing log

{-
TODO:

 - amend-record shows the diff between the conflicted state and the resolution, which is unhelpful
 - testing
 - make aggregate commands
 - argument handling
 - what should happen to patch comment on unsuspend?
 - don't just drop explicit dependencies:
    - turn patchnames/explicit deps into patch type and use commutation
 - repo representation
 - seem to be able to get a messed up unrevert context
 - darcs pull/get can setup a rebase patch in a remote repo without the right format
    - rebase patches seem to parse as empty rather than failing??
 - warn about suspending conflicts
 - indication of expected conflicts on unsuspend
    - why isn't ! when you do x accurate?
 - rebase obliterate for more efficient removing of suspended patches
 - 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?
 - rebase changes for viewing suspended patch
 - matching options for rebase unsuspend (etc)
 - 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
 - rebase suspend needs --match
 - patch count: get English right in <n> suspended patch(es)
 - darcs check should check integrity of rebase patch
 - review existence of reify and inject commands - bit of an internals hack
 - need to move rebase to front before adding amend-record hint (and test this)
 - print something while moving rebase to front
-}

