module Darcs.Patch.Conflict
( Conflict(..), CommuteNoConflicts(..)
, IsConflictedPrim(..), ConflictState(..) )
where
import Darcs.Patch.Effect ( Effect(..) )
import Darcs.Patch.Inspect ( PatchInspect(..) )
import Darcs.Patch.Permutations ()
import Darcs.Patch.Prim.Class ( PrimOf )
import Darcs.Witnesses.Ordered
( FL(..), RL(..), (:>)(..)
, mapFL, reverseFL, mapRL, reverseRL
)
import Darcs.Witnesses.Sealed ( Sealed, unseal )
import Darcs.Utils ( nubsort )
#include "gadts.h"
class (Effect p, PatchInspect (PrimOf p)) => Conflict p where
listConflictedFiles :: p C(x y) -> [FilePath]
listConflictedFiles p =
nubsort $ concatMap (unseal listTouchedFiles) $ concat $ resolveConflicts p
resolveConflicts :: p C(x y) -> [[Sealed (FL (PrimOf p) C(y))]]
conflictedEffect :: p C(x y) -> [IsConflictedPrim (PrimOf p)]
conflictedEffect x = case listConflictedFiles x of
[] -> mapFL (IsC Okay) $ effect x
_ -> mapFL (IsC Conflicted) $ effect x
class CommuteNoConflicts p where
commuteNoConflicts :: (p :> p) C(x y) -> Maybe ((p :> p) C(x y))
instance (CommuteNoConflicts p, Conflict p) => Conflict (FL p) where
listConflictedFiles = nubsort . concat . mapFL listConflictedFiles
resolveConflicts NilFL = []
resolveConflicts x = resolveConflicts $ reverseFL x
conflictedEffect = concat . mapFL conflictedEffect
instance CommuteNoConflicts p => CommuteNoConflicts (FL p) where
commuteNoConflicts (NilFL :> x) = Just (x :> NilFL)
commuteNoConflicts (x :> NilFL) = Just (NilFL :> x)
commuteNoConflicts (xs :> ys) = do ys' :> rxs' <- commuteNoConflictsRLFL (reverseFL xs :> ys)
return $ ys' :> reverseRL rxs'
instance (CommuteNoConflicts p, Conflict p) => Conflict (RL p) where
listConflictedFiles = nubsort . concat . mapRL listConflictedFiles
resolveConflicts x = rcs x NilFL
where rcs :: RL p C(x y) -> FL p C(y w) -> [[Sealed (FL (PrimOf p) C(w))]]
rcs NilRL _ = []
rcs (p:<:ps) passedby | (_:_) <- resolveConflicts p =
case commuteNoConflictsFL (p:>passedby) of
Just (_:> p') -> resolveConflicts p' ++ rcs ps (p:>:passedby)
Nothing -> rcs ps (p:>:passedby)
rcs (p:<:ps) passedby = seq passedby $ rcs ps (p:>:passedby)
conflictedEffect = concat . reverse . mapRL conflictedEffect
instance CommuteNoConflicts p => CommuteNoConflicts (RL p) where
commuteNoConflicts (NilRL :> x) = Just (x :> NilRL)
commuteNoConflicts (x :> NilRL) = Just (NilRL :> x)
commuteNoConflicts (xs :> ys) = do ys' :> rxs' <- commuteNoConflictsRLFL (xs :> reverseRL ys)
return $ reverseFL ys' :> rxs'
data IsConflictedPrim prim where
IsC :: !ConflictState -> !(prim C(x y)) -> IsConflictedPrim prim
data ConflictState = Okay | Conflicted | Duplicated deriving ( Eq, Ord, Show, Read)
commuteNoConflictsFL :: CommuteNoConflicts p => (p :> FL p) C(x y) -> Maybe ((FL p :> p) C(x y))
commuteNoConflictsFL (p :> NilFL) = Just (NilFL :> p)
commuteNoConflictsFL (q :> p :>: ps) = do p' :> q' <- commuteNoConflicts (q :> p)
ps' :> q'' <- commuteNoConflictsFL (q' :> ps)
return (p' :>: ps' :> q'')
commuteNoConflictsRL :: CommuteNoConflicts p => (RL p :> p) C(x y) -> Maybe ((p :> RL p) C(x y))
commuteNoConflictsRL (NilRL :> p) = Just (p :> NilRL)
commuteNoConflictsRL (p :<: ps :> q) = do q' :> p' <- commuteNoConflicts (p :> q)
q'' :> ps' <- commuteNoConflictsRL (ps :> q')
return (q'' :> p' :<: ps')
commuteNoConflictsRLFL :: CommuteNoConflicts p => (RL p :> FL p) C(x y) -> Maybe ((FL p :> RL p) C(x y))
commuteNoConflictsRLFL (NilRL :> ys) = Just (ys :> NilRL)
commuteNoConflictsRLFL (xs :> NilFL) = Just (NilFL :> xs)
commuteNoConflictsRLFL (xs :> y :>: ys) = do y' :> xs' <- commuteNoConflictsRL (xs :> y)
ys' :> xs'' <- commuteNoConflictsRLFL (xs' :> ys)
return (y' :>: ys' :> xs'')