module Darcs.Repository.Merge
( tentativelyMergePatches
, considerMergeToWorking
) where
import Darcs.Prelude
import Control.Monad ( when, unless )
import System.Exit ( exitSuccess )
import System.IO.Error
( catchIOError
, ioeGetErrorType
, isIllegalOperationErrorType
)
import Darcs.Util.Tree( Tree )
import Darcs.Util.External ( backupByCopying )
import Darcs.Patch
( RepoPatch, IsRepoType, PrimOf, merge
, effect
, listConflictedFiles )
import Darcs.Patch.Apply ( ApplyState )
import Darcs.Patch.Ident ( merge2FL )
import Darcs.Patch.Named ( patchcontents, anonymous )
import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, n2pia, hopefully )
import Darcs.Patch.Progress( progressFL )
import Darcs.Patch.Set ( PatchSet, Origin, patchSet2RL )
import Darcs.Patch.Witnesses.Ordered
( FL(..), RL(..), Fork(..), (:\/:)(..), (:/\:)(..), (+>+), (+<<+)
, mapFL_FL, concatFL, reverseFL )
import Darcs.Patch.Witnesses.Sealed ( Sealed(Sealed), seal )
import Darcs.Repository.Flags
( UseIndex
, ScanKnown
, AllowConflicts (..)
, Reorder (..)
, UpdatePending (..)
, ExternalMerge (..)
, Verbosity (..)
, Compression (..)
, WantGuiPause (..)
, DiffAlgorithm (..)
, LookForMoves(..)
, LookForReplaces(..)
)
import Darcs.Repository.Hashed
( tentativelyAddPatches_
, tentativelyRemovePatches_
, UpdatePristine(..)
)
import Darcs.Repository.Pristine
( applyToTentativePristine
, ApplyDir(..)
)
import Darcs.Repository.InternalTypes ( Repository, repoLocation )
import Darcs.Repository.Pending ( setTentativePending )
import Darcs.Repository.Resolution
( externalResolution
, standardResolution
, StandardResolution(..)
, announceConflicts
)
import Darcs.Repository.State ( unrecordedChanges, readUnrecorded )
import Darcs.Util.Prompt ( promptYorn )
import Darcs.Util.Path ( anchorPath, displayPath )
import Darcs.Util.Progress( debugMessage )
import Darcs.Util.Printer.Color ( ePutDocLn )
import Darcs.Util.Printer ( redText, vcat )
data MakeChanges = MakeChanges | DontMakeChanges deriving ( MakeChanges -> MakeChanges -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MakeChanges -> MakeChanges -> Bool
$c/= :: MakeChanges -> MakeChanges -> Bool
== :: MakeChanges -> MakeChanges -> Bool
$c== :: MakeChanges -> MakeChanges -> Bool
Eq )
tentativelyMergePatches_ :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)
=> MakeChanges
-> Repository rt p wR wU wR -> String
-> AllowConflicts
-> ExternalMerge -> WantGuiPause
-> Compression -> Verbosity -> Reorder
-> ( UseIndex, ScanKnown, DiffAlgorithm )
-> Fork (PatchSet rt p)
(FL (PatchInfoAnd rt p))
(FL (PatchInfoAnd rt p)) Origin wR wY
-> IO (Sealed (FL (PrimOf p) wU))
tentativelyMergePatches_ :: forall (rt :: RepoType) (p :: * -> * -> *) wR wU wY.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
MakeChanges
-> Repository rt p wR wU wR
-> String
-> AllowConflicts
-> ExternalMerge
-> WantGuiPause
-> Compression
-> Verbosity
-> Reorder
-> (UseIndex, ScanKnown, DiffAlgorithm)
-> Fork
(PatchSet rt p)
(FL (PatchInfoAnd rt p))
(FL (PatchInfoAnd rt p))
Origin
wR
wY
-> IO (Sealed (FL (PrimOf p) wU))
tentativelyMergePatches_ MakeChanges
mc Repository rt p wR wU wR
_repo String
cmd AllowConflicts
allowConflicts ExternalMerge
externalMerge WantGuiPause
wantGuiPause
Compression
compression Verbosity
verbosity Reorder
reorder diffingOpts :: (UseIndex, ScanKnown, DiffAlgorithm)
diffingOpts@(UseIndex
useidx, ScanKnown
_, DiffAlgorithm
dflag) (Fork PatchSet rt p Origin wU
context FL (PatchInfoAnd rt p) wU wR
us FL (PatchInfoAnd rt p) wU wY
them) = do
(FL (PatchInfoAnd rt p) wR wZ
them' :/\: FL (PatchInfoAnd rt p) wY wZ
us')
<- forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (p :: * -> * -> *) wX wY wZ.
(Commute p, Merge p, Ident p) =>
FL p wX wY -> FL p wX wZ -> (:/\:) (FL p) (FL p) wY wZ
merge2FL (forall (a :: * -> * -> *) wX wY. String -> FL a wX wY -> FL a wX wY
progressFL String
"Merging us" FL (PatchInfoAnd rt p) wU wR
us)
(forall (a :: * -> * -> *) wX wY. String -> FL a wX wY -> FL a wX wY
progressFL String
"Merging them" FL (PatchInfoAnd rt p) wU wY
them)
FL (PrimOf p) wR wU
pw <- 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, ScanKnown, DiffAlgorithm)
diffingOpts LookForMoves
NoLookForMoves LookForReplaces
NoLookForReplaces Repository rt p wR wU wR
_repo forall a. Maybe a
Nothing
PatchInfoAndG rt (Named p) wR wU
anonpw <- forall (p :: * -> * -> *) wX wY (rt :: RepoType).
(Ident p, PatchId p ~ PatchInfo) =>
p wX wY -> PatchInfoAndG rt p wX wY
n2pia forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` forall (p :: * -> * -> *) wX wY.
FromPrim p =>
FL (PrimOf p) wX wY -> IO (Named p wX wY)
anonymous FL (PrimOf p) wR wU
pw
FL (PatchInfoAnd rt p) wZ wZ
pw' :/\: FL (PatchInfoAnd rt p) wU wZ
them'' <- forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (p :: * -> * -> *) wX wY.
Merge p =>
(:\/:) p p wX wY -> (:/\:) p p wX wY
merge (FL (PatchInfoAnd rt p) wR wZ
them' forall (a1 :: * -> * -> *) (a2 :: * -> * -> *) wX wY wZ.
a1 wZ wX -> a2 wZ wY -> (:\/:) a1 a2 wX wY
:\/: PatchInfoAndG rt (Named p) wR wU
anonpw forall (a :: * -> * -> *) wX wY wZ.
a wX wY -> FL a wY wZ -> FL a wX wZ
:>: forall (a :: * -> * -> *) wX. FL a wX wX
NilFL)
let them''content :: FL p wU wZ
them''content = forall (a :: * -> * -> *) wX wZ. FL (FL a) wX wZ -> FL a wX wZ
concatFL forall a b. (a -> b) -> a -> b
$ forall (a :: * -> * -> *) wX wY. String -> FL a wX wY -> FL a wX wY
progressFL String
"Examining patches for conflicts" forall a b. (a -> b) -> a -> b
$
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 (p :: * -> * -> *) wX wY. Named p wX wY -> FL p wX wY
patchcontents forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (rt :: RepoType) (p :: * -> * -> *) wA wB.
PatchInfoAndG rt p wA wB -> p wA wB
hopefully) FL (PatchInfoAnd rt p) wU wZ
them''
let conflicts :: StandardResolution (PrimOf p) wZ
conflicts =
forall (p :: * -> * -> *) (rt :: RepoType) wO wX wY.
(Commute p, PrimPatchBase p, Conflict p) =>
RL (PatchInfoAnd rt p) wO wX
-> RL (PatchInfoAnd rt p) wX wY -> StandardResolution (PrimOf p) wY
standardResolution
(forall (rt :: RepoType) (p :: * -> * -> *) wStart wX.
PatchSet rt p wStart wX -> RL (PatchInfoAnd rt p) wStart wX
patchSet2RL PatchSet rt p Origin wU
context forall (p :: * -> * -> *) wX wY wZ.
RL p wX wY -> FL p wY wZ -> RL p wX wZ
+<<+ FL (PatchInfoAnd rt p) wU wR
us forall (a :: * -> * -> *) wX wY wZ.
RL a wX wY -> a wY wZ -> RL a wX wZ
:<: PatchInfoAndG rt (Named p) wR wU
anonpw)
(forall (a :: * -> * -> *) wX wZ. FL a wX wZ -> RL a wX wZ
reverseFL FL (PatchInfoAnd rt p) wU wZ
them'')
let standard_resolution :: Mangled (PrimOf p) wZ
standard_resolution = forall (prim :: * -> * -> *) wX.
StandardResolution prim wX -> Mangled prim wX
mangled StandardResolution (PrimOf p) wZ
conflicts
String -> IO ()
debugMessage String
"Checking for conflicts..."
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (AllowConflicts
allowConflicts forall a. Eq a => a -> a -> Bool
== AllowConflicts
YesAllowConflictsAndMark) forall a b. (a -> b) -> a -> b
$
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ String -> IO ()
backupByCopying forall a b. (a -> b) -> a -> b
$
forall a b. (a -> b) -> [a] -> [b]
map (String -> AnchoredPath -> String
anchorPath (forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> String
repoLocation Repository rt p wR wU wR
_repo)) forall a b. (a -> b) -> a -> b
$
forall (prim :: * -> * -> *) wX.
StandardResolution prim wX -> [AnchoredPath]
conflictedPaths StandardResolution (PrimOf p) wZ
conflicts
String -> IO ()
debugMessage String
"Announcing conflicts..."
Bool
have_conflicts <-
forall (prim :: * -> * -> *) wX.
PrimPatch prim =>
String
-> AllowConflicts
-> ExternalMerge
-> StandardResolution prim wX
-> IO Bool
announceConflicts String
cmd AllowConflicts
allowConflicts ExternalMerge
externalMerge StandardResolution (PrimOf p) wZ
conflicts
String -> IO ()
debugMessage String
"Checking for unrecorded conflicts..."
let pw'content :: FL p wZ wZ
pw'content = forall (a :: * -> * -> *) wX wZ. FL (FL a) wX wZ -> FL a wX wZ
concatFL forall a b. (a -> b) -> a -> b
$ forall (a :: * -> * -> *) wX wY. String -> FL a wX wY -> FL a wX wY
progressFL String
"Examining patches for conflicts" forall a b. (a -> b) -> a -> b
$
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 (p :: * -> * -> *) wX wY. Named p wX wY -> FL p wX wY
patchcontents forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (rt :: RepoType) (p :: * -> * -> *) wA wB.
PatchInfoAndG rt p wA wB -> p wA wB
hopefully) FL (PatchInfoAnd rt p) wZ wZ
pw'
case forall (p :: * -> * -> *) wX wY.
(Summary p, PatchInspect (PrimOf p)) =>
p wX wY -> [AnchoredPath]
listConflictedFiles FL p wZ wZ
pw'content of
[] -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
[AnchoredPath]
fs -> do
Doc -> IO ()
ePutDocLn forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
vcat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map String -> Doc
redText forall a b. (a -> b) -> a -> b
$
String
"You have conflicting unrecorded changes to:" forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map AnchoredPath -> String
displayPath [AnchoredPath]
fs
Bool
confirmed <- String -> IO Bool
promptYorn String
"Proceed?" forall a. IO a -> (IOError -> IO a) -> IO a
`catchIOError` (\IOError
e ->
if IOErrorType -> Bool
isIllegalOperationErrorType (IOError -> IOErrorType
ioeGetErrorType IOError
e)
then forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
else forall a. IOError -> IO a
ioError IOError
e)
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
confirmed forall a b. (a -> b) -> a -> b
$ do
String -> IO ()
putStrLn String
"Cancelled."
forall a. IO a
exitSuccess
String -> IO ()
debugMessage String
"Reading working tree..."
Tree IO
working <- forall (p :: * -> * -> *) (rt :: RepoType) wR wU.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR
-> UseIndex -> Maybe [AnchoredPath] -> IO (Tree IO)
readUnrecorded Repository rt p wR wU wR
_repo UseIndex
useidx forall a. Maybe a
Nothing
String -> IO ()
debugMessage String
"Working out conflict markup..."
Sealed FL (PrimOf p) wZ wX
resolution <-
case (ExternalMerge
externalMerge , Bool
have_conflicts) of
(ExternalMerge
NoExternalMerge, Bool
_) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ if AllowConflicts
allowConflicts forall a. Eq a => a -> a -> Bool
== AllowConflicts
YesAllowConflicts
then forall (a :: * -> *) wX. a wX -> Sealed a
seal forall (a :: * -> * -> *) wX. FL a wX wX
NilFL
else Mangled (PrimOf p) wZ
standard_resolution
(ExternalMerge
_, Bool
False) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Mangled (PrimOf p) wZ
standard_resolution
(YesExternalMerge String
c, Bool
True) -> forall (p :: * -> * -> *) wX wY wZ wA.
(RepoPatch p, ApplyState p ~ Tree) =>
DiffAlgorithm
-> Tree IO
-> String
-> WantGuiPause
-> FL (PrimOf p) wX wY
-> FL (PrimOf p) wX wZ
-> FL p wY wA
-> IO (Sealed (FL (PrimOf p) wA))
externalResolution DiffAlgorithm
dflag Tree IO
working String
c WantGuiPause
wantGuiPause
(forall (p :: * -> * -> *) wX wY.
Effect p =>
p wX wY -> FL (PrimOf p) wX wY
effect FL (PatchInfoAnd rt p) wU wR
us forall (a :: * -> * -> *) wX wY wZ.
FL a wX wY -> FL a wY wZ -> FL a wX wZ
+>+ FL (PrimOf p) wR wU
pw) (forall (p :: * -> * -> *) wX wY.
Effect p =>
p wX wY -> FL (PrimOf p) wX wY
effect FL (PatchInfoAnd rt p) wU wY
them) FL p wU wZ
them''content
String -> IO ()
debugMessage String
"Adding patches to the inventory and writing new pending..."
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (MakeChanges
mc forall a. Eq a => a -> a -> Bool
== MakeChanges
MakeChanges) forall a b. (a -> b) -> a -> b
$ do
forall (q :: * -> * -> *) (rt :: RepoType) (p :: * -> * -> *) wR wU
wT wY.
(ApplyState q ~ Tree, Apply q, ShowPatch q) =>
Repository rt p wR wU wT
-> ApplyDir -> Verbosity -> q wT wY -> IO ()
applyToTentativePristine Repository rt p wR wU wR
_repo ApplyDir
ApplyNormal Verbosity
verbosity FL (PatchInfoAnd rt p) wR wZ
them'
Repository rt p wR wU wZ
_repo <- case Reorder
reorder of
Reorder
NoReorder -> do
forall (p :: * -> * -> *) (rt :: RepoType) wR wU wT wY.
(RepoPatch p, ApplyState p ~ Tree) =>
UpdatePristine
-> Repository rt p wR wU wT
-> Compression
-> Verbosity
-> UpdatePending
-> FL (PatchInfoAnd rt p) wT wY
-> IO (Repository rt p wR wU wY)
tentativelyAddPatches_ UpdatePristine
DontUpdatePristine Repository rt p wR wU wR
_repo
Compression
compression Verbosity
verbosity UpdatePending
NoUpdatePending FL (PatchInfoAnd rt p) wR wZ
them'
Reorder
Reorder -> do
Repository rt p wR wU wU
r1 <- forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT wX.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
UpdatePristine
-> Repository rt p wR wU wT
-> Compression
-> UpdatePending
-> FL (PatchInfoAnd rt p) wX wT
-> IO (Repository rt p wR wU wX)
tentativelyRemovePatches_ UpdatePristine
DontUpdatePristineNorRevert Repository rt p wR wU wR
_repo
Compression
compression UpdatePending
NoUpdatePending FL (PatchInfoAnd rt p) wU wR
us
Repository rt p wR wU wY
r2 <- forall (p :: * -> * -> *) (rt :: RepoType) wR wU wT wY.
(RepoPatch p, ApplyState p ~ Tree) =>
UpdatePristine
-> Repository rt p wR wU wT
-> Compression
-> Verbosity
-> UpdatePending
-> FL (PatchInfoAnd rt p) wT wY
-> IO (Repository rt p wR wU wY)
tentativelyAddPatches_ UpdatePristine
DontUpdatePristine Repository rt p wR wU wU
r1
Compression
compression Verbosity
verbosity UpdatePending
NoUpdatePending FL (PatchInfoAnd rt p) wU wY
them
forall (p :: * -> * -> *) (rt :: RepoType) wR wU wT wY.
(RepoPatch p, ApplyState p ~ Tree) =>
UpdatePristine
-> Repository rt p wR wU wT
-> Compression
-> Verbosity
-> UpdatePending
-> FL (PatchInfoAnd rt p) wT wY
-> IO (Repository rt p wR wU wY)
tentativelyAddPatches_ UpdatePristine
DontUpdatePristine Repository rt p wR wU wY
r2
Compression
compression Verbosity
verbosity UpdatePending
NoUpdatePending FL (PatchInfoAnd rt p) wY wZ
us'
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT wP.
RepoPatch p =>
Repository rt p wR wU wT -> FL (PrimOf p) wT wP -> IO ()
setTentativePending Repository rt p wR wU wZ
_repo (forall (p :: * -> * -> *) wX wY.
Effect p =>
p wX wY -> FL (PrimOf p) wX wY
effect FL (PatchInfoAnd rt p) wZ wZ
pw' forall (a :: * -> * -> *) wX wY wZ.
FL a wX wY -> FL a wY wZ -> FL a wX wZ
+>+ FL (PrimOf p) wZ wX
resolution)
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (a :: * -> *) wX. a wX -> Sealed a
seal (forall (p :: * -> * -> *) wX wY.
Effect p =>
p wX wY -> FL (PrimOf p) wX wY
effect FL p wU wZ
them''content forall (a :: * -> * -> *) wX wY wZ.
FL a wX wY -> FL a wY wZ -> FL a wX wZ
+>+ FL (PrimOf p) wZ wX
resolution)
tentativelyMergePatches :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)
=> Repository rt p wR wU wR -> String
-> AllowConflicts
-> ExternalMerge -> WantGuiPause
-> Compression -> Verbosity -> Reorder
-> ( UseIndex, ScanKnown, DiffAlgorithm )
-> Fork (PatchSet rt p)
(FL (PatchInfoAnd rt p))
(FL (PatchInfoAnd rt p)) Origin wR wY
-> IO (Sealed (FL (PrimOf p) wU))
tentativelyMergePatches :: forall (rt :: RepoType) (p :: * -> * -> *) wR wU wY.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR
-> String
-> AllowConflicts
-> ExternalMerge
-> WantGuiPause
-> Compression
-> Verbosity
-> Reorder
-> (UseIndex, ScanKnown, DiffAlgorithm)
-> Fork
(PatchSet rt p)
(FL (PatchInfoAnd rt p))
(FL (PatchInfoAnd rt p))
Origin
wR
wY
-> IO (Sealed (FL (PrimOf p) wU))
tentativelyMergePatches = forall (rt :: RepoType) (p :: * -> * -> *) wR wU wY.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
MakeChanges
-> Repository rt p wR wU wR
-> String
-> AllowConflicts
-> ExternalMerge
-> WantGuiPause
-> Compression
-> Verbosity
-> Reorder
-> (UseIndex, ScanKnown, DiffAlgorithm)
-> Fork
(PatchSet rt p)
(FL (PatchInfoAnd rt p))
(FL (PatchInfoAnd rt p))
Origin
wR
wY
-> IO (Sealed (FL (PrimOf p) wU))
tentativelyMergePatches_ MakeChanges
MakeChanges
considerMergeToWorking :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)
=> Repository rt p wR wU wR -> String
-> AllowConflicts
-> ExternalMerge -> WantGuiPause
-> Compression -> Verbosity -> Reorder
-> ( UseIndex, ScanKnown, DiffAlgorithm )
-> Fork (PatchSet rt p)
(FL (PatchInfoAnd rt p))
(FL (PatchInfoAnd rt p)) Origin wR wY
-> IO (Sealed (FL (PrimOf p) wU))
considerMergeToWorking :: forall (rt :: RepoType) (p :: * -> * -> *) wR wU wY.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR
-> String
-> AllowConflicts
-> ExternalMerge
-> WantGuiPause
-> Compression
-> Verbosity
-> Reorder
-> (UseIndex, ScanKnown, DiffAlgorithm)
-> Fork
(PatchSet rt p)
(FL (PatchInfoAnd rt p))
(FL (PatchInfoAnd rt p))
Origin
wR
wY
-> IO (Sealed (FL (PrimOf p) wU))
considerMergeToWorking = forall (rt :: RepoType) (p :: * -> * -> *) wR wU wY.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
MakeChanges
-> Repository rt p wR wU wR
-> String
-> AllowConflicts
-> ExternalMerge
-> WantGuiPause
-> Compression
-> Verbosity
-> Reorder
-> (UseIndex, ScanKnown, DiffAlgorithm)
-> Fork
(PatchSet rt p)
(FL (PatchInfoAnd rt p))
(FL (PatchInfoAnd rt p))
Origin
wR
wY
-> IO (Sealed (FL (PrimOf p) wU))
tentativelyMergePatches_ MakeChanges
DontMakeChanges