module Triplets
( gzipWithM3
, gzipWithT3
, gzipWithA3
, gzip3
, gzipQ3
, gzipBut3
, gzipButA3
, extQ2
, extQ3
, extT3
, mkQ3
, mkQ2
, mergeBy
, GB, GM, GA, PB, PM, PA
) where
import Prelude hiding (GT)
import Control.Applicative (Applicative(..))
import Control.Applicative.Error (Failing(..))
import Control.Monad (MonadPlus(mzero, mplus))
import Data.Generics (Data, Typeable, Typeable1, toConstr, cast, gcast, gmapAccumQ, gshow, gfoldlAccum,
unGT, GenericT, GenericT'(GT), gmapAccumT,
unGM, GenericM, GenericM'(GM), gmapAccumM,
unGQ, GenericQ, GenericQ'(GQ), gmapQ)
import Data.Maybe (fromMaybe)
instance Monad Failing where
return = Success
m >>= f =
case m of
(Failure errs) -> (Failure errs)
(Success a) -> f a
fail errMsg = Failure [errMsg]
instance MonadPlus Failing where
mzero = Failure []
mplus (Failure xs) (Failure ys) = Failure (xs ++ ys)
mplus success@(Success _) _ = success
mplus _ success@(Success _) = success
deriving instance Typeable1 Failing
deriving instance Data a => Data (Failing a)
deriving instance Read a => Read (Failing a)
deriving instance Eq a => Eq (Failing a)
deriving instance Ord a => Ord (Failing a)
cast' :: (Monad m, Typeable a, Typeable b) => a -> m b
cast' = maybe (fail "cast") return . cast
gzipWithT3 ::
GenericQ (GenericQ (GenericT))
-> GenericQ (GenericQ (GenericT))
gzipWithT3 f x y z =
case gmapAccumT perkid funs z of
([], c) -> c
_ -> error "gzipWithT3"
where
perkid a d = (tail a, unGT (head a) d)
funs = case gmapAccumQ perkid' funs' y of
([], q) -> q
_ -> error "gzipWithT3"
where
perkid' a d = (tail a, unGQ (head a) d)
funs' = gmapQ (\k -> (GQ (\k' -> GT (f k k')))) x
gzipWithM3 :: Monad m
=> GenericQ (GenericQ (GenericM m))
-> GenericQ (GenericQ (GenericM m))
gzipWithM3 f x y z =
case gmapAccumM perkid funs z of
([], c) -> c
_ -> error "gzipWithM3"
where
perkid a d = (tail a, unGM (head a) d)
funs = case gmapAccumQ perkid' funs' y of
([], q) -> q
_ -> error "gzipWithM3"
where
perkid' a d = (tail a, unGQ (head a) d)
funs' = gmapQ (\k -> (GQ (\k' -> GM (f k k')))) x
gzipWithA3 :: forall f. Applicative f => GA f -> GA f
gzipWithA3 f x y z =
case gmapAccumA perkid funs z of
([], c) -> c
_ -> error "gzipWithA3"
where
perkid a d = (tail a, unGM (head a) d)
funs = case gmapAccumQ perkid' funs' y of
([], q) -> q
_ -> error "gzipWithA3"
where
perkid' a d = (tail a, unGQ (head a) d)
funs' = gmapQ (\k -> (GQ (\k' -> GM (f k k')))) x
type GB = GenericQ (GenericQ (GenericQ Bool))
type GM = MonadPlus m => GenericQ (GenericQ (GenericM m))
type PB = forall x. Data x => x -> x -> x -> Bool
type PM = forall m x. (MonadPlus m, Data x) => x -> x -> x -> m x
type GA f = GenericQ (GenericQ (GenericM f))
type PA f = forall x. Data x => x -> x -> x -> f x
gmapAccumA :: forall a d f. (Data d, Applicative f)
=> (forall e. Data e => a -> e -> (a, f e))
-> a -> d -> (a, f d)
gmapAccumA f a0 d0 = gfoldlAccum k z a0 d0
where
k :: forall d e. (Data d) =>
a -> f (d -> e) -> d -> (a, f e)
k a c d = let (a',d') = f a d
c' = c <*> d'
in (a', c')
z :: forall t a f. (Applicative f) =>
t -> a -> (t, f a)
z a x = (a, pure x)
gzip3 :: PM -> PM
gzip3 f = gzipBut3 f gzipQ3
gzipQ3 :: GM
gzipQ3 x y z =
if and [toConstr x == toConstr y, toConstr y == toConstr z]
then return undefined
else fail ("Conflict: x=" ++ gshow x ++ " y=" ++ gshow y ++ " z=" ++ gshow z)
gzipBut3 :: PM -> GM -> PM
gzipBut3 merge continue x y z =
gzip3' merge' x y z
where
merge' :: GM
merge' x y z = cast' x >>= \x' -> cast' y >>= \y' -> merge x' y' z
gzip3' :: GM -> GM
gzip3' merge x y z =
merge x y z
`mplus`
(continue x y z >> gzipWithM3 (gzip3' merge) x y z)
gzipButA3 :: forall f. (Applicative f) => PM -> GB -> PA f -> PA f
gzipButA3 merge continue conflict x y z =
gzip3' x y z
where
gzip3' :: GA f
gzip3' x y z =
case merge' x y z of
Just x' -> pure x'
Nothing ->
if continue x y z
then gzipWithA3 gzip3' x y z
else conflict' x y z
merge' :: GM
merge' x y z =
case (cast x, cast y) of
(Just x', Just y') -> merge x' y' z
_ -> fail "type conflict"
conflict' :: GA f
conflict' x y z =
case (cast x, cast y) of
(Just x', Just y') -> conflict x' y' z
_ -> error "type conflict"
extQ2 :: (Typeable a, Typeable b, Typeable d, Typeable e)
=> (a -> b -> r) -> (d -> e -> r) -> a -> b -> r
extQ2 d q x y = fromMaybe (d x y) $ cast x >>= \x' -> cast y >>= \y' -> Just (q x' y')
extQ3 :: (Typeable a, Typeable b, Typeable c, Typeable d, Typeable e, Typeable f)
=> (a -> b -> c -> r) -> (d -> e -> f -> r) -> a -> b -> c -> r
extQ3 d q x y z = fromMaybe (d x y z) $ cast x >>= \x' -> cast y >>= \y' -> cast z >>= \z' -> Just (q x' y' z')
mkQ3 :: (Typeable a, Typeable b, Typeable c, Typeable d, Typeable e, Typeable f)
=> r -> (a -> b -> c -> r) -> d -> e -> f -> r
mkQ3 d q x y z = extQ3 (\ _ _ _ -> d) q x y z
extT3 :: (Typeable a, Typeable b)
=> (a -> a -> a -> Maybe a) -> (b -> b -> b -> Maybe b) -> a -> a -> a -> Maybe a
extT3 d q x y z = fromMaybe (d x y z) $ cast x >>= \x' -> cast y >>= \y' -> cast z >>= \z' -> gcast (q x' y' z')
mkQ2 :: (Data a, Data b, Data c) => (a -> b -> r) -> (c -> c -> r) -> a -> b -> r
mkQ2 d q x y = fromMaybe (d x y) $ cast x >>= \x' -> cast y >>= \y' -> Just (q x' y')
mergeBy :: forall a m. MonadPlus m => (a -> a -> a -> m a) -> (a -> a -> Bool) -> a -> a -> a -> m a
mergeBy conflict eq original left right =
if eq original left then return right
else if eq original right then return left
else if eq left right then return left
else conflict original left right