Skip to content

Instantly share code, notes, and snippets.

@as-capabl as-capabl/Lang.hs
Created Nov 6, 2018

Embed
What would you like to do?
{-# 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
You can’t perform that action at this time.