int.icl

   1 implementation module int
   2
   3 import StdEnv
   4
   5 import Data.Either
   6 import Data.Functor
   7 import Data.Maybe
   8 import Data.List
   9 import Control.Applicative
  10 import Control.Monad
  11 import Control.Monad.State
  12 import Control.Monad.Trans
  13
  14 import ast
  15
  16 int :: Expression -> Either [String] Value
  17 int _ = Left ["intbork"]
  18 /*int (AST fs) = evalStateT (mapM evalFun fs >>| getStart fs >>= eval >>= printer) preamble
  19
  20 err :: String -> Eval a
  21 err e = liftT (Left [e])
  22
  23 getStart :: [Function] -> Eval Expression
  24 getStart [] = err "No start rule defined"
  25 getStart [(Function ['start'] _ e):_] = pure e
  26 getStart [_:fs] = getStart fs
  27
  28 :: Eval a :== StateT EvalState (Either [String]) a
  29 :: EvalState :== [([Char], Value)]
  30 preamble =
  31         [(['if'], Func 3 [] (Builtin ['if']))
  32         ,(['eq'], Func 2 [] (Builtin ['eq']))
  33         ,(['mul'], Func 2 [] (Builtin ['mul']))
  34         ,(['div'], Func 2 [] (Builtin ['div']))
  35         ,(['add'], Func 2 [] (Builtin ['add']))
  36         ,(['sub'], Func 2 [] (Builtin ['sub']))
  37         ]
  38
  39 putEnv :: [Char] Value -> Eval ()
  40 putEnv i v = modify (\vs->[(i,v):vs])
  41
  42 getEnv :: [Char] -> Eval Value
  43 getEnv v = gets (lookup v)
  44         >>= maybe (err ("Variable " +++ toString v +++ " not found")) pure
  45
  46 evalFun :: Function -> Eval ()
  47 evalFun (Function v a b) = putEnv v (Func (length a) [] (\es->fun a es b))
  48 where
  49         fun [] [] body = body
  50         fun [a:as] [e:es] body = fun as es (sub a e body)
  51
  52 printer :: Value -> Eval Value
  53 printer t=:(Func 0 args body) = eval (body args) >>= printer
  54 printer a = pure a
  55
  56 sub :: [Char] Expression Expression -> Expression
  57 sub ident subst (Var v)
  58         | ident == v = subst
  59 sub ident subst (App e1 e2) = App (sub ident subst e1) (sub ident subst e2)
  60 sub ident subst (Lambda v b)
  61         | ident <> v = Lambda v (sub ident b subst)
  62 sub _ _ x = x
  63
  64 eval :: Expression -> Eval Value
  65 eval (Lit v) = pure v
  66 eval (Var v) = getEnv v
  67 eval (App e1 e2) = eval e1 >>= \v->case v of
  68 //      (Func 0 a b) = err "Saturated function"
  69         (Func n as b) = pure (Func (n-1) (as ++ [e2]) b)
  70 //      _ = err ("Cannot apply " +++ toString e2 +++ " to " +++ toString e1)
  71 eval (Lambda a b) = pure (Func 1 [] (\[arg]->sub a arg b))
  72 eval (Builtin i as) = case (i, as) of
  73         (['if'], [p,t,e]) = eval p >>= printer >>= \v->case v of
  74                 Bool v = eval (if v t e)
  75 //              _ = err ("first argument of if must be a bool but is " +++ toString v)
  76         (['add'], [l,r]) = eval l >>= printer >>= \l->eval r >>= printer >>= \r->case (l,r) of
  77                 (Int a, Int b) = pure (Int (a + b))
  78 //              _ = err "add only defined for integers"
  79         (['sub'], [l,r]) = eval l >>= printer >>= \l->eval r >>= printer >>= \r->case (l,r) of
  80                 (Int a, Int b) = pure (Int (a - b))
  81 //              _ = err "sub only defined for integers"
  82         (['mul'], [l,r]) = eval l >>= printer >>= \l->eval r >>= printer >>= \r->case (l,r) of
  83                 (Int a, Int b) = pure (Int (a * b))
  84 //              _ = err "mul only defined for integers"
  85         (['div'], [l,r]) = eval l >>= \l->eval r >>= \r->case (l,r) of
  86                 (Int a, Int b) = pure (Int (a / b))
  87 //              _ = err "div only defined for integers"
  88         (['eq'], [l,r]) = eval l >>= printer >>= \l->eval r >>= printer >>= \r->case (l,r) of
  89                 (Int a, Int b) = pure (Bool (a == b))
  90 //              _ = err "eq only defined for integers"
  91 */