int.icl

   1 implementation module int
   2
   3 import StdEnv
   4 import Data.Either
   5 import Data.Functor
   6 import Data.Maybe
   7 import Data.List
   8 import Data.Tuple
   9 import Control.Applicative
  10 import Control.Monad
  11 import Control.Monad.State
  12 import Control.Monad.Trans
  13
  14 import ast
  15
  16 :: Eval a :== StateT [([Char], Value)] (Either [String]) a
  17
  18 int :: !Expression -> Either [String] Value
  19 int e = evalStateT (eval e)
  20         [(['_if'], Builtin \i->pure (Lit (Builtin \t->pure (Lit (Builtin \e->
  21                 eval i >>= \(Bool b)->pure (if b t e))))))
  22         ,(['_eq'],  binop \(Int i) (Int j)->Bool (i == j))
  23         ,(['_sub'], binop \(Int i) (Int j)->Int  (i - j))
  24         ,(['_add'], binop \(Int i) (Int j)->Int  (i + j))
  25         ,(['_mul'], binop \(Int i) (Int j)->Int  (i * j))
  26         ,(['_div'], binop \(Int i) (Int j)->Int  (i / j))
  27         ]
  28 where
  29         binop :: (Value Value -> Value) -> Value
  30         binop op = Builtin \l->pure (Lit (Builtin \r->(o) Lit o op <$> eval l <*> eval r))
  31
  32 eval :: Expression -> Eval Value
  33 eval (Let ns rest) = sequence [eval v >>= \v->modify (\vs->[(n, v):vs])\\(n, v)<-ns] >>| eval rest
  34 eval (Lit v) = pure v
  35 eval (Var v) = gets (lookup v) >>= maybe (liftT (Left [toString v +++ " not found"])) pure
  36 eval (Lambda a b) = pure (Lambda` a b)
  37 eval (App e1 e2) = eval e1 >>= \v->case v of
  38         (Lambda` v b) = eval (sub v e2 b)
  39         (Builtin f) = f e2 >>= eval
  40 where
  41         sub :: [Char] Expression Expression -> Expression
  42         sub i subs (Let ns rest)
  43                 | not (isMember i (map fst ns)) = Let (fmap (sub i subs) <$> ns) (sub i subs rest)
  44         sub i subs (Var v)
  45                 | i == v = subs
  46         sub i subs (App e1 e2) = App (sub i subs e1) (sub i subs e2)
  47         sub i subs (Lambda v b)
  48                 | i <> v = Lambda v (sub i subs b)
  49         sub _ _ x = x