module eadt

import StdEnv
import Control.Monad
import Control.Applicative
import Data.Functor
import Data.Maybe

:: BM a b = { to :: a -> b, fro :: b -> a}
bm :: BM a a
bm = {to=id, fro=id}

class eval m where eval :: (m a) -> Maybe a
class print m where print :: (m a) [String] -> [String]
class flat m where flat :: (m a) -> DSL a
:: DSL a
	= E.e: Lit (BM e a) a & toString e
	| E.e: Plus (BM e a) (DSL e) (DSL e) & + e
	| E.m: Ext (m a) & eval, print, flat m
lit = Lit bm
(+.) infixl 6
(+.) = Plus bm

instance eval DSL where
	eval (Lit _ a) = Just a
	eval (Plus bm x y) = bm.to <$> ((+) <$> eval x <*> eval y)
	eval (Ext m) = eval m

instance print DSL where
	print (Lit bm a) c = [toString (bm.fro a):c]
	print (Plus _ x y) c = print x ["+":print y c]
	print (Ext m) c = print m c

instance flat DSL where
	flat (Ext m) = Ext (flat m)
	flat a = a

:: Div a = E.e: Div (BM e a) (DSL e) (DSL e) & /, zero, == e
(/.) infixl 7
(/.) x y = Ext (Div bm x y)

instance eval Div where
	eval (Div bm x y) = bm.to <$> (eval x >>= \x->eval y >>= \y->
		if (y == zero) Nothing (Just (x/y)))

instance print Div where
	print (Div bm x y) c = print x ["/":print y c]

instance flat Div where
	flat a = Ext a

:: In a b = In infix 0 a b
:: Var a = E.b: Var ((DSL b) -> In (DSL b) (DSL a))
var = Ext o Var
instance eval Var where
	eval (Var def) =
		let (init In body) = def init
		in eval body

instance print Var where
	print (Var def) c =
		let (init In body) = def init
		in ["let _ = ":print init [" in ":print body c]]

instance flat Var where
	flat (Var def) =
		let (init In body) = def init
		in body

Start = printEval (var \x=lit 41 In x +. lit 1)

printEval :: (DSL a) -> (Maybe a, [String])
printEval e = (eval e, print e [])