+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 [])