Lazyな(おもちゃ)言語

Lang.hs

{-# LANGUAGE TupleSections #-}
module Lang where

import Control.Arrow
import Control.Monad.State
import Data.Bool
import Data.Either
import Data.List
import Data.Maybe
import Control.Monad.Trans.Iter
import Control.Monad.Identity

-- 抽象構文

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)
            | Add (Term a) (Term a)
            | Por (Term a) (Term a)
  deriving Show

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

-- 式

type Expr = Term Name
type Name = String

-- プログラム変換

normalize :: Expr -> Expr
normalize = flip evalState 0 . norm

type NameSupply = Int

norm :: Expr -> State NameSupply Expr
norm expr = case expr of
  Lam v body       -> Lam v <$> norm body
  Var x            -> return $ Var x
  App e1 v@(Var _) -> App <$> norm e1 <*> return v
  App e1 e2        -> do
    { n <- get
    ; put (succ n)
    ; let v = "v_"++show n
    ; Let <$> ((:[]) <$> ((v,) <$> norm e2)) <*> (App <$> norm e1 <*> return (Var v))
    }
  Let bs e         -> Let <$> mapM (\ (v,e') -> (v,) <$> norm e') bs <*> norm e
  Con n            -> return (Con n)
  Div e1 e2        -> Div <$> norm e1 <*> norm e2
  Add e1 e2        -> Add <$> norm e1 <*> norm e2
  Por e1 e2        -> Por <$> norm e1 <*> norm e2

-- 値

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

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

-- 近似列

type Value = Iter Value' 

-- 環境

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 = delay $ case expr of
  Lam x e   -> return $ Fun (\ val -> interp e ((x,val) : env))
  App e v   -> join $ (fun_ <$> interp e env) <*> return (interp v env)
  Var x     -> rho env x
  Con n     -> return $ Val n
  Div e1 e2 -> div' <$> interp e1 env
                    <*> do { d <- interp e2 env
                           ; case d of
                               Val 0 -> bottom
                               _     -> return d
                           }
  Add e1 e2 -> add'  <$> interp e1 env <*> interp e2 env
  Let bs e  -> interp e (expandEnv bs env)
  Por x y   -> por (interp x env) (interp y env)          -- 並列-OR

-- 環境更新子

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

-- Value' 上のプリミティブ演算

add' :: Value' -> Value' -> Value'
add' (Val m) (Val n) = Val (m + n)

div' :: Value' -> Value' -> Value'
div' (Val m) (Val n) = Val (m `div` n)

-- Value 上のプリミティブ演算

bottom :: Value
bottom = interp (Let [("bot", Var "bot")] (Var "bot")) []

por :: Value -> Value -> Value
por x y = case (runIter x, runIter y) of
  (x',y') -> case x' of
    Left (Val 0) -> case y' of
      Left (Val 0) -> return (Val 0)
      Left v       -> return v
      _            -> bottom
    _ -> case y' of
      Left (Val 0) -> delay (repack x')
      Left v       -> return v
      _            -> delay (por (repack y') (repack x'))

porAlt :: Value -> Value -> Value
porAlt x y = case (runIter x, runIter y) of
  (Left l, _) -> return l
  (_, Left r) -> return r
  (x', y')    -> delay $ porAlt (repack x') (repack y')

repack :: Either Value' Value -> Value
repack = either return id

-- 近似列の極限

eval' :: Expr -> Value'
eval' = runIdentity . retract . flip interp [] . normalize

-- 近似列の表示

eval'N :: Integer -> Expr -> Maybe Value'
eval'N n = runIdentity . retract . cutoff n . flip interp [] . normalize

evalShow :: Int -> Expr -> String
evalShow n e = case break isJust (take n (map (flip eval'N e) [0 ..])) of
  (xs,[])   -> intercalate "," (map showV' xs) ++ ",..."
  (xs,y:ys) -> intercalate "," (map showV' xs) ++ "," ++ showV' y

showV' :: Maybe Value' -> String
showV' Nothing  = "⊥"
showV' (Just v) = show v

-- 式の例

three :: Expr
three = Lam "x" (Div (Con 6) (Con 2))         -- \ x -> 6 `div` 2

div0 :: Expr
div0 = Div (Con 1) (Con 0)                    -- 1 `div` 0

bot :: Expr
bot = Let [("bot", Var "bot")] (Var "bot")    -- let bot = bot in bot

ex0 :: Expr
ex0 = App three div0                          -- three div0

ex1 :: Expr
ex1 = App three bot                           -- three bot

ex2 :: Expr
ex2 = Let [("bot", div0)] (Con 0)             -- let bot = 1 `div` 0 in 0

ex3 :: Expr
ex3 = Por bot bot                              -- bot `por` bot