-- 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
    , announceMergeConflicts
    ) where

import Prelude ()
import Darcs.Prelude

import Control.Monad ( when, unless )
import Data.List.Ordered ( nubSort )
import System.Exit ( exitSuccess )

import Darcs.Util.Tree( Tree )
import Darcs.Util.External ( backupByCopying )

import Darcs.Patch
    ( RepoPatch, IsRepoType, PrimOf, merge, listTouchedFiles
    , fromPrims, effect, WrappedNamed
    , listConflictedFiles )
import Darcs.Patch.Prim ( PrimPatch )
import Darcs.Patch.Apply ( ApplyState )
import Darcs.Patch.Depends( merge2FL )
import Darcs.Patch.Named.Wrapped ( activecontents, anonymous, namedIsInternal )
import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, n2pia, hopefully )
import Darcs.Patch.Progress( progressFL )
import Darcs.Patch.Witnesses.Ordered
    ( FL(..), (:\/:)(..), (:/\:)(..), (+>+),
    mapFL_FL, concatFL, filterOutFLFL )
import Darcs.Patch.Witnesses.Sealed ( Sealed(Sealed), seal )

import Darcs.Repository.Flags
    ( UseIndex
    , ScanKnown
    , AllowConflicts (..)
    , Reorder (..)
    , UpdateWorking (..)
    , ExternalMerge (..)
    , Verbosity (..)
    , Compression (..)
    , WantGuiPause (..)
    , DiffAlgorithm (..)
    , UseCache(..)
    , LookForMoves(..)
    , LookForReplaces(..)
    )
import Darcs.Repository.Hashed
    ( tentativelyAddPatches_
    , applyToTentativePristine
    , tentativelyRemovePatches_
    , UpdatePristine(..) )
import Darcs.Repository.Identify ( identifyRepository )
import Darcs.Repository.InternalTypes ( Repository )
import Darcs.Repository.Pending ( setTentativePending, readPending )
import Darcs.Repository.Resolution ( standardResolution, externalResolution )
import Darcs.Repository.State ( unrecordedChanges, readUnrecorded )

import Darcs.Util.Prompt ( promptYorn )
import Darcs.Util.Global ( darcsdir )
import Darcs.Util.Progress( debugMessage )
import Darcs.Util.Printer.Color (fancyPrinters)
import Darcs.Util.Printer ( text, ($$), redText, putDocLnWith, ($$) )

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
/= :: MakeChanges -> MakeChanges -> Bool
$c/= :: MakeChanges -> MakeChanges -> Bool
== :: MakeChanges -> MakeChanges -> Bool
$c== :: MakeChanges -> MakeChanges -> Bool
Eq )

tentativelyMergePatches_ :: forall rt p wR wU wT wY wX
                          . (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)
                         => MakeChanges
                         -> Repository rt p wR wU wT -> String
                         -> AllowConflicts -> UpdateWorking
                         -> ExternalMerge -> WantGuiPause
                         -> Compression -> Verbosity -> Reorder
                         -> ( UseIndex, ScanKnown, DiffAlgorithm )
                         -> FL (PatchInfoAnd rt p) wX wT
                         -> FL (PatchInfoAnd rt p) wX wY
                         -> IO (Sealed (FL (PrimOf p) wU))
tentativelyMergePatches_ :: MakeChanges
-> Repository rt p wR wU wT
-> String
-> AllowConflicts
-> UpdateWorking
-> ExternalMerge
-> WantGuiPause
-> Compression
-> Verbosity
-> Reorder
-> (UseIndex, ScanKnown, DiffAlgorithm)
-> FL (PatchInfoAnd rt p) wX wT
-> FL (PatchInfoAnd rt p) wX wY
-> IO (Sealed (FL (PrimOf p) wU))
tentativelyMergePatches_ mc :: MakeChanges
mc r :: Repository rt p wR wU wT
r cmd :: String
cmd allowConflicts :: AllowConflicts
allowConflicts updateWorking :: UpdateWorking
updateWorking externalMerge :: ExternalMerge
externalMerge
  wantGuiPause :: WantGuiPause
wantGuiPause compression :: Compression
compression verbosity :: Verbosity
verbosity reorder :: Reorder
reorder diffingOpts :: (UseIndex, ScanKnown, DiffAlgorithm)
diffingOpts@(_, _, dflag :: DiffAlgorithm
dflag) us :: FL (PatchInfoAnd rt p) wX wT
us them :: FL (PatchInfoAnd rt p) wX wY
them = do
    (them_merged :: FL (PatchInfoAnd rt p) wT wZ
them_merged :/\: us_merged :: FL (PatchInfoAnd rt p) wY wZ
us_merged)
         <- (:/\:) (FL (PatchInfoAnd rt p)) (FL (PatchInfoAnd rt p)) wT wY
