module Data.Comp.Multi.Algebra (
HAlg,
hfree,
hcata,
hcata',
appHCxt,
HAlgM,
hfreeM,
hcataM,
hcataM',
liftMHAlg,
HCxtFun,
HSigFun,
HTermHom,
appHTermHom,
compHTermHom,
appHSigFun,
compHSigFun,
htermHom,
compHAlg,
HCxtFunM,
HSigFunM,
HTermHomM,
hsigFunM,
appHTermHomM,
htermHomM,
appHSigFunM,
compHTermHomM,
compHSigFunM,
compHAlgM,
compHAlgM',
HCoalg,
hana,
HCoalgM,
hanaM,
HRAlg,
hpara,
HRAlgM,
hparaM,
HRCoalg,
hapo,
HRCoalgM,
hapoM,
HCVCoalg,
hfutu,
HCVCoalgM,
hfutuM,
appHTermHomE,
hcataE,
appHCxtE
) where
import Data.Comp.Multi.Term
import Data.Comp.Multi.Functor
import Data.Comp.Multi.Traversable
import Data.Comp.Multi.ExpFunctor
import Data.Comp.Ops
import Control.Monad
type HAlg f e = f e :-> e
hfree :: forall f h a b . (HFunctor f) =>
HAlg f b -> (a :-> b) -> HCxt h f a :-> b
hfree f g = run
where run :: HCxt h f a :-> b
run (HHole v) = g v
run (HTerm c) = f $ hfmap run c
hcata :: forall f a. (HFunctor f) => HAlg f a -> HTerm f :-> a
hcata f = run
where run :: HTerm f :-> a
run (HTerm t) = f (hfmap run t)
hcata' :: (HFunctor f) => HAlg f e -> HCxt h f e :-> e
hcata' alg = hfree alg id
appHCxt :: (HFunctor f) => HContext f (HCxt h f a) :-> HCxt h f a
appHCxt = hcata' HTerm
liftMHAlg :: forall m f. (Monad m, HTraversable f) =>
HAlg f I -> HAlg f m
liftMHAlg 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 HAlgM m f e = NatM m (f e) e
hfreeM :: forall f m h a b. (HTraversable f, Monad m) =>
HAlgM m f b -> NatM m a b -> NatM m (HCxt h f a) b
hfreeM algm var = run
where run :: NatM m (HCxt h f a) b
run (HHole x) = var x
run (HTerm x) = hmapM run x >>= algm
hcataM :: forall f m a. (HTraversable f, Monad m) =>
HAlgM m f a -> NatM m (HTerm f) a
hcataM alg = run
where run :: NatM m (HTerm f) a
run (HTerm x) = alg =<< hmapM run x
hcataM' :: forall m h a f. (Monad m, HTraversable f) => HAlgM m f a -> NatM m (HCxt h f a) a
hcataM' f = run
where run :: NatM m (HCxt h f a) a
run (HHole x) = return x
run (HTerm x) = hmapM run x >>= f
type HCxtFun f g = forall a h. HCxt h f a :-> HCxt h g a
type HSigFun f g = forall a. f a :-> g a
type HTermHom f g = HSigFun f (HContext g)
appHTermHom :: (HFunctor f, HFunctor g) => HTermHom f g -> HCxtFun f g
appHTermHom _ (HHole b) = HHole b
appHTermHom f (HTerm t) = appHCxt . f . hfmap (appHTermHom f) $ t
compHTermHom :: (HFunctor g, HFunctor h) => HTermHom g h -> HTermHom f g -> HTermHom f h
compHTermHom f g = appHTermHom f . g
compHAlg :: (HFunctor g) => HAlg g a -> HTermHom f g -> HAlg f a
compHAlg alg talg = hcata' alg . talg
appHSigFun :: (HFunctor f, HFunctor g) => HSigFun f g -> HCxtFun f g
appHSigFun f = appHTermHom $ htermHom f
compHSigFun :: HSigFun g h -> HSigFun f g -> HSigFun f h
compHSigFun f g = f . g
htermHom :: (HFunctor g) => HSigFun f g -> HTermHom f g
htermHom f = simpHCxt . f
type HCxtFunM m f g = forall a h. NatM m (HCxt h f a) (HCxt h g a)
type HSigFunM m f g = forall a. NatM m (f a) (g a)
type HTermHomM m f g = HSigFunM m f (HContext g)
hsigFunM :: (Monad m) => HSigFun f g -> HSigFunM m f g
hsigFunM f = return . f
htermHom' :: (HFunctor f, HFunctor g, Monad m) =>
HSigFunM m f g -> HTermHomM m f g
htermHom' f = liftM (HTerm . hfmap HHole) . f
htermHomM :: (HFunctor g, Monad m) => HSigFun f g -> HTermHomM m f g
htermHomM f = hsigFunM $ htermHom f
appHTermHomM :: forall f g m . (HTraversable f, HFunctor g, Monad m)
=> HTermHomM m f g -> HCxtFunM m f g
appHTermHomM f = run
where run :: NatM m (HCxt h f a) (HCxt h g a)
run (HHole b) = return $ HHole b
run (HTerm t) = liftM appHCxt . (>>= f) . hmapM run $ t
appHSigFunM :: (HTraversable f, HFunctor g, Monad m) =>
HSigFunM m f g -> HCxtFunM m f g
appHSigFunM f = appHTermHomM $ htermHom' f
compHTermHomM :: (HTraversable g, HFunctor h, Monad m)
=> HTermHomM m g h -> HTermHomM m f g -> HTermHomM m f h
compHTermHomM f g a = g a >>= appHTermHomM f
compHAlgM :: (HTraversable g, Monad m) => HAlgM m g a -> HTermHomM m f g -> HAlgM m f a
compHAlgM alg talg c = hcataM' alg =<< talg c
compHAlgM' :: (HTraversable g, Monad m) => HAlgM m g a -> HTermHom f g -> HAlgM m f a
compHAlgM' alg talg = hcataM' alg . talg
compHSigFunM :: (Monad m) => HSigFunM m g h -> HSigFunM m f g -> HSigFunM m f h
compHSigFunM f g a = g a >>= f
type HCoalg f a = a :-> f a
hana :: forall f a. HFunctor f => HCoalg f a -> a :-> HTerm f
hana f = run
where run :: a :-> HTerm f
run t = HTerm $ hfmap run (f t)
type HCoalgM m f a = NatM m a (f a)
hanaM :: forall a m f. (HTraversable f, Monad m)
=> HCoalgM m f a -> NatM m a (HTerm f)
hanaM f = run
where run :: NatM m a (HTerm f)
run t = liftM HTerm $ f t >>= hmapM run
type HRAlg f a = f (HTerm f :*: a) :-> a
hpara :: forall f a. (HFunctor f) => HRAlg f a -> HTerm f :-> a
hpara f = fsnd . hcata run
where run :: HAlg f (HTerm f :*: a)
run t = HTerm (hfmap ffst t) :*: f t
type HRAlgM m f a = NatM m (f (HTerm f :*: a)) a
hparaM :: forall f m a. (HTraversable f, Monad m) =>
HRAlgM m f a -> NatM m(HTerm f) a
hparaM f = liftM fsnd . hcataM run
where run :: HAlgM m f (HTerm f :*: a)
run t = do
a <- f t
return (HTerm (hfmap ffst t) :*: a)
type HRCoalg f a = a :-> f (HTerm f :+: a)
hapo :: forall f a . (HFunctor f) => HRCoalg f a -> a :-> HTerm f
hapo f = run
where run :: a :-> HTerm f
run = HTerm . hfmap run' . f
run' :: HTerm f :+: a :-> HTerm f
run' (Inl t) = t
run' (Inr a) = run a
type HRCoalgM m f a = NatM m a (f (HTerm f :+: a))
hapoM :: forall f m a . (HTraversable f, Monad m) =>
HRCoalgM m f a -> NatM m a (HTerm f)
hapoM f = run
where run :: NatM m a (HTerm f)
run a = do
t <- f a
t' <- hmapM run' t
return $ HTerm t'
run' :: NatM m (HTerm f :+: a) (HTerm f)
run' (Inl t) = return t
run' (Inr a) = run a
type HCVCoalg f a = a :-> f (HContext f a)
hfutu :: forall f a . HFunctor f => HCVCoalg f a -> a :-> HTerm f
hfutu coa = hana run . HHole
where run :: HCoalg f (HContext f a)
run (HHole a) = coa a
run (HTerm v) = v
type HCVCoalgM m f a = NatM m a (f (HContext f a))
hfutuM :: forall f a m . (HTraversable f, Monad m) =>
HCVCoalgM m f a -> NatM m a (HTerm f)
hfutuM coa = hanaM run . HHole
where run :: HCoalgM m f (HContext f a)
run (HHole a) = coa a
run (HTerm v) = return v
hcataE :: forall f a . HExpFunctor f => HAlg f a -> HTerm f :-> a
hcataE f = cataFS . toHCxt
where cataFS :: HExpFunctor f => HContext f a :-> a
cataFS (HHole x) = x
cataFS (HTerm t) = f (hxmap cataFS HHole t)
appHCxtE :: (HExpFunctor f) => HContext f (HCxt h f a) :-> HCxt h f a
appHCxtE (HHole x) = x
appHCxtE (HTerm t) = HTerm (hxmap appHCxtE HHole t)
appHTermHomE :: forall f g . (HExpFunctor f, HExpFunctor g) => HTermHom f g
-> HTerm f :-> HTerm g
appHTermHomE f = cataFS . toHCxt
where cataFS :: HContext f (HTerm g) :-> HTerm g
cataFS (HHole x) = x
cataFS (HTerm t) = appHCxtE (f (hxmap cataFS HHole t))