--  Copyright (C) 2003,2005 David Roundy
--
--  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.Resolution
    ( standardResolution
    , externalResolution
    , patchsetConflictResolutions
    , StandardResolution(..)
    , announceConflicts
    , warnUnmangled
    , showUnmangled
    , showUnravelled
    ) where

import Darcs.Prelude

import System.FilePath.Posix ( (</>) )
import System.Exit ( ExitCode( ExitSuccess ) )
import System.Directory ( setCurrentDirectory, getCurrentDirectory )
import Data.List ( intersperse, zip4 )
import Data.List.Ordered ( nubSort )
import Data.Maybe ( catMaybes, isNothing )
import Control.Monad ( when )

import Darcs.Repository.Diff( treeDiff )
import Darcs.Patch
    ( PrimOf
    , PrimPatchBase
    , RepoPatch
    , applyToTree
    , effect
    , effectOnPaths
    , invert
    , listConflictedFiles
    , resolveConflicts
    )
import Darcs.Patch.Apply( ApplyState )
import Darcs.Patch.Commute ( Commute )
import Darcs.Patch.Conflict ( Conflict, ConflictDetails(..), Mangled, Unravelled )
import Darcs.Patch.Inspect ( listTouchedFiles )
import Darcs.Patch.Merge ( mergeList )
import Darcs.Patch.Prim ( PrimPatch )
import Darcs.Util.Path
    ( AnchoredPath
    , anchorPath
    , displayPath
    , filterPaths
    , toFilePath
    )
import Darcs.Patch.Witnesses.Ordered ( FL(..), RL(..) )
import Darcs.Patch.Witnesses.Sealed ( Sealed(..), unseal, unFreeLeft )

import Darcs.Util.CommandLine ( parseCmd )
import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd )
import Darcs.Util.Prompt ( askEnter )
import Darcs.Patch.Set ( PatchSet(..), Origin, patchSet2RL )
import Darcs.Repository.Prefs ( filetypeFunction )
import Darcs.Util.Exec ( exec, Redirect(..) )
import Darcs.Util.Lock ( withTempDir )
import Darcs.Util.External ( cloneTree )
import Darcs.Repository.Flags
    ( AllowConflicts (..)
    , ExternalMerge (..)
    , WantGuiPause (..)
    , DiffAlgorithm (..)
    )

import qualified Darcs.Util.Tree as Tree
import Darcs.Util.Tree.Plain ( writePlainTree, readPlainTree )

import Darcs.Util.Global ( darcsdir )
import Darcs.Util.Printer ( Doc, renderString, ($$), text, redText, vcat )
import Darcs.Util.Printer.Color ( ePutDocLn )
import Darcs.Patch ( displayPatch )

data StandardResolution prim wX =
  StandardResolution {
    StandardResolution prim wX -> Mangled prim wX
mangled :: Mangled prim wX,
    StandardResolution prim wX -> [Unravelled prim wX]
unmangled :: [Unravelled prim wX],
    StandardResolution prim wX -> [AnchoredPath]
conflictedPaths :: [AnchoredPath]
  }

standardResolution :: (Commute p, PrimPatchBase p, Conflict p)
                   => RL (PatchInfoAnd rt p) wO wX
                   -> RL (PatchInfoAnd rt p) wX wY
                   -> StandardResolution (PrimOf p) wY
standardResolution :: RL (PatchInfoAnd rt p) wO wX
-> RL (PatchInfoAnd rt p) wX wY -> StandardResolution (PrimOf p) wY
standardResolution RL (PatchInfoAnd rt p) wO wX
context RL (PatchInfoAnd rt p) wX wY
interesting =
  case [Sealed (FL (PrimOf p) wY)]
-> Either
     (Sealed (FL (PrimOf p) wY), Sealed (FL (PrimOf p) wY))
     (Sealed (FL (PrimOf p) wY))
forall (p :: * -> * -> *) wX.
CleanMerge p =>
[Sealed (FL p wX)]
-> Either (Sealed (FL p wX), Sealed (FL p wX)) (Sealed (FL p wX))
mergeList ([Sealed (FL (PrimOf p) wY)]
 -> Either
      (Sealed (FL (PrimOf p) wY), Sealed (FL (PrimOf p) wY))
      (Sealed (FL (PrimOf p) wY)))
-> [Sealed (FL (PrimOf p) wY)]
-> Either
     (Sealed (FL (PrimOf p) wY), Sealed (FL (PrimOf p) wY))
     (Sealed (FL (PrimOf p) wY))
