Eagerな(おもちゃ)言語

SLang.hs

{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE TupleSections #-}
module SLang where

import Control.Monad.State
import Data.Bool
import Data.Maybe

-- Abstract Syntax

data Term a = Lam a (Term a)
            | App (Term a) (Term a)
            | Var a
            | Let [Bnd a] (Term a)
            | Con Int
            | Div (Term a) (Term a)
  deriving Show

type Bnd a = (a, Term a)
type Alt a = (Term a, Term a)

-- Expression

type Expr = Term Name
type Name = String

-- Expression normalizer

normalize :: Expr -> Expr
normalize expr = case expr of
  Lam v body  -> Lam v (normalize body)
  Var x       -> Var x
  App e1 e2   -> App (normalize e1) (normalize e2)
  Let bs e    -> case bs of
    []        -> normalize e
    (x,e'):bs -> App (Lam x (normalize (Let bs e))) (normalize e')
  Con n       -> Con n
  Div e1 e2   -> Div (normalize e1) (normalize e2)

-- Value

data Value = Val {val_ :: !Int}
           | Fun {fun_ :: Value -> Value}

instance Show Value where
  show (Val n)       = show n
  show (Fun _)       = "<Function>"

-- Environment

type Bind a = (a, Value)

type Env = [Bind Name]
type Rho = Name -> Value

rho :: Env -> Rho
rho = foldr expand rho0

rho0 :: Rho
rho0 name = error ("Variable unbound : " ++ name)

expand :: (Name, Value) -> Rho -> Rho
expand (var, val) pho var' = bool (pho var') val (var == var')

interp :: Expr -> Env -> Value
interp expr env = case expr of
  Lam x e   -> Fun (\ !val -> interp e ((x,val) : env))
  App e v   -> fun_ (interp e env) (interp v env)
  Var x     -> rho env x
  Con n     -> Val n
  Div e1 e2 -> case interp e1 env of
    Val m     -> case interp e2 env of
      Val n     -> Val (m `div` n)
  Let bs e  -> interp e (expandEnv bs env)

expandEnv :: [(Name, Expr)] -> Env -> Env
expandEnv bnds env = env'
  where
    env' = foldr f env bnds
    f (name, exp) = ((name, interp exp env') :)

--

{- |
  評価器
>>> three
Lam "x" (Div (Con 6) (Con 2))
>>> eval three
<Function>
>>> div0
Div (Con 1) (Con 0)
>>> eval div0
*** Exception: divide by zero
>>> bot                              -- let bot = bot in bot
Let [("bot",Var "bot")] (Var "bot")
>>> ex
App (Lam "x" (Div (Con 6) (Con 2))) (Div (Con 1) (Con 0))
>>> eval ex
*** Exception: divide by zero
>>> ex'
App (Lam "x" (Div (Con 6) (Con 2))) (Let [("bot",Var "bot")] (Var "bot"))
>>> ex''
Let [("bot",Div (Con 1) (Con 0))] (Con 0)
-}
eval :: Expr -> Value
eval = flip interp [] . normalize

--

three :: Expr                               -- 非正格関数にならない
three = Lam "x" (Div (Con 6) (Con 2))

div0 :: Expr
div0 = Div (Con 1) (Con 0)                  -- Haskellの例外が発生

bot :: Expr
bot = Let [("bot", Var "bot")] (Var "bot")  -- ⊥値をもつ式（評価しようとする無限ループ）

ex :: Expr
ex = App three div0

ex' :: Expr
ex' = App three bot

ex'' :: Expr
ex'' = Let [("bot", div0)] (Con 0)