Mini programming language to implement the recursive `fact` function.

semantickata.hs

{-# LANGUAGE LambdaCase #-}
module Main where

import Control.Applicative (liftA2)
import Control.Monad.Reader

type Varname = String
type Env = [(Varname, Dom)]

data Dom
  = IntDom Int
  | BoolDom Bool
  | FunDom (Dom -> Dom)
  | Error RuntimeError

instance Show Dom where
  show (IntDom i)  = show i
  show (BoolDom b) = show b
  show (FunDom _)  = "<function>"
  show (Error e)   = show e

data RuntimeError
  = UnknownVariable Varname
  | TypeError
  deriving Show

data Expr
  = I Int
  | B Bool
  | Var Varname
  | Subtract Expr Expr
  | Times Expr Expr
  | IsLtEq Expr Expr
  | If Expr Expr Expr
  | Lam Varname Expr
  | App Expr Expr
  | LetRec Varname Expr Expr
  deriving Show

eval :: Expr -> Reader Env Dom
eval (I i) = return (IntDom i)

eval (B b) = return (BoolDom b)

eval (Var x) = do
  env  <- ask
  case lookup x env of
    Just val -> return val
    _        -> return (Error (UnknownVariable x))

eval (Subtract lhs rhs) =
  liftA2 (,) (eval lhs) (eval rhs) >>= \case
    (IntDom x, IntDom y) -> return (IntDom (x - y))
    _                    -> return (Error TypeError)

eval (Times lhs rhs) =
  liftA2 (,) (eval lhs) (eval rhs) >>= \case
    (IntDom x, IntDom y) -> return (IntDom (x * y))
    _                    -> return (Error TypeError)

eval (IsLtEq lhs rhs) =
  liftA2 (,) (eval lhs) (eval rhs) >>= \case
    (IntDom x, IntDom y) -> return (BoolDom (x <= y))
    _                    -> return (Error TypeError)

eval (If c t f) =
  eval c >>= \case
    BoolDom True  -> eval t
    BoolDom False -> eval f
    _             -> return (Error TypeError)

eval (Lam v e) = do
  env <- ask
  return . FunDom $ \x ->
    runReader (eval e) ((v, x):env)

eval (App lhs rhs) =
  liftA2 (,) (eval lhs) (eval rhs) >>= \case
    (FunDom f, x) -> return (f x)
    _             -> return (Error TypeError)

eval (LetRec v e b) =
  eval (Lam v e) >>= \case
    FunDom rec -> local ((v, fix rec):) (eval b)
    _          -> return (Error TypeError)

fact :: Expr
fact =
  LetRec "fact" (
    Lam "n" (
      (If (IsLtEq (Var "n") (I 0))
          (I 1)
          (Times (App (Var "fact") (Subtract (Var "n") (I 1))) (Var "n"))
      )
    )
  ) (App (Var "fact") (I 6))

main :: IO ()
main = print $ runReader (eval fact) []