#include "gadts.h"
module Darcs.Patch.Choices ( PatchChoices, patchChoices, patchChoicesTps,
patchChoicesTpsSub,
patchSlot,
getChoices,
separateFirstMiddleFromLast,
separateFirstFromMiddleLast,
forceFirst, forceFirsts, forceLast, forceLasts,
forceMatchingFirst, forceMatchingLast,
selectAllMiddles,
makeUncertain, makeEverythingLater,
TaggedPatch, Tag, tag, tpPatch,
Slot(..),
substitute,
) where
import System.IO.Unsafe ( unsafePerformIO )
import Data.IORef ( newIORef, writeIORef, readIORef )
import Darcs.Patch
import Darcs.Patch.Permutations ( commuteWhatWeCanRL )
import Darcs.Patch.Patchy ( Invert, Commute )
import Darcs.Witnesses.Ordered ( FL(..), RL(..), MyEq, unsafeCompare, EqCheck(..),
(:>)(..), (:\/:)(..), (:/\:)(..), (:||:)(..),
zipWithFL, mapFL_FL, mapFL, concatFL,
(+>+), reverseRL, unsafeCoerceP )
import Darcs.Witnesses.Sealed ( Sealed2(..) )
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 (TaggedPatch p C(x y)) Slot
newtype PatchChoices p C(x y) = PCs (FL (PatchChoice p) C(x y))
data Slot = InFirst | InMiddle | InLast
negTag :: Tag -> Tag
negTag (TG k n) = TG k (n)
invertTag :: Slot -> Slot
invertTag InFirst = InLast
invertTag InLast = InFirst
invertTag t = t
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'
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 $ zipWithFL (flip PC) (repeat InMiddle) 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
instance Invert p => Invert (PatchChoice p) where
invert (PC tp mf) = PC (invert tp) (invertTag mf)
identity = PC identity InMiddle
instance Commute p => Commute (PatchChoice p) where
commute (PC t1 x1 :> PC t2 x2)
= do t2' :> t1' <- commute (t1 :> t2)
return (PC t2' x2 :> PC t1' x1)
merge (PC t1 x1 :\/: PC t2 x2)
= case merge (t1 :\/: t2) of
t2' :/\: t1' -> PC t2' x2 :/\: PC t1' x1
listTouchedFiles (PC t _) = listTouchedFiles t
hunkMatches f (PC t _) = hunkMatches f t
invertSeq :: (Invert p, Invert q) => (p :> q) C(x y) -> (q :> p) C(y x)
invertSeq (x :> y) = (invert y :> invert x)
separateFirstFromMiddleLast :: Patchy p => PatchChoices p C(x z)
-> (FL (TaggedPatch p) :> FL (TaggedPatch p)) C(x z)
separateFirstFromMiddleLast (PCs e) = pull_only_firsts e
separateFirstMiddleFromLast :: Patchy p => PatchChoices p C(x z)
-> (FL (TaggedPatch p) :> FL (TaggedPatch p)) C(x z)
separateFirstMiddleFromLast (PCs e) = pull_firsts_middles e
getChoices :: Patchy p => PatchChoices p C(x y)
-> (FL (TaggedPatch p) :> FL (TaggedPatch p) :> FL (TaggedPatch p)) C(x y)
getChoices (PCs e) = case pull_firsts e of
f :> ml -> case pull_firsts (invert ml) of
l :> m -> f :> mapFL_FL pc2tp (invert m) :> invert l
where pc2tp (PC tp _) = tp
pull_firsts_middles :: Patchy p => FL (PatchChoice p) C(x z) -> (FL (TaggedPatch p) :> FL (TaggedPatch p)) C(x z)
pull_firsts_middles easyPC =
let r = unsafePerformIO
$ newIORef (error "pull_firsts_middles called badly")
f :: Patchy p => RL (TaggedPatch p) C(a x) -> FL (PatchChoice p) C(x z) -> FL (TaggedPatch p) C(a d)
f acc NilFL = unsafePerformIO (writeIORef r (reverseRL acc)) `seq` (unsafeCoerceP NilFL)
f acc (PC tp InLast:>:e) = f (tp:<:acc) e
f acc (PC tp _:>:e) = case commuteWhatWeCanRL (acc :> tp) of
more :> tp' :> acc' -> reverseRL more+>+tp':>:f acc' e
xs = f NilRL easyPC
in (xs :> unsafePerformIO (readIORef r))
pull_only_firsts :: Patchy p => FL (PatchChoice p) C(x z) -> (FL (TaggedPatch p) :> FL (TaggedPatch p)) C(x z)
pull_only_firsts easyPC =
let r = unsafePerformIO
$ newIORef (error "pull_only_firsts called badly")
f :: Patchy p => RL (TaggedPatch p) C(a x) -> FL (PatchChoice p) C(x z) -> FL (TaggedPatch p) C(a d)
f acc NilFL = unsafePerformIO (writeIORef r (reverseRL acc)) `seq` (unsafeCoerceP NilFL)
f acc (PC tp InFirst:>:e) = case commuteWhatWeCanRL (acc :> tp) of
more :> tp' :> acc' -> reverseRL more+>+tp':>:f acc' e
f acc (PC tp _:>:e) = f (tp:<:acc) e
xs = f NilRL easyPC
in (xs :> unsafePerformIO (readIORef r))
pull_firsts :: Patchy p => FL (PatchChoice p) C(x z) -> (FL (TaggedPatch p) :> FL (PatchChoice p)) C(x z)
pull_firsts e = case pull_first e of
Nothing -> (NilFL :> e)
Just (p:>e') -> case pull_firsts e' of
(ps:>e'') -> (p:>:ps :> e'')
pull_lasts :: Patchy p => FL (PatchChoice p) C(x y) -> (FL (PatchChoice p) :> FL (TaggedPatch p)) C(x y)
pull_lasts e = invertSeq $ pull_firsts $ invert e
pull_first :: Patchy p => FL (PatchChoice p) C(x z) -> Maybe ((TaggedPatch p :> FL (PatchChoice p)) C(x z))
pull_first NilFL = Nothing
pull_first (PC tp InFirst:>:e) = Just (tp :> e)
pull_first (PC (TP t p) InLast:>:e) =
case pull_first e of
Just (TP t2 p2 :> e') ->
case commute (p:>p2) of
Just (p2':>p') -> Just (TP t2 p2' :> PC (TP t p') InLast:>:e')
Nothing -> error "Aaack fixme!"
Nothing -> Nothing
pull_first (PC tp@(TP t p) InMiddle:>:e) =
case pull_first e of
Just (TP t2 p2 :> e') ->
case commute (p:>p2) of
Just (p2':>p') -> Just (TP t2 p2' :> (PC (TP t p') InMiddle:>:e'))
Nothing -> Just (tp :> PC (TP (negTag t2) p2) InFirst:>:e')
Nothing -> Nothing
patchSlot :: forall p C(a b x y). TaggedPatch p C(a b) -> PatchChoices p C(x y) -> Slot
patchSlot tp (PCs e) = ipf e
where ipf :: FL (PatchChoice p) C(u v) -> Slot
ipf (PC a mb:>:e') | tag a == tag tp = mb
| otherwise = ipf e'
ipf NilFL = InLast
setSimplys :: [Tag] -> Slot -> FL (PatchChoice p) C(x y) -> FL (PatchChoice p) C(x y)
setSimplys ts s e = mapFL_FL ch e
where ch (PC tp@(TP t _) _)
| t `elem` ts = PC tp s
| otherwise = PC tp InMiddle
m2ids :: (FORALL(x y) TaggedPatch p C(x y) -> Bool) -> FL (PatchChoice p) C(a b) -> [Tag]
m2ids m (PC tp@(TP t _) _:>:e)
| m tp = t:m2ids m e
| otherwise = m2ids m e
m2ids _ NilFL = []
forceMatchingFirst :: Patchy p => (FORALL(x y) TaggedPatch p C(x y) -> Bool)
-> PatchChoices p C(a b) -> PatchChoices p C(a b)
forceMatchingFirst m (PCs e) =
let thd (PC (TP t _) _) = t
xs = m2ids m e
not_needed = case pull_firsts $ setSimplys xs InFirst e of
_ :> rest -> mapFL thd rest
ch pc@(PC tp@(TP t _) _)
| t `elem` not_needed = pc
| otherwise = PC tp InFirst
in PCs $ mapFL_FL ch e
forceFirsts :: Patchy p => [Tag] -> PatchChoices p C(x y) -> PatchChoices p C(x y)
forceFirsts ps pc = forceMatchingFirst ((`elem` ps) . tag) pc
forceFirst :: Patchy p => Tag -> PatchChoices p C(x y) -> PatchChoices p C(x y)
forceFirst p pc = forceMatchingFirst ((== p) . tag) pc
selectAllMiddles :: Patchy p => Bool -> PatchChoices p C(x y) -> PatchChoices p C(x y)
selectAllMiddles b (PCs e) = PCs (mapFL_FL f e)
where f (PC tp InMiddle) = PC tp (if b then InLast else InFirst)
f pc = pc
reverse_pc :: Patchy p => PatchChoices p C(x y) -> PatchChoices p C(y x)
reverse_pc (PCs e) = PCs $ invert e
forceMatchingLast :: Patchy p => (FORALL(x y) TaggedPatch p C(x y) -> Bool)
-> PatchChoices p C(a b) -> PatchChoices p C(a b)
forceMatchingLast m (PCs e) =
let thd (PC (TP t _) _) = t
xs = m2ids m e
not_needed = case pull_lasts $ setSimplys xs InLast e of
rest :> _ -> mapFL thd rest
ch pc@(PC tp@(TP t _) _)
| t `elem` not_needed = pc
| otherwise = PC tp InLast
in PCs $ mapFL_FL ch e
forceLast :: Patchy p => Tag -> PatchChoices p C(x y) -> PatchChoices p C(x y)
forceLast p pc = reverse_pc $ forceFirst p $ reverse_pc pc
forceLasts :: Patchy p => [Tag] -> PatchChoices p C(x y) -> PatchChoices p C(x y)
forceLasts ps pc = reverse_pc $ forceFirsts ps $ reverse_pc pc
makeUncertain :: Patchy p => Tag -> PatchChoices p C(x y) -> PatchChoices p C(x y)
makeUncertain t (PCs e) = PCs $ mapFL_FL ch e
where ch pc@(PC x _) = if t == tag x then PC x InMiddle else pc
makeEverythingLater :: Patchy p => PatchChoices p C(x y) -> PatchChoices p C(x y)
makeEverythingLater (PCs e) = PCs $ mapFL_FL ch e
where ch (PC tp InMiddle) = PC tp InLast
ch (PC tp InFirst) = PC tp InMiddle
ch x = x
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 pcs) = PCs (concatFL (mapFL_FL translate pcs))
where translate :: PatchChoice p C(a b) -> FL (PatchChoice p) C(a b)
translate (PC tp' c)
| IsEq <- compareTags tp tp' = mapFL_FL (flip PC c) new_tps
| otherwise = PC tp' c :>: NilFL