Last active
November 3, 2018 12:32
-
-
Save nobsun/1f2535d5f191f6733df0039cede9face to your computer and use it in GitHub Desktop.
Eagerな(おもちゃ)言語
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
{-# 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) |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment