content: 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
  