forall a b. (a -> b) -> a -> b
$ [Maybe (Sealed (FL (PrimOf p) wY))] -> [Sealed (FL (PrimOf p) wY)]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe (Sealed (FL (PrimOf p) wY))]
 -> [Sealed (FL (PrimOf p) wY)])
-> [Maybe (Sealed (FL (PrimOf p) wY))]
-> [Sealed (FL (PrimOf p) wY)]
forall a b. (a -> b) -> a -> b
$ (ConflictDetails (PrimOf p) wY
 -> Maybe (Sealed (FL (PrimOf p) wY)))
-> [ConflictDetails (PrimOf p) wY]
-> [Maybe (Sealed (FL (PrimOf p) wY))]
forall a b. (a -> b) -> [a] -> [b]
map ConflictDetails (PrimOf p) wY -> Maybe (Sealed (FL (PrimOf p) wY))
forall (prim :: * -> * -> *) wX.
ConflictDetails prim wX -> Maybe (Mangled prim wX)
conflictMangled [ConflictDetails (PrimOf p) wY]
conflicts of
    Right Sealed (FL (PrimOf p) wY)
mangled -> StandardResolution :: forall (prim :: * -> * -> *) wX.
Mangled prim wX
-> [Unravelled prim wX]
-> [AnchoredPath]
-> StandardResolution prim wX
StandardResolution {[[Sealed (FL (PrimOf p) wY)]]
[AnchoredPath]
Sealed (FL (PrimOf p) wY)
conflictedPaths :: [AnchoredPath]
unmangled :: [[Sealed (FL (PrimOf p) wY)]]
mangled :: Sealed (FL (PrimOf p) wY)
conflictedPaths :: [AnchoredPath]
unmangled :: [[Sealed (FL (PrimOf p) wY)]]
mangled :: Sealed (FL (PrimOf p) wY)
..}
    Left (Sealed FL (PrimOf p) wY wX
ps, Sealed FL (PrimOf p) wY wX
qs) ->
      [Char] -> StandardResolution (PrimOf p) wY
forall a. HasCallStack => [Char] -> a
error ([Char] -> StandardResolution (PrimOf p) wY)
-> [Char] -> StandardResolution (PrimOf p) wY
forall a b. (a -> b) -> a -> b
$ Doc -> [Char]
renderString
        (Doc -> [Char]) -> Doc -> [Char]
forall a b. (a -> b) -> a -> b
$ [Char] -> Doc
redText [Char]
"resolutions conflict:"
        Doc -> Doc -> Doc
$$ FL (PrimOf p) wY wX -> Doc
forall (p :: * -> * -> *) wX wY. ShowPatchBasic p => p wX wY -> Doc
displayPatch FL (PrimOf p) wY wX
ps
        Doc -> Doc -> Doc
$$ [Char] -> Doc
redText [Char]
"conflicts with"
        Doc -> Doc -> Doc
$$ FL (PrimOf p) wY wX -> Doc
forall (p :: * -> * -> *) wX wY. ShowPatchBasic p => p wX wY -> Doc
displayPatch FL (PrimOf p) wY wX
qs
  where
    conflicts :: [ConflictDetails (PrimOf (PatchInfoAnd rt p)) wY]
conflicts = RL (PatchInfoAnd rt p) wO wX
-> RL (PatchInfoAnd rt p) wX wY
-> [ConflictDetails (PrimOf (PatchInfoAnd rt p)) wY]
forall (p :: * -> * -> *) wO wX wY.
Conflict p =>
RL p wO wX -> RL p wX wY -> [ConflictDetails (PrimOf p) wY]
resolveConflicts RL (PatchInfoAnd rt p) wO wX
context RL (PatchInfoAnd rt p) wX wY
interesting
    unmangled :: [[Sealed (FL (PrimOf p) wY)]]
