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.File ( backupByCopying )
import Darcs.Patch
( RepoPatch, PrimOf, merge
, effect
, listConflictedFiles )
import Darcs.Patch.Apply ( ApplyState )
import Darcs.Patch.Depends ( slightlyOptimizePatchset )
import Darcs.Patch.Invertible ( mkInvertible )
import Darcs.Patch.Named ( patchcontents, anonymous )
import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, n2pia, hopefully )
import Darcs.Patch.Progress( progressFL, progressRL )
import Darcs.Patch.Set ( PatchSet, Origin, appendPSFL, patchSet2RL )
import Darcs.Patch.Witnesses.Ordered
( FL(..), RL(..), Fork(..), (:\/:)(..), (:/\:)(..), (+>+), (+<<+)
, lengthFL, mapFL_FL, concatFL, reverseFL )
import Darcs.Patch.Witnesses.Sealed ( Sealed(Sealed), seal )
import Darcs.Repository.Flags
( DiffOpts (..)
, AllowConflicts (..)
, ResolveConflicts (..)
, Reorder (..)
, UpdatePending (..)
, WantGuiPause (..)
)
import Darcs.Repository.Hashed
( tentativelyAddPatches_
, tentativelyRemovePatches_
, UpdatePristine(..)
)
import Darcs.Repository.Pristine
( applyToTentativePristine
)
import Darcs.Repository.InternalTypes ( AccessType(RW), Repository, repoLocation )
import Darcs.Repository.Pending ( setTentativePending )
import Darcs.Repository.Resolution
( StandardResolution(..)
, announceConflicts
, haveConflicts
, externalResolution
, patchsetConflictResolutions
, standardResolution
)
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
(MakeChanges -> MakeChanges -> Bool)
-> (MakeChanges -> MakeChanges -> Bool) -> Eq MakeChanges
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: MakeChanges -> MakeChanges -> Bool
== :: MakeChanges -> MakeChanges -> Bool
$c/= :: MakeChanges -> MakeChanges -> Bool
/= :: MakeChanges -> MakeChanges -> Bool
Eq )
tentativelyMergePatches_ :: (RepoPatch p, ApplyState p ~ Tree)
=> MakeChanges
-> Repository 'RW p wU wR -> String
-> AllowConflicts
-> WantGuiPause
-> Reorder
-> DiffOpts
-> Fork (PatchSet p)
(FL (PatchInfoAnd p))
(FL (PatchInfoAnd p)) Origin wR wY
-> IO (Sealed (FL (PrimOf p) wU))
tentativelyMergePatches_ :: forall (p :: * -> * -> *) wU wR wY.
(RepoPatch p, ApplyState p ~ Tree) =>
MakeChanges
-> Repository 'RW p wU wR
-> String
-> AllowConflicts
-> WantGuiPause
-> Reorder
-> DiffOpts
-> Fork
(PatchSet p)
(FL (PatchInfoAnd p))
(FL (PatchInfoAnd p))
Origin
wR
wY
-> IO (Sealed (FL (PrimOf p) wU))
tentativelyMergePatches_ MakeChanges
mc Repository 'RW p wU wR
_repo String
cmd AllowConflicts
allowConflicts WantGuiPause
wantGuiPause
Reorder
reorder diffingOpts :: DiffOpts
diffingOpts@DiffOpts{DiffAlgorithm
UseIndex
LookForMoves
LookForReplaces
LookForAdds
withIndex :: UseIndex
lookForAdds :: LookForAdds
lookForReplaces :: LookForReplaces
lookForMoves :: LookForMoves
diffAlg :: DiffAlgorithm
withIndex :: DiffOpts -> UseIndex
lookForAdds :: DiffOpts -> LookForAdds
lookForReplaces :: DiffOpts -> LookForReplaces
lookForMoves :: DiffOpts -> LookForMoves
diffAlg :: DiffOpts -> DiffAlgorithm
..} (Fork PatchSet p Origin wU
context FL (PatchInfoAnd p) wU wR
us FL (PatchInfoAnd p) wU wY
them) = do
(FL (PatchInfoAnd p) wR wZ
them' :/\: FL (PatchInfoAnd p) wY wZ
us') <-
(:/\:) (FL (PatchInfoAnd p)) (FL (PatchInfoAnd p)) wR wY
-> IO ((:/\:) (FL (PatchInfoAnd p)) (FL (PatchInfoAnd p)) wR wY)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((:/\:) (FL (PatchInfoAnd p)) (FL (PatchInfoAnd p)) wR wY
-> IO ((:/\:) (FL (PatchInfoAnd p)) (FL (PatchInfoAnd p)) wR wY))
-> (:/\:) (FL (PatchInfoAnd p)) (FL (PatchInfoAnd p)) wR wY
-> IO ((:/\:) (FL (PatchInfoAnd p)) (FL (PatchInfoAnd p)) wR wY)
forall a b. (a -> b) -> a -> b
$ (:\/:) (FL (PatchInfoAnd p)) (FL (PatchInfoAnd p)) wR wY
-> (:/\:) (FL (PatchInfoAnd p)) (FL (PatchInfoAnd p)) wR wY
forall wX wY.
(:\/:) (FL (PatchInfoAnd p)) (FL (PatchInfoAnd p)) wX wY
-> (:/\:) (FL (PatchInfoAnd p)) (FL (PatchInfoAnd p)) wX wY
forall (p :: * -> * -> *) wX wY.
Merge p =>
(:\/:) p p wX wY -> (:/\:) p p wX wY
merge (String -> FL (PatchInfoAnd p) wU wR -> FL (PatchInfoAnd p) wU wR
forall (a :: * -> * -> *) wX wY. String -> FL a wX wY -> FL a wX wY
progressFL String
"Merging us" FL (PatchInfoAnd p) wU wR
us FL (PatchInfoAnd p) wU wR
-> FL (PatchInfoAnd p) wU wY
-> (:\/:) (FL (PatchInfoAnd p)) (FL (PatchInfoAnd p)) wR wY
forall (a1 :: * -> * -> *) (a2 :: * -> * -> *) wX wY wZ.
a1 wZ wX -> a2 wZ wY -> (:\/:) a1 a2 wX wY
:\/: String -> FL (PatchInfoAnd p) wU wY -> FL (PatchInfoAnd p) wU wY
forall (a :: * -> * -> *) wX wY. String -> FL a wX wY -> FL a wX wY
progressFL String
"Merging them" FL (PatchInfoAnd p) wU wY
them)
FL (PrimOf p) wR wU
pw <- DiffOpts
-> Repository 'RW p wU wR
-> Maybe [AnchoredPath]
-> IO (FL (PrimOf p) wR wU)
forall (p :: * -> * -> *) (rt :: AccessType) wU wR.
(RepoPatch p, ApplyState p ~ Tree) =>
DiffOpts
-> Repository rt p wU wR
-> Maybe [AnchoredPath]
-> IO (FL (PrimOf p) wR wU)
unrecordedChanges DiffOpts
diffingOpts Repository 'RW p wU wR
_repo Maybe [AnchoredPath]
forall a. Maybe a
Nothing
PatchInfoAndG (Named p) wR wU
anonpw <- Named p wR wU -> PatchInfoAndG (Named p) wR wU
forall (p :: * -> * -> *) wX wY.
(Ident p, PatchId p ~ PatchInfo) =>
p wX wY -> PatchInfoAndG p wX wY
n2pia (Named p wR wU -> PatchInfoAndG (Named p) wR wU)
-> IO (Named p wR wU) -> IO (PatchInfoAndG (Named p) wR wU)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` FL (PrimOf p) wR wU -> IO (Named p wR wU)
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 p) wZ wZ
pw' :/\: FL (PatchInfoAnd p) wU wZ
them'' <- (:/\:) (FL (PatchInfoAnd p)) (FL (PatchInfoAnd p)) wZ wU
-> IO ((:/\:) (FL (PatchInfoAnd p)) (FL (PatchInfoAnd p)) wZ wU)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((:/\:) (FL (PatchInfoAnd p)) (FL (PatchInfoAnd p)) wZ wU
-> IO ((:/\:) (FL (PatchInfoAnd p)) (FL (PatchInfoAnd p)) wZ wU))
-> (:/\:) (FL (PatchInfoAnd p)) (FL (PatchInfoAnd p)) wZ wU
-> IO ((:/\:) (FL (PatchInfoAnd p)) (FL (PatchInfoAnd p)) wZ wU)
forall a b. (a -> b) -> a -> b
$ (:\/:) (FL (PatchInfoAnd p)) (FL (PatchInfoAnd p)) wZ wU
-> (:/\:) (FL (PatchInfoAnd p)) (FL (PatchInfoAnd p)) wZ wU
forall wX wY.
(:\/:) (FL (PatchInfoAnd p)) (FL (PatchInfoAnd p)) wX wY
-> (:/\:) (FL (PatchInfoAnd p)) (FL (PatchInfoAnd p)) wX wY
forall (p :: * -> * -> *) wX wY.
Merge p =>
(:\/:) p p wX wY -> (:/\:) p p wX wY
merge (FL (PatchInfoAnd p) wR wZ
them' FL (PatchInfoAnd p) wR wZ
-> FL (PatchInfoAnd p) wR wU
-> (:\/:) (FL (PatchInfoAnd p)) (FL (PatchInfoAnd p)) wZ wU
forall (a1 :: * -> * -> *) (a2 :: * -> * -> *) wX wY wZ.
a1 wZ wX -> a2 wZ wY -> (:\/:) a1 a2 wX wY
:\/: PatchInfoAndG (Named p) wR wU
anonpw PatchInfoAndG (Named p) wR wU
-> FL (PatchInfoAnd p) wU wU -> FL (PatchInfoAnd p) wR wU
forall (a :: * -> * -> *) wX wY wZ.
a wX wY -> FL a wY wZ -> FL a wX wZ
:>: FL (PatchInfoAnd p) wU wU
forall (a :: * -> * -> *) wX. FL a wX wX
NilFL)
let them''content :: FL p wU wZ
them''content = FL (FL p) wU wZ -> FL p wU wZ
forall (a :: * -> * -> *) wX wZ. FL (FL a) wX wZ -> FL a wX wZ
concatFL (FL (FL p) wU wZ -> FL p wU wZ) -> FL (FL p) wU wZ -> FL p wU wZ
forall a b. (a -> b) -> a -> b
$ (forall wW wY. PatchInfoAnd p wW wY -> FL p wW wY)
-> FL (PatchInfoAnd p) wU wZ -> FL (FL p) wU wZ
forall (a :: * -> * -> *) (b :: * -> * -> *) wX wZ.
(forall wW wY. a wW wY -> b wW wY) -> FL a wX wZ -> FL b wX wZ
mapFL_FL (Named p wW wY -> FL p wW wY
forall (p :: * -> * -> *) wX wY. Named p wX wY -> FL p wX wY
patchcontents (Named p wW wY -> FL p wW wY)
-> (PatchInfoAnd p wW wY -> Named p wW wY)
-> PatchInfoAnd p wW wY
-> FL p wW wY
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PatchInfoAnd p wW wY -> Named p wW wY
forall (p :: * -> * -> *) wA wB. PatchInfoAndG p wA wB -> p wA wB
hopefully) FL (PatchInfoAnd p) wU wZ
them''
no_conflicts_in_them :: Bool
no_conflicts_in_them =
Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ StandardResolution (PrimOf p) wY -> Bool
forall (prim :: * -> * -> *) wX. StandardResolution prim wX -> Bool
haveConflicts (StandardResolution (PrimOf p) wY -> Bool)
-> StandardResolution (PrimOf p) wY -> Bool
forall a b. (a -> b) -> a -> b
$ PatchSet p Origin wY -> StandardResolution (PrimOf p) wY
forall (p :: * -> * -> *) wX.
RepoPatch p =>
PatchSet p Origin wX -> StandardResolution (PrimOf p) wX
patchsetConflictResolutions (PatchSet p Origin wY -> StandardResolution (PrimOf p) wY)
-> PatchSet p Origin wY -> StandardResolution (PrimOf p) wY
forall a b. (a -> b) -> a -> b
$
PatchSet p Origin wY -> PatchSet p Origin wY
forall (p :: * -> * -> *) wStart wX.
PatchSet p wStart wX -> PatchSet p wStart wX
slightlyOptimizePatchset (PatchSet p Origin wU
-> FL (PatchInfoAnd p) wU wY -> PatchSet p Origin wY
forall (p :: * -> * -> *) wStart wX wY.
PatchSet p wStart wX
-> FL (PatchInfoAnd p) wX wY -> PatchSet p wStart wY
appendPSFL PatchSet p Origin wU
context FL (PatchInfoAnd p) wU wY
them)
conflicts :: StandardResolution (PrimOf p) wZ
conflicts =
let us'' :: FL (PatchInfoAnd p) wY wZ
us'' = FL (PatchInfoAnd p) wY wZ
us' FL (PatchInfoAnd p) wY wZ
-> FL (PatchInfoAnd p) wZ wZ -> FL (PatchInfoAnd p) wY wZ
forall (a :: * -> * -> *) wX wY wZ.
FL a wX wY -> FL a wY wZ -> FL a wX wZ
+>+ FL (PatchInfoAnd p) wZ wZ
pw' in
if FL (PatchInfoAnd p) wY wZ -> Int
forall (a :: * -> * -> *) wX wZ. FL a wX wZ -> Int
lengthFL FL (PatchInfoAnd p) wY wZ
us'' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< FL (PatchInfoAnd p) wU wZ -> Int
forall (a :: * -> * -> *) wX wZ. FL a wX wZ -> Int
lengthFL FL (PatchInfoAnd p) wU wZ
them'' Bool -> Bool -> Bool
&& Bool
no_conflicts_in_them then
RL (PatchInfoAnd p) Origin wY
-> RL (PatchInfoAnd p) wY wZ -> StandardResolution (PrimOf p) wZ
forall (p :: * -> * -> *) wO wX wY.
RepoPatch p =>
RL (PatchInfoAnd p) wO wX
-> RL (PatchInfoAnd p) wX wY -> StandardResolution (PrimOf p) wY
standardResolution
(PatchSet p Origin wU -> RL (PatchInfoAnd p) Origin wU
forall (p :: * -> * -> *) wStart wX.
PatchSet p wStart wX -> RL (PatchInfoAnd p) wStart wX
patchSet2RL PatchSet p Origin wU
context RL (PatchInfoAnd p) Origin wU
-> FL (PatchInfoAnd p) wU wY -> RL (PatchInfoAnd p) Origin wY
forall (p :: * -> * -> *) wX wY wZ.
RL p wX wY -> FL p wY wZ -> RL p wX wZ
+<<+ FL (PatchInfoAnd p) wU wY
them)
(String -> RL (PatchInfoAnd p) wY wZ -> RL (PatchInfoAnd p) wY wZ
forall (a :: * -> * -> *) wX wY. String -> RL a wX wY -> RL a wX wY
progressRL String
"Examining patches for conflicts" (RL (PatchInfoAnd p) wY wZ -> RL (PatchInfoAnd p) wY wZ)
-> RL (PatchInfoAnd p) wY wZ -> RL (PatchInfoAnd p) wY wZ
forall a b. (a -> b) -> a -> b
$ FL (PatchInfoAnd p) wY wZ -> RL (PatchInfoAnd p) wY wZ
forall (a :: * -> * -> *) wX wZ. FL a wX wZ -> RL a wX wZ
reverseFL FL (PatchInfoAnd p) wY wZ
us'')
else
RL (PatchInfoAnd p) Origin wU
-> RL (PatchInfoAnd p) wU wZ -> StandardResolution (PrimOf p) wZ
forall (p :: * -> * -> *) wO wX wY.
RepoPatch p =>
RL (PatchInfoAnd p) wO wX
-> RL (PatchInfoAnd p) wX wY -> StandardResolution (PrimOf p) wY
standardResolution
(PatchSet p Origin wU -> RL (PatchInfoAnd p) Origin wU
forall (p :: * -> * -> *) wStart wX.
PatchSet p wStart wX -> RL (PatchInfoAnd p) wStart wX
patchSet2RL PatchSet p Origin wU
context RL (PatchInfoAnd p) Origin wU
-> FL (PatchInfoAnd p) wU wR -> RL (PatchInfoAnd p) Origin wR
forall (p :: * -> * -> *) wX wY wZ.
RL p wX wY -> FL p wY wZ -> RL p wX wZ
+<<+ FL (PatchInfoAnd p) wU wR
us RL (PatchInfoAnd p) Origin wR
-> PatchInfoAndG (Named p) wR wU -> RL (PatchInfoAnd p) Origin wU
forall (a :: * -> * -> *) wX wY wZ.
RL a wX wY -> a wY wZ -> RL a wX wZ
:<: PatchInfoAndG (Named p) wR wU
anonpw)
(String -> RL (PatchInfoAnd p) wU wZ -> RL (PatchInfoAnd p) wU wZ
forall (a :: * -> * -> *) wX wY. String -> RL a wX wY -> RL a wX wY
progressRL String
"Examining patches for conflicts" (RL (PatchInfoAnd p) wU wZ -> RL (PatchInfoAnd p) wU wZ)
-> RL (PatchInfoAnd p) wU wZ -> RL (PatchInfoAnd p) wU wZ
forall a b. (a -> b) -> a -> b
$ FL (PatchInfoAnd p) wU wZ -> RL (PatchInfoAnd p) wU wZ
forall (a :: * -> * -> *) wX wZ. FL a wX wZ -> RL a wX wZ
reverseFL FL (PatchInfoAnd p) wU wZ
them'')
String -> IO ()
debugMessage String
"Checking for conflicts..."
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (AllowConflicts
allowConflicts AllowConflicts -> AllowConflicts -> Bool
forall a. Eq a => a -> a -> Bool
== ResolveConflicts -> AllowConflicts
YesAllowConflicts ResolveConflicts
MarkConflicts) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
(String -> IO ()) -> [String] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ String -> IO ()
backupByCopying ([String] -> IO ()) -> [String] -> IO ()
forall a b. (a -> b) -> a -> b
$
(AnchoredPath -> String) -> [AnchoredPath] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String -> AnchoredPath -> String
anchorPath (Repository 'RW p wU wR -> String
forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
Repository rt p wU wR -> String
repoLocation Repository 'RW p wU wR
_repo)) ([AnchoredPath] -> [String]) -> [AnchoredPath] -> [String]
forall a b. (a -> b) -> a -> b
$
StandardResolution (PrimOf p) wZ -> [AnchoredPath]
forall (prim :: * -> * -> *) wX.
StandardResolution prim wX -> [AnchoredPath]
conflictedPaths StandardResolution (PrimOf p) wZ
conflicts
String -> IO ()
debugMessage String
"Announcing conflicts..."
Bool
have_conflicts <- String
-> AllowConflicts -> StandardResolution (PrimOf p) wZ -> IO Bool
forall (prim :: * -> * -> *) wX.
PrimPatch prim =>
String -> AllowConflicts -> StandardResolution prim wX -> IO Bool
announceConflicts String
cmd AllowConflicts
allowConflicts StandardResolution (PrimOf p) wZ
conflicts
String -> IO ()
debugMessage String
"Checking for unrecorded conflicts..."
let pw'content :: FL p wZ wZ
pw'content = FL (FL p) wZ wZ -> FL p wZ wZ
forall (a :: * -> * -> *) wX wZ. FL (FL a) wX wZ -> FL a wX wZ
concatFL (FL (FL p) wZ wZ -> FL p wZ wZ) -> FL (FL p) wZ wZ -> FL p wZ wZ
forall a b. (a -> b) -> a -> b
$ (forall wW wY. PatchInfoAnd p wW wY -> FL p wW wY)
-> FL (PatchInfoAnd p) wZ wZ -> FL (FL p) wZ wZ
forall (a :: * -> * -> *) (b :: * -> * -> *) wX wZ.
(forall wW wY. a wW wY -> b wW wY) -> FL a wX wZ -> FL b wX wZ
mapFL_FL (Named p wW wY -> FL p wW wY
forall (p :: * -> * -> *) wX wY. Named p wX wY -> FL p wX wY
patchcontents (Named p wW wY -> FL p wW wY)
-> (PatchInfoAnd p wW wY -> Named p wW wY)
-> PatchInfoAnd p wW wY
-> FL p wW wY
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PatchInfoAnd p wW wY -> Named p wW wY
forall (p :: * -> * -> *) wA wB. PatchInfoAndG p wA wB -> p wA wB
hopefully) FL (PatchInfoAnd p) wZ wZ
pw'
case FL p wZ wZ -> [AnchoredPath]
forall (p :: * -> * -> *) wX wY.
(Summary p, PatchInspect (PrimOf p)) =>
p wX wY -> [AnchoredPath]
listConflictedFiles FL p wZ wZ
pw'content of
[] -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
[AnchoredPath]
fs -> do
Doc -> IO ()
ePutDocLn (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
vcat ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (String -> Doc) -> [String] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map String -> Doc
redText ([String] -> [Doc]) -> [String] -> [Doc]
forall a b. (a -> b) -> a -> b
$
String
"You have conflicting unrecorded changes to:" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: (AnchoredPath -> String) -> [AnchoredPath] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map AnchoredPath -> String
displayPath [AnchoredPath]
fs
Bool
confirmed <- String -> IO Bool
promptYorn String
"Proceed?" IO Bool -> (IOError -> IO Bool) -> IO Bool
forall a. IO a -> (IOError -> IO a) -> IO a
`catchIOError` (\IOError
e ->
if IOErrorType -> Bool
isIllegalOperationErrorType (IOError -> IOErrorType
ioeGetErrorType IOError
e)
then Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
else IOError -> IO Bool
forall a. IOError -> IO a
ioError IOError
e)
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
confirmed (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
String -> IO ()
putStrLn String
"Cancelled."
IO ()
forall a. IO a
exitSuccess
String -> IO ()
debugMessage String
"Reading working tree..."
Tree IO
working <- Repository 'RW p wU wR
-> UseIndex -> Maybe [AnchoredPath] -> IO (Tree IO)
forall (p :: * -> * -> *) (rt :: AccessType) wU wR.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wU wR
-> UseIndex -> Maybe [AnchoredPath] -> IO (Tree IO)
readUnrecorded Repository 'RW p wU wR
_repo UseIndex
withIndex Maybe [AnchoredPath]
forall a. Maybe a
Nothing
String -> IO ()
debugMessage String
"Working out conflict markup..."
Sealed FL (PrimOf p) wZ wX
resolution <-
if Bool
have_conflicts then
case AllowConflicts
allowConflicts of
YesAllowConflicts (ExternalMerge String
merge_cmd) ->
DiffAlgorithm
-> Tree IO
-> String
-> WantGuiPause
-> FL (PrimOf p) wU wU
-> FL (PrimOf p) wU wY
-> FL p wU wZ
-> IO (Sealed (FL (PrimOf p) wZ))
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
diffAlg Tree IO
working String
merge_cmd WantGuiPause
wantGuiPause
(FL (PatchInfoAnd p) wU wR
-> FL (PrimOf (FL (PatchInfoAnd p))) wU wR
forall wX wY.
FL (PatchInfoAnd p) wX wY
-> FL (PrimOf (FL (PatchInfoAnd p))) wX wY
forall (p :: * -> * -> *) wX wY.
Effect p =>
p wX wY -> FL (PrimOf p) wX wY
effect FL (PatchInfoAnd p) wU wR
us FL (PrimOf p) wU wR -> FL (PrimOf p) wR wU -> FL (PrimOf p) wU wU
forall (a :: * -> * -> *) wX wY wZ.
FL a wX wY -> FL a wY wZ -> FL a wX wZ
+>+ FL (PrimOf p) wR wU
pw) (FL (PatchInfoAnd p) wU wY
-> FL (PrimOf (FL (PatchInfoAnd p))) wU wY
forall wX wY.
FL (PatchInfoAnd p) wX wY
-> FL (PrimOf (FL (PatchInfoAnd p))) wX wY
forall (p :: * -> * -> *) wX wY.
Effect p =>
p wX wY -> FL (PrimOf p) wX wY
effect FL (PatchInfoAnd p) wU wY
them) FL p wU wZ
them''content
YesAllowConflicts ResolveConflicts
NoResolveConflicts -> Sealed (FL (PrimOf p) wZ) -> IO (Sealed (FL (PrimOf p) wZ))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Sealed (FL (PrimOf p) wZ) -> IO (Sealed (FL (PrimOf p) wZ)))
-> Sealed (FL (PrimOf p) wZ) -> IO (Sealed (FL (PrimOf p) wZ))
forall a b. (a -> b) -> a -> b
$ FL (PrimOf p) wZ wZ -> Sealed (FL (PrimOf p) wZ)
forall (a :: * -> *) wX. a wX -> Sealed a
seal FL (PrimOf p) wZ wZ
forall (a :: * -> * -> *) wX. FL a wX wX
NilFL
YesAllowConflicts ResolveConflicts
MarkConflicts -> Sealed (FL (PrimOf p) wZ) -> IO (Sealed (FL (PrimOf p) wZ))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Sealed (FL (PrimOf p) wZ) -> IO (Sealed (FL (PrimOf p) wZ)))
-> Sealed (FL (PrimOf p) wZ) -> IO (Sealed (FL (PrimOf p) wZ))
forall a b. (a -> b) -> a -> b
$ StandardResolution (PrimOf p) wZ -> Sealed (FL (PrimOf p) wZ)
forall (prim :: * -> * -> *) wX.
StandardResolution prim wX -> Mangled prim wX
mangled StandardResolution (PrimOf p) wZ
conflicts
AllowConflicts
NoAllowConflicts -> String -> IO (Sealed (FL (PrimOf p) wZ))
forall a. HasCallStack => String -> a
error String
"impossible"
else Sealed (FL (PrimOf p) wZ) -> IO (Sealed (FL (PrimOf p) wZ))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Sealed (FL (PrimOf p) wZ) -> IO (Sealed (FL (PrimOf p) wZ)))
-> Sealed (FL (PrimOf p) wZ) -> IO (Sealed (FL (PrimOf p) wZ))
forall a b. (a -> b) -> a -> b
$ FL (PrimOf p) wZ wZ -> Sealed (FL (PrimOf p) wZ)
forall (a :: * -> *) wX. a wX -> Sealed a
seal FL (PrimOf p) wZ wZ
forall (a :: * -> * -> *) wX. FL a wX wX
NilFL
String -> IO ()
debugMessage String
"Adding patches to the inventory and writing new pending..."
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (MakeChanges
mc MakeChanges -> MakeChanges -> Bool
forall a. Eq a => a -> a -> Bool
== MakeChanges
MakeChanges) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
Repository 'RW p wU wR
-> Invertible (FL (PatchInfoAnd p)) wR wZ -> IO ()
forall (p :: * -> * -> *) wU wR wY.
(ApplyState p ~ Tree, RepoPatch p) =>
Repository 'RW p wU wR
-> Invertible (FL (PatchInfoAnd p)) wR wY -> IO ()
applyToTentativePristine Repository 'RW p wU wR
_repo (Invertible (FL (PatchInfoAnd p)) wR wZ -> IO ())
-> Invertible (FL (PatchInfoAnd p)) wR wZ -> IO ()
forall a b. (a -> b) -> a -> b
$ FL (PatchInfoAnd p) wR wZ -> Invertible (FL (PatchInfoAnd p)) wR wZ
forall (p :: * -> * -> *) wX wY. p wX wY -> Invertible p wX wY
mkInvertible (FL (PatchInfoAnd p) wR wZ
-> Invertible (FL (PatchInfoAnd p)) wR wZ)
-> FL (PatchInfoAnd p) wR wZ
-> Invertible (FL (PatchInfoAnd p)) wR wZ
forall a b. (a -> b) -> a -> b
$
String -> FL (PatchInfoAnd p) wR wZ -> FL (PatchInfoAnd p) wR wZ
forall (a :: * -> * -> *) wX wY. String -> FL a wX wY -> FL a wX wY
progressFL String
"Applying patches to pristine" FL (PatchInfoAnd p) wR wZ
them'
Repository 'RW p wU wZ
_repo <- case Reorder
reorder of
Reorder
NoReorder -> do
UpdatePristine
-> Repository 'RW p wU wR
-> UpdatePending
-> FL (PatchInfoAnd p) wR wZ
-> IO (Repository 'RW p wU wZ)
forall (p :: * -> * -> *) wU wR wY.
(RepoPatch p, ApplyState p ~ Tree) =>
UpdatePristine
-> Repository 'RW p wU wR
-> UpdatePending
-> FL (PatchInfoAnd p) wR wY
-> IO (Repository 'RW p wU wY)
tentativelyAddPatches_ UpdatePristine
DontUpdatePristine Repository 'RW p wU wR
_repo UpdatePending
NoUpdatePending FL (PatchInfoAnd p) wR wZ
them'
Reorder
Reorder -> do
Repository 'RW p wU wU
_repo <- UpdatePristine
-> Repository 'RW p wU wR
-> UpdatePending
-> FL (PatchInfoAnd p) wU wR
-> IO (Repository 'RW p wU wU)
forall (p :: * -> * -> *) wU wR wX.
(RepoPatch p, ApplyState p ~ Tree) =>
UpdatePristine
-> Repository 'RW p wU wR
-> UpdatePending
-> FL (PatchInfoAnd p) wX wR
-> IO (Repository 'RW p wU wX)
tentativelyRemovePatches_ UpdatePristine
DontUpdatePristineNorRevert Repository 'RW p wU wR
_repo
UpdatePending
NoUpdatePending FL (PatchInfoAnd p) wU wR
us
Repository 'RW p wU wY
_repo <- UpdatePristine
-> Repository 'RW p wU wU
-> UpdatePending
-> FL (PatchInfoAnd p) wU wY
-> IO (Repository 'RW p wU wY)
forall (p :: * -> * -> *) wU wR wY.
(RepoPatch p, ApplyState p ~ Tree) =>
UpdatePristine
-> Repository 'RW p wU wR
-> UpdatePending
-> FL (PatchInfoAnd p) wR wY
-> IO (Repository 'RW p wU wY)
tentativelyAddPatches_ UpdatePristine
DontUpdatePristine Repository 'RW p wU wU
_repo
UpdatePending
NoUpdatePending FL (PatchInfoAnd p) wU wY
them
UpdatePristine
-> Repository 'RW p wU wY
-> UpdatePending
-> FL (PatchInfoAnd p) wY wZ
-> IO (Repository 'RW p wU wZ)
forall (p :: * -> * -> *) wU wR wY.
(RepoPatch p, ApplyState p ~ Tree) =>
UpdatePristine
-> Repository 'RW p wU wR
-> UpdatePending
-> FL (PatchInfoAnd p) wR wY
-> IO (Repository 'RW p wU wY)
tentativelyAddPatches_ UpdatePristine
DontUpdatePristine Repository 'RW p wU wY
_repo UpdatePending
NoUpdatePending FL (PatchInfoAnd p) wY wZ
us'
Repository 'RW p wU wZ -> FL (PrimOf p) wZ wX -> IO ()
forall (p :: * -> * -> *) wU wR wP.
RepoPatch p =>
Repository 'RW p wU wR -> FL (PrimOf p) wR wP -> IO ()
setTentativePending Repository 'RW p wU wZ
_repo (FL (PatchInfoAnd p) wZ wZ
-> FL (PrimOf (FL (PatchInfoAnd p))) wZ wZ
forall wX wY.
FL (PatchInfoAnd p) wX wY
-> FL (PrimOf (FL (PatchInfoAnd p))) wX wY
forall (p :: * -> * -> *) wX wY.
Effect p =>
p wX wY -> FL (PrimOf p) wX wY
effect FL (PatchInfoAnd p) wZ wZ
pw' FL (PrimOf p) wZ wZ -> FL (PrimOf p) wZ wX -> FL (PrimOf p) wZ wX
forall (a :: * -> * -> *) wX wY wZ.
FL a wX wY -> FL a wY wZ -> FL a wX wZ
+>+ FL (PrimOf p) wZ wX
resolution)
Sealed (FL (PrimOf p) wU) -> IO (Sealed (FL (PrimOf p) wU))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Sealed (FL (PrimOf p) wU) -> IO (Sealed (FL (PrimOf p) wU)))
-> Sealed (FL (PrimOf p) wU) -> IO (Sealed (FL (PrimOf p) wU))
forall a b. (a -> b) -> a -> b
$ FL (PrimOf p) wU wX -> Sealed (FL (PrimOf p) wU)
forall (a :: * -> *) wX. a wX -> Sealed a
seal (FL p wU wZ -> FL (PrimOf (FL p)) wU wZ
forall wX wY. FL p wX wY -> FL (PrimOf (FL p)) wX wY
forall (p :: * -> * -> *) wX wY.
Effect p =>
p wX wY -> FL (PrimOf p) wX wY
effect FL p wU wZ
them''content FL (PrimOf p) wU wZ -> FL (PrimOf p) wZ wX -> FL (PrimOf p) wU wX
forall (a :: * -> * -> *) wX wY wZ.
FL a wX wY -> FL a wY wZ -> FL a wX wZ
+>+ FL (PrimOf p) wZ wX
resolution)
tentativelyMergePatches :: (RepoPatch p, ApplyState p ~ Tree)
=> Repository 'RW p wU wR -> String
-> AllowConflicts
-> WantGuiPause
-> Reorder
-> DiffOpts
-> Fork (PatchSet p)
(FL (PatchInfoAnd p))
(FL (PatchInfoAnd p)) Origin wR wY
-> IO (Sealed (FL (PrimOf p) wU))
tentativelyMergePatches :: forall (p :: * -> * -> *) wU wR wY.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository 'RW p wU wR
-> String
-> AllowConflicts
-> WantGuiPause
-> Reorder
-> DiffOpts
-> Fork
(PatchSet p)
(FL (PatchInfoAnd p))
(FL (PatchInfoAnd p))
Origin
wR
wY
-> IO (Sealed (FL (PrimOf p) wU))
tentativelyMergePatches = MakeChanges
-> Repository 'RW p wU wR
-> String
-> AllowConflicts
-> WantGuiPause
-> Reorder
-> DiffOpts
-> Fork
(PatchSet p)
(FL (PatchInfoAndG (Named p)))
(FL (PatchInfoAndG (Named p)))
Origin
wR
wY
-> IO (Sealed (FL (PrimOf p) wU))
forall (p :: * -> * -> *) wU wR wY.
(RepoPatch p, ApplyState p ~ Tree) =>
MakeChanges
-> Repository 'RW p wU wR
-> String
-> AllowConflicts
-> WantGuiPause
-> Reorder
-> DiffOpts
-> Fork
(PatchSet p)
(FL (PatchInfoAnd p))
(FL (PatchInfoAnd p))
Origin
wR
wY
-> IO (Sealed (FL (PrimOf p) wU))
tentativelyMergePatches_ MakeChanges
MakeChanges
considerMergeToWorking :: (RepoPatch p, ApplyState p ~ Tree)
=> Repository 'RW p wU wR -> String
-> AllowConflicts
-> WantGuiPause
-> Reorder
-> DiffOpts
-> Fork (PatchSet p)
(FL (PatchInfoAnd p))
(FL (PatchInfoAnd p)) Origin wR wY
-> IO (Sealed (FL (PrimOf p) wU))
considerMergeToWorking :: forall (p :: * -> * -> *) wU wR wY.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository 'RW p wU wR
-> String
-> AllowConflicts
-> WantGuiPause
-> Reorder
-> DiffOpts
-> Fork
(PatchSet p)
(FL (PatchInfoAnd p))
(FL (PatchInfoAnd p))
Origin
wR
wY
-> IO (Sealed (FL (PrimOf p) wU))
considerMergeToWorking = MakeChanges
-> Repository 'RW p wU wR
-> String
-> AllowConflicts
-> WantGuiPause
-> Reorder
-> DiffOpts
-> Fork
(PatchSet p)
(FL (PatchInfoAndG (Named p)))
(FL (PatchInfoAndG (Named p)))
Origin
wR
wY
-> IO (Sealed (FL (PrimOf p) wU))
forall (p :: * -> * -> *) wU wR wY.
(RepoPatch p, ApplyState p ~ Tree) =>
MakeChanges
-> Repository 'RW p wU wR
-> String
-> AllowConflicts
-> WantGuiPause
-> Reorder
-> DiffOpts
-> Fork
(PatchSet p)
(FL (PatchInfoAnd p))
(FL (PatchInfoAnd p))
Origin
wR
wY
-> IO (Sealed (FL (PrimOf p) wU))
tentativelyMergePatches_ MakeChanges
DontMakeChanges