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         ,(['_fst'], Builtin \t->eval t >>= \(a ** b)->pure a)
  28         ,(['_snd'], Builtin \t->eval t >>= \(a ** b)->pure b)
  29         ]
  30 where
  31         binop :: (Value Value -> Value) -> Value
  32         binop op = Builtin \l->pure (Lit (Builtin \r->(o) Lit o op <$> eval l <*> eval r))
  33
  34 eval :: Expression -> Eval Value
  35 eval (Let ns rest) = sequence [eval v >>= \v->modify (\vs->[(n, v):vs])\\(n, v)<-ns] >>| eval rest
  36 eval (Lit v) = pure v
  37 eval (Var v) = gets (lookup v) >>= maybe (liftT (Left [toString v +++ " not found"])) pure
  38 eval (Lambda a b) = pure (Lambda` a b)
  39 eval (Tuple a b) = pure (a ** b)
  40 eval (App e1 e2) = eval e1 >>= \v->case v of
  41         (Lambda` v b) = eval (sub v e2 b)
  42         (Builtin f) = f e2 >>= eval
  43 where
  44         sub :: [Char] Expression Expression -> Expression
  45         sub i subs (Let ns rest)
  46                 | not (isMember i (map fst ns)) = Let (fmap (sub i subs) <$> ns) (sub i subs rest)
  47         sub i subs (Var v)
  48                 | i == v = subs
  49         sub i subs (App e1 e2) = App (sub i subs e1) (sub i subs e2)
  50         sub i subs (Lambda v b)
  51                 | i <> v = Lambda v (sub i subs b)
  52         sub _ _ x = x