-

[clean-tests.git] / eadt.icl

diff --git a/eadt.icl b/eadt.icl
new file mode 100644 (file)
index 0000000..30ec0e1
--- /dev/null
+++ b/eadt.icl
@@ -0,0 +1,73 @@
+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 [])