https://gist.github.com/nobsun/1f2535d5f191f6733df0039cede9face をIterで改変

Lang.hs

{-# 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)