unmangled = (ConflictDetails (PrimOf p) wY -> [Sealed (FL (PrimOf p) wY)])
-> [ConflictDetails (PrimOf p) wY] -> [[Sealed (FL (PrimOf p) wY)]]
forall a b. (a -> b) -> [a] -> [b]
map ConflictDetails (PrimOf p) wY -> [Sealed (FL (PrimOf p) wY)]
forall (prim :: * -> * -> *) wX.
ConflictDetails prim wX -> Unravelled prim wX
conflictParts ([ConflictDetails (PrimOf p) wY] -> [[Sealed (FL (PrimOf p) wY)]])
-> [ConflictDetails (PrimOf p) wY] -> [[Sealed (FL (PrimOf p) wY)]]
forall a b. (a -> b) -> a -> b
$ (ConflictDetails (PrimOf p) wY -> Bool)
-> [ConflictDetails (PrimOf p) wY]
-> [ConflictDetails (PrimOf p) wY]
forall a. (a -> Bool) -> [a] -> [a]
filter (Maybe (Sealed (FL (PrimOf p) wY)) -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe (Sealed (FL (PrimOf p) wY)) -> Bool)
-> (ConflictDetails (PrimOf p) wY
    -> Maybe (Sealed (FL (PrimOf p) wY)))
-> ConflictDetails (PrimOf p) wY
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConflictDetails (PrimOf p) wY -> Maybe (Sealed (FL (PrimOf p) wY))
forall (prim :: * -> * -> *) wX.
ConflictDetails prim wX -> Maybe (Mangled prim wX)
conflictMangled) [ConflictDetails (PrimOf p) wY]
conflicts
    conflictedPaths :: [AnchoredPath]
conflictedPaths =
      [AnchoredPath] -> [AnchoredPath]
forall a. Ord a => [a] -> [a]
nubSort ([AnchoredPath] -> [AnchoredPath])
-> [AnchoredPath] -> [AnchoredPath]
forall a b. (a -> b) -> a -> b
$
      (Sealed (FL (PrimOf p) wY) -> [AnchoredPath])
-> [Sealed (FL (PrimOf p) wY)] -> [AnchoredPath]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((forall wX. FL (PrimOf p) wY wX -> [AnchoredPath])
-> Sealed (FL (PrimOf p) wY) -> [AnchoredPath]
forall (a :: * -> *) b. (forall wX. a wX -> b) -> Sealed a -> b
unseal forall wX. FL (PrimOf p) wY wX -> [AnchoredPath]
forall (p :: * -> * -> *) wX wY.
PatchInspect p =>
p wX wY -> [AnchoredPath]
listTouchedFiles) ((ConflictDetails (PrimOf p) wY -> [Sealed (FL (PrimOf p) wY)])
-> [ConflictDetails (PrimOf p) wY] -> [Sealed (FL (PrimOf p) wY)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ConflictDetails (PrimOf p) wY -> [Sealed (FL (PrimOf p) wY)]
forall (prim :: * -> * -> *) wX.
ConflictDetails prim wX -> Unravelled prim wX
conflictParts [ConflictDetails (PrimOf p) wY]
conflicts)

warnUnmangled :: PrimPatch prim => StandardResolution prim wX -> IO ()
warnUnmangled :: StandardResolution prim wX -> IO ()
warnUnmangled StandardResolution {[Unravelled prim wX]
[AnchoredPath]
Mangled prim wX
conflictedPaths :: [AnchoredPath]
unmangled :: [Unravelled prim wX]
mangled :: Mangled prim wX
conflictedPaths :: forall (prim :: * -> * -> *) wX.
StandardResolution prim wX -> [AnchoredPath]
unmangled :: forall (prim :: * -> * -> *) wX.
StandardResolution prim wX -> [Unravelled prim wX]
mangled :: forall (prim :: * -> * -> *) wX.
StandardResolution prim wX -> Mangled prim wX
..}
  | [Unravelled prim wX] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Unravelled prim wX]
unmangled = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  | Bool
otherwise = Doc -> IO ()
ePutDocLn (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ [Unravelled prim wX] -> Doc
forall (prim :: * -> * -> *) wX.
PrimPatch prim =>
[Unravelled prim wX] -> Doc
showUnmangled [Unravelled prim wX]
unmangled

showUnmangled :: PrimPatch prim => [Unravelled prim wX] -> Doc
showUnmangled :: [Unravelled prim wX] -> Doc
showUnmangled = [Doc] -> Doc
vcat ([Doc] -> Doc)
-> ([Unravelled prim wX] -> [Doc]) -> [Unravelled prim wX] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Unravelled prim wX -> Doc) -> [Unravelled prim wX] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map Unravelled prim wX -> Doc
forall (prim :: * -> * -> *) wX.
(CleanMerge prim, Commute prim, Invert prim, Eq2 prim, IsHunk prim,
 PatchInspect prim, RepairToFL prim, Show2 prim, PrimConstruct prim,
 PrimCanonize prim, PrimClassify prim, PrimDetails prim,
 PrimApply prim, PrimSift prim, PrimMangleUnravelled prim,
 ReadPatch prim, ShowPatch prim, ShowContextPatch prim,
 PatchListFormat prim) =>
Unravelled prim wX -> Doc
showUnmangledConflict
  where
    showUnmangledConflict :: Unravelled prim wX -> Doc
showUnmangledConflict Unravelled prim wX
unravelled =
      [Char] -> Doc
redText [Char]
"Cannot mark these conflicting patches:" Doc -> Doc -> Doc
$$
      Doc -> Unravelled prim wX -> Doc
forall (prim :: * -> * -> *) wX.
PrimPatch prim =>
Doc -> Unravelled prim wX -> Doc
showUnravelled ([Char] -> Doc
redText [Char]
"versus") Unravelled prim wX
unravelled

showUnravelled :: PrimPatch prim => Doc -> Unravelled prim wX -> Doc
showUnravelled :: Doc -> Unravelled prim wX -> Doc
showUnravelled Doc
sep =
  [Doc] -> Doc
vcat ([Doc] -> Doc)
-> (Unravelled prim wX -> [Doc]) -> Unravelled prim wX -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
intersperse Doc
sep ([Doc] -> [Doc])
-> (Unravelled prim wX -> [Doc]) -> Unravelled prim wX -> [Doc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Sealed (FL prim wX) -> Doc) -> Unravelled prim wX -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map ((forall wX. FL prim wX wX -> Doc) -> Sealed (FL prim wX) -> Doc
forall (a :: * -> *) b. (forall wX. a wX -> b) -> Sealed a -> b
unseal forall wX. FL prim wX wX -> Doc
forall (p :: * -> * -> *) wX wY. ShowPatchBasic p => p wX wY -> Doc
displayPatch)

announceConflicts :: PrimPatch prim
                  => String
                  -> AllowConflicts
                  -> ExternalMerge
                  -> StandardResolution prim wX
                  -> IO Bool
announceConflicts :: [Char]
-> AllowConflicts
-> ExternalMerge
-> StandardResolution prim wX
-> IO Bool
announceConflicts [Char]
cmd AllowConflicts
allowConflicts ExternalMerge
externalMerge StandardResolution prim wX
conflicts =
  case [AnchoredPath] -> [AnchoredPath]
forall a. Ord a => [a] -> [a]
nubSort (StandardResolution prim wX -> [AnchoredPath]
forall (prim :: * -> * -> *) wX.
StandardResolution prim wX -> [AnchoredPath]
conflictedPaths StandardResolution prim wX
conflicts) of
    [] -> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
    [AnchoredPath]
cfs -> 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
$ [Char] -> Doc
redText
        [Char]
"We have conflicts in the following files:" Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
: (AnchoredPath -> Doc) -> [AnchoredPath] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map ([Char] -> Doc
text ([Char] -> Doc) -> (AnchoredPath -> [Char]) -> AnchoredPath -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AnchoredPath -> [Char]
displayPath) [AnchoredPath]
cfs
      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
$ StandardResolution prim wX -> IO ()
forall (prim :: * -> * -> *) wX.
PrimPatch prim =>
StandardResolution prim wX -> IO ()
warnUnmangled StandardResolution prim wX
conflicts
      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 Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
        else [Char] -> IO Bool
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> IO Bool) -> [Char] -> IO Bool
forall a b. (a -> b) -> a -> b
$
          [Char]
"Refusing to "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
cmd[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
" patches leading to conflicts.\n"[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
          [Char]
"If you would rather apply the patch and mark the conflicts,\n"[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
          [Char]
"use the --mark-conflicts or --allow-conflicts options to "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
cmd[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
"\n"[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
          [Char]
"These can set as defaults by adding\n"[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
          [Char]
" "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
cmd[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
" mark-conflicts\n"[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
          [Char]
"to "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
darcsdir[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
"/prefs/defaults in the target repo. "

externalResolution :: forall p wX wY wZ wA. (RepoPatch p, ApplyState p ~ Tree.Tree)
                   => DiffAlgorithm
                   -> Tree.Tree IO        -- ^ working tree
                   -> String              -- ^ external merge tool command
                   -> WantGuiPause        -- ^ tell whether we want GUI pause
                   -> FL (PrimOf p) wX wY -- ^ our effect
                   -> FL (PrimOf p) wX wZ -- ^ their effect
                   -> FL p wY wA          -- ^ them merged (standard_resolution)
                   -> IO (Sealed (FL (PrimOf p) wA))
externalResolution :: DiffAlgorithm
-> Tree IO
-> [Char]
-> WantGuiPause
-> FL (PrimOf p) wX wY
-> FL (PrimOf p) wX wZ
-> FL p wY wA
-> IO (Sealed (FL (PrimOf p) wA))
externalResolution DiffAlgorithm
diffa Tree IO
s1 [Char]
c WantGuiPause
wantGuiPause FL (PrimOf p) wX wY
p1 FL (PrimOf p) wX wZ
p2 FL p wY wA
pmerged = do
 Tree IO
sa <- FL (PrimOf p) wY wX -> Tree IO -> IO (Tree IO)
forall (p :: * -> * -> *) (m :: * -> *) wX wY.
(Apply p, Monad m, ApplyState p ~ Tree) =>
p wX wY -> Tree m -> m (Tree m)
applyToTree (FL (PrimOf p) wX wY -> FL (PrimOf p) wY wX
forall (p :: * -> * -> *) wX wY. Invert p => p wX wY -> p wY wX
invert FL (PrimOf p) wX wY
p1) Tree IO
s1
 Tree IO
sm <- FL p wY wA -> Tree IO -> IO (Tree IO)
forall (p :: * -> * -> *) (m :: * -> *) wX wY.
(Apply p, Monad m, ApplyState p ~ Tree) =>
p wX wY -> Tree m -> m (Tree m)
applyToTree FL p wY wA
pmerged Tree IO
s1
 Tree IO
s2 <- FL (PrimOf p) wX wZ -> Tree IO -> IO (Tree IO)
forall (p :: * -> * -> *) (m :: * -> *) wX wY.
(Apply p, Monad m, ApplyState p ~ Tree) =>
p wX wY -> Tree m -> m (Tree m)
applyToTree FL (PrimOf p) wX wZ
p2 Tree IO
sa
 let nms :: [AnchoredPath]
nms = FL p wY wA -> [AnchoredPath]
forall (p :: * -> * -> *) wX wY.
(Summary p, PatchInspect (PrimOf p)) =>
p wX wY -> [AnchoredPath]
listConflictedFiles FL p wY wA
pmerged
     nas :: [AnchoredPath]
nas = FL (PrimOf p) wA wY -> [AnchoredPath] -> [AnchoredPath]
forall (p :: * -> * -> *) wX wY.
(Apply p, ApplyState p ~ Tree) =>
p wX wY -> [AnchoredPath] -> [AnchoredPath]
effectOnPaths (FL (PrimOf p) wY wA -> FL (PrimOf p) wA wY
forall (p :: * -> * -> *) wX wY. Invert p => p wX wY -> p wY wX
invert (FL p wY wA -> FL (PrimOf (FL p)) wY wA
forall (p :: * -> * -> *) wX wY.
Effect p =>
p wX wY -> FL (PrimOf p) wX wY
effect FL p wY wA
pmerged)) [AnchoredPath]
nms
     n1s :: [AnchoredPath]
n1s = FL (PrimOf p) wX wY -> [AnchoredPath] -> [AnchoredPath]
forall (p :: * -> * -> *) wX wY.
(Apply p, ApplyState p ~ Tree) =>
p wX wY -> [AnchoredPath] -> [AnchoredPath]
effectOnPaths FL (PrimOf p) wX wY
p1 [AnchoredPath]
nas
     n2s :: [AnchoredPath]
n2s = FL (PrimOf p) wX wZ -> [AnchoredPath] -> [AnchoredPath]
forall (p :: * -> * -> *) wX wY.
(Apply p, ApplyState p ~ Tree) =>
p wX wY -> [AnchoredPath] -> [AnchoredPath]
effectOnPaths FL (PrimOf p) wX wZ
p2 [AnchoredPath]
nas
     ns :: [([Char], [Char], [Char], [Char])]
ns = [[Char]]
-> [[Char]]
-> [[Char]]
-> [[Char]]
-> [([Char], [Char], [Char], [Char])]
forall a b c d. [a] -> [b] -> [c] -> [d] -> [(a, b, c, d)]
zip4 ([AnchoredPath] -> [[Char]]
tofp [AnchoredPath]
nas) ([AnchoredPath] -> [[Char]]
tofp [AnchoredPath]
n1s) ([AnchoredPath] -> [[Char]]
tofp [AnchoredPath]
n2s) ([AnchoredPath] -> [[Char]]
tofp [AnchoredPath]
nms)
     tofp :: [AnchoredPath] -> [[Char]]
tofp = (AnchoredPath -> [Char]) -> [AnchoredPath] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map ([Char] -> AnchoredPath -> [Char]
anchorPath [Char]
"")
     write_files :: Tree IO -> [AnchoredPath] -> IO ()
write_files Tree IO
tree [AnchoredPath]
fs = Tree IO -> [Char] -> IO ()
writePlainTree ((AnchoredPath -> TreeItem IO -> Bool) -> Tree IO -> Tree IO
forall (a :: (* -> *) -> *) (m :: * -> *).
FilterTree a m =>
(AnchoredPath -> TreeItem m -> Bool) -> a m -> a m
Tree.filter ([AnchoredPath] -> AnchoredPath -> TreeItem IO -> Bool
forall t. [AnchoredPath] -> AnchoredPath -> t -> Bool
filterPaths [AnchoredPath]
fs) Tree IO
tree) [Char]
"."
  in do
   [Char]
former_dir <- IO [Char]
getCurrentDirectory
   [Char]
-> (AbsolutePath -> IO (Sealed (FL (PrimOf p) wA)))
-> IO (Sealed (FL (PrimOf p) wA))
forall a. [Char] -> (AbsolutePath -> IO a) -> IO a
withTempDir [Char]
"version1" ((AbsolutePath -> IO (Sealed (FL (PrimOf p) wA)))
 -> IO (Sealed (FL (PrimOf p) wA)))
-> (AbsolutePath -> IO (Sealed (FL (PrimOf p) wA)))
-> IO (Sealed (FL (PrimOf p) wA))
forall a b. (a -> b) -> a -> b
$ \AbsolutePath
absd1 -> do
     let d1 :: [Char]
d1 = AbsolutePath -> [Char]
forall a. FilePathLike a => a -> [Char]
toFilePath AbsolutePath
absd1
     Tree IO -> [AnchoredPath] -> IO ()
write_files Tree IO
s1 [AnchoredPath]
n1s
     [Char] -> IO ()
setCurrentDirectory [Char]
former_dir
     [Char]
-> (AbsolutePath -> IO (Sealed (FL (PrimOf p) wA)))
-> IO (Sealed (FL (PrimOf p) wA))
forall a. [Char] -> (AbsolutePath -> IO a) -> IO a
withTempDir [Char]
"ancestor" ((AbsolutePath -> IO (Sealed (FL (PrimOf p) wA)))
 -> IO (Sealed (FL (PrimOf p) wA)))
-> (AbsolutePath -> IO (Sealed (FL (PrimOf p) wA)))
-> IO (Sealed (FL (PrimOf p) wA))
forall a b. (a -> b) -> a -> b
$ \AbsolutePath
absda -> do
       let da :: [Char]
da = AbsolutePath -> [Char]
forall a. FilePathLike a => a -> [Char]
toFilePath AbsolutePath
absda
       Tree IO -> [AnchoredPath] -> IO ()
write_files Tree IO
sa [AnchoredPath]
nas
       [Char] -> IO ()
setCurrentDirectory [Char]
former_dir
       [Char]
-> (AbsolutePath -> IO (Sealed (FL (PrimOf p) wA)))
-> IO (Sealed (FL (PrimOf p) wA))
forall a. [Char] -> (AbsolutePath -> IO a) -> IO a
withTempDir [Char]
"merged" ((AbsolutePath -> IO (Sealed (FL (PrimOf p) wA)))
 -> IO (Sealed (FL (PrimOf p) wA)))
-> (AbsolutePath -> IO (Sealed (FL (PrimOf p) wA)))
-> IO (Sealed (FL (PrimOf p) wA))
forall a b. (a -> b) -> a -> b
$ \AbsolutePath
absdm -> do
         let dm :: [Char]
dm = AbsolutePath -> [Char]
forall a. FilePathLike a => a -> [Char]
toFilePath AbsolutePath
absdm
         Tree IO -> [AnchoredPath] -> IO ()
write_files Tree IO
sm [AnchoredPath]
nms
         [Char] -> IO ()
setCurrentDirectory [Char]
former_dir
         [Char]
-> (AbsolutePath -> IO (Sealed (FL (PrimOf p) wA)))
-> IO (Sealed (FL (PrimOf p) wA))
forall a. [Char] -> (AbsolutePath -> IO a) -> IO a
withTempDir [Char]
"cleanmerged" ((AbsolutePath -> IO (Sealed (FL (PrimOf p) wA)))
 -> IO (Sealed (FL (PrimOf p) wA)))
-> (AbsolutePath -> IO (Sealed (FL (PrimOf p) wA)))
-> IO (Sealed (FL (PrimOf p) wA))
forall a b. (a -> b) -> a -> b
$ \AbsolutePath
absdc -> do
           let dc :: [Char]
dc = AbsolutePath -> [Char]
forall a. FilePathLike a => a -> [Char]
toFilePath AbsolutePath
absdc
           [Char] -> [Char] -> IO ()
cloneTree [Char]
dm [Char]
"."
           [Char] -> IO ()
setCurrentDirectory [Char]
former_dir
           [Char]
-> (AbsolutePath -> IO (Sealed (FL (PrimOf p) wA)))
-> IO (Sealed (FL (PrimOf p) wA))
forall a. [Char] -> (AbsolutePath -> IO a) -> IO a
withTempDir [Char]
"version2" ((AbsolutePath -> IO (Sealed (FL (PrimOf p) wA)))
 -> IO (Sealed (FL (PrimOf p) wA)))
-> (AbsolutePath -> IO (Sealed (FL (PrimOf p) wA)))
-> IO (Sealed (FL (PrimOf p) wA))
forall a b. (a -> b) -> a -> b
$ \AbsolutePath
absd2 -> do
             let d2 :: [Char]
d2 = AbsolutePath -> [Char]
forall a. FilePathLike a => a -> [Char]
toFilePath AbsolutePath
absd2
             Tree IO -> [AnchoredPath] -> IO ()
write_files Tree IO
s2 [AnchoredPath]
n2s
             (([Char], [Char], [Char], [Char]) -> IO ())
-> [([Char], [Char], [Char], [Char])] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ([Char]
-> WantGuiPause
-> [Char]
-> [Char]
-> [Char]
-> [Char]
-> ([Char], [Char], [Char], [Char])
-> IO ()
externallyResolveFile [Char]
c WantGuiPause
wantGuiPause [Char]
da [Char]
d1 [Char]
d2 [Char]
dm) [([Char], [Char], [Char], [Char])]
ns
             Tree IO
sc <- [Char] -> IO (Tree IO)
readPlainTree [Char]
dc
             Tree IO
sfixed <- [Char] -> IO (Tree IO)
readPlainTree [Char]
dm
             [Char] -> FileType
ftf <- IO ([Char] -> FileType)
filetypeFunction
             FreeLeft (FL (PrimOf p)) -> Sealed (FL (PrimOf p) wA)
forall (p :: * -> * -> *) wX. FreeLeft p -> Sealed (p wX)
unFreeLeft (FreeLeft (FL (PrimOf p)) -> Sealed (FL (PrimOf p) wA))
-> IO (FreeLeft (FL (PrimOf p))) -> IO (Sealed (FL (PrimOf p) wA))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` DiffAlgorithm
-> ([Char] -> FileType)
-> Tree IO
-> Tree IO
-> IO (FreeLeft (FL (PrimOf p)))
forall (m :: * -> *) (w :: (* -> * -> *) -> *)
       (prim :: * -> * -> *).
(Monad m, Gap w, PrimPatch prim) =>
DiffAlgorithm
-> ([Char] -> FileType) -> Tree m -> Tree m -> m (w (FL prim))
treeDiff DiffAlgorithm
diffa [Char] -> FileType
ftf Tree IO
sc Tree IO
sfixed

externallyResolveFile :: String -- ^ external merge tool command
                      -> WantGuiPause -- ^ tell whether we want GUI pause
                      -> String -- ^ path to merge base
                      -> String -- ^ path to side 1 of the merge
                      -> String -- ^ path to side 2 of the merge
                      -> String -- ^ path where resolved content should go
                      -> (FilePath, FilePath, FilePath, FilePath)
                      -> IO ()
externallyResolveFile :: [Char]
-> WantGuiPause
-> [Char]
-> [Char]
-> [Char]
-> [Char]
-> ([Char], [Char], [Char], [Char])
-> IO ()
externallyResolveFile [Char]
c WantGuiPause
wantGuiPause [Char]
da [Char]
d1 [Char]
d2 [Char]
dm ([Char]
fa, [Char]
f1, [Char]
f2, [Char]
fm) = do
    [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Merging file "[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
fm[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++[Char]
" by hand."
    ExitCode
ec <- [Char] -> [(Char, [Char])] -> IO ExitCode
run [Char]
c [(Char
'1', [Char]
d1[Char] -> [Char] -> [Char]
</>[Char]
f1), (Char
'2', [Char]
d2[Char] -> [Char] -> [Char]
</>[Char]
f2), (Char
'a', [Char]
da[Char] -> [Char] -> [Char]
</>[Char]
fa), (Char
'o', [Char]
dm[Char] -> [Char] -> [Char]
</>[Char]
fm), (Char
'%', [Char]
"%")]
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ExitCode
ec ExitCode -> ExitCode -> Bool
forall a. Eq a => a -> a -> Bool
/= ExitCode
ExitSuccess) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
         [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"External merge command exited with " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ ExitCode -> [Char]
forall a. Show a => a -> [Char]
show ExitCode
ec
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (WantGuiPause
wantGuiPause WantGuiPause -> WantGuiPause -> Bool
forall a. Eq a => a -> a -> Bool
== WantGuiPause
YesWantGuiPause) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        [Char] -> IO ()
askEnter [Char]
"Hit return to move on, ^C to abort the whole operation..."

run :: String -> [(Char,String)] -> IO ExitCode
run :: [Char] -> [(Char, [Char])] -> IO ExitCode
run [Char]
c [(Char, [Char])]
replacements =
    case [(Char, [Char])] -> [Char] -> Either ParseError ([[Char]], Bool)
parseCmd [(Char, [Char])]
replacements [Char]
c of
    Left ParseError
err     -> [Char] -> IO ExitCode
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> IO ExitCode) -> [Char] -> IO ExitCode
forall a b. (a -> b) -> a -> b
$ ParseError -> [Char]
forall a. Show a => a -> [Char]
show ParseError
err
    Right ([[Char]]
c2,Bool
_) -> [[Char]] -> IO ExitCode
rr [[Char]]
c2
    where rr :: [[Char]] -> IO ExitCode
rr ([Char]
command:[[Char]]
args) = do [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Running command '" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
                                            [[Char]] -> [Char]
unwords ([Char]
command[Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
:[[Char]]
args) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"'"
                                 [Char] -> [[Char]] -> Redirects -> IO ExitCode
exec [Char]
command [[Char]]
args (Redirect
Null,Redirect
Null,Redirect
Null)
          rr [] = ExitCode -> IO ExitCode
forall (m :: * -> *) a. Monad m => a -> m a
return ExitCode
ExitSuccess

patchsetConflictResolutions :: RepoPatch p
                            => PatchSet rt p Origin wX
                            -> StandardResolution (PrimOf p) wX
patchsetConflictResolutions :: PatchSet rt p Origin wX -> StandardResolution (PrimOf p) wX
patchsetConflictResolutions (PatchSet RL (Tagged rt p) Origin wX
ts RL (PatchInfoAnd rt p) wX wX
xs) =
  -- optimization: all patches before the latest known clean tag
  -- are known to be resolved
  RL (PatchInfoAnd rt p) Origin wX
-> RL (PatchInfoAnd rt p) wX wX -> StandardResolution (PrimOf p) wX
forall (p :: * -> * -> *) (rt :: RepoType) wO wX wY.
(Commute p, PrimPatchBase p, Conflict p) =>
RL (PatchInfoAnd rt p) wO wX
-> RL (PatchInfoAnd rt p) wX wY -> StandardResolution (PrimOf p) wY
standardResolution (PatchSet rt p Origin wX -> RL (PatchInfoAnd rt p) Origin wX
forall (rt :: RepoType) (p :: * -> * -> *) wStart wX.
PatchSet rt p wStart wX -> RL (PatchInfoAnd rt p) wStart wX
patchSet2RL (RL (Tagged rt p) Origin wX
-> RL (PatchInfoAnd rt p) wX wX -> PatchSet rt p Origin wX
forall (rt :: RepoType) (p :: * -> * -> *) wX wY.
RL (Tagged rt p) Origin wX
-> RL (PatchInfoAnd rt p) wX wY -> PatchSet rt p Origin wY
PatchSet RL (Tagged rt p) Origin wX
ts RL (PatchInfoAnd rt p) wX wX
forall (a :: * -> * -> *) wX. RL a wX wX
NilRL)) RL (PatchInfoAnd rt p) wX wX
xs