#include "gadts.h"
module Darcs.Repository.Merge ( tentativelyMergePatches, considerMergeToWorking ) where
import Darcs.Resolution ( standardResolution, externalResolution )
import Darcs.External ( backupByCopying )
import Control.Monad ( when, unless )
import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, n2pia, hopefully )
import Darcs.Flags
( DarcsFlag( AllowConflicts, NoAllowConflicts ), wantExternalMerge, diffingOpts, compression )
import Darcs.Witnesses.Ordered
( FL(..), (:\/:)(..), (:/\:)(..), (+>+), mapFL_FL )
import Darcs.Patch
( RepoPatch, PrimOf, merge, joinPatches, listTouchedFiles
, patchcontents, anonymous, fromPrims, effect )
import Darcs.Patch.Apply ( ApplyState )
import Darcs.Patch.Depends( merge2FL )
import Progress( debugMessage )
import Darcs.ProgressPatches( progressFL )
import Darcs.Witnesses.Sealed( Sealed(Sealed), seal )
import Darcs.Repository.InternalTypes( Repository(..) )
import Darcs.Repository.State( unrecordedChanges, readUnrecorded )
import Darcs.Repository.Internal
( announceMergeConflicts, checkUnrecordedConflicts
, MakeChanges(..), setTentativePending
, tentativelyAddPatch_, applyToTentativePristine, UpdatePristine(..) )
import Storage.Hashed.Tree( Tree )
tentativelyMergePatches_ :: forall p C(r u t y x). (RepoPatch p, ApplyState p ~ Tree)
=> MakeChanges
-> Repository p C(r u t) -> String -> [DarcsFlag]
-> FL (PatchInfoAnd p) C(x t) -> FL (PatchInfoAnd p) C(x y)
-> IO (Sealed (FL (PrimOf p) C(u)))
tentativelyMergePatches_ mc r cmd opts usi themi =
do let us = mapFL_FL hopefully usi
them = mapFL_FL hopefully themi
Sealed pc <- return $ merge2FL (progressFL "Merging us" usi) (progressFL "Merging them" themi)
pend <- unrecordedChanges (diffingOpts opts) r Nothing
anonpend <- n2pia `fmap` anonymous (fromPrims pend)
pend' :/\: pw <- return $ merge (pc :\/: anonpend :>: NilFL)
let pwprim = joinPatches $ progressFL "Examining patches for conflicts" $
mapFL_FL (patchcontents . hopefully) pw
Sealed standard_resolved_pw <- return $ standardResolution pwprim
debugMessage "Checking for conflicts..."
unless (AllowConflicts `elem` opts || NoAllowConflicts `elem` opts) $
mapM_ backupByCopying $ listTouchedFiles standard_resolved_pw
debugMessage "Announcing conflicts..."
have_conflicts <- announceMergeConflicts cmd opts standard_resolved_pw
debugMessage "Checking for unrecorded conflicts..."
have_unrecorded_conflicts <- checkUnrecordedConflicts opts $ mapFL_FL hopefully pc
debugMessage "Reading working directory..."
working <- readUnrecorded r Nothing
debugMessage "Working out conflicts in actual working directory..."
Sealed pw_resolution <-
case (wantExternalMerge opts, have_conflicts || have_unrecorded_conflicts) of
(Nothing,_) -> return $ if AllowConflicts `elem` opts
then seal NilFL
else seal standard_resolved_pw
(_,False) -> return $ seal standard_resolved_pw
(Just c, True) -> externalResolution working c opts
(effect us +>+ pend)
(effect them) pwprim
debugMessage "Applying patches to the local directories..."
when (mc == MakeChanges) $
do let doChanges :: FL (PatchInfoAnd p) C(x t) -> IO ()
doChanges NilFL = applyps r themi
doChanges _ = applyps r pc
doChanges usi
setTentativePending r (effect pend' +>+ pw_resolution)
return $ seal (effect pwprim +>+ pw_resolution)
where mapAdd :: Repository p C(m l i) -> FL (PatchInfoAnd p) C(i j) -> IO (Repository p C(m l j))
mapAdd repo NilFL = return repo
mapAdd repo (a:>:as) =
do repo' <- tentativelyAddPatch_ DontUpdatePristine repo (compression opts) a
mapAdd repo' as
applyps :: Repository p C(m l i) -> FL (PatchInfoAnd p) C(i j) -> IO ()
applyps repo ps = do debugMessage "Adding patches to inventory..."
_ <- mapAdd repo ps
debugMessage "Applying patches to pristine..."
applyToTentativePristine repo ps
tentativelyMergePatches :: (RepoPatch p, ApplyState p ~ Tree)
=> Repository p C(r u t) -> String -> [DarcsFlag]
-> FL (PatchInfoAnd p) C(x t) -> FL (PatchInfoAnd p) C(x y)
-> IO (Sealed (FL (PrimOf p) C(u)))
tentativelyMergePatches = tentativelyMergePatches_ MakeChanges
considerMergeToWorking :: (RepoPatch p, ApplyState p ~ Tree)
=> Repository p C(r u t) -> String -> [DarcsFlag]
-> FL (PatchInfoAnd p) C(x t) -> FL (PatchInfoAnd p) C(x y)
-> IO (Sealed (FL (PrimOf p) C(u)))
considerMergeToWorking = tentativelyMergePatches_ DontMakeChanges