-> IO
     ((:/\:) (FL (PatchInfoAnd rt p)) (FL (PatchInfoAnd rt p)) wT wY)
forall (m :: * -> *) a. Monad m => a -> m a
return ((:/\:) (FL (PatchInfoAnd rt p)) (FL (PatchInfoAnd rt p)) wT wY
 -> IO
      ((:/\:) (FL (PatchInfoAnd rt p)) (FL (PatchInfoAnd rt p)) wT wY))
-> (:/\:) (FL (PatchInfoAnd rt p)) (FL (PatchInfoAnd rt p)) wT wY
-> IO
     ((:/\:) (FL (PatchInfoAnd rt p)) (FL (PatchInfoAnd rt p)) wT wY)
forall a b. (a -> b) -> a -> b
$ FL (PatchInfoAnd rt p) wX wT
-> FL (PatchInfoAnd rt p) wX wY
-> (:/\:) (FL (PatchInfoAnd rt p)) (FL (PatchInfoAnd rt p)) wT wY
forall (p :: * -> * -> *) (rt :: RepoType) wX wY wZ.
Merge p =>
FL (PatchInfoAnd rt p) wX wY
-> FL (PatchInfoAnd rt p) wX wZ
-> (:/\:) (FL (PatchInfoAnd rt p)) (FL (PatchInfoAnd rt p)) wY wZ
merge2FL (String
-> FL (PatchInfoAnd rt p) wX wT -> FL (PatchInfoAnd rt p) wX wT
forall (a :: * -> * -> *) wX wY. String -> FL a wX wY -> FL a wX wY
progressFL "Merging us" FL (PatchInfoAnd rt p) wX wT
us)
                              (String
-> FL (PatchInfoAnd rt p) wX wY -> FL (PatchInfoAnd rt p) wX wY
forall (a :: * -> * -> *) wX wY. String -> FL a wX wY -> FL a wX wY
progressFL "Merging them" FL (PatchInfoAnd rt p) wX wY
them)
    FL (PrimOf p) wT wU
pend <- (UseIndex, ScanKnown, DiffAlgorithm)
-> LookForMoves
-> LookForReplaces
-> Repository rt p wR wU wT
-> Maybe [SubPath]
-> IO (FL (PrimOf p) wT 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 (UseIndex, ScanKnown, DiffAlgorithm)
diffingOpts LookForMoves
NoLookForMoves LookForReplaces
NoLookForReplaces Repository rt p wR wU wT
r Maybe [SubPath]
forall a. Maybe a
Nothing
    PatchInfoAnd rt p wT wU
anonpend <- WrappedNamed rt p wT wU -> PatchInfoAnd rt p wT wU
forall (rt :: RepoType) (p :: * -> * -> *) wX wY.
WrappedNamed rt p wX wY -> PatchInfoAnd rt p wX wY
n2pia (WrappedNamed rt p wT wU -> PatchInfoAnd rt p wT wU)
-> IO (WrappedNamed rt p wT wU) -> IO (PatchInfoAnd rt p wT wU)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` FL p wT wU -> IO (WrappedNamed rt p wT wU)
forall (p :: * -> * -> *) wX wY (rt :: RepoType).
FL p wX wY -> IO (WrappedNamed rt p wX wY)
anonymous (FL (PrimOf (FL p)) wT wU -> FL p wT wU
forall (p :: * -> * -> *) wX wY.
FromPrims p =>
FL (PrimOf p) wX wY -> p wX wY
fromPrims FL (PrimOf p) wT wU
FL (PrimOf (FL p)) wT wU
pend)
    pend' :: FL (PatchInfoAnd rt p) wZ wZ
pend' :/\: pw :: FL (PatchInfoAnd rt p) wU wZ
pw <- (:/\:) (FL (PatchInfoAnd rt p)) (FL (PatchInfoAnd rt p)) wZ wU
-> IO
     ((:/\:) (FL (PatchInfoAnd rt p)) (FL (PatchInfoAnd rt p)) wZ wU)
forall (m :: * -> *) a. Monad m => a -> m a
return ((:/\:) (FL (PatchInfoAnd rt p)) (FL (PatchInfoAnd rt p)) wZ wU
 -> IO
      ((:/\:) (FL (PatchInfoAnd rt p)) (FL (PatchInfoAnd rt p)) wZ wU))
-> (:/\:) (FL (PatchInfoAnd rt p)) (FL (PatchInfoAnd rt p)) wZ wU
-> IO
     ((:/\:) (FL (PatchInfoAnd rt p)) (FL (PatchInfoAnd rt p)) wZ wU)
forall a b. (a -> b) -> a -> b
$ (:\/:) (FL (PatchInfoAnd rt p)) (FL (PatchInfoAnd rt p)) wZ wU
-> (:/\:) (FL (PatchInfoAnd rt p)) (FL (PatchInfoAnd rt p)) wZ wU
forall (p :: * -> * -> *) wX wY.
Merge p =>
(:\/:) p p wX wY -> (:/\:) p p wX wY
merge (FL (PatchInfoAnd rt p) wT wZ
them_merged FL (PatchInfoAnd rt p) wT wZ
-> FL (PatchInfoAnd rt p) wT wU
-> (:\/:) (FL (PatchInfoAnd rt p)) (FL (PatchInfoAnd rt p)) wZ wU
forall (a1 :: * -> * -> *) (a2 :: * -> * -> *) wX wY wZ.
a1 wZ wX -> a2 wZ wY -> (:\/:) a1 a2 wX wY
:\/: PatchInfoAnd rt p wT wU
anonpend PatchInfoAnd rt p wT wU
-> FL (PatchInfoAnd rt p) wU wU -> FL (PatchInfoAnd rt p) wT wU
forall (a :: * -> * -> *) wX wY wZ.
a wX wY -> FL a wY wZ -> FL a wX wZ
:>: FL (PatchInfoAnd rt p) wU wU
forall (a :: * -> * -> *) wX. FL a wX wX
NilFL)
    let pwprim :: FL p wU wZ
pwprim = 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
$ String -> FL (FL p) wU wZ -> FL (FL p) wU wZ
forall (a :: * -> * -> *) wX wY. String -> FL a wX wY -> FL a wX wY
progressFL "Examining patches for conflicts" (FL (FL p) wU wZ -> FL (FL p) wU wZ)
-> FL (FL p) wU wZ -> FL (FL p) wU wZ
forall a b. (a -> b) -> a -> b
$
                                (forall wW wY. PatchInfoAnd rt p wW wY -> FL p wW wY)
-> FL (PatchInfoAnd rt 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 (WrappedNamed rt p wW wY -> FL p wW wY
forall (rt :: RepoType) (p :: * -> * -> *) wX wY.
WrappedNamed rt p wX wY -> FL p wX wY
activecontents (WrappedNamed rt p wW wY -> FL p wW wY)
-> (PatchInfoAnd rt p wW wY -> WrappedNamed rt p wW wY)
-> PatchInfoAnd rt p wW wY
-> FL p wW wY
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PatchInfoAnd rt p wW wY -> WrappedNamed rt p wW wY
forall (rt :: RepoType) (p :: * -> * -> *) wA wB.
PatchInfoAnd rt p wA wB -> WrappedNamed rt p wA wB
hopefully) FL (PatchInfoAnd rt p) wU wZ
pw
    Sealed standard_resolved_pw :: FL (PrimOf p) wZ wX
standard_resolved_pw <- Sealed (FL (PrimOf p) wZ) -> IO (Sealed (FL (PrimOf p) wZ))
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 p wU wZ -> Sealed (FL (PrimOf p) wZ)
forall (p :: * -> * -> *) wX wY.
(PrimPatchBase p, Conflict p, CommuteNoConflicts p) =>
FL p wX wY -> Sealed (FL (PrimOf p) wY)
standardResolution FL p wU wZ
pwprim
    String -> IO ()
debugMessage "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
== AllowConflicts
YesAllowConflictsAndMark) (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
$ FL (PrimOf p) wZ wX -> [String]
forall (p :: * -> * -> *) wX wY.
PatchInspect p =>
p wX wY -> [String]
listTouchedFiles FL (PrimOf p) wZ wX
standard_resolved_pw
    String -> IO ()
debugMessage "Announcing conflicts..."
    Bool
have_conflicts <-
        String
-> AllowConflicts
-> ExternalMerge
-> FL (PrimOf p) wZ wX
-> IO Bool
forall (p :: * -> * -> *) wX wY.
PrimPatch p =>
String -> AllowConflicts -> ExternalMerge -> FL p wX wY -> IO Bool
announceMergeConflicts String
cmd AllowConflicts
allowConflicts ExternalMerge
externalMerge FL (PrimOf p) wZ wX
standard_resolved_pw
    String -> IO ()
debugMessage "Checking for unrecorded conflicts..."
    Bool
have_unrecorded_conflicts <- UpdateWorking -> FL (WrappedNamed rt p) wT wZ -> IO Bool
forall (rt :: RepoType) (p :: * -> * -> *) wT wY.
RepoPatch p =>
UpdateWorking -> FL (WrappedNamed rt p) wT wY -> IO Bool
checkUnrecordedConflicts UpdateWorking
updateWorking (FL (WrappedNamed rt p) wT wZ -> IO Bool)
-> FL (WrappedNamed rt p) wT wZ -> IO Bool
forall a b. (a -> b) -> a -> b
$
                                     (forall wW wY. PatchInfoAnd rt p wW wY -> WrappedNamed rt p wW wY)
-> FL (PatchInfoAnd rt p) wT wZ -> FL (WrappedNamed rt p) wT 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 forall wW wY. PatchInfoAnd rt p wW wY -> WrappedNamed rt p wW wY
forall (rt :: RepoType) (p :: * -> * -> *) wA wB.
PatchInfoAnd rt p wA wB -> WrappedNamed rt p wA wB
hopefully FL (PatchInfoAnd rt p) wT wZ
them_merged
    String -> IO ()
debugMessage "Reading working directory..."
    Tree IO
working <- Repository rt p wR wU wT -> Maybe [SubPath] -> IO (Tree IO)
forall (p :: * -> * -> *) (rt :: RepoType) wR wU wT.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wT -> Maybe [SubPath] -> IO (Tree IO)
readUnrecorded Repository rt p wR wU wT
r Maybe [SubPath]
forall a. Maybe a
Nothing
    String -> IO ()
debugMessage "Working out conflicts in actual working directory..."
    let haveConflicts :: Bool
haveConflicts = Bool
have_conflicts Bool -> Bool -> Bool
|| Bool
have_unrecorded_conflicts
    Sealed pw_resolution :: FL (PrimOf p) wZ wX
pw_resolution <-
        case (ExternalMerge
externalMerge , Bool
haveConflicts) of
            (NoExternalMerge, _)       -> Sealed (FL (PrimOf p) wZ) -> IO (Sealed (FL (PrimOf p) wZ))
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
$ if AllowConflicts
allowConflicts AllowConflicts -> AllowConflicts -> Bool
forall a. Eq a => a -> a -> Bool
== AllowConflicts
YesAllowConflicts
                                                     then 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
                                                     else FL (PrimOf p) wZ wX -> Sealed (FL (PrimOf p) wZ)
forall (a :: * -> *) wX. a wX -> Sealed a
seal FL (PrimOf p) wZ wX
standard_resolved_pw
            (_, False)                 -> Sealed (FL (PrimOf p) wZ) -> IO (Sealed (FL (PrimOf p) wZ))
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 wX -> Sealed (FL (PrimOf p) wZ)
forall (a :: * -> *) wX. a wX -> Sealed a
seal FL (PrimOf p) wZ wX
standard_resolved_pw
            (YesExternalMerge c :: String
c, True) -> DiffAlgorithm
-> Tree IO
-> String
-> WantGuiPause
-> FL (PrimOf p) wX wU
-> FL (PrimOf p) wX 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
dflag Tree IO
working String
c WantGuiPause
wantGuiPause
                                             (FL (PatchInfoAnd rt p) wX wT
-> FL (PrimOf (FL (PatchInfoAnd rt p))) wX wT
forall (p :: * -> * -> *) wX wY.
Effect p =>
p wX wY -> FL (PrimOf p) wX wY
effect FL (PatchInfoAnd rt p) wX wT
us FL (PrimOf p) wX wT -> FL (PrimOf p) wT wU -> FL (PrimOf p) wX wU
forall (a :: * -> * -> *) wX wY wZ.
FL a wX wY -> FL a wY wZ -> FL a wX wZ
+>+ FL (PrimOf p) wT wU
pend) (FL (PatchInfoAnd rt p) wX wY
-> FL (PrimOf (FL (PatchInfoAnd rt p))) wX wY
forall (p :: * -> * -> *) wX wY.
Effect p =>
p wX wY -> FL (PrimOf p) wX wY
effect FL (PatchInfoAnd rt p) wX wY
them) FL p wU wZ
pwprim
    String -> IO ()
debugMessage "Applying patches to the local directories..."
    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
        -- 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 rt p wR wU wZ
r' <- case Reorder
reorder of
            NoReorder -> do
                UpdatePristine
-> Repository rt p wR wU wT
-> Compression
-> Verbosity
-> UpdateWorking
-> FL (PatchInfoAnd rt p) wT wZ
-> IO (Repository rt p wR wU wZ)
forall (p :: * -> * -> *) (rt :: RepoType) wR wU wT wY.
(RepoPatch p, ApplyState p ~ Tree) =>
UpdatePristine
-> Repository rt p wR wU wT
-> Compression
-> Verbosity
-> UpdateWorking
-> FL (PatchInfoAnd rt p) wT wY
-> IO (Repository rt p wR wU wY)
tentativelyAddPatches_ UpdatePristine
DontUpdatePristine Repository rt p wR wU wT
r
                    Compression
compression Verbosity
verbosity UpdateWorking
updateWorking FL (PatchInfoAnd rt p) wT wZ
them_merged
            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 rt p wR wU wX
r1 <- UpdatePristine
-> Repository rt p wR wU wT
-> Compression
-> UpdateWorking
-> FL (PatchInfoAnd rt p) wX wT
-> IO (Repository rt p wR wU wX)
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT wX.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
UpdatePristine
-> Repository rt p wR wU wT
-> Compression
-> UpdateWorking
-> FL (PatchInfoAnd rt p) wX wT
-> IO (Repository rt p wR wU wX)
tentativelyRemovePatches_ UpdatePristine
DontUpdatePristineNorRevert Repository rt p wR wU wT
r
                          Compression
compression UpdateWorking
NoUpdateWorking
                          ((forall wX wY. PatchInfoAnd rt p wX wY -> EqCheck wX wY)
-> FL (PatchInfoAnd rt p) wX wT -> FL (PatchInfoAnd rt p) wX wT
forall (p :: * -> * -> *) wW wZ.
(forall wX wY. p wX wY -> EqCheck wX wY)
-> FL p wW wZ -> FL p wW wZ
filterOutFLFL (WrappedNamed rt p wX wY -> EqCheck wX wY
forall (rt :: RepoType) (p :: * -> * -> *) wX wY.
IsRepoType rt =>
WrappedNamed rt p wX wY -> EqCheck wX wY
namedIsInternal (WrappedNamed rt p wX wY -> EqCheck wX wY)
-> (PatchInfoAnd rt p wX wY -> WrappedNamed rt p wX wY)
-> PatchInfoAnd rt p wX wY
-> EqCheck wX wY
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PatchInfoAnd rt p wX wY -> WrappedNamed rt p wX wY
forall (rt :: RepoType) (p :: * -> * -> *) wA wB.
PatchInfoAnd rt p wA wB -> WrappedNamed rt p wA wB
hopefully) FL (PatchInfoAnd rt p) wX wT
us)
                Repository rt p wR wU wY
r2 <- UpdatePristine
-> Repository rt p wR wU wX
-> Compression
-> Verbosity
-> UpdateWorking
-> FL (PatchInfoAnd rt p) wX wY
-> IO (Repository rt p wR wU wY)
forall (p :: * -> * -> *) (rt :: RepoType) wR wU wT wY.
(RepoPatch p, ApplyState p ~ Tree) =>
UpdatePristine
-> Repository rt p wR wU wT
-> Compression
-> Verbosity
-> UpdateWorking
-> FL (PatchInfoAnd rt p) wT wY
-> IO (Repository rt p wR wU wY)
tentativelyAddPatches_ UpdatePristine
DontUpdatePristine Repository rt p wR wU wX
r1
                          Compression
compression Verbosity
verbosity UpdateWorking
NoUpdateWorking FL (PatchInfoAnd rt p) wX wY
them
                UpdatePristine
-> Repository rt p wR wU wY
-> Compression
-> Verbosity
-> UpdateWorking
-> FL (PatchInfoAnd rt p) wY wZ
-> IO (Repository rt p wR wU wZ)
forall (p :: * -> * -> *) (rt :: RepoType) wR wU wT wY.
(RepoPatch p, ApplyState p ~ Tree) =>
UpdatePristine
-> Repository rt p wR wU wT
-> Compression
-> Verbosity
-> UpdateWorking
-> 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 UpdateWorking
NoUpdateWorking
                    ((forall wX wY. PatchInfoAnd rt p wX wY -> EqCheck wX wY)
-> FL (PatchInfoAnd rt p) wY wZ -> FL (PatchInfoAnd rt p) wY wZ
forall (p :: * -> * -> *) wW wZ.
(forall wX wY. p wX wY -> EqCheck wX wY)
-> FL p wW wZ -> FL p wW wZ
filterOutFLFL (WrappedNamed rt p wX wY -> EqCheck wX wY
forall (rt :: RepoType) (p :: * -> * -> *) wX wY.
IsRepoType rt =>
WrappedNamed rt p wX wY -> EqCheck wX wY
namedIsInternal (WrappedNamed rt p wX wY -> EqCheck wX wY)
-> (PatchInfoAnd rt p wX wY -> WrappedNamed rt p wX wY)
-> PatchInfoAnd rt p wX wY
-> EqCheck wX wY
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PatchInfoAnd rt p wX wY -> WrappedNamed rt p wX wY
forall (rt :: RepoType) (p :: * -> * -> *) wA wB.
PatchInfoAnd rt p wA wB -> WrappedNamed rt p wA wB
hopefully) FL (PatchInfoAnd rt p) wY wZ
us_merged)
        -- must use the original r, not the updated one here:
        Repository rt p wR wU wT
-> Verbosity -> FL (PatchInfoAnd rt p) wT wZ -> IO ()
forall (q :: * -> * -> *) (rt :: RepoType) (p :: * -> * -> *) wR wU
       wT wY.
(ApplyState q ~ Tree, Apply q, ShowPatch q) =>
Repository rt p wR wU wT -> Verbosity -> q wT wY -> IO ()
applyToTentativePristine Repository rt p wR wU wT
r Verbosity
verbosity FL (PatchInfoAnd rt p) wT wZ
them_merged
        Repository rt p wR wU wZ
-> UpdateWorking -> FL (PrimOf p) wZ wX -> IO ()
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT wX wY.
RepoPatch p =>
Repository rt p wR wU wT
-> UpdateWorking -> FL (PrimOf p) wX wY -> IO ()
setTentativePending Repository rt p wR wU wZ
r' UpdateWorking
updateWorking (FL (PatchInfoAnd rt p) wZ wZ
-> FL (PrimOf (FL (PatchInfoAnd rt p))) wZ wZ
forall (p :: * -> * -> *) wX wY.
Effect p =>
p wX wY -> FL (PrimOf p) wX wY
effect FL (PatchInfoAnd rt p) wZ wZ
pend' 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
pw_resolution)
    Sealed (FL (PrimOf p) wU) -> IO (Sealed (FL (PrimOf p) wU))
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 (p :: * -> * -> *) wX wY.
Effect p =>
p wX wY -> FL (PrimOf p) wX wY
effect FL p wU wZ
pwprim 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
pw_resolution)

tentativelyMergePatches :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)
                        => Repository rt p wR wU wT -> String
                        -> AllowConflicts -> UpdateWorking
                        -> ExternalMerge -> WantGuiPause
                        -> Compression -> Verbosity -> Reorder
                        -> ( UseIndex, ScanKnown, DiffAlgorithm )
                        -> FL (PatchInfoAnd rt p) wX wT
                        -> FL (PatchInfoAnd rt p) wX wY
                        -> IO (Sealed (FL (PrimOf p) wU))
tentativelyMergePatches :: Repository rt p wR wU wT
-> String
-> AllowConflicts
-> UpdateWorking
-> ExternalMerge
-> WantGuiPause
-> Compression
-> Verbosity
-> Reorder
-> (UseIndex, ScanKnown, DiffAlgorithm)
-> FL (PatchInfoAnd rt p) wX wT
-> FL (PatchInfoAnd rt p) wX wY
-> IO (Sealed (FL (PrimOf p) wU))
tentativelyMergePatches = MakeChanges
-> Repository rt p wR wU wT
-> String
-> AllowConflicts
-> UpdateWorking
-> ExternalMerge
-> WantGuiPause
-> Compression
-> Verbosity
-> Reorder
-> (UseIndex, ScanKnown, DiffAlgorithm)
-> FL (PatchInfoAnd rt p) wX wT
-> FL (PatchInfoAnd rt p) wX wY
-> IO (Sealed (FL (PrimOf p) wU))
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT wY wX.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
MakeChanges
-> Repository rt p wR wU wT
-> String
-> AllowConflicts
-> UpdateWorking
-> ExternalMerge
-> WantGuiPause
-> Compression
-> Verbosity
-> Reorder
-> (UseIndex, ScanKnown, DiffAlgorithm)
-> FL (PatchInfoAnd rt p) wX wT
-> FL (PatchInfoAnd rt p) wX wY
-> IO (Sealed (FL (PrimOf p) wU))
tentativelyMergePatches_ MakeChanges
MakeChanges


considerMergeToWorking :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)
                       => Repository rt p wR wU wT -> String
                       -> AllowConflicts -> UpdateWorking
                       -> ExternalMerge -> WantGuiPause
                       -> Compression -> Verbosity -> Reorder
                       -> ( UseIndex, ScanKnown, DiffAlgorithm )
                       -> FL (PatchInfoAnd rt p) wX wT
                       -> FL (PatchInfoAnd rt p) wX wY
                       -> IO (Sealed (FL (PrimOf p) wU))
considerMergeToWorking :: Repository rt p wR wU wT
-> String
-> AllowConflicts
-> UpdateWorking
-> ExternalMerge
-> WantGuiPause
-> Compression
-> Verbosity
-> Reorder
-> (UseIndex, ScanKnown, DiffAlgorithm)
-> FL (PatchInfoAnd rt p) wX wT
-> FL (PatchInfoAnd rt p) wX wY
-> IO (Sealed (FL (PrimOf p) wU))
considerMergeToWorking = MakeChanges
-> Repository rt p wR wU wT
-> String
-> AllowConflicts
-> UpdateWorking
-> ExternalMerge
-> WantGuiPause
-> Compression
-> Verbosity
-> Reorder
-> (UseIndex, ScanKnown, DiffAlgorithm)
-> FL (PatchInfoAnd rt p) wX wT
-> FL (PatchInfoAnd rt p) wX wY
-> IO (Sealed (FL (PrimOf p) wU))
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT wY wX.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
MakeChanges
-> Repository rt p wR wU wT
-> String
-> AllowConflicts
-> UpdateWorking
-> ExternalMerge
-> WantGuiPause
-> Compression
-> Verbosity
-> Reorder
-> (UseIndex, ScanKnown, DiffAlgorithm)
-> FL (PatchInfoAnd rt p) wX wT
-> FL (PatchInfoAnd rt p) wX wY
-> IO (Sealed (FL (PrimOf p) wU))
tentativelyMergePatches_ MakeChanges
DontMakeChanges


announceMergeConflicts :: (PrimPatch p)
                       => String
                       -> AllowConflicts
                       -> ExternalMerge
                       -> FL p wX wY
                       -> IO Bool
announceMergeConflicts :: String -> AllowConflicts -> ExternalMerge -> FL p wX wY -> IO Bool
announceMergeConflicts cmd :: String
cmd allowConflicts :: AllowConflicts
allowConflicts externalMerge :: ExternalMerge
externalMerge resolved_pw :: FL p wX wY
resolved_pw =
  case [String] -> [String]
forall a. Ord a => [a] -> [a]
nubSort ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ FL p wX wY -> [String]
forall (p :: * -> * -> *) wX wY.
PatchInspect p =>
p wX wY -> [String]
listTouchedFiles FL p wX wY
resolved_pw of
    [] -> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
    cfs :: [String]
cfs -> if AllowConflicts
allowConflicts AllowConflicts -> [AllowConflicts] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [AllowConflicts
YesAllowConflicts,AllowConflicts
YesAllowConflictsAndMark]
              Bool -> Bool -> Bool
|| ExternalMerge
externalMerge ExternalMerge -> ExternalMerge -> Bool
forall a. Eq a => a -> a -> Bool
/= ExternalMerge
NoExternalMerge
           then do Printers -> Doc -> IO ()
putDocLnWith Printers
fancyPrinters (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$
                     String -> Doc
redText "We have conflicts in the following files:" Doc -> Doc -> Doc
$$ String -> Doc
text ([String] -> String
unlines [String]
cfs)
                   Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
           else do Printers -> Doc -> IO ()
putDocLnWith Printers
fancyPrinters (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$
                     String -> Doc
redText "There are conflicts in the following files:" Doc -> Doc -> Doc
$$ String -> Doc
text ([String] -> String
unlines [String]
cfs)
                   String -> IO Bool
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO Bool) -> String -> IO Bool
forall a b. (a -> b) -> a -> b
$ "Refusing to "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
cmdString -> String -> String
forall a. [a] -> [a] -> [a]
++" patches leading to conflicts.\n"String -> String -> String
forall a. [a] -> [a] -> [a]
++
                          "If you would rather apply the patch and mark the conflicts,\n"String -> String -> String
forall a. [a] -> [a] -> [a]
++
                          "use the --mark-conflicts or --allow-conflicts options to "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
cmdString -> String -> String
forall a. [a] -> [a] -> [a]
++"\n"String -> String -> String
forall a. [a] -> [a] -> [a]
++
                          "These can set as defaults by adding\n"String -> String -> String
forall a. [a] -> [a] -> [a]
++
                          " "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
cmdString -> String -> String
forall a. [a] -> [a] -> [a]
++" mark-conflicts\n"String -> String -> String
forall a. [a] -> [a] -> [a]
++
                          "to "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
darcsdirString -> String -> String
forall a. [a] -> [a] -> [a]
++"/prefs/defaults in the target repo. "

checkUnrecordedConflicts :: forall rt p wT wY. RepoPatch p
                         => UpdateWorking
                         -> FL (WrappedNamed rt p) wT wY
                         -> IO Bool
checkUnrecordedConflicts :: UpdateWorking -> FL (WrappedNamed rt p) wT wY -> IO Bool
checkUnrecordedConflicts NoUpdateWorking _
 = Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False -- because we are called by `darcs convert` hence we don't care
checkUnrecordedConflicts _ pc :: FL (WrappedNamed rt p) wT wY
pc =
    do Repository rt p Any Any wT
repository <- UseCache -> String -> IO (Repository rt p Any Any wT)
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
UseCache -> String -> IO (Repository rt p wR wU wT)
identifyRepository UseCache
NoUseCache "."
       Repository rt p Any Any wT -> IO Bool
forall wR wU. Repository rt p wR wU wT -> IO Bool
cuc Repository rt p Any Any wT
repository
    where cuc :: Repository rt p wR wU wT -> IO Bool
          cuc :: Repository rt p wR wU wT -> IO Bool
cuc r :: Repository rt p wR wU wT
r = do Sealed (mpend :: FL (PrimOf p) wT wX) <- Repository rt p wR wU wT -> IO (Sealed (FL (PrimOf p) wT))
forall (p :: * -> * -> *) (rt :: RepoType) wR wU wT.
RepoPatch p =>
Repository rt p wR wU wT -> IO (Sealed (FL (PrimOf p) wT))
readPending Repository rt p wR wU wT
r :: IO (Sealed (FL (PrimOf p) wT))
                     case FL (PrimOf p) wT wX
mpend of
                       NilFL -> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
                       pend :: FL (PrimOf p) wT wX
pend ->
                           case (:\/:) (FL p) (FL p) wX wY -> (:/\:) (FL p) (FL p) wX wY
forall (p :: * -> * -> *) wX wY.
Merge p =>
(:\/:) p p wX wY -> (:/\:) p p wX wY
merge (FL (PrimOf p) wT wX -> FL p wT wX
forall wA wB. FL (PrimOf p) wA wB -> FL p wA wB
fromPrims_ FL (PrimOf p) wT wX
pend FL p wT wX -> FL p wT wY -> (:\/:) (FL p) (FL p) wX wY
forall (a1 :: * -> * -> *) (a2 :: * -> * -> *) wX wY wZ.
a1 wZ wX -> a2 wZ wY -> (:\/:) a1 a2 wX wY
:\/: FL (PrimOf p) wT wY -> FL p wT wY
forall wA wB. FL (PrimOf p) wA wB -> FL p wA wB
fromPrims_ (FL (FL (PrimOf p)) wT wY -> FL (PrimOf p) wT wY
forall (a :: * -> * -> *) wX wZ. FL (FL a) wX wZ -> FL a wX wZ
concatFL (FL (FL (PrimOf p)) wT wY -> FL (PrimOf p) wT wY)
-> FL (FL (PrimOf p)) wT wY -> FL (PrimOf p) wT wY
forall a b. (a -> b) -> a -> b
$ (forall wW wY. WrappedNamed rt p wW wY -> FL (PrimOf p) wW wY)
-> FL (WrappedNamed rt p) wT wY -> FL (FL (PrimOf p)) wT wY
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 wW wY. WrappedNamed rt p wW wY -> FL (PrimOf p) wW wY
forall (p :: * -> * -> *) wX wY.
Effect p =>
p wX wY -> FL (PrimOf p) wX wY
effect FL (WrappedNamed rt p) wT wY
pc)) of
                           _ :/\: pend' :: FL p wY wZ
pend' ->
                               case FL p wY wZ -> [String]
forall (p :: * -> * -> *) wX wY. Conflict p => p wX wY -> [String]
listConflictedFiles FL p wY wZ
pend' of
                               [] -> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
                               fs :: [String]
fs -> do String -> IO ()
putStrLn ("You have conflicting local changes to:\n"
                                                 String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
unwords [String]
fs)
                                        Bool
confirmed <- String -> IO Bool
promptYorn "Proceed?"
                                        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 "Cancelled."
                                                IO ()
forall a. IO a
exitSuccess
                                        Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
          fromPrims_ :: FL (PrimOf p) wA wB -> FL p wA wB
          fromPrims_ :: FL (PrimOf p) wA wB -> FL p wA wB
fromPrims_ = FL (PrimOf p) wA wB -> FL p wA wB
forall (p :: * -> * -> *) wX wY.
FromPrims p =>
FL (PrimOf p) wX wY -> p wX wY
fromPrims