-- Copyright (C) 2002-2004,2007-2008 David Roundy
-- Copyright (C) 2005 Juliusz Chroboczek
-- Copyright (C) 2009 Petr Rockai
--
-- This program is free software; you can redistribute it and/or modify
-- it under the terms of the GNU General Public License as published by
-- the Free Software Foundation; either version 2, or (at your option)
-- any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-- GNU General Public License for more details.
--
-- You should have received a copy of the GNU General Public License
-- along with this program; see the file COPYING.  If not, write to
-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
-- Boston, MA 02110-1301, USA.


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' is not easy to understand by just staring at
the code. So here is an in-depth explanation.

We start out at the state X at which our repo and the their repo deviate,
assuming any patches common to both repos have first been commuted to the
common part before X. So X is the intermediate state that is existentially
hiddden inside the Fork we get passed as argument. R is our recorded state
and Y is the recorded state of their repo.

 Y       R
  \     /
 them  us
    \ /
     X
     |
   common
     |
     O

We will elide the common part from now on. It doesn't change and we only
pass it unmodified to standardResolution, see below.

The easy part is to merge the local patches (us) with the remote ones
(them), giving us them' and us'.

     T
    / \
  us'  them'
  /     \
 Y       R
  \     /
 them  us
    \ /
     X


We can ignore us' and just add them' on top of us (which are already in our
repo), unless --reorder-patches is in effect, in which case we remove us and
then first add them and afterwards us'. The new state on top is T which
stands for the new /tentative/ state i.e. what will become the recorded
state after we finalize our changes.

But we're not done yet: we must also adapt the pending patch and the working
tree. Note that changing the working tree is not done in this procedure, we
merely return a list of prims to apply to working. Let us add the difference
between pristine and working, which we call pw, to the picture.

     T       U
    / \     /
 us' them' pw
  /     \ /
 Y       R
  \     /
 them  us
    \ /
     X

It is easy to see now that we must merge pw with them', as both start at the
(old) recorded state. This gives us pw' and them''.

         U'
        / \
      pw' them''
      /     \
     T       U
    / \     /
 us' them' pw
  /     \ /
 Y       R
  \     /
 them  us
    \ /
     X

Since U is our unrecorded state, them'' leads us from our old unrecorded
state to the new one, so this is what we will return (if there are no
conflicts; if there are, see below).

What about the pending patch? It starts at R and goes half-way toward U
since it is a prefix of pw. The new pending should start at T and go
half-way toward the new working state U'. Instead of adapting the old
pending patch, we set the new pending patch to pw', ignoring the old one.
This relies on sifting to commute out and drop the parts that need not be in
the pending patch, which is done when we finalize the tentative changes.

Up to now we did not consider conflicts. Any new conflicts arising from the
merges we made so far must be "resolved", that is, marked for manual
resolution, if possible, or at least reported to the user. We made two
merges, one with us and one with pw. It is important now to realize that our
existing repo, and in particular the sequence us, could already be
conflicted. Our job is to resolve only /new/ conflicts and not any
unresolved conflicts that were already in our repo. So, from the rightmost
branch of our double merge us+>+pw+>+them'', we should /not/ resolve us. And
since the original pw cannot be conflicted (it consists of prim patches
only) we can disregard it. This leaves only them'' which is what we pass to
standardResolution to generate the markup, along with its full context,
consisting of (common +>+ us +>+ pw).

The resulting "resolution" goes on top, leading to our final unrecorded
state U'':

         U''
         |
        res
         |
         U'
        / \
      pw' them''
      /     \
     T       U
    / \     /
 us' them' pw
  /     \ /
 Y       R
  \     /
 them  us
    \ /
     X

In case the patches we pull are in conflict with local /unrecorded/ changes
(i.e. pw), we want to warn the user about that and allow them to cancel the
operation. The reason is that it is hard to reconstruct the original
unrecorded changes when they are messed up with conflict resolution markup.
To see if this is the case we check whether pw' has conflicts. As an extra
precaution we backup any conflicted files, so the user can refer to them to
restore things or compare in a diff viewer.

The patches we return are what we need to update U to U'' i.e. them''+>+res.
The new pending patch starts out at the new tentative state, so as explained
above, we set it to pw'+>+res, and again rely on sifting to commute out and
drop anything we don't need.

TODO: We should return a properly coerced @Repository 'RW p wU wR@.
-}

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
    -- Note: we use anonymous here to wrap the unrecorded changes.
    -- This is benign because we only retain the effect of the results
    -- of the merge (pw' and them'').
    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
          -- This optimization is valid only if @them@ didn't have
          -- (unresolved) conflicts in the first place
          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
          -- we catch "hIsTerminalDevice: illegal operation (handle is closed)"
          -- which can be thrown when we apply patches remotely (i.e. during push)
          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" -- was handled in announceConflicts
      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'
        -- these two cases result in the same trees (that's the idea of
        -- merging), so we only operate on the set of patches and do the
        -- adaption of pristine and pending in the common code below
        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
                -- we do not actually remove any effect in the end, so
                -- it would be wrong to update the unrevert bundle or
                -- the working tree or pending
                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