#include "gadts.h"
module Darcs.Patch.Choices ( PatchChoices, patchChoices, patchChoicesTps,
patchChoicesTpsSub,
patchSlot, patchSlot',
getChoices, refineChoices,
separateFirstMiddleFromLast,
separateFirstFromMiddleLast,
forceFirst, forceFirsts, forceLast, forceLasts,
forceMatchingFirst, forceMatchingLast,
selectAllMiddles,
makeUncertain, makeEverythingLater, makeEverythingSooner,
TaggedPatch, Tag, tag, tpPatch,
Slot(..),
substitute
) where
import Control.Monad.State( State(..) )
import Darcs.Patch
import Darcs.Patch.Permutations ( commuteWhatWeCanRL, commuteWhatWeCanFL )
import Darcs.Patch.Patchy ( Invert, Commute )
import Darcs.Witnesses.Ordered ( FL(..), RL(..), MyEq, unsafeCompare, EqCheck(..),
(:>)(..), (:\/:)(..), (:/\:)(..), (:||:)(..),
zipWithFL, mapFL_FL, concatFL,
(+>+), reverseRL, unsafeCoerceP, anyFL )
import Darcs.Witnesses.Sealed ( Sealed2(..) )
#include "impossible.h"
data Tag = TG (Maybe Tag) Integer deriving ( Eq, Ord )
data TaggedPatch p C(x y) = TP Tag (p C(x y))
data PatchChoice p C(x y) = PC { pcPatch :: (TaggedPatch p C(x y))
, choice :: Bool}
data PatchChoices p C(x y) where
PCs { firsts :: FL (TaggedPatch p) C(x m)
, lasts :: FL (PatchChoice p) C(m y)} :: PatchChoices p C(x y)
data Slot = InFirst | InMiddle | InLast
tag :: TaggedPatch p C(x y) -> Tag
tag (TP tg _) = tg
tpPatch :: TaggedPatch p C(x y) -> p C(x y)
tpPatch (TP _ p) = p
liftTP :: (p C(x y) -> p C(a b)) -> (TaggedPatch p C(x y) -> TaggedPatch p C(a b))
liftTP f (TP t p) = TP t (f p)
compareTags :: TaggedPatch p C(a b) -> TaggedPatch p C(c d) -> EqCheck C((a, b) (c, d))
compareTags (TP t1 _) (TP t2 _) = if t1 == t2 then unsafeCoerceP IsEq else NotEq
instance MyEq p => MyEq (TaggedPatch p) where
unsafeCompare (TP t1 p1) (TP t2 p2) = t1 == t2 && unsafeCompare p1 p2
instance Invert p => Invert (TaggedPatch p) where
invert = liftTP invert
identity = TP (TG Nothing (1)) identity
instance Commute p => Commute (TaggedPatch p) where
commute (TP t1 p1 :> TP t2 p2) = do p2' :> p1' <- commute (p1 :> p2)
return (TP t2 p2' :> TP t1 p1')
listTouchedFiles (TP _ p) = listTouchedFiles p
hunkMatches f (TP _ p) = hunkMatches f p
merge (TP t1 p1 :\/: TP t2 p2) = case merge (p1 :\/: p2) of
p2' :/\: p1' -> TP t2 p2' :/\: TP t1 p1'
instance Commute p => Commute (PatchChoice p) where
commute (PC p1 c1 :> PC p2 c2) = do p2' :> p1' <- commute (p1 :> p2)
return (PC p2' c2 :> PC p1' c1)
listTouchedFiles (PC p _) = listTouchedFiles p
hunkMatches f (PC p _) = hunkMatches f p
merge (PC tp1 c1 :\/: PC tp2 c2) = case merge (tp1 :\/: tp2) of
tp2' :/\: tp1' -> PC tp2' c2 :/\: PC tp1' c1
patchChoices :: Patchy p => FL p C(x y) -> PatchChoices p C(x y)
patchChoices = fst . patchChoicesTps
patchChoicesTpsSub :: Patchy p
=> Maybe Tag -> FL p C(x y)
-> (PatchChoices p C(x y), FL (TaggedPatch p) C(x y))
patchChoicesTpsSub tg ps = let tps = zipWithFL TP (map (TG tg) [1..]) ps
in (PCs NilFL (mapFL_FL (\tp -> PC tp False) tps), tps)
patchChoicesTps :: Patchy p => FL p C(x y) -> (PatchChoices p C(x y), FL (TaggedPatch p) C(x y))
patchChoicesTps = patchChoicesTpsSub Nothing
instance MyEq p => MyEq (PatchChoice p) where
unsafeCompare (PC tp1 _) (PC tp2 _) = unsafeCompare tp1 tp2
separateFirstFromMiddleLast :: Patchy p => PatchChoices p C(x z)
-> (FL (TaggedPatch p) :> FL (TaggedPatch p)) C(x z)
separateFirstFromMiddleLast (PCs f l) = f :> mapFL_FL (\ (PC tp _) -> tp) l
separateFirstMiddleFromLast :: Patchy p => PatchChoices p C(x z)
-> (FL (TaggedPatch p) :> FL (TaggedPatch p)) C(x z)
separateFirstMiddleFromLast (PCs f l) =
case pushLasts l of
(m :> l') -> f +>+ m :> l'
getChoices :: Patchy p => PatchChoices p C(x y)
-> (FL (TaggedPatch p) :> FL (TaggedPatch p) :> FL (TaggedPatch p)) C(x y)
getChoices (PCs f l) =
case pushLasts l of
(m :> l') -> f :> m :> l'
pushLasts :: Patchy p => FL (PatchChoice p) C(x y)
-> (FL (TaggedPatch p) :> FL (TaggedPatch p)) C(x y)
pushLasts NilFL = NilFL :> NilFL
pushLasts (PC tp False :>: pcs) =
case pushLasts pcs of
(m :> l) -> (tp :>: m) :> l
pushLasts (PC tp True :>: pcs) =
case pushLasts pcs of
(m :> l) ->
case commuteWhatWeCanFL (tp :> m) of
(m' :> tp' :> deps) -> m' :> (tp' :>: deps +>+ l)
refineChoices :: (Patchy p, Monad m, Functor m) =>
(FORALL(u v) FL (TaggedPatch p) C(u v) ->
PatchChoices p C(u v) ->
m (PatchChoices p C(u v)))
-> PatchChoices p C(x y) -> m (PatchChoices p C(x y))
refineChoices act ps =
case getChoices ps of
(f :> m :> l) -> do
let mchoices = PCs NilFL . mapFL_FL (flip PC False) $ m
(PCs f' l') <- act m mchoices
return . PCs (f +>+ f') $ l' +>+ mapFL_FL (flip PC True) l
patchSlot :: forall p C(a b x y). Patchy p => TaggedPatch p C(a b)
-> PatchChoices p C(x y) -> (Slot, PatchChoices p C(x y))
patchSlot (TP t _) pc@(PCs f l) =
if foundIn f
then (InFirst, pc)
else psLast f NilRL NilRL l
where
foundIn = anyFL ((== t) . tag)
psLast :: FORALL(m b l)
FL (TaggedPatch p) C(x m) ->
RL (TaggedPatch p) C(m b) ->
RL (TaggedPatch p) C(b l) ->
FL (PatchChoice p) C(l y) ->
(Slot, PatchChoices p C(x y))
psLast firsts middles bubble (PC tp True :>: ls)
| tag tp == t = (InLast
, PCs { firsts = firsts
, lasts = settleM middles
+>+ settleB bubble
+>+ PC tp True :>: ls})
psLast firsts middles bubble (PC tp False :>: ls)
| tag tp == t =
case commuteRL (bubble :> tp) of
Just (tp' :> bubble') -> (InMiddle,
PCs { firsts = firsts
, lasts = settleM middles
+>+ PC tp' False
:>: settleB bubble'
+>+ ls})
Nothing -> (InLast,
PCs { firsts = firsts
, lasts = settleM middles
+>+ settleB bubble
+>+ PC tp True
:>: ls})
psLast firsts middles bubble (PC tp True :>: ls) =
psLast firsts middles (tp :<: bubble) ls
psLast firsts middles bubble (PC tp False :>: ls) =
case commuteRL (bubble :> tp) of
Just (tp' :> bubble') -> psLast firsts (tp' :<: middles) bubble' ls
Nothing -> psLast firsts middles (tp :<: bubble) ls
psLast _ _ _ NilFL = impossible
settleM middles = mapFL_FL (\tp -> PC tp False) $ reverseRL middles
settleB bubble = mapFL_FL (\tp -> PC tp True) $ reverseRL bubble
patchSlot' :: Patchy p =>
TaggedPatch p C(a b) -> State (PatchChoices p C(x y)) Slot
patchSlot' = State . patchSlot
forceMatchingFirst :: forall p C(a b). Patchy p =>
( FORALL(x y) TaggedPatch p C(x y) -> Bool)
-> PatchChoices p C(a b)
-> PatchChoices p C(a b)
forceMatchingFirst pred (PCs f l) =
fmfLasts f NilRL l
where
fmfLasts :: FL (TaggedPatch p) C(a m)
-> RL (PatchChoice p) C(m n)
-> FL (PatchChoice p) C(n b)
-> PatchChoices p C(a b)
fmfLasts f l1 (a :>: l2)
| pred_pc a =
case commuteWhatWeCanRL (l1 :> a) of
(deps :> a' :> l1') ->
let
f' = f +>+ mapFL_FL pcPatch (reverseRL deps) +>+ (pcPatch a' :>: NilFL)
in fmfLasts f' l1' l2
fmfLasts f l1 (a :>: l2) = fmfLasts f (a :<: l1) l2
fmfLasts f l1 NilFL = PCs { firsts = f
, lasts = reverseRL l1 }
pred_pc :: FORALL(x y) PatchChoice p C(x y) -> Bool
pred_pc (PC tp _) = pred tp
forceFirsts :: Patchy p => [Tag] -> PatchChoices p C(a b)
-> PatchChoices p C(a b)
forceFirsts ps = forceMatchingFirst ((`elem` ps) . tag)
forceFirst :: Patchy p => Tag -> PatchChoices p C(a b)
-> PatchChoices p C(a b)
forceFirst p = forceMatchingFirst ((== p) . tag)
selectAllMiddles :: forall p C(x y). Patchy p => Bool
-> PatchChoices p C(x y) -> PatchChoices p C(x y)
selectAllMiddles True (PCs f l) = PCs f (mapFL_FL g l)
where g (PC tp _) = PC tp True
selectAllMiddles False (PCs f l) = samf f NilRL NilRL l
where
samf :: FORALL(m1 m2 m3)
FL (TaggedPatch p) C(x m1) ->
RL (TaggedPatch p) C(m1 m2) ->
RL (PatchChoice p) C(m2 m3) ->
FL (PatchChoice p) C(m3 y) ->
PatchChoices p C(x y)
samf f1 f2 l1 (pc@(PC tp False) :>: l2) =
case commuteRL (l1 :> pc) of
Nothing -> samf f1 f2 (PC tp True :<: l1) l2
Just ((PC tp' _) :> l1') -> samf f1 (tp' :<: f2) l1' l2
samf f1 f2 l1 (PC tp True :>: l2) = samf f1 f2 (PC tp True :<: l1) l2
samf f1 f2 l1 NilFL = PCs (f1 +>+ reverseRL f2) (reverseRL l1)
forceMatchingLast :: Patchy p => (FORALL(x y) TaggedPatch p C(x y) -> Bool)
-> PatchChoices p C(a b)
-> PatchChoices p C(a b)
forceMatchingLast pred (PCs f l) = do
fmlFirst pred True NilRL f l
fmlFirst :: forall p C(a b m1 m2) . Patchy p =>
(FORALL(x y) TaggedPatch p C(x y) -> Bool) -> Bool
-> RL (TaggedPatch p) C(a m1)
-> FL (TaggedPatch p) C(m1 m2)
-> FL (PatchChoice p) C(m2 b)
-> PatchChoices p C(a b)
fmlFirst pred b f1 (a :>: f2) l
| pred a =
case commuteWhatWeCanFL (a :> f2) of
(f2' :> a' :> deps) ->
let
l' = mapFL_FL (\tp -> PC tp b) (a' :>: deps) +>+ l
in
fmlFirst pred b f1 f2' l'
fmlFirst pred b f1 (a :>: f2) l = fmlFirst pred b (a :<: f1) f2 l
fmlFirst pred b f1 NilFL l = PCs { firsts = reverseRL f1
, lasts = mapFL_FL ch l}
where ch (PC tp c) = (PC tp (if pred tp then b else c) )
forceLasts :: Patchy p => [Tag]
-> PatchChoices p C(a b) -> PatchChoices p C(a b)
forceLasts ps = forceMatchingLast ((`elem` ps) . tag)
forceLast :: Patchy p => Tag
-> PatchChoices p C(a b) -> PatchChoices p C(a b)
forceLast p = forceMatchingLast ((== p) . tag)
makeUncertain :: Patchy p => Tag -> PatchChoices p C(a b) -> PatchChoices p C(a b)
makeUncertain t (PCs f l) = fmlFirst ((== t) . tag) False NilRL f l
makeEverythingLater :: Patchy p => PatchChoices p C(x y) -> PatchChoices p C(x y)
makeEverythingLater (PCs f l) =
let m = mapFL_FL (\tp -> PC tp False) f
l' = mapFL_FL (\(PC tp _) -> PC tp True) l
in
PCs NilFL $ m +>+ l'
makeEverythingSooner :: forall p C(x y).
Patchy p => PatchChoices p C(x y) -> PatchChoices p C(x y)
makeEverythingSooner (PCs f l) =
case mes NilRL NilRL l
of (m :> l) ->
PCs (f +>+ m) l
where
mes :: FORALL(m1 m2 m3)
RL (TaggedPatch p) C(m1 m2) ->
RL (TaggedPatch p) C(m2 m3) ->
FL (PatchChoice p) C(m3 y) ->
(FL (TaggedPatch p) :> FL (PatchChoice p)) C(m1 y)
mes middle bubble (PC tp True :>: ls) = mes middle (tp :<: bubble) ls
mes middle bubble (PC tp False :>: ls) =
case commuteRL (bubble :> tp) of
Nothing -> mes middle (tp :<: bubble) ls
Just (tp' :> bubble') -> mes (tp' :<: middle) bubble' ls
mes middle bubble NilFL = (reverseRL middle) :> mapFL_FL (\tp -> PC tp False) (reverseRL bubble)
substitute :: forall p C(x y)
. Patchy p
=> Sealed2 (TaggedPatch p :||: FL (TaggedPatch p))
-> PatchChoices p C(x y)
-> PatchChoices p C(x y)
substitute (Sealed2 (tp :||: new_tps)) (PCs f l) =
PCs (concatFL $ mapFL_FL substTp f) (concatFL $ mapFL_FL substPc l)
where
substTp :: TaggedPatch p C(a b) -> FL (TaggedPatch p) C(a b)
substTp tp'
| IsEq <- compareTags tp tp' = new_tps
| otherwise = tp' :>: NilFL
substPc :: PatchChoice p C(a b) -> FL (PatchChoice p) C(a b)
substPc (PC tp' c)
| IsEq <- compareTags tp tp' = mapFL_FL (flip PC c) new_tps
| otherwise = PC tp' c :>: NilFL