{-# LANGUAGE OverloadedStrings #-}
module Darcs.UI.Commands.MarkConflicts ( markconflicts ) where
import Prelude ()
import Darcs.Prelude
import System.Exit ( exitSuccess )
import Data.List.Ordered ( nubSort, isect )
import Data.Maybe ( fromJust )
import Control.Monad ( when, unless )
import Control.Exception ( catch, IOException )
import Darcs.Util.Prompt ( promptYorn )
import Darcs.Util.SignalHandler ( withSignalsBlocked )
import Darcs.Util.Path ( AbsolutePath, SubPath, toFilePath, simpleSubPath )
import Darcs.Util.Printer
( Doc, putDocLnWith, text, redText, debugDocLn, vsep, (<+>), ($$) )
import Darcs.Util.Printer.Color ( fancyPrinters )
import Darcs.Util.Text ( pathlist )
import Darcs.UI.Commands
( DarcsCommand(..), withStdOpts, nodefaults, amInHashedRepository, putInfo )
import Darcs.UI.Commands.Util ( filterExistingPaths )
import Darcs.UI.Completion ( knownFileArgs )
import Darcs.UI.Flags
( DarcsFlag, diffingOpts, verbosity, dryRun, umask
, useCache, fixSubPaths )
import Darcs.UI.Options ( (^), odesc, ocheck, onormalise, defaultFlags, (?) )
import qualified Darcs.UI.Options.All as O
import Darcs.Repository.Flags ( UpdateWorking (..) )
import Darcs.Repository
( withRepoLock
, RepoJob(..)
, addToPending
, applyToWorking
, readRepo
, unrecordedChanges )
import Darcs.Patch ( invert, listTouchedFiles, effectOnFilePaths )
import Darcs.Patch.Show
import Darcs.Patch.TouchesFiles ( chooseTouching )
import Darcs.Patch.Witnesses.Ordered ( FL(..), mapFL )
import Darcs.Patch.Witnesses.Sealed ( Sealed(Sealed) )
import Darcs.Repository.Resolution ( patchsetConflictResolutions )
markconflictsDescription :: String
markconflictsDescription :: String
markconflictsDescription =
"Mark unresolved conflicts in working tree, for manual resolution."
markconflictsHelp :: String
markconflictsHelp :: String
markconflictsHelp = [String] -> String
unlines
["Darcs requires human guidance to unify changes to the same part of a"
,"source file. When a conflict first occurs, darcs will add the"
,"initial state and both choices to the working tree, delimited by the"
,"markers `v v v`, `=====`, `* * *` and `^ ^ ^`, as follows:"
,""
," v v v v v v v"
," Initial state."
," ============="
," First choice."
," *************"
," Second choice."
," ^ ^ ^ ^ ^ ^ ^"
,""
,"However, you might revert or manually delete these markers without"
,"actually resolving the conflict. In this case, `darcs mark-conflicts`"
,"is useful to show where are the unresolved conflicts. It is also"
,"useful if `darcs apply` or `darcs pull` is called with"
,"`--allow-conflicts`, where conflicts aren't marked initially."
,""
,"Unless you use the `--dry-run` flag, any unrecorded changes to the"
,"affected files WILL be lost forever when you run this command!"
,"You will be prompted for confirmation before this takes place."
]
markconflicts :: DarcsCommand [DarcsFlag]
markconflicts :: DarcsCommand [DarcsFlag]
markconflicts = DarcsCommand :: forall parsedFlags.
String
-> String
-> String
-> String
-> Int
-> [String]
-> ((AbsolutePath, AbsolutePath)
-> parsedFlags -> [String] -> IO ())
-> ([DarcsFlag] -> IO (Either String ()))
-> ((AbsolutePath, AbsolutePath)
-> [DarcsFlag] -> [String] -> IO [String])
-> ([DarcsFlag] -> AbsolutePath -> [String] -> IO [String])
-> [DarcsOptDescr DarcsFlag]
-> [DarcsOptDescr DarcsFlag]
-> [DarcsFlag]
-> ([DarcsFlag] -> [String])
-> ([DarcsFlag] -> parsedFlags)
-> DarcsCommand parsedFlags
DarcsCommand
{ commandProgramName :: String
commandProgramName = "darcs"
, commandName :: String
commandName = "mark-conflicts"
, commandHelp :: String
commandHelp = String
markconflictsHelp
, commandDescription :: String
commandDescription = String
markconflictsDescription
, commandExtraArgs :: Int
commandExtraArgs = -1
, commandExtraArgHelp :: [String]
commandExtraArgHelp = ["[FILE or DIRECTORY]..."]
, commandCommand :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
commandCommand = (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
markconflictsCmd
, 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]
knownFileArgs
, commandArgdefaults :: [DarcsFlag] -> AbsolutePath -> [String] -> IO [String]
commandArgdefaults = [DarcsFlag] -> AbsolutePath -> [String] -> IO [String]
nodefaults
, commandAdvancedOptions :: [DarcsOptDescr DarcsFlag]
commandAdvancedOptions = OptSpec DarcsOptDescr DarcsFlag Any (UMask -> Any)
-> [DarcsOptDescr DarcsFlag]
forall (d :: * -> *) f a b. OptSpec d f a b -> [d f]
odesc OptSpec DarcsOptDescr DarcsFlag Any (UMask -> Any)
forall a. PrimOptSpec DarcsOptDescr DarcsFlag a UMask
markconflictsAdvancedOpts
, commandBasicOptions :: [DarcsOptDescr DarcsFlag]
commandBasicOptions = OptSpec
DarcsOptDescr
DarcsFlag
Any
(UseIndex
-> Maybe String -> DiffAlgorithm -> DryRun -> XmlOutput -> Any)
-> [DarcsOptDescr DarcsFlag]
forall (d :: * -> *) f a b. OptSpec d f a b -> [d f]
odesc OptSpec
DarcsOptDescr
DarcsFlag
Any
(UseIndex
-> Maybe String -> DiffAlgorithm -> DryRun -> XmlOutput -> Any)
forall a.
OptSpec
DarcsOptDescr
DarcsFlag
a
(UseIndex
-> Maybe String -> DiffAlgorithm -> DryRun -> XmlOutput -> a)
markconflictsBasicOpts
, commandDefaults :: [DarcsFlag]
commandDefaults = OptSpec
DarcsOptDescr
DarcsFlag
[DarcsFlag]
(UseIndex
-> Maybe String
-> DiffAlgorithm
-> DryRun
-> XmlOutput
-> Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UMask
-> UseCache
-> HooksConfig
-> [DarcsFlag])
-> [DarcsFlag]
forall (d :: * -> *) f b. OptSpec d f [f] b -> [f]
defaultFlags OptSpec
DarcsOptDescr
DarcsFlag
[DarcsFlag]
(UseIndex
-> Maybe String
-> DiffAlgorithm
-> DryRun
-> XmlOutput
-> Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UMask
-> UseCache
-> HooksConfig
-> [DarcsFlag])
forall a.
DarcsOption
a
(UseIndex
-> Maybe String
-> DiffAlgorithm
-> DryRun
-> XmlOutput
-> Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UMask
-> UseCache
-> HooksConfig
-> a)
markconflictsOpts
, commandCheckOptions :: [DarcsFlag] -> [String]
commandCheckOptions = OptSpec
DarcsOptDescr
DarcsFlag
Any
(UseIndex
-> Maybe String
-> DiffAlgorithm
-> DryRun
-> XmlOutput
-> Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UMask
-> UseCache
-> HooksConfig
-> Any)
-> [DarcsFlag] -> [String]
forall (d :: * -> *) f a b. OptSpec d f a b -> [f] -> [String]
ocheck OptSpec
DarcsOptDescr
DarcsFlag
Any
(UseIndex
-> Maybe String
-> DiffAlgorithm
-> DryRun
-> XmlOutput
-> Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UMask
-> UseCache
-> HooksConfig
-> Any)
forall a.
DarcsOption
a
(UseIndex
-> Maybe String
-> DiffAlgorithm
-> DryRun
-> XmlOutput
-> Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UMask
-> UseCache
-> HooksConfig
-> a)
markconflictsOpts
, commandParseOptions :: [DarcsFlag] -> [DarcsFlag]
commandParseOptions = OptSpec
DarcsOptDescr
DarcsFlag
[DarcsFlag]
(UseIndex
-> Maybe String
-> DiffAlgorithm
-> DryRun
-> XmlOutput
-> Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UMask
-> UseCache
-> HooksConfig
-> [DarcsFlag])
-> [DarcsFlag] -> [DarcsFlag]
forall (d :: * -> *) f b. OptSpec d f [f] b -> [f] -> [f]
onormalise OptSpec
DarcsOptDescr
DarcsFlag
[DarcsFlag]
(UseIndex
-> Maybe String
-> DiffAlgorithm
-> DryRun
-> XmlOutput
-> Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UMask
-> UseCache
-> HooksConfig
-> [DarcsFlag])
forall a.
DarcsOption
a
(UseIndex
-> Maybe String
-> DiffAlgorithm
-> DryRun
-> XmlOutput
-> Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UMask
-> UseCache
-> HooksConfig
-> a)
markconflictsOpts
}
where
markconflictsBasicOpts :: OptSpec
DarcsOptDescr
DarcsFlag
a
(UseIndex
-> Maybe String -> DiffAlgorithm -> DryRun -> XmlOutput -> a)
markconflictsBasicOpts
= PrimOptSpec
DarcsOptDescr
DarcsFlag
(Maybe String -> DiffAlgorithm -> DryRun -> XmlOutput -> a)
UseIndex
PrimDarcsOption UseIndex
O.useIndex
PrimOptSpec
DarcsOptDescr
DarcsFlag
(Maybe String -> DiffAlgorithm -> DryRun -> XmlOutput -> a)
UseIndex
-> OptSpec
DarcsOptDescr
DarcsFlag
(DiffAlgorithm -> DryRun -> XmlOutput -> a)
(Maybe String -> DiffAlgorithm -> DryRun -> XmlOutput -> a)
-> OptSpec
DarcsOptDescr
DarcsFlag
(DiffAlgorithm -> DryRun -> XmlOutput -> a)
(UseIndex
-> Maybe String -> DiffAlgorithm -> DryRun -> XmlOutput -> a)
forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ OptSpec
DarcsOptDescr
DarcsFlag
(DiffAlgorithm -> DryRun -> XmlOutput -> a)
(Maybe String -> DiffAlgorithm -> DryRun -> XmlOutput -> a)
PrimDarcsOption (Maybe String)
O.repoDir
OptSpec
DarcsOptDescr
DarcsFlag
(DiffAlgorithm -> DryRun -> XmlOutput -> a)
(UseIndex
-> Maybe String -> DiffAlgorithm -> DryRun -> XmlOutput -> a)
-> OptSpec
DarcsOptDescr
DarcsFlag
(DryRun -> XmlOutput -> a)
(DiffAlgorithm -> DryRun -> XmlOutput -> a)
-> OptSpec
DarcsOptDescr
DarcsFlag
(DryRun -> XmlOutput -> a)
(UseIndex
-> Maybe String -> DiffAlgorithm -> DryRun -> XmlOutput -> a)
forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ OptSpec
DarcsOptDescr
DarcsFlag
(DryRun -> XmlOutput -> a)
(DiffAlgorithm -> DryRun -> XmlOutput -> a)
PrimDarcsOption DiffAlgorithm
O.diffAlgorithm
OptSpec
DarcsOptDescr
DarcsFlag
(DryRun -> XmlOutput -> a)
(UseIndex
-> Maybe String -> DiffAlgorithm -> DryRun -> XmlOutput -> a)
-> OptSpec DarcsOptDescr DarcsFlag a (DryRun -> XmlOutput -> a)
-> OptSpec
DarcsOptDescr
DarcsFlag
a
(UseIndex
-> Maybe String -> DiffAlgorithm -> DryRun -> XmlOutput -> a)
forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ OptSpec DarcsOptDescr DarcsFlag a (DryRun -> XmlOutput -> a)
forall a. DarcsOption a (DryRun -> XmlOutput -> a)
O.dryRunXml
markconflictsAdvancedOpts :: PrimOptSpec DarcsOptDescr DarcsFlag a UMask
markconflictsAdvancedOpts = PrimOptSpec DarcsOptDescr DarcsFlag a UMask
forall a. PrimOptSpec DarcsOptDescr DarcsFlag a UMask
O.umask
markconflictsOpts :: DarcsOption
a
(UseIndex
-> Maybe String
-> DiffAlgorithm
-> DryRun
-> XmlOutput
-> Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UMask
-> UseCache
-> HooksConfig
-> a)
markconflictsOpts = OptSpec
DarcsOptDescr
DarcsFlag
(Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UMask
-> UseCache
-> HooksConfig
-> a)
(UseIndex
-> Maybe String
-> DiffAlgorithm
-> DryRun
-> XmlOutput
-> Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UMask
-> UseCache
-> HooksConfig
-> a)
forall a.
OptSpec
DarcsOptDescr
DarcsFlag
a
(UseIndex
-> Maybe String -> DiffAlgorithm -> DryRun -> XmlOutput -> a)
markconflictsBasicOpts OptSpec
DarcsOptDescr
DarcsFlag
(Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UMask
-> UseCache
-> HooksConfig
-> a)
(UseIndex
-> Maybe String
-> DiffAlgorithm
-> DryRun
-> XmlOutput
-> Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UMask
-> UseCache
-> HooksConfig
-> a)
-> DarcsOption
(UseCache -> HooksConfig -> a)
(UMask -> UseCache -> HooksConfig -> a)
-> DarcsOption
a
(UseIndex
-> Maybe String
-> DiffAlgorithm
-> DryRun
-> XmlOutput
-> Maybe StdCmdAction
-> Bool
-> Bool
-> Verbosity
-> Bool
-> UMask
-> UseCache
-> HooksConfig
-> a)
forall b c a.
DarcsOption
(Maybe StdCmdAction -> Bool -> Bool -> Verbosity -> Bool -> b) c
-> DarcsOption (UseCache -> HooksConfig -> a) b -> DarcsOption a c
`withStdOpts` DarcsOption
(UseCache -> HooksConfig -> a)
(UMask -> UseCache -> HooksConfig -> a)
forall a. PrimOptSpec DarcsOptDescr DarcsFlag a UMask
markconflictsAdvancedOpts
markconflictsCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
markconflictsCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
markconflictsCmd fps :: (AbsolutePath, AbsolutePath)
fps opts :: [DarcsFlag]
opts args :: [String]
args = do
Only [SubPath]
paths <- if [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
args then Only [SubPath] -> IO (Only [SubPath])
forall (m :: * -> *) a. Monad m => a -> m a
return Only [SubPath]
forall a. Only a
Everything else [SubPath] -> Only [SubPath]
sps2ps ([SubPath] -> Only [SubPath])
-> IO [SubPath] -> IO (Only [SubPath])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (AbsolutePath, AbsolutePath) -> [String] -> IO [SubPath]
fixSubPaths (AbsolutePath, AbsolutePath)
fps [String]
args
Doc -> IO ()
debugDocLn (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ "::: paths =" Doc -> Doc -> Doc
<+> (String -> Doc
text (String -> Doc)
-> (Only [SubPath] -> String) -> Only [SubPath] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Only [SubPath] -> String
forall a. Show a => a -> String
show) Only [SubPath]
paths
DryRun -> UseCache -> UpdateWorking -> UMask -> RepoJob () -> IO ()
forall a.
DryRun -> UseCache -> UpdateWorking -> UMask -> RepoJob a -> IO a
withRepoLock (PrimDarcsOption DryRun
dryRun PrimDarcsOption DryRun -> [DarcsFlag] -> DryRun
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) (PrimDarcsOption UseCache
useCache PrimDarcsOption UseCache -> [DarcsFlag] -> UseCache
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) UpdateWorking
YesUpdateWorking (forall a. PrimOptSpec DarcsOptDescr DarcsFlag a UMask
umask (forall a. PrimOptSpec DarcsOptDescr DarcsFlag a UMask)
-> [DarcsFlag] -> UMask
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) (RepoJob () -> IO ()) -> RepoJob () -> IO ()
forall a b. (a -> b) -> a -> b
$ (forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR -> IO ())
-> RepoJob ()
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 (rt :: RepoType) (p :: * -> * -> *) wR wU.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR -> IO ())
-> RepoJob ())
-> (forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR -> IO ())
-> RepoJob ()
forall a b. (a -> b) -> a -> b
$ \repository :: Repository rt p wR wU wR
repository -> do
let (useidx :: UseIndex
useidx, scan :: ScanKnown
scan, _) = [DarcsFlag] -> (UseIndex, ScanKnown, DiffAlgorithm)
diffingOpts [DarcsFlag]
opts
verb :: Verbosity
verb = PrimDarcsOption Verbosity
verbosity PrimDarcsOption Verbosity -> [DarcsFlag] -> Verbosity
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts
Only ([SubPath], [SubPath])
classified_paths <-
([SubPath] -> IO ([SubPath], [SubPath]))
-> Only [SubPath] -> IO (Only ([SubPath], [SubPath]))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Repository rt p wR wU wR
-> Verbosity
-> UseIndex
-> ScanKnown
-> LookForMoves
-> [SubPath]
-> IO ([SubPath], [SubPath])
forall (p :: * -> * -> *) (rt :: RepoType) wR wU wT.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wT
-> Verbosity
-> UseIndex
-> ScanKnown
-> LookForMoves
-> [SubPath]
-> IO ([SubPath], [SubPath])
filterExistingPaths Repository rt p wR wU wR
repository Verbosity
verb UseIndex
useidx ScanKnown
scan LookForMoves
O.NoLookForMoves) Only [SubPath]
paths
FL (PrimOf p) wR wU
unrecorded <- (UseIndex, ScanKnown, DiffAlgorithm)
-> LookForMoves
-> LookForReplaces
-> Repository rt p wR wU wR
-> Maybe [SubPath]
-> IO (FL (PrimOf p) wR wU)
forall (p :: * -> * -> *) (rt :: RepoType) wR wU wT.
(RepoPatch p, ApplyState p ~ Tree) =>
(UseIndex, ScanKnown, DiffAlgorithm)
-> LookForMoves
-> LookForReplaces
-> Repository rt p wR wU wT
-> Maybe [SubPath]
-> IO (FL (PrimOf p) wT wU)
unrecordedChanges ([DarcsFlag] -> (UseIndex, ScanKnown, DiffAlgorithm)
diffingOpts [DarcsFlag]
opts)
LookForMoves
O.NoLookForMoves LookForReplaces
O.NoLookForReplaces
Repository rt p wR wU wR
repository (Only [SubPath] -> Maybe [SubPath]
forall a. Only a -> Maybe a
fromOnly Only [SubPath]
forall a. Only a
Everything)
let forward_renames :: Only [SubPath] -> Only [SubPath]
forward_renames = ([String] -> [String]) -> Only [SubPath] -> Only [SubPath]
liftToPathSet (FL (PrimOf p) wR wU -> [String] -> [String]
forall (p :: * -> * -> *) wX wY.
(Apply p, ApplyState p ~ Tree) =>
p wX wY -> [String] -> [String]
effectOnFilePaths FL (PrimOf p) wR wU
unrecorded)
backward_renames :: Only [SubPath] -> Only [SubPath]
backward_renames = ([String] -> [String]) -> Only [SubPath] -> Only [SubPath]
liftToPathSet (FL (PrimOf p) wU wR -> [String] -> [String]
forall (p :: * -> * -> *) wX wY.
(Apply p, ApplyState p ~ Tree) =>
p wX wY -> [String] -> [String]
effectOnFilePaths (FL (PrimOf p) wR wU -> FL (PrimOf p) wU wR
forall (p :: * -> * -> *) wX wY. Invert p => p wX wY -> p wY wX
invert FL (PrimOf p) wR wU
unrecorded))
existing_paths :: Only [SubPath]
existing_paths = (([SubPath], [SubPath]) -> [SubPath])
-> Only ([SubPath], [SubPath]) -> Only [SubPath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([SubPath], [SubPath]) -> [SubPath]
forall a b. (a, b) -> b
snd Only ([SubPath], [SubPath])
classified_paths
pre_pending_paths :: Only [SubPath]
pre_pending_paths = Only [SubPath] -> Only [SubPath]
backward_renames Only [SubPath]
existing_paths
Doc -> IO ()
debugDocLn (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ "::: pre_pending_paths =" Doc -> Doc -> Doc
<+> (String -> Doc
text (String -> Doc)
-> (Only [SubPath] -> String) -> Only [SubPath] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Only [SubPath] -> String
forall a. Show a => a -> String
show) Only [SubPath]
pre_pending_paths
PatchSet rt p Origin wR
r <- Repository rt p wR wU wR -> IO (PatchSet rt p Origin wR)
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
Sealed res :: FL (PrimOf p) wR wX
res <- case PatchSet rt p Origin wR -> Sealed (FL (PrimOf p) wR)
forall (p :: * -> * -> *) (rt :: RepoType) wX.
RepoPatch p =>
PatchSet rt p Origin wX -> Sealed (FL (PrimOf p) wX)
patchsetConflictResolutions PatchSet rt p Origin wR
r of
Sealed raw_res :: FL (PrimOf p) wR wX
raw_res -> do
let raw_res_paths :: Only [SubPath]
raw_res_paths = [String] -> Only [SubPath]
fps2ps (FL (PrimOf p) wR wX -> [String]
forall (p :: * -> * -> *) wX wY.
PatchInspect p =>
p wX wY -> [String]
listTouchedFiles FL (PrimOf p) wR wX
raw_res)
Doc -> IO ()
debugDocLn (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ "::: raw_res_paths =" Doc -> Doc -> Doc
<+> (String -> Doc
text (String -> Doc)
-> (Only [SubPath] -> String) -> Only [SubPath] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Only [SubPath] -> String
forall a. Show a => a -> String
show) Only [SubPath]
raw_res_paths
Sealed (FL (PrimOf p) wR) -> IO (Sealed (FL (PrimOf p) wR))
forall (m :: * -> *) a. Monad m => a -> m a
return (Sealed (FL (PrimOf p) wR) -> IO (Sealed (FL (PrimOf p) wR)))
-> Sealed (FL (PrimOf p) wR) -> IO (Sealed (FL (PrimOf p) wR))
forall a b. (a -> b) -> a -> b
$ Maybe [String] -> FL (PrimOf p) wR wX -> Sealed (FL (PrimOf p) wR)
forall (p :: * -> * -> *) wX wY.
(Apply p, Commute p, PatchInspect p, ApplyState p ~ Tree) =>
Maybe [String] -> FL p wX wY -> Sealed (FL p wX)
chooseTouching (Only [SubPath] -> Maybe [String]
ps2fps Only [SubPath]
pre_pending_paths) FL (PrimOf p) wR wX
raw_res
let res_paths :: Only [SubPath]
res_paths = [String] -> Only [SubPath]
fps2ps (FL (PrimOf p) wR wX -> [String]
forall (p :: * -> * -> *) wX wY.
PatchInspect p =>
p wX wY -> [String]
listTouchedFiles FL (PrimOf p) wR wX
res)
Doc -> IO ()
debugDocLn (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ "::: res_paths =" Doc -> Doc -> Doc
<+> (String -> Doc
text (String -> Doc)
-> (Only [SubPath] -> String) -> Only [SubPath] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Only [SubPath] -> String
forall a. Show a => a -> String
show) Only [SubPath]
res_paths
let affected_paths :: Only [SubPath]
affected_paths = Only [SubPath] -> Only [SubPath] -> Only [SubPath]
isectPathSet Only [SubPath]
res_paths Only [SubPath]
pre_pending_paths
Doc -> IO ()
debugDocLn (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ "::: affected_paths =" Doc -> Doc -> Doc
<+> (String -> Doc
text (String -> Doc)
-> (Only [SubPath] -> String) -> Only [SubPath] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Only [SubPath] -> String
forall a. Show a => a -> String
show) Only [SubPath]
affected_paths
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Only [SubPath]
affected_paths Only [SubPath] -> Only [SubPath] -> Bool
forall a. Eq a => a -> a -> Bool
== [SubPath] -> Only [SubPath]
forall a. a -> Only a
Only []) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
[DarcsFlag] -> Doc -> IO ()
putInfo [DarcsFlag]
opts "No conflicts to mark."
IO ()
forall a. IO a
exitSuccess
FL (PrimOf p) wR wU
to_revert <- (UseIndex, ScanKnown, DiffAlgorithm)
-> LookForMoves
-> LookForReplaces
-> Repository rt p wR wU wR
-> Maybe [SubPath]
-> IO (FL (PrimOf p) wR wU)
forall (p :: * -> * -> *) (rt :: RepoType) wR wU wT.
(RepoPatch p, ApplyState p ~ Tree) =>
(UseIndex, ScanKnown, DiffAlgorithm)
-> LookForMoves
-> LookForReplaces
-> Repository rt p wR wU wT
-> Maybe [SubPath]
-> IO (FL (PrimOf p) wT wU)
unrecordedChanges ([DarcsFlag] -> (UseIndex, ScanKnown, DiffAlgorithm)
diffingOpts [DarcsFlag]
opts)
LookForMoves
O.NoLookForMoves LookForReplaces
O.NoLookForReplaces
Repository rt p wR wU wR
repository (Only [SubPath] -> Maybe [SubPath]
forall a. Only a -> Maybe a
fromOnly Only [SubPath]
affected_paths)
let post_pending_affected_paths :: Only [SubPath]
post_pending_affected_paths = Only [SubPath] -> Only [SubPath]
forward_renames Only [SubPath]
affected_paths
[DarcsFlag] -> Doc -> IO ()
putInfo [DarcsFlag]
opts (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ "Marking conflicts in:" Doc -> Doc -> Doc
<+> Only [SubPath] -> Doc
showPathSet Only [SubPath]
post_pending_affected_paths Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> "."
Doc -> IO ()
debugDocLn (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ "::: to_revert =" Doc -> Doc -> Doc
$$ [Doc] -> Doc
vsep ((forall wW wZ. PrimOf p wW wZ -> Doc)
-> FL (PrimOf p) wR wU -> [Doc]
forall (a :: * -> * -> *) b wX wY.
(forall wW wZ. a wW wZ -> b) -> FL a wX wY -> [b]
mapFL forall wW wZ. PrimOf p wW wZ -> Doc
forall (p :: * -> * -> *) wX wY. ShowPatchBasic p => p wX wY -> Doc
displayPatch FL (PrimOf p) wR wU
to_revert)
Doc -> IO ()
debugDocLn (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ "::: res = " Doc -> Doc -> Doc
$$ [Doc] -> Doc
vsep ((forall wW wZ. PrimOf p wW wZ -> Doc)
-> FL (PrimOf p) wR wX -> [Doc]
forall (a :: * -> * -> *) b wX wY.
(forall wW wZ. a wW wZ -> b) -> FL a wX wY -> [b]
mapFL forall wW wZ. PrimOf p wW wZ -> Doc
forall (p :: * -> * -> *) wX wY. ShowPatchBasic p => p wX wY -> Doc
displayPatch FL (PrimOf p) wR wX
res)
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (DryRun -> Bool
forall a. YesNo a => a -> Bool
O.yes (PrimDarcsOption DryRun
dryRun PrimDarcsOption DryRun -> [DarcsFlag] -> DryRun
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts)) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
[DarcsFlag] -> Doc -> IO ()
putInfo [DarcsFlag]
opts (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ "Conflicts will not be marked: this is a dry run."
IO ()
forall a. IO a
exitSuccess
Repository rt p wR wR wR
repository' <- case FL (PrimOf p) wR wU
to_revert of
NilFL -> Repository rt p wR wU wR -> IO (Repository rt p wR wU wR)
forall (m :: * -> *) a. Monad m => a -> m a
return Repository rt p wR wU wR
repository
_ -> do
Printers -> Doc -> IO ()
putDocLnWith Printers
fancyPrinters (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$
"Warning: This will revert all unrecorded changes in:"
Doc -> Doc -> Doc
<+> Only [SubPath] -> Doc
showPathSet Only [SubPath]
post_pending_affected_paths Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> "."
Doc -> Doc -> Doc
$$ String -> Doc
redText "These changes will be LOST."
Bool
confirmed <- String -> IO Bool
promptYorn "Are you sure? "
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
confirmed IO ()
forall a. IO a
exitSuccess
let to_add :: FL (PrimOf p) wU wR
to_add = FL (PrimOf p) wR wU -> FL (PrimOf p) wU wR
forall (p :: * -> * -> *) wX wY. Invert p => p wX wY -> p wY wX
invert FL (PrimOf p) wR wU
to_revert
Repository rt p wR wU wR
-> UpdateWorking -> FL (PrimOf p) wU wR -> IO ()
forall (p :: * -> * -> *) (rt :: RepoType) wR wU wT wY.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wT
-> UpdateWorking -> FL (PrimOf p) wU wY -> IO ()
addToPending Repository rt p wR wU wR
repository UpdateWorking
YesUpdateWorking FL (PrimOf p) wU wR
to_add
Repository rt p wR wU wR
-> Verbosity
-> FL (PrimOf p) wU wR
-> IO (Repository rt p wR wR wR)
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 wR wU wR
repository (PrimDarcsOption Verbosity
verbosity PrimDarcsOption Verbosity -> [DarcsFlag] -> Verbosity
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) FL (PrimOf p) wU wR
to_add IO (Repository rt p wR wR wR)
-> (IOException -> IO (Repository rt p wR wR wR))
-> IO (Repository rt p wR wR wR)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \(IOException
e :: IOException) ->
String -> IO (Repository rt p wR wR wR)
forall a. String -> a
bug ("Can't undo pending changes!" String -> String -> String
forall a. [a] -> [a] -> [a]
++ IOException -> String
forall a. Show a => a -> String
show IOException
e)
IO () -> IO ()
forall a. IO a -> IO a
withSignalsBlocked (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
do Repository rt p wR wR wR
-> UpdateWorking -> FL (PrimOf p) wR wX -> IO ()
forall (p :: * -> * -> *) (rt :: RepoType) wR wU wT wY.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wT
-> UpdateWorking -> FL (PrimOf p) wU wY -> IO ()
addToPending Repository rt p wR wR wR
repository' UpdateWorking
YesUpdateWorking FL (PrimOf p) wR wX
res
Repository rt p wR wX wR
_ <- Repository rt p wR wR wR
-> Verbosity
-> FL (PrimOf p) wR wX
-> IO (Repository rt p wR wX wR)
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 wR wR wR
repository' (PrimDarcsOption Verbosity
verbosity PrimDarcsOption Verbosity -> [DarcsFlag] -> Verbosity
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) FL (PrimOf p) wR wX
res IO (Repository rt p wR wX wR)
-> (IOException -> IO (Repository rt p wR wX wR))
-> IO (Repository rt p wR wX wR)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \(IOException
e :: IOException) ->
String -> IO (Repository rt p wR wX wR)
forall a. String -> a
bug ("Problem marking conflicts in mark-conflicts!" String -> String -> String
forall a. [a] -> [a] -> [a]
++ IOException -> String
forall a. Show a => a -> String
show IOException
e)
() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
[DarcsFlag] -> Doc -> IO ()
putInfo [DarcsFlag]
opts "Finished marking conflicts."
data Only a = Everything | Only a deriving (Only a -> Only a -> Bool
(Only a -> Only a -> Bool)
-> (Only a -> Only a -> Bool) -> Eq (Only a)
forall a. Eq a => Only a -> Only a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Only a -> Only a -> Bool
$c/= :: forall a. Eq a => Only a -> Only a -> Bool
== :: Only a -> Only a -> Bool
$c== :: forall a. Eq a => Only a -> Only a -> Bool
Eq, Eq (Only a)
Eq (Only a) =>
(Only a -> Only a -> Ordering)
-> (Only a -> Only a -> Bool)
-> (Only a -> Only a -> Bool)
-> (Only a -> Only a -> Bool)
-> (Only a -> Only a -> Bool)
-> (Only a -> Only a -> Only a)
-> (Only a -> Only a -> Only a)
-> Ord (Only a)
Only a -> Only a -> Bool
Only a -> Only a -> Ordering
Only a -> Only a -> Only a
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall a. Ord a => Eq (Only a)
forall a. Ord a => Only a -> Only a -> Bool
forall a. Ord a => Only a -> Only a -> Ordering
forall a. Ord a => Only a -> Only a -> Only a
min :: Only a -> Only a -> Only a
$cmin :: forall a. Ord a => Only a -> Only a -> Only a
max :: Only a -> Only a -> Only a
$cmax :: forall a. Ord a => Only a -> Only a -> Only a
>= :: Only a -> Only a -> Bool
$c>= :: forall a. Ord a => Only a -> Only a -> Bool
> :: Only a -> Only a -> Bool
$c> :: forall a. Ord a => Only a -> Only a -> Bool
<= :: Only a -> Only a -> Bool
$c<= :: forall a. Ord a => Only a -> Only a -> Bool
< :: Only a -> Only a -> Bool
$c< :: forall a. Ord a => Only a -> Only a -> Bool
compare :: Only a -> Only a -> Ordering
$ccompare :: forall a. Ord a => Only a -> Only a -> Ordering
$cp1Ord :: forall a. Ord a => Eq (Only a)
Ord, Int -> Only a -> String -> String
[Only a] -> String -> String
Only a -> String
(Int -> Only a -> String -> String)
-> (Only a -> String)
-> ([Only a] -> String -> String)
-> Show (Only a)
forall a. Show a => Int -> Only a -> String -> String
forall a. Show a => [Only a] -> String -> String
forall a. Show a => Only a -> String
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [Only a] -> String -> String
$cshowList :: forall a. Show a => [Only a] -> String -> String
show :: Only a -> String
$cshow :: forall a. Show a => Only a -> String
showsPrec :: Int -> Only a -> String -> String
$cshowsPrec :: forall a. Show a => Int -> Only a -> String -> String
Show)
instance Functor Only where
fmap :: (a -> b) -> Only a -> Only b
fmap _ Everything = Only b
forall a. Only a
Everything
fmap f :: a -> b
f (Only x :: a
x) = b -> Only b
forall a. a -> Only a
Only (a -> b
f a
x)
instance Foldable Only where
foldMap :: (a -> m) -> Only a -> m
foldMap _ Everything = m
forall a. Monoid a => a
mempty
foldMap f :: a -> m
f (Only x :: a
x) = a -> m
f a
x
instance Traversable Only where
traverse :: (a -> f b) -> Only a -> f (Only b)
traverse _ Everything = Only b -> f (Only b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Only b
forall a. Only a
Everything
traverse f :: a -> f b
f (Only x :: a
x) = b -> Only b
forall a. a -> Only a
Only (b -> Only b) -> f b -> f (Only b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> f b
f a
x
fromOnly :: Only a -> Maybe a
fromOnly :: Only a -> Maybe a
fromOnly Everything = Maybe a
forall a. Maybe a
Nothing
fromOnly (Only x :: a
x) = a -> Maybe a
forall a. a -> Maybe a
Just a
x
type PathSet = Only [SubPath]
isectPathSet :: PathSet -> PathSet -> PathSet
isectPathSet :: Only [SubPath] -> Only [SubPath] -> Only [SubPath]
isectPathSet Everything ys :: Only [SubPath]
ys = Only [SubPath]
ys
isectPathSet xs :: Only [SubPath]
xs Everything = Only [SubPath]
xs
isectPathSet (Only xs :: [SubPath]
xs) (Only ys :: [SubPath]
ys) = [SubPath] -> Only [SubPath]
forall a. a -> Only a
Only ([SubPath] -> [SubPath] -> [SubPath]
forall a. Ord a => [a] -> [a] -> [a]
isect [SubPath]
xs [SubPath]
ys)
sps2ps :: [SubPath] -> PathSet
sps2ps :: [SubPath] -> Only [SubPath]
sps2ps = [SubPath] -> Only [SubPath]
forall a. a -> Only a
Only ([SubPath] -> Only [SubPath])
-> ([SubPath] -> [SubPath]) -> [SubPath] -> Only [SubPath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [SubPath] -> [SubPath]
forall a. Ord a => [a] -> [a]
nubSort
fps2ps :: [FilePath] -> PathSet
fps2ps :: [String] -> Only [SubPath]
fps2ps = [SubPath] -> Only [SubPath]
sps2ps ([SubPath] -> Only [SubPath])
-> ([String] -> [SubPath]) -> [String] -> Only [SubPath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> SubPath) -> [String] -> [SubPath]
forall a b. (a -> b) -> [a] -> [b]
map String -> SubPath
fp2sp
ps2fps :: PathSet -> Maybe [FilePath]
ps2fps :: Only [SubPath] -> Maybe [String]
ps2fps = ([SubPath] -> [String]) -> Maybe [SubPath] -> Maybe [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((SubPath -> String) -> [SubPath] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map SubPath -> String
sp2fp) (Maybe [SubPath] -> Maybe [String])
-> (Only [SubPath] -> Maybe [SubPath])
-> Only [SubPath]
-> Maybe [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Only [SubPath] -> Maybe [SubPath]
forall a. Only a -> Maybe a
fromOnly
showPathSet :: Only [SubPath] -> Doc
showPathSet :: Only [SubPath] -> Doc
showPathSet Everything = String -> Doc
text "all paths"
showPathSet (Only xs :: [SubPath]
xs) = [String] -> Doc
pathlist ((SubPath -> String) -> [SubPath] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map SubPath -> String
sp2fp [SubPath]
xs)
liftToPathSet :: ([FilePath] -> [FilePath]) -> PathSet -> PathSet
liftToPathSet :: ([String] -> [String]) -> Only [SubPath] -> Only [SubPath]
liftToPathSet f :: [String] -> [String]
f = ([SubPath] -> [SubPath]) -> Only [SubPath] -> Only [SubPath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([SubPath] -> [SubPath]
forall a. Ord a => [a] -> [a]
nubSort ([SubPath] -> [SubPath])
-> ([SubPath] -> [SubPath]) -> [SubPath] -> [SubPath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> SubPath) -> [String] -> [SubPath]
forall a b. (a -> b) -> [a] -> [b]
map String -> SubPath
fp2sp ([String] -> [SubPath])
-> ([SubPath] -> [String]) -> [SubPath] -> [SubPath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> [String]
f ([String] -> [String])
-> ([SubPath] -> [String]) -> [SubPath] -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SubPath -> String) -> [SubPath] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map SubPath -> String
sp2fp)
fp2sp :: FilePath -> SubPath
fp2sp :: String -> SubPath
fp2sp = Maybe SubPath -> SubPath
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe SubPath -> SubPath)
-> (String -> Maybe SubPath) -> String -> SubPath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe SubPath
simpleSubPath
sp2fp :: SubPath -> FilePath
sp2fp :: SubPath -> String
sp2fp = SubPath -> String
forall a. FilePathLike a => a -> String
toFilePath