{-# LANGUAGE BangPatterns #-} | |
{-# LANGUAGE TupleSections #-} | |
module SLang where | |
import Control.Monad.State | |
import Data.Bool | |
import Data.Maybe | |
import Control.Monad.Trans.Iter | |
import Control.Monad.Identity | |
-- 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) | |
| Por (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 | |
_ -> Let (nmBind <$> bs) (normalize e) -- App (Lam x (normalize (Let bs e))) (normalize e') | |
Con n -> Con n | |
Div e1 e2 -> Div (normalize e1) (normalize e2) | |
Por e1 e2 -> Por (normalize e1) (normalize e2) | |
where | |
nmBind (n, e) = (n, normalize e) | |
-- Value | |
data Value = Val {val_ :: !Int} | |
| Fun {fun_ :: Iter Value -> Iter Value} | |
instance Show Value where | |
show (Val n) = show n | |
show (Fun _) = "<Function>" | |
-- Environment | |
type Bind a = (a, Iter Value) | |
type Env = [Bind Name] | |
type Rho = Name -> Iter Value | |
rho :: Env -> Rho | |
rho env n = foldr expand rho0 env n | |
rho0 :: Rho | |
rho0 name = error ("Variable unbound : " ++ name) | |
expand :: (Name, Iter Value) -> Rho -> Rho | |
expand (var, val) pho var' = bool (pho var') val (var == var') | |
interp :: Expr -> Env -> Iter Value | |
interp expr env = delay $ case expr of | |
Lam x e -> return $ Fun (\ val -> interp e ((x,val) : env)) | |
App e v -> do { e' <- interp e env; fun_ e' (interp v env) } | |
Var x -> rho env x | |
Con n -> return $ Val n | |
Div e1 e2 -> do | |
Val m <- interp e1 env | |
Val n <- interp e2 env | |
return $ Val (m `div` n) | |
Let bs e -> interp e (expandEnv bs env) | |
Por x y -> por (interp x env) (interp y env) | |
por :: Iter Value -> Iter Value -> Iter Value | |
por x y = case (runIter x, runIter y) of | |
(Left (Val k), _) | isTrue k -> return (Val 1) | |
(_, Left (Val l)) | isTrue l -> return (Val 1) | |
(Left (Val _), Left (Val _)) -> return (Val 0) | |
(x', y') -> delay $ por (repack x') (repack y') | |
where | |
repack :: Either Value (Iter Value) -> Iter Value | |
repack = either return id | |
isTrue = (/= 0) | |
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 | |
3 | |
>>> 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) | |
>>> evalN 1000 bot | |
Nothing | |
>>> eval $ Con 1 `Por` bot | |
1 | |
>>> eval $ bot `Por` Con 1 | |
1 | |
>>> eval $ Con 0 `Por` Con 0 | |
0 | |
>>> evalN 1000 $ Con 0 `Por` bot | |
Nothing | |
-} | |
eval :: Expr -> Value | |
eval = runIdentity . retract . flip interp [] . normalize | |
evalN :: Integer -> Expr -> Maybe Value | |
evalN n = runIdentity . retract . cutoff n . 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