-- {-# OPTIONS -fglasgow-exts -XNoMonomorphismRestriction -XOverlappingInstances #-}

{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE OverlappingInstances #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}

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
            
-- Borrowed from Data types \`a la Carte

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