module Data.Comp.Param.Multi.Algebra (
Alg,
free,
cata,
cata',
appCxt,
AlgM,
freeM,
cataM,
AlgM',
Compose(..),
freeM',
cataM',
CxtFun,
SigFun,
Hom,
appHom,
appHom',
compHom,
appSigFun,
appSigFun',
compSigFun,
hom,
compAlg,
CxtFunM,
SigFunM,
HomM,
sigFunM,
hom',
appHomM,
appTHomM,
appHomM',
appTHomM',
homM,
appSigFunM,
appTSigFunM,
appSigFunM',
appTSigFunM',
compHomM,
compSigFunM,
compAlgM,
compAlgM'
) where
import Prelude hiding (sequence, mapM)
import Control.Monad hiding (sequence, mapM)
import Data.Functor.Compose
import Data.Comp.Param.Multi.Term
import Data.Comp.Param.Multi.HDifunctor
import Data.Comp.Param.Multi.HDitraversable
type Alg f a = f a a :-> a
free :: forall h f a b. HDifunctor f
=> Alg f a -> (b :-> a) -> Cxt h f a b :-> a
free f g = run
where run :: Cxt h f a b :-> a
run (In t) = f (hfmap run t)
run (Hole x) = g x
run (Var p) = p
cata :: forall f a. HDifunctor f => Alg f a -> Term f :-> a
cata f (Term t) = run t
where run :: Trm f a :-> a
run (In t) = f (hfmap run t)
run (Var x) = x
cata' :: HDifunctor f => Alg f a -> Cxt h f a a :-> a
cata' f = free f id
appCxt :: HDifunctor f => Cxt Hole f a (Cxt h f a b) :-> Cxt h f a b
appCxt (In t) = In (hfmap appCxt t)
appCxt (Hole x) = x
appCxt (Var p) = Var p
type AlgM m f a = NatM m (f a a) a
freeM :: forall m h f a b. (HDitraversable f, Monad m)
=> AlgM m f a -> NatM m b a -> NatM m (Cxt h f a b) a
freeM f g = run
where run :: NatM m (Cxt h f a b) a
run (In t) = f =<< hdimapM run t
run (Hole x) = g x
run (Var p) = return p
cataM :: forall m f a. (HDitraversable f, Monad m)
=> AlgM m f a -> NatM m (Term f) a
cataM algm (Term t) = run t
where run :: NatM m (Trm f a) a
run (In t) = algm =<< hdimapM run t
run (Var x) = return x
type AlgM' m f a = NatM m (f a (Compose m a)) a
freeM' :: forall m h f a b. (HDifunctor f, Monad m)
=> AlgM' m f a -> NatM m b a -> NatM m (Cxt h f a b) a
freeM' f g = run
where run :: NatM m (Cxt h f a b) a
run (In t) = f $ hfmap (Compose . run) t
run (Hole x) = g x
run (Var p) = return p
cataM' :: forall m f a. (HDifunctor f, Monad m)
=> AlgM' m f a -> NatM m (Term f) a
cataM' algm (Term t) = run t
where run :: NatM m (Trm f a) a
run (In t) = algm $ hfmap (Compose . run) t
run (Var x) = return x
type SigFun f g = forall (a :: * -> *) (b :: * -> *) . f a b :-> g a b
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. (HDifunctor f, HDifunctor g) => Hom f g -> CxtFun f g
appHom f = run where
run :: CxtFun f g
run (In t) = appCxt (f (hfmap run t))
run (Hole x) = Hole x
run (Var p) = Var p
appHom' :: forall f g. (HDifunctor g)
=> Hom f g -> CxtFun f g
appHom' f = run where
run :: CxtFun f g
run (In t) = appCxt (hfmapCxt run (f t))
run (Hole x) = Hole x
run (Var p) = Var p
compHom :: (HDifunctor g, HDifunctor h)
=> Hom g h -> Hom f g -> Hom f h
compHom f g = appHom f . g
compAlg :: (HDifunctor f, HDifunctor g) => Alg g a -> Hom f g -> Alg f a
compAlg alg talg = cata' alg . talg
appSigFun :: forall f g. (HDifunctor f) => SigFun f g -> CxtFun f g
appSigFun f = run where
run :: CxtFun f g
run (In t) = In (f (hfmap run t))
run (Hole x) = Hole x
run (Var p) = Var p
appSigFun' :: forall f g. (HDifunctor g) => SigFun f g -> CxtFun f g
appSigFun' f = run where
run :: CxtFun f g
run (In t) = In (hfmap run (f t))
run (Hole x) = Hole x
run (Var p) = Var p
compSigFun :: SigFun g h -> SigFun f g -> SigFun f h
compSigFun f g = f . g
hom :: HDifunctor g => SigFun f g -> Hom f g
hom f = simpCxt . f
type SigFunM m f g = forall (a :: * -> *) (b :: * -> *) . NatM m (f a b) (g a b)
type CxtFunM m f g = forall h . SigFunM m (Cxt h f) (Cxt h g)
type HomM m f g = SigFunM m f (Cxt Hole g)
sigFunM :: Monad m => SigFun f g -> SigFunM m f g
sigFunM f = return . f
hom' :: (HDifunctor f, HDifunctor g, Monad m)
=> SigFunM m f g -> HomM m f g
hom' f = liftM (In . hfmap Hole) . f
homM :: (HDifunctor g, Monad m) => SigFun f g -> HomM m f g
homM f = sigFunM $ hom f
appHomM :: forall f g m. (HDitraversable f, Monad m, HDifunctor g)
=> HomM m f g -> CxtFunM m f g
appHomM f = run
where run :: CxtFunM m f g
run (In t) = liftM appCxt (f =<< hdimapM run t)
run (Hole x) = return (Hole x)
run (Var p) = return (Var p)
appTHomM :: (HDitraversable f, Monad m, ParamFunctor m, HDifunctor g)
=> HomM m f g -> Term f i -> m (Term g i)
appTHomM f (Term t) = termM (appHomM f t)
appHomM' :: forall f g m. (HDitraversable g, Monad m)
=> HomM m f g -> CxtFunM m f g
appHomM' f = run
where run :: CxtFunM m f g
run (In t) = liftM appCxt (hdimapMCxt run =<< f t)
run (Hole x) = return (Hole x)
run (Var p) = return (Var p)
appTHomM' :: (HDitraversable g, Monad m, ParamFunctor m, HDifunctor g)
=> HomM m f g -> Term f i -> m (Term g i)
appTHomM' f (Term t) = termM (appHomM' f t)
appSigFunM :: forall m f g. (HDitraversable f, Monad m)
=> SigFunM m f g -> CxtFunM m f g
appSigFunM f = run
where run :: CxtFunM m f g
run (In t) = liftM In (f =<< hdimapM run t)
run (Hole x) = return (Hole x)
run (Var p) = return (Var p)
appTSigFunM :: (HDitraversable f, Monad m, ParamFunctor m, HDifunctor g)
=> SigFunM m f g -> Term f i -> m (Term g i)
appTSigFunM f (Term t) = termM (appSigFunM f t)
appSigFunM' :: forall m f g. (HDitraversable g, Monad m)
=> SigFunM m f g -> CxtFunM m f g
appSigFunM' f = run
where run :: CxtFunM m f g
run (In t) = liftM In (hdimapM run =<< f t)
run (Hole x) = return (Hole x)
run (Var p) = return (Var p)
appTSigFunM' :: (HDitraversable g, Monad m, ParamFunctor m, HDifunctor g)
=> SigFunM m f g -> Term f i -> m (Term g i)
appTSigFunM' f (Term t) = termM (appSigFunM' f t)
compHomM :: (HDitraversable g, HDifunctor h, Monad m)
=> HomM m g h -> HomM m f g -> HomM m f h
compHomM f g = appHomM f <=< g
compAlgM :: (HDitraversable g, Monad m) => AlgM m g a -> HomM m f g -> AlgM m f a
compAlgM alg talg = freeM alg return <=< talg
compAlgM' :: (HDitraversable g, Monad m) => AlgM m g a -> Hom f g -> AlgM m f a
compAlgM' alg talg = freeM alg return . talg
compSigFunM :: Monad m => SigFunM m g h -> SigFunM m f g -> SigFunM m f h
compSigFunM f g a = g a >>= f