X-Git-Url: https://git.martlubbers.net/?a=blobdiff_plain;f=eadt.icl;fp=eadt.icl;h=30ec0e128d5132066b06c2de00ea1dd9bb30ccb0;hb=4b62b5d397d86147e393c05b3083af74a3a0c4af;hp=0000000000000000000000000000000000000000;hpb=e5305ee9d4290e1aa803a2e62a14f32e5cd29782;p=clean-tests.git

diff --git a/eadt.icl b/eadt.icl
new file mode 100644
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 [])