module Control.Monatron.Open where
import Control.Monatron.Monatron ()
import Control.Monatron.AutoLift
infixr 9 :+:
infixr 9 <@>
data (:+:) f g a = Inl (f a) | Inr (g a)
newtype Fix f = In {out :: f (Fix f)}
type Open e f r = (e -> r) -> (f e -> r)
(<@>) :: Open e f r -> Open e g r -> Open e (f :+: g) r
evalf <@> evalg = \eval e ->
case e of
Inl el -> evalf eval el
Inr er -> evalg eval er
fix :: Open (Fix f) f r -> (Fix f -> r)
fix f = let this = f this . out
in this
class (f :<: g) where
inj :: f a -> g a
instance Functor f => (:<:) f f where
inj = id
instance (Functor g, Functor f)
=> (:<:) f (f :+: g) where
inj = Inl
instance (Functor g, Functor h, Functor f, f :<: g)
=> (:<:) f (h :+: g) where
inj = Inr . inj
inject :: (f :<: g) => f (Fix g) -> Fix g
inject = In . inj
instance (Functor f, Functor g) =>
Functor (f :+: g) where
fmap f (Inl x) = Inl (fmap f x)
fmap f (Inr y) = Inr (fmap f y)
foldFix :: Functor f => (f a -> a) -> Fix f -> a
foldFix f = f . fmap (foldFix f) . out