module Data.Comp.Multi.Algebra (
Alg,
free,
cata,
cata',
appCxt,
AlgM,
freeM,
cataM,
cataM',
liftMAlg,
CxtFun,
SigFun,
Hom,
appHom,
appHom',
compHom,
appSigFun,
appSigFun',
compSigFun,
hom,
compAlg,
CxtFunM,
SigFunM,
HomM,
sigFunM,
hom',
appHomM,
appHomM',
homM,
appSigFunM,
appSigFunM',
compHomM,
compSigFunM,
compAlgM,
compAlgM',
Coalg,
ana,
CoalgM,
anaM,
RAlg,
para,
RAlgM,
paraM,
RCoalg,
apo,
RCoalgM,
apoM,
CVCoalg,
futu,
CVCoalgM,
futuM,
) where
import Control.Monad
import Data.Comp.Multi.HFunctor
import Data.Comp.Multi.HTraversable
import Data.Comp.Multi.Term
import Data.Comp.Ops
type Alg f e = f e :-> e
free :: forall f h a b . (HFunctor f) =>
Alg f b -> (a :-> b) -> Cxt h f a :-> b
free f g = run
where run :: Cxt h f a :-> b
run (Hole v) = g v
run (Term c) = f $ hfmap run c
cata :: forall f a. HFunctor f => Alg f a -> Term f :-> a
cata f = run
where run :: Term f :-> a
run (Term t) = f (hfmap run t)
cata' :: HFunctor f => Alg f e -> Cxt h f e :-> e
cata' alg = free alg id
appCxt :: HFunctor f => Context f (Cxt h f a) :-> Cxt h f a
appCxt = cata' Term
liftMAlg :: forall m f. (Monad m, HTraversable f) =>
Alg f I -> Alg f m
liftMAlg alg = turn . liftM alg . hmapM run
where run :: m i -> m (I i)
run m = do x <- m
return $ I x
turn x = do I y <- x
return y
type AlgM m f e = NatM m (f e) e
freeM :: forall f m h a b. (HTraversable f, Monad m) =>
AlgM m f b -> NatM m a b -> NatM m (Cxt h f a) b
freeM algm var = run
where run :: NatM m (Cxt h f a) b
run (Hole x) = var x
run (Term x) = hmapM run x >>= algm
cataM :: forall f m a. (HTraversable f, Monad m) =>
AlgM m f a -> NatM m (Term f) a
cataM alg = run
where run :: NatM m (Term f) a
run (Term x) = alg =<< hmapM run x
cataM' :: forall m h a f. (Monad m, HTraversable f) => AlgM m f a -> NatM m (Cxt h f a) a
cataM' f = run
where run :: NatM m (Cxt h f a) a
run (Hole x) = return x
run (Term x) = hmapM run x >>= f
type SigFun f g = forall (a :: * -> *). f a :-> g a
type CxtFun f g = forall h . SigFun (Cxt h f) (Cxt h g)
type Hom f g = SigFun f (Context g)
appHom :: forall f g . (HFunctor f, HFunctor g) => Hom f g -> CxtFun f g
appHom f = run where
run :: CxtFun f g
run (Hole b) = Hole b
run (Term t) = appCxt . f . hfmap run $ t
appHom' :: forall f g . (HFunctor g) => Hom f g -> CxtFun f g
appHom' f = run where
run :: CxtFun f g
run (Hole b) = Hole b
run (Term t) = appCxt . hfmap run . f $ t
compHom :: (HFunctor g, HFunctor h) => Hom g h -> Hom f g -> Hom f h
compHom f g = appHom f . g
compAlg :: (HFunctor g) => Alg g a -> Hom f g -> Alg f a
compAlg alg talg = cata' alg . talg
appSigFun' :: forall f g. (HFunctor g) => SigFun f g -> CxtFun f g
appSigFun' f = run
where run :: CxtFun f g
run (Hole b) = Hole b
run (Term t) = Term . hfmap run . f $ t
appSigFun :: forall f g. (HFunctor f) => SigFun f g -> CxtFun f g
appSigFun f = run
where run :: CxtFun f g
run (Hole b) = Hole b
run (Term t) = Term . f . hfmap run $ t
compSigFun :: SigFun g h -> SigFun f g -> SigFun f h
compSigFun f g = f . g
hom :: (HFunctor g) => SigFun f g -> Hom f g
hom f = simpCxt . f
type SigFunM m f g = forall (a :: * -> *) . NatM m (f a) (g a)
type CxtFunM m f g = forall h. SigFunM m (Cxt h f) (Cxt h g)
type HomM m f g = SigFunM m f (Context g)
sigFunM :: (Monad m) => SigFun f g -> SigFunM m f g
sigFunM f = return . f
hom' :: (HFunctor f, HFunctor g, Monad m) =>
SigFunM m f g -> HomM m f g
hom' f = liftM (Term . hfmap Hole) . f
homM :: (HFunctor g, Monad m) => SigFun f g -> HomM m f g
homM f = sigFunM $ hom f
appHomM :: forall f g m . (HTraversable f, HFunctor g, Monad m)
=> HomM m f g -> CxtFunM m f g
appHomM f = run
where run :: CxtFunM m f g
run (Hole b) = return $ Hole b
run (Term t) = liftM appCxt . (>>= f) . hmapM run $ t
appHomM' :: forall f g m . (HTraversable g, Monad m)
=> HomM m f g -> CxtFunM m f g
appHomM' f = run
where run :: CxtFunM m f g
run (Hole b) = return $ Hole b
run (Term t) = liftM appCxt . hmapM run =<< f t
appSigFunM :: forall f g m. (HTraversable f, Monad m) =>
SigFunM m f g -> CxtFunM m f g
appSigFunM f = run
where run :: CxtFunM m f g
run (Hole b) = return $ Hole b
run (Term t) = liftM Term . f =<< hmapM run t
appSigFunM' :: forall f g m. (HTraversable g, Monad m) =>
SigFunM m f g -> CxtFunM m f g
appSigFunM' f = run
where run :: CxtFunM m f g
run (Hole b) = return $ Hole b
run (Term t) = liftM Term . hmapM run =<< f t
compHomM :: (HTraversable g, HFunctor h, Monad m)
=> HomM m g h -> HomM m f g -> HomM m f h
compHomM f g a = g a >>= appHomM f
compAlgM :: (HTraversable g, Monad m) => AlgM m g a -> HomM m f g -> AlgM m f a
compAlgM alg talg c = cataM' alg =<< talg c
compAlgM' :: (HTraversable g, Monad m) => AlgM m g a -> Hom f g -> AlgM m f a
compAlgM' alg talg = cataM' alg . talg
compSigFunM :: (Monad m) => SigFunM m g h -> SigFunM m f g -> SigFunM m f h
compSigFunM f g a = g a >>= f
type Coalg f a = a :-> f a
ana :: forall f a. HFunctor f => Coalg f a -> a :-> Term f
ana f = run
where run :: a :-> Term f
run t = Term $ hfmap run (f t)
type CoalgM m f a = NatM m a (f a)
anaM :: forall a m f. (HTraversable f, Monad m)
=> CoalgM m f a -> NatM m a (Term f)
anaM f = run
where run :: NatM m a (Term f)
run t = liftM Term $ f t >>= hmapM run
type RAlg f a = f (Term f :*: a) :-> a
para :: forall f a. (HFunctor f) => RAlg f a -> Term f :-> a
para f = fsnd . cata run
where run :: Alg f (Term f :*: a)
run t = Term (hfmap ffst t) :*: f t
type RAlgM m f a = NatM m (f (Term f :*: a)) a
paraM :: forall f m a. (HTraversable f, Monad m) =>
RAlgM m f a -> NatM m(Term f) a
paraM f = liftM fsnd . cataM run
where run :: AlgM m f (Term f :*: a)
run t = do
a <- f t
return (Term (hfmap ffst t) :*: a)
type RCoalg f a = a :-> f (Term f :+: a)
apo :: forall f a . (HFunctor f) => RCoalg f a -> a :-> Term f
apo f = run
where run :: a :-> Term f
run = Term . hfmap run' . f
run' :: Term f :+: a :-> Term f
run' (Inl t) = t
run' (Inr a) = run a
type RCoalgM m f a = NatM m a (f (Term f :+: a))
apoM :: forall f m a . (HTraversable f, Monad m) =>
RCoalgM m f a -> NatM m a (Term f)
apoM f = run
where run :: NatM m a (Term f)
run a = do
t <- f a
t' <- hmapM run' t
return $ Term t'
run' :: NatM m (Term f :+: a) (Term f)
run' (Inl t) = return t
run' (Inr a) = run a
type CVCoalg f a = a :-> f (Context f a)
futu :: forall f a . HFunctor f => CVCoalg f a -> a :-> Term f
futu coa = ana run . Hole
where run :: Coalg f (Context f a)
run (Hole a) = coa a
run (Term v) = v
type CVCoalgM m f a = NatM m a (f (Context f a))
futuM :: forall f a m . (HTraversable f, Monad m) =>
CVCoalgM m f a -> NatM m a (Term f)
futuM coa = anaM run . Hole
where run :: CoalgM m f (Context f a)
run (Hole a) = coa a
run (Term v) = return v