🤡

a5/src/APL/Eval.hs

@@ -0,0 +1,128 @@
+module APL.Eval
+  ( Val (..),
+    Env,
+    eval,
+    runEval,
+  )
+where
+
+import APL.AST (Exp (..), VName)
+import APL.Error (Error (..))
+import Control.Monad (ap, liftM)
+
+data Val
+  = ValInt Integer
+  | ValBool Bool
+  | ValFun Env VName Exp
+  deriving (Eq, Show)
+
+type Env = [(VName, Val)]
+
+envEmpty :: Env
+envEmpty = []
+
+envExtend :: VName -> Val -> Env -> Env
+envExtend v val env = (v, val) : env
+
+envLookup :: VName -> Env -> Maybe Val
+envLookup v env = lookup v env
+
+newtype EvalM a = EvalM (Env -> Either Error a)
+
+instance Functor EvalM where
+  fmap = liftM
+
+instance Applicative EvalM where
+  pure x = EvalM $ \_env -> Right x
+  (<*>) = ap
+
+instance Monad EvalM where
+  EvalM x >>= f = EvalM $ \env ->
+    case x env of
+      Left err -> Left err
+      Right x' ->
+        let EvalM y = f x'
+         in y env
+
+askEnv :: EvalM Env
+askEnv = EvalM $ \env -> Right env
+
+localEnv :: (Env -> Env) -> EvalM a -> EvalM a
+localEnv f (EvalM m) = EvalM $ \env -> m (f env)
+
+failure :: Error -> EvalM a
+failure s = EvalM $ \_env -> Left s
+
+catch :: EvalM a -> EvalM a -> EvalM a
+catch (EvalM m1) (EvalM m2) = EvalM $ \env ->
+  case m1 env of
+    Left _ -> m2 env
+    Right x -> Right x
+
+runEval :: EvalM a -> Either Error a
+runEval (EvalM m) = m envEmpty
+
+evalIntBinOp :: (Integer -> Integer -> EvalM Integer) -> Exp -> Exp -> EvalM Val
+evalIntBinOp f e1 e2 = do
+  v1 <- eval e1
+  v2 <- eval e2
+  case (v1, v2) of
+    (ValInt x, ValInt y) -> ValInt <$> f x y
+    (_, _) -> failure NonInteger
+
+evalIntBinOp' :: (Integer -> Integer -> Integer) -> Exp -> Exp -> EvalM Val
+evalIntBinOp' f e1 e2 =
+  evalIntBinOp f' e1 e2
+  where
+    f' x y = pure $ f x y
+
+eval :: Exp -> EvalM Val
+eval (CstInt x) = pure $ ValInt x
+eval (CstBool b) = pure $ ValBool b
+eval (Var v) = do
+  env <- askEnv
+  case envLookup v env of
+    Just x -> pure x
+    Nothing -> failure $ UnknownVariable v
+eval (Add e1 e2) = evalIntBinOp' (+) e1 e2
+eval (Sub e1 e2) = evalIntBinOp' (-) e1 e2
+eval (Mul e1 e2) = evalIntBinOp' (*) e1 e2
+eval (Div e1 e2) = evalIntBinOp checkedDiv e1 e2
+  where
+    checkedDiv _ 0 = failure DivisionByZero
+    checkedDiv x y = pure $ x `div` y
+eval (Pow e1 e2) = evalIntBinOp checkedPow e1 e2
+  where
+    checkedPow x y =
+      if y < 0
+        then failure NegativeExponent
+        else pure $ x ^ y
+eval (Eql e1 e2) = do
+  v1 <- eval e1
+  v2 <- eval e2
+  case (v1, v2) of
+    (ValInt x, ValInt y) -> pure $ ValBool $ x == y
+    (ValBool x, ValBool y) -> pure $ ValBool $ x == y
+    (_, _) -> failure InvalidEqual
+eval (If cond e1 e2) = do
+  cond' <- eval cond
+  case cond' of
+    ValBool True -> eval e1
+    ValBool False -> eval e2
+    _ -> failure NonBoolean
+eval (Let var e1 e2) = do
+  v1 <- eval e1
+  localEnv (envExtend var v1) $ eval e2
+eval (Lambda var body) = do
+  env <- askEnv
+  pure $ ValFun env var body
+eval (Apply e1 e2) = do
+  v1 <- eval e1
+  v2 <- eval e2
+  case (v1, v2) of
+    (ValFun f_env var body, arg) ->
+      localEnv (const $ envExtend var arg f_env) $ eval body
+    (_, _) ->
+      failure NonFunction
+eval (TryCatch e1 e2) =
+  eval e1 `catch` eval e2