{-# LANGUAGE OverloadedStrings #-}
module Darcs.UI.Commands.Unrecord
( unrecord
, unpull
, obliterate
) where
import Control.Monad ( when, void )
import Data.Maybe( fromJust, isJust )
import Darcs.Util.Tree( Tree )
import System.Exit ( exitSuccess )
import Darcs.Prelude
import Darcs.Patch ( RepoPatch, invert, commute, effect )
import Darcs.Patch.Apply( ApplyState )
import Darcs.Patch.Bundle ( makeBundle, minContext )
import Darcs.Patch.Depends ( removeFromPatchSet )
import Darcs.Patch.PatchInfoAnd ( hopefully, patchDesc )
import Darcs.Patch.Set ( PatchSet, Origin )
import Darcs.Patch.Witnesses.Sealed ( Sealed(..) )
import Darcs.Patch.Witnesses.Ordered ( (:>)(..), mapFL_FL, nullFL, FL(..) )
import Darcs.Util.Path( useAbsoluteOrStd, AbsolutePath, toFilePath, doesPathExist )
import Darcs.Util.SignalHandler ( catchInterrupt, withSignalsBlocked )
import Darcs.Repository
( PatchInfoAnd
, RepoJob(..)
, applyToWorking
, finalizeRepositoryChanges
, invalidateIndex
, readRepo
, tentativelyAddToPending
, tentativelyRemovePatches
, unrecordedChanges
, withRepoLock
)
import Darcs.Repository.Flags( UseIndex(..), ScanKnown(..), UpdatePending(..), DryRun(NoDryRun) )
import Darcs.Util.Lock( writeDocBinFile )
import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults, commandAlias
, putVerbose
, setEnvDarcsPatches, amInHashedRepository
, putInfo, putFinished )
import Darcs.UI.Commands.Util
( getUniqueDPatchName
, printDryRunMessageAndExit
, preselectPatches
, historyEditHelp
)
import Darcs.UI.Completion ( noArgs )
import Darcs.UI.Flags
( DarcsFlag, changesReverse, compress, verbosity, getOutput
, useCache, dryRun, umask, minimize
, diffAlgorithm, xmlOutput, isInteractive, selectDeps )
import Darcs.UI.Options ( (^), odesc, ocheck, defaultFlags, parseFlags, (?) )
import qualified Darcs.UI.Options.All as O
import Darcs.UI.SelectChanges ( WhichChanges(..),
selectionConfig, runSelection )
import qualified Darcs.UI.SelectChanges as S ( PatchSelectionOptions (..) )
import Darcs.Util.English ( presentParticiple )
import Darcs.Util.Printer ( Doc, formatWords, text, putDoc, sentence, (<+>), ($+$) )
import Darcs.Util.Progress ( debugMessage )
unrecordDescription :: String
unrecordDescription :: String
unrecordDescription =
String
"Remove recorded patches without changing the working tree."
unrecordHelp :: Doc
unrecordHelp :: Doc
unrecordHelp = [String] -> Doc
formatWords
[ String
"Unrecord does the opposite of record: it deletes patches from"
, String
"the repository without changing the working tree. The changes"
, String
"are now again visible with `darcs whatsnew` and you can record"
, String
"or revert them as you please."
]
Doc -> Doc -> Doc
$+$ Doc
historyEditHelp
unrecord :: DarcsCommand
unrecord :: DarcsCommand
unrecord = DarcsCommand
{ commandProgramName :: String
commandProgramName = String
"darcs"
, commandName :: String
commandName = String
"unrecord"
, commandHelp :: Doc
commandHelp = Doc
unrecordHelp
, commandDescription :: String
commandDescription = String
unrecordDescription
, commandExtraArgs :: Int
commandExtraArgs = Int
0
, commandExtraArgHelp :: [String]
commandExtraArgHelp = []
, commandCommand :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
commandCommand = (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
unrecordCmd
, commandPrereq :: [DarcsFlag] -> IO (Either String ())
commandPrereq = [DarcsFlag] -> IO (Either String ())
amInHashedRepository
, commandCompleteArgs :: (AbsolutePath, AbsolutePath)
-> [DarcsFlag] -> [String] -> IO [String]
commandCompleteArgs = (AbsolutePath, AbsolutePath)
-> [DarcsFlag] -> [String] -> IO [String]
noArgs
, commandArgdefaults :: [DarcsFlag] -> AbsolutePath -> [String] -> IO [String]
commandArgdefaults = [DarcsFlag] -> AbsolutePath -> [String] -> IO [String]
nodefaults
, commandAdvancedOptions :: [DarcsOptDescr DarcsFlag]
commandAdvancedOptions = forall (d :: * -> *) f a b. OptSpec d f a b -> [d f]
odesc forall {a}.
OptSpec
DarcsOptDescr DarcsFlag a (Compression -> UMask -> Bool -> a)
unrecordAdvancedOpts
, commandBasicOptions :: [DarcsOptDescr DarcsFlag]
commandBasicOptions = forall (d :: * -> *) f a b. OptSpec d f a b -> [d f]
odesc forall {a}.
OptSpec
DarcsOptDescr
DarcsFlag
a
([NotInRemote]
-> [MatchFlag] -> SelectDeps -> Maybe Bool -> Maybe String -> a)
unrecordBasicOpts
, commandDefaults :: [DarcsFlag]
commandDefaults = forall (d :: * -> *) f b. OptSpec d f [f] b -> [f]
defaultFlags forall {a}.
DarcsOption
a
([NotInRemote]
-> [MatchFlag]
-> SelectDeps
-> Maybe Bool
-> Maybe String
-> Maybe StdCmdAction
-> Verbosity
-> Compression
-> UMask
-> Bool
-> UseCache
-> HooksConfig
-> Bool
-> Bool
-> Bool
-> a)
unrecordOpts
, commandCheckOptions :: [DarcsFlag] -> [String]
commandCheckOptions = forall (d :: * -> *) f a b. OptSpec d f a b -> [f] -> [String]
ocheck forall {a}.
DarcsOption
a
([NotInRemote]
-> [MatchFlag]
-> SelectDeps
-> Maybe Bool
-> Maybe String
-> Maybe StdCmdAction
-> Verbosity
-> Compression
-> UMask
-> Bool
-> UseCache
-> HooksConfig
-> Bool
-> Bool
-> Bool
-> a)
unrecordOpts
}
where
unrecordBasicOpts :: OptSpec
DarcsOptDescr
DarcsFlag
a
([NotInRemote]
-> [MatchFlag] -> SelectDeps -> Maybe Bool -> Maybe String -> a)
unrecordBasicOpts
= PrimDarcsOption [NotInRemote]
O.notInRemote
forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ MatchOption
O.matchSeveralOrLast
forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ PrimDarcsOption SelectDeps
O.selectDeps
forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ PrimDarcsOption (Maybe Bool)
O.interactive
forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ PrimDarcsOption (Maybe String)
O.repoDir
unrecordAdvancedOpts :: OptSpec
DarcsOptDescr DarcsFlag a (Compression -> UMask -> Bool -> a)
unrecordAdvancedOpts
= PrimDarcsOption Compression
O.compress
forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ PrimDarcsOption UMask
O.umask
forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ PrimDarcsOption Bool
O.changesReverse
unrecordOpts :: DarcsOption
a
([NotInRemote]
-> [MatchFlag]
-> SelectDeps
-> Maybe Bool
-> Maybe String
-> Maybe StdCmdAction
-> Verbosity
-> Compression
-> UMask
-> Bool
-> UseCache
-> HooksConfig
-> Bool
-> Bool
-> Bool
-> a)
unrecordOpts = forall {a}.
OptSpec
DarcsOptDescr
DarcsFlag
a
([NotInRemote]
-> [MatchFlag] -> SelectDeps -> Maybe Bool -> Maybe String -> a)
unrecordBasicOpts forall b c a.
DarcsOption (Maybe StdCmdAction -> Verbosity -> b) c
-> DarcsOption
(UseCache -> HooksConfig -> Bool -> Bool -> Bool -> a) b
-> DarcsOption a c
`withStdOpts` forall {a}.
OptSpec
DarcsOptDescr DarcsFlag a (Compression -> UMask -> Bool -> a)
unrecordAdvancedOpts
unrecordCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
unrecordCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
unrecordCmd (AbsolutePath, AbsolutePath)
_ [DarcsFlag]
opts [String]
_ =
forall a.
DryRun -> UseCache -> UpdatePending -> UMask -> RepoJob a -> IO a
withRepoLock DryRun
NoDryRun (PrimDarcsOption UseCache
useCache forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) UpdatePending
YesUpdatePending (PrimDarcsOption UMask
umask forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) forall a b. (a -> b) -> a -> b
$
forall a.
(forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR -> IO a)
-> RepoJob a
RepoJob forall a b. (a -> b) -> a -> b
$ \Repository rt p wR wU wR
_repository -> do
(PatchSet rt p Origin wZ
_ :> FL (PatchInfoAnd rt p) wZ wR
removal_candidates) <- forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
(IsRepoType rt, RepoPatch p) =>
[DarcsFlag]
-> Repository rt p wR wU wT
-> IO ((:>) (PatchSet rt p) (FL (PatchInfoAnd rt p)) Origin wR)
preselectPatches [DarcsFlag]
opts Repository rt p wR wU wR
_repository
let direction :: WhichChanges
direction = if PrimDarcsOption Bool
changesReverse forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts then WhichChanges
Last else WhichChanges
LastReversed
selection_config :: SelectionConfig (PatchInfoAnd rt p)
selection_config =
forall (p :: * -> * -> *).
Matchable p =>
WhichChanges
-> String
-> PatchSelectionOptions
-> Maybe (Splitter p)
-> Maybe [AnchoredPath]
-> SelectionConfig p
selectionConfig WhichChanges
direction String
"unrecord" ([DarcsFlag] -> PatchSelectionOptions
patchSelOpts [DarcsFlag]
opts) forall a. Maybe a
Nothing forall a. Maybe a
Nothing
(FL (PatchInfoAnd rt p) wZ wZ
_ :> FL (PatchInfoAnd rt p) wZ wR
to_unrecord) <- forall (p :: * -> * -> *) wX wY.
(MatchableRP p, ShowPatch p, ShowContextPatch p,
ApplyState p ~ Tree, ApplyState p ~ ApplyState (PrimOf p)) =>
FL p wX wY -> SelectionConfig p -> IO ((:>) (FL p) (FL p) wX wY)
runSelection FL (PatchInfoAnd rt p) wZ wR
removal_candidates SelectionConfig (PatchInfoAnd rt p)
selection_config
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (a :: * -> * -> *) wX wZ. FL a wX wZ -> Bool
nullFL FL (PatchInfoAnd rt p) wZ wR
to_unrecord) forall a b. (a -> b) -> a -> b
$ do
[DarcsFlag] -> Doc -> IO ()
putInfo [DarcsFlag]
opts Doc
"No patches selected!"
forall a. IO a
exitSuccess
[DarcsFlag] -> Doc -> IO ()
putVerbose [DarcsFlag]
opts forall a b. (a -> b) -> a -> b
$
String -> Doc
text String
"About to write out (potentially) modified patches..."
forall (p :: * -> * -> *) (rt :: RepoType) wX wY.
RepoPatch p =>
FL (PatchInfoAnd rt p) wX wY -> IO ()
setEnvDarcsPatches FL (PatchInfoAnd rt p) wZ wR
to_unrecord
forall t. t -> IO ()
invalidateIndex Repository rt p wR wU wR
_repository
Repository rt p wR wU wZ
_repository <- forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT wX.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wT
-> Compression
-> UpdatePending
-> FL (PatchInfoAnd rt p) wX wT
-> IO (Repository rt p wR wU wX)
tentativelyRemovePatches Repository rt p wR wU wR
_repository (PrimDarcsOption Compression
compress forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts)
UpdatePending
YesUpdatePending FL (PatchInfoAnd rt p) wZ wR
to_unrecord
Repository rt p wZ wU wZ
_ <- forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wT
-> UpdatePending -> Compression -> IO (Repository rt p wT wU wT)
finalizeRepositoryChanges Repository rt p wR wU wZ
_repository UpdatePending
YesUpdatePending (PrimDarcsOption Compression
compress forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts)
[DarcsFlag] -> Doc -> IO ()
putInfo [DarcsFlag]
opts Doc
"Finished unrecording."
unpullDescription :: String
unpullDescription :: String
unpullDescription =
String
"Opposite of pull; unsafe if patch is not in remote repository."
unpullHelp :: Doc
unpullHelp :: Doc
unpullHelp = String -> Doc
text forall a b. (a -> b) -> a -> b
$ String
"Unpull is an alias for what is nowadays called `obliterate`."
unpull :: DarcsCommand
unpull :: DarcsCommand
unpull = (String -> Maybe DarcsCommand -> DarcsCommand -> DarcsCommand
commandAlias String
"unpull" forall a. Maybe a
Nothing DarcsCommand
obliterate)
{ commandHelp :: Doc
commandHelp = Doc
unpullHelp
, commandDescription :: String
commandDescription = String
unpullDescription
, commandCommand :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
commandCommand = (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
unpullCmd
}
unpullCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
unpullCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
unpullCmd = String
-> (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
genericObliterateCmd String
"unpull"
obliterateDescription :: String
obliterateDescription :: String
obliterateDescription =
String
"Delete selected patches from the repository."
obliterateHelp :: Doc
obliterateHelp :: Doc
obliterateHelp = [String] -> Doc
formatWords
[ String
"Obliterate completely removes recorded patches from your local"
, String
"repository. The changes will be undone in your working tree and the"
, String
"patches will not be shown in your changes list anymore. Beware that"
, String
"you can lose precious code by obliterating!"
]
Doc -> Doc -> Doc
$+$ [String] -> Doc
formatWords
[ String
"One way to save obliterated patches is to use the -O flag. A patch"
, String
"bundle will be created locally, that you will be able to apply"
, String
"later to your repository with `darcs apply`. See `darcs send` for"
, String
"a more detailed description."
]
Doc -> Doc -> Doc
$+$ Doc
historyEditHelp
obliterate :: DarcsCommand
obliterate :: DarcsCommand
obliterate = DarcsCommand
{ commandProgramName :: String
commandProgramName = String
"darcs"
, commandName :: String
commandName = String
"obliterate"
, commandHelp :: Doc
commandHelp = Doc
obliterateHelp
, commandDescription :: String
commandDescription = String
obliterateDescription
, commandExtraArgs :: Int
commandExtraArgs = Int
0
, commandExtraArgHelp :: [String]
commandExtraArgHelp = []
, commandCommand :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
commandCommand = (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
obliterateCmd
, commandPrereq :: [DarcsFlag] -> IO (Either String ())
commandPrereq = [DarcsFlag] -> IO (Either String ())
amInHashedRepository
, commandCompleteArgs :: (AbsolutePath, AbsolutePath)
-> [DarcsFlag] -> [String] -> IO [String]
commandCompleteArgs = (AbsolutePath, AbsolutePath)
-> [DarcsFlag] -> [String] -> IO [String]
noArgs
, commandArgdefaults :: [DarcsFlag] -> AbsolutePath -> [String] -> IO [String]
commandArgdefaults = [DarcsFlag] -> AbsolutePath -> [String] -> IO [String]
nodefaults
, commandAdvancedOptions :: [DarcsOptDescr DarcsFlag]
commandAdvancedOptions = forall (d :: * -> *) f a b. OptSpec d f a b -> [d f]
odesc forall {a}.
OptSpec
DarcsOptDescr
DarcsFlag
a
(Compression -> UseIndex -> UMask -> Bool -> a)
obliterateAdvancedOpts
, commandBasicOptions :: [DarcsOptDescr DarcsFlag]
commandBasicOptions = forall (d :: * -> *) f a b. OptSpec d f a b -> [d f]
odesc forall {a}.
OptSpec
DarcsOptDescr
DarcsFlag
a
([NotInRemote]
-> [MatchFlag]
-> SelectDeps
-> Maybe Bool
-> Maybe String
-> WithSummary
-> Maybe Output
-> Bool
-> DiffAlgorithm
-> DryRun
-> XmlOutput
-> a)
obliterateBasicOpts
, commandDefaults :: [DarcsFlag]
commandDefaults = forall (d :: * -> *) f b. OptSpec d f [f] b -> [f]
defaultFlags forall {a}.
DarcsOption
a
([NotInRemote]
-> [MatchFlag]
-> SelectDeps
-> Maybe Bool
-> Maybe String
-> WithSummary
-> Maybe Output
-> Bool
-> DiffAlgorithm
-> DryRun
-> XmlOutput
-> Maybe StdCmdAction
-> Verbosity
-> Compression
-> UseIndex
-> UMask
-> Bool
-> UseCache
-> HooksConfig
-> Bool
-> Bool
-> Bool
-> a)
obliterateOpts
, commandCheckOptions :: [DarcsFlag] -> [String]
commandCheckOptions = forall (d :: * -> *) f a b. OptSpec d f a b -> [f] -> [String]
ocheck forall {a}.
DarcsOption
a
([NotInRemote]
-> [MatchFlag]
-> SelectDeps
-> Maybe Bool
-> Maybe String
-> WithSummary
-> Maybe Output
-> Bool
-> DiffAlgorithm
-> DryRun
-> XmlOutput
-> Maybe StdCmdAction
-> Verbosity
-> Compression
-> UseIndex
-> UMask
-> Bool
-> UseCache
-> HooksConfig
-> Bool
-> Bool
-> Bool
-> a)
obliterateOpts
}
where
obliterateBasicOpts :: OptSpec
DarcsOptDescr
DarcsFlag
a
([NotInRemote]
-> [MatchFlag]
-> SelectDeps
-> Maybe Bool
-> Maybe String
-> WithSummary
-> Maybe Output
-> Bool
-> DiffAlgorithm
-> DryRun
-> XmlOutput
-> a)
obliterateBasicOpts
= PrimDarcsOption [NotInRemote]
O.notInRemote
forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ MatchOption
O.matchSeveralOrLast
forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ PrimDarcsOption SelectDeps
O.selectDeps
forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ PrimDarcsOption (Maybe Bool)
O.interactive
forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ PrimDarcsOption (Maybe String)
O.repoDir
forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ PrimDarcsOption WithSummary
O.withSummary
forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ PrimDarcsOption (Maybe Output)
O.output
forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ PrimDarcsOption Bool
O.minimize
forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ PrimDarcsOption DiffAlgorithm
O.diffAlgorithm
forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ forall a. DarcsOption a (DryRun -> XmlOutput -> a)
O.dryRunXml
obliterateAdvancedOpts :: OptSpec
DarcsOptDescr
DarcsFlag
a
(Compression -> UseIndex -> UMask -> Bool -> a)
obliterateAdvancedOpts
= PrimDarcsOption Compression
O.compress
forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ PrimDarcsOption UseIndex
O.useIndex
forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ PrimDarcsOption UMask
O.umask
forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ PrimDarcsOption Bool
O.changesReverse
obliterateOpts :: DarcsOption
a
([NotInRemote]
-> [MatchFlag]
-> SelectDeps
-> Maybe Bool
-> Maybe String
-> WithSummary
-> Maybe Output
-> Bool
-> DiffAlgorithm
-> DryRun
-> XmlOutput
-> Maybe StdCmdAction
-> Verbosity
-> Compression
-> UseIndex
-> UMask
-> Bool
-> UseCache
-> HooksConfig
-> Bool
-> Bool
-> Bool
-> a)
obliterateOpts = forall {a}.
OptSpec
DarcsOptDescr
DarcsFlag
a
([NotInRemote]
-> [MatchFlag]
-> SelectDeps
-> Maybe Bool
-> Maybe String
-> WithSummary
-> Maybe Output
-> Bool
-> DiffAlgorithm
-> DryRun
-> XmlOutput
-> a)
obliterateBasicOpts forall b c a.
DarcsOption (Maybe StdCmdAction -> Verbosity -> b) c
-> DarcsOption
(UseCache -> HooksConfig -> Bool -> Bool -> Bool -> a) b
-> DarcsOption a c
`withStdOpts` forall {a}.
OptSpec
DarcsOptDescr
DarcsFlag
a
(Compression -> UseIndex -> UMask -> Bool -> a)
obliterateAdvancedOpts
obliterateCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
obliterateCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
obliterateCmd = String
-> (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
genericObliterateCmd String
"obliterate"
genericObliterateCmd :: String
-> (AbsolutePath, AbsolutePath)
-> [DarcsFlag]
-> [String]
-> IO ()
genericObliterateCmd :: String
-> (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
genericObliterateCmd String
cmdname (AbsolutePath, AbsolutePath)
_ [DarcsFlag]
opts [String]
_ =
let cacheOpt :: UseCache
cacheOpt = PrimDarcsOption UseCache
useCache forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts
verbOpt :: Verbosity
verbOpt = PrimDarcsOption Verbosity
verbosity forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts
in forall a.
DryRun -> UseCache -> UpdatePending -> UMask -> RepoJob a -> IO a
withRepoLock (PrimDarcsOption DryRun
dryRun forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) UseCache
cacheOpt UpdatePending
YesUpdatePending (PrimDarcsOption UMask
umask forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) forall a b. (a -> b) -> a -> b
$
forall a.
(forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR -> IO a)
-> RepoJob a
RepoJob forall a b. (a -> b) -> a -> b
$ \Repository rt p wR wU wR
_repository -> do
FL (PrimOf p) wR wU
pend <- forall (p :: * -> * -> *) (rt :: RepoType) wR wU.
(RepoPatch p, ApplyState p ~ Tree) =>
(UseIndex, ScanKnown, DiffAlgorithm)
-> LookForMoves
-> LookForReplaces
-> Repository rt p wR wU wR
-> Maybe [AnchoredPath]
-> IO (FL (PrimOf p) wR wU)
unrecordedChanges (UseIndex
UseIndex, ScanKnown
ScanKnown, PrimDarcsOption DiffAlgorithm
diffAlgorithm forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts)
LookForMoves
O.NoLookForMoves LookForReplaces
O.NoLookForReplaces Repository rt p wR wU wR
_repository forall a. Maybe a
Nothing
(PatchSet rt p Origin wZ
_ :> FL (PatchInfoAnd rt p) wZ wR
removal_candidates) <- forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
(IsRepoType rt, RepoPatch p) =>
[DarcsFlag]
-> Repository rt p wR wU wT
-> IO ((:>) (PatchSet rt p) (FL (PatchInfoAnd rt p)) Origin wR)
preselectPatches [DarcsFlag]
opts Repository rt p wR wU wR
_repository
let direction :: WhichChanges
direction = if PrimDarcsOption Bool
changesReverse forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts then WhichChanges
Last else WhichChanges
LastReversed
selection_config :: SelectionConfig (PatchInfoAnd rt p)
selection_config =
forall (p :: * -> * -> *).
Matchable p =>
WhichChanges
-> String
-> PatchSelectionOptions
-> Maybe (Splitter p)
-> Maybe [AnchoredPath]
-> SelectionConfig p
selectionConfig WhichChanges
direction String
cmdname ([DarcsFlag] -> PatchSelectionOptions
patchSelOpts [DarcsFlag]
opts) forall a. Maybe a
Nothing forall a. Maybe a
Nothing
(FL (PatchInfoAnd rt p) wZ wZ
_ :> FL (PatchInfoAnd rt p) wZ wR
removed) <-
forall (p :: * -> * -> *) wX wY.
(MatchableRP p, ShowPatch p, ShowContextPatch p,
ApplyState p ~ Tree, ApplyState p ~ ApplyState (PrimOf p)) =>
FL p wX wY -> SelectionConfig p -> IO ((:>) (FL p) (FL p) wX wY)
runSelection FL (PatchInfoAnd rt p) wZ wR
removal_candidates SelectionConfig (PatchInfoAnd rt p)
selection_config
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (a :: * -> * -> *) wX wZ. FL a wX wZ -> Bool
nullFL FL (PatchInfoAnd rt p) wZ wR
removed) forall a b. (a -> b) -> a -> b
$ do
[DarcsFlag] -> Doc -> IO ()
putInfo [DarcsFlag]
opts Doc
"No patches selected!"
forall a. IO a
exitSuccess
case forall (p :: * -> * -> *) wX wY.
Commute p =>
(:>) p p wX wY -> Maybe ((:>) p p wX wY)
commute (forall (p :: * -> * -> *) wX wY.
Effect p =>
p wX wY -> FL (PrimOf p) wX wY
effect FL (PatchInfoAnd rt p) wZ wR
removed forall (a1 :: * -> * -> *) (a2 :: * -> * -> *) wX wY wZ.
a1 wX wZ -> a2 wZ wY -> (:>) a1 a2 wX wY
:> FL (PrimOf p) wR wU
pend) of
Maybe ((:>) (FL (PrimOf p)) (FL (PrimOf p)) wZ wU)
Nothing -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Can't " forall a. [a] -> [a] -> [a]
++ String
cmdname
forall a. [a] -> [a] -> [a]
++ String
" patch without reverting some "
forall a. [a] -> [a] -> [a]
++ String
"unrecorded change."
Just (FL (PrimOf p) wZ wZ
_ :> FL (PrimOf p) wZ wU
p_after_pending) -> do
forall (p :: * -> * -> *) (rt :: RepoType) wX wY.
RepoPatch p =>
String
-> Verbosity
-> WithSummary
-> DryRun
-> XmlOutput
-> Bool
-> FL (PatchInfoAnd rt p) wX wY
-> IO ()
printDryRunMessageAndExit String
"obliterate"
Verbosity
verbOpt
(PrimDarcsOption WithSummary
O.withSummary forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts)
(PrimDarcsOption DryRun
dryRun forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts)
(PrimDarcsOption XmlOutput
xmlOutput forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts)
(Bool -> [DarcsFlag] -> Bool
isInteractive Bool
True [DarcsFlag]
opts)
FL (PatchInfoAnd rt p) wZ wR
removed
forall (p :: * -> * -> *) (rt :: RepoType) wX wY.
RepoPatch p =>
FL (PatchInfoAnd rt p) wX wY -> IO ()
setEnvDarcsPatches FL (PatchInfoAnd rt p) wZ wR
removed
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. Maybe a -> Bool
isJust forall a b. (a -> b) -> a -> b
$ [DarcsFlag] -> String -> Maybe AbsolutePathOrStd
getOutput [DarcsFlag]
opts String
"") forall a b. (a -> b) -> a -> b
$
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
(IsRepoType rt, RepoPatch p) =>
Repository rt p wR wU wT -> IO (PatchSet rt p Origin wR)
readRepo Repository rt p wR wU wR
_repository forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (p :: * -> * -> *) (rt :: RepoType) wX wR.
(RepoPatch p, ApplyState p ~ Tree) =>
[DarcsFlag]
-> FL (PatchInfoAnd rt p) wX wR -> PatchSet rt p Origin wR -> IO ()
savetoBundle [DarcsFlag]
opts FL (PatchInfoAnd rt p) wZ wR
removed
forall t. t -> IO ()
invalidateIndex Repository rt p wR wU wR
_repository
Repository rt p wR wU wZ
_repository <- forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT wX.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wT
-> Compression
-> UpdatePending
-> FL (PatchInfoAnd rt p) wX wT
-> IO (Repository rt p wR wU wX)
tentativelyRemovePatches Repository rt p wR wU wR
_repository
(PrimDarcsOption Compression
compress forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) UpdatePending
YesUpdatePending FL (PatchInfoAnd rt p) wZ wR
removed
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT wX wY.
RepoPatch p =>
Repository rt p wR wU wT -> FL (PrimOf p) wX wY -> IO ()
tentativelyAddToPending Repository rt p wR wU wZ
_repository forall a b. (a -> b) -> a -> b
$ forall (p :: * -> * -> *) wX wY. Invert p => p wX wY -> p wY wX
invert forall a b. (a -> b) -> a -> b
$ forall (p :: * -> * -> *) wX wY.
Effect p =>
p wX wY -> FL (PrimOf p) wX wY
effect FL (PatchInfoAnd rt p) wZ wR
removed
forall a. IO a -> IO a
withSignalsBlocked forall a b. (a -> b) -> a -> b
$ do
Repository rt p wZ wU wZ
_repository <- forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wT
-> UpdatePending -> Compression -> IO (Repository rt p wT wU wT)
finalizeRepositoryChanges Repository rt p wR wU wZ
_repository
UpdatePending
YesUpdatePending (PrimDarcsOption Compression
compress forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts)
String -> IO ()
debugMessage String
"Applying patches to working tree..."
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (p :: * -> * -> *) (rt :: RepoType) wR wU wT wY.
(ApplyState p ~ Tree, RepoPatch p) =>
Repository rt p wR wU wT
-> Verbosity
-> FL (PrimOf p) wU wY
-> IO (Repository rt p wR wY wT)
applyToWorking Repository rt p wZ wU wZ
_repository Verbosity
verbOpt (forall (p :: * -> * -> *) wX wY. Invert p => p wX wY -> p wY wX
invert FL (PrimOf p) wZ wU
p_after_pending)
[DarcsFlag] -> String -> IO ()
putFinished [DarcsFlag]
opts (String -> String
presentParticiple String
cmdname)
savetoBundle :: (RepoPatch p, ApplyState p ~ Tree)
=> [DarcsFlag]
-> FL (PatchInfoAnd rt p) wX wR
-> PatchSet rt p Origin wR
-> IO ()
savetoBundle :: forall (p :: * -> * -> *) (rt :: RepoType) wX wR.
(RepoPatch p, ApplyState p ~ Tree) =>
[DarcsFlag]
-> FL (PatchInfoAnd rt p) wX wR -> PatchSet rt p Origin wR -> IO ()
savetoBundle [DarcsFlag]
_ FL (PatchInfoAnd rt p) wX wR
NilFL PatchSet rt p Origin wR
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()
savetoBundle [DarcsFlag]
opts removed :: FL (PatchInfoAnd rt p) wX wR
removed@(PatchInfoAnd rt p wX wY
x :>: FL (PatchInfoAnd rt p) wY wR
_) PatchSet rt p Origin wR
orig = do
let kept :: PatchSet rt p Origin wX
kept = forall a. HasCallStack => Maybe a -> a
fromJust forall a b. (a -> b) -> a -> b
$ forall (p :: * -> * -> *) (rt :: RepoType) wX wY wStart.
(Commute p, Eq2 p) =>
FL (PatchInfoAnd rt p) wX wY
-> PatchSet rt p wStart wY -> Maybe (PatchSet rt p wStart wX)
removeFromPatchSet FL (PatchInfoAnd rt p) wX wR
removed PatchSet rt p Origin wR
orig
genFullBundle :: IO Doc
genFullBundle = forall (p :: * -> * -> *) (rt :: RepoType) wStart wX wY.
(ApplyState p ~ Tree, RepoPatch p) =>
Maybe (Tree IO)
-> PatchSet rt p wStart wX -> FL (Named p) wX wY -> IO Doc
makeBundle forall a. Maybe a
Nothing PatchSet rt p Origin wX
kept (forall (a :: * -> * -> *) (b :: * -> * -> *) wX wZ.
(forall wW wY. a wW wY -> b wW wY) -> FL a wX wZ -> FL b wX wZ
mapFL_FL forall (rt :: RepoType) (p :: * -> * -> *) wA wB.
PatchInfoAndG rt p wA wB -> p wA wB
hopefully FL (PatchInfoAnd rt p) wX wR
removed)
Doc
bundle <- if Bool -> Bool
not (PrimDarcsOption Bool
minimize forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts)
then IO Doc
genFullBundle
else do [DarcsFlag] -> Doc -> IO ()
putInfo [DarcsFlag]
opts Doc
"Minimizing context, to generate bundle with full context hit ctrl-C..."
( case forall (p :: * -> * -> *) (rt :: RepoType) wStart wB wC.
RepoPatch p =>
PatchSet rt p wStart wB
-> FL (PatchInfoAnd rt p) wB wC
-> Sealed ((:>) (PatchSet rt p) (FL (PatchInfoAnd rt p)) wStart)
minContext PatchSet rt p Origin wX
kept FL (PatchInfoAnd rt p) wX wR
removed of
Sealed (PatchSet rt p Origin wZ
kept' :> FL (PatchInfoAnd rt p) wZ wX
removed') -> forall (p :: * -> * -> *) (rt :: RepoType) wStart wX wY.
(ApplyState p ~ Tree, RepoPatch p) =>
Maybe (Tree IO)
-> PatchSet rt p wStart wX -> FL (Named p) wX wY -> IO Doc
makeBundle forall a. Maybe a
Nothing PatchSet rt p Origin wZ
kept' (forall (a :: * -> * -> *) (b :: * -> * -> *) wX wZ.
(forall wW wY. a wW wY -> b wW wY) -> FL a wX wZ -> FL b wX wZ
mapFL_FL forall (rt :: RepoType) (p :: * -> * -> *) wA wB.
PatchInfoAndG rt p wA wB -> p wA wB
hopefully FL (PatchInfoAnd rt p) wZ wX
removed') )
forall a. IO a -> IO a -> IO a
`catchInterrupt` IO Doc
genFullBundle
String
filename <- String -> IO String
getUniqueDPatchName (forall (rt :: RepoType) (p :: * -> * -> *) wX wY.
PatchInfoAnd rt p wX wY -> String
patchDesc PatchInfoAnd rt p wX wY
x)
let Just AbsolutePathOrStd
outname = [DarcsFlag] -> String -> Maybe AbsolutePathOrStd
getOutput [DarcsFlag]
opts String
filename
Bool
exists <- forall a. (AbsolutePath -> a) -> a -> AbsolutePathOrStd -> a
useAbsoluteOrStd (String -> IO Bool
doesPathExist forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. FilePathLike a => a -> String
toFilePath) (forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False) AbsolutePathOrStd
outname
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
exists forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Directory or file named '" forall a. [a] -> [a] -> [a]
++ (forall a. Show a => a -> String
show AbsolutePathOrStd
outname) forall a. [a] -> [a] -> [a]
++ String
"' already exists."
forall a. (AbsolutePath -> a) -> a -> AbsolutePathOrStd -> a
useAbsoluteOrStd forall p. FilePathLike p => p -> Doc -> IO ()
writeDocBinFile Doc -> IO ()
putDoc AbsolutePathOrStd
outname Doc
bundle
[DarcsFlag] -> Doc -> IO ()
putInfo [DarcsFlag]
opts forall a b. (a -> b) -> a -> b
$ Doc -> Doc
sentence forall a b. (a -> b) -> a -> b
$
forall a. (AbsolutePath -> a) -> a -> AbsolutePathOrStd -> a
useAbsoluteOrStd ((Doc
"Saved patch bundle" Doc -> Doc -> Doc
<+>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Doc
text forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. FilePathLike a => a -> String
toFilePath) (String -> Doc
text String
"stdout") AbsolutePathOrStd
outname
patchSelOpts :: [DarcsFlag] -> S.PatchSelectionOptions
patchSelOpts :: [DarcsFlag] -> PatchSelectionOptions
patchSelOpts [DarcsFlag]
flags = S.PatchSelectionOptions
{ verbosity :: Verbosity
S.verbosity = PrimDarcsOption Verbosity
verbosity forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
flags
, matchFlags :: [MatchFlag]
S.matchFlags = forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
parseFlags MatchOption
O.matchSeveralOrLast [DarcsFlag]
flags
, interactive :: Bool
S.interactive = Bool -> [DarcsFlag] -> Bool
isInteractive Bool
True [DarcsFlag]
flags
, selectDeps :: SelectDeps
S.selectDeps = PrimDarcsOption SelectDeps
selectDeps forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
flags
, withSummary :: WithSummary
S.withSummary = PrimDarcsOption WithSummary
O.withSummary forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
flags
, withContext :: WithContext
S.withContext = WithContext
O.NoContext
}