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