eadt.icl

   1 module eadt
   2
   3 import StdEnv
   4 import Control.Monad
   5 import Control.Applicative
   6 import Data.Functor
   7 import Data.Maybe
   8
   9 :: BM a b = { to :: a -> b, fro :: b -> a}
  10 bm :: BM a a
  11 bm = {to=id, fro=id}
  12
  13 class eval m where eval :: (m a) -> Maybe a
  14 class print m where print :: (m a) [String] -> [String]
  15 class flat m where flat :: (m a) -> DSL a
  16 :: DSL a
  17         = E.e: Lit (BM e a) a & toString e
  18         | E.e: Plus (BM e a) (DSL e) (DSL e) & + e
  19         | E.m: Ext (m a) & eval, print, flat m
  20 lit = Lit bm
  21 (+.) infixl 6
  22 (+.) = Plus bm
  23
  24 instance eval DSL where
  25         eval (Lit _ a) = Just a
  26         eval (Plus bm x y) = bm.to <$> ((+) <$> eval x <*> eval y)
  27         eval (Ext m) = eval m
  28
  29 instance print DSL where
  30         print (Lit bm a) c = [toString (bm.fro a):c]
  31         print (Plus _ x y) c = print x ["+":print y c]
  32         print (Ext m) c = print m c
  33
  34 instance flat DSL where
  35         flat (Ext m) = Ext (flat m)
  36         flat a = a
  37
  38 :: Div a = E.e: Div (BM e a) (DSL e) (DSL e) & /, zero, == e
  39 (/.) infixl 7
  40 (/.) x y = Ext (Div bm x y)
  41
  42 instance eval Div where
  43         eval (Div bm x y) = bm.to <$> (eval x >>= \x->eval y >>= \y->
  44                 if (y == zero) Nothing (Just (x/y)))
  45
  46 instance print Div where
  47         print (Div bm x y) c = print x ["/":print y c]
  48
  49 instance flat Div where
  50         flat a = Ext a
  51
  52 :: In a b = In infix 0 a b
  53 :: Var a = E.b: Var ((DSL b) -> In (DSL b) (DSL a))
  54 var = Ext o Var
  55 instance eval Var where
  56         eval (Var def) =
  57                 let (init In body) = def init
  58                 in eval body
  59
  60 instance print Var where
  61         print (Var def) c =
  62                 let (init In body) = def init
  63                 in ["let _ = ":print init [" in ":print body c]]
  64
  65 instance flat Var where
  66         flat (Var def) =
  67                 let (init In body) = def init
  68                 in body
  69
  70 Start = printEval (var \x=lit 41 In x +. lit 1)
  71
  72 printEval :: (DSL a) -> (Maybe a, [String])
  73 printEval e = (eval e, print e [])