Hatena::Grouphaskell

mokeheheの日記

2009-08-02

Stateモナドを使用する

defineを作る - HaskellでLispを書く日記 - haskellを見ると、evalでの状態の受け渡しにStateモナドを使ってる。

これによれば、状態の取得はgetgets、上書きはput、変更はmodify、実行して結果と状態を受け取るにはrunState、結果だけならevalStateを使うらしい。

これを参考に書き換える:

Intp.hs
module Intp (
	intp,
	IntpState(..),
	Value(..)
) where

import Prelude hiding (EQ, LT, GT, catch)
import Parser (Node(..), Op(..))
import Control.Monad.State

-- 値
data Value =
		DValue Double                    -- 直値
	|	Lambda [String] Node             -- 関数
	|	Native Int ([Double] -> Double)  -- ネイティブ関数

instance Show Value where
	show (DValue d)   = show d
	show (Lambda _ _) = "<lambda>"
	show (Native _ _) = "<native>"

-- 環境
type Environment = [(String, Value)]

doAssign :: String -> Value -> Environment -> Environment
doAssign var val env = (var, val) : filter ((/= var) . fst) env

-- インタプリタの状態
data IntpState =
	IntpState {
		global :: Environment
		}
	deriving (Show)

-- インタープリト
intp :: Node -> IntpState -> (Double, IntpState)
intp node state = runState (eval node) state

---------------------------------------
-- Intp

false   = 0.0
true    = 1.0
isFalse = (== false)
isTrue  = (/= false)

type MyST a = State IntpState a

eval :: Node -> MyST Double
eval (Literal v)      = return v
eval (Arith op n1 n2) = arith op n1 n2
eval (Ident name) = do
	st <- get
	case (lookup name (global st)) of
		Nothing -> fail $ "undefined variable: " ++ name
		Just v  ->
			case v of
				DValue x -> return x
				Lambda _ _ -> fail $ "<" ++ name ++ ":lambda>"
				Native _ _ -> fail $ "<" ++ name ++ ":native>"
eval (Assign name n) = do
	v <- eval n
	modify (\st -> st{ global = doAssign name (DValue v) (global st) })
	return v
eval (If c t e) = do
	v <- eval c
	eval $ if isTrue v then t else e
eval (Funcall fname params) = do
	realparams <- evalNodeList params
	st <- get
	case (lookup fname (global st)) of
		Nothing -> fail $ "undefined variable: " ++ fname
		Just v  -> callfn v realparams
	where
		callfn (Lambda args body) realparams
			| length realparams /= length args  = fail $ fname ++ ": illegal argnum, " ++ show (length realparams) ++ " for " ++ show (length args)
			| otherwise = do
				st <- get
				put $ st { global = override args realparams (global st) }
				res <- eval body
				put st
				return res
		callfn (Native argnum f) realparams
			| length realparams /= argnum = fail $ fname ++ ": illegal argnum, " ++ show (length realparams) ++ " for " ++ show argnum
			| otherwise = return $ f realparams
		callfn _ _ = fail $ fname ++ " is not function"

		override args realparams env =
			foldl (\e (a,p) -> doAssign a (DValue p) e) env $ zip args realparams
eval (Defun name args body) = do
	modify (\st -> st { global = doAssign name (Lambda args body) (global st) })
	return true

arith Add     n1 n2 = evalArith (+)  n1 n2
arith Sub     n1 n2 = evalArith (-)  n1 n2
arith Mul     n1 n2 = evalArith (*)  n1 n2
arith Div     n1 n2 = evalArith (/)  n1 n2
arith Pow     n1 n2 = evalArith (**) n1 n2
arith EQ      n1 n2 = evalBool  (==) n1 n2
arith NE      n1 n2 = evalBool  (/=) n1 n2
arith LT      n1 n2 = evalBool  (<)  n1 n2
arith LE      n1 n2 = evalBool  (<=) n1 n2
arith GT      n1 n2 = evalBool  (>)  n1 n2
arith GE      n1 n2 = evalBool  (>=) n1 n2
arith LogiAnd n1 n2 = evalShortcut isFalse n1 n2
arith LogiOr  n1 n2 = evalShortcut isTrue  n1 n2
arith Negate  n1 _  = eval n1 >>= return . negate

evalArith op n1 n2 = do
	v1 <- eval n1
	v2 <- eval n2
	return $ v1 `op` v2
evalBool  op n1 n2 = do
	v1 <- eval n1
	v2 <- eval n2
	return $ if v1 `op` v2 then true else false
evalShortcut f n1 n2 = do
	v1 <- eval n1
	if f v1 then return v1 else eval n2

evalNodeList :: [Node] -> MyST [Double]
evalNodeList []     = return []
evalNodeList (x:xs) = do
	v <- eval x
	vs <- evalNodeList xs
	return $ v:vs
  • 書き換えはほとんど大したことはなくて、Stateモナドへの状態と値の順序が逆だったので入れ替えたのと、getState, updateState, applySTをget, modify, runStateに置き換えたくらい

これによって、ST風モナドは一切いらなくなった。まあ自分で書いたことによって裏側の動作がわかったのでよしとする。

説明が難しすぎて読んでも利用方法がわからなかったよ…

Haskell風の関数呼び出しに変更する

関数定義はHaskell風に「関数名 引数 ... = 本体」だけど、関数呼び出しは数学やC言語などのように括弧+カンマ区切り、となってるので紛らわしい。なので関数呼び出しもHaskell風にスペース区切りで引数を渡すように変更する。

funcallOrVarrefで関数定義と変数参照をひとまとめにパースしていたのをそれぞれ分離して、factorは関数呼び出しか純factorとし、純factorは括弧つきの式かリテラルか変数参照とする:

factor :: MyParser Node
factor = try(funcall) <|> primFactor

primFactor :: MyParser Node
primFactor = parenedExpr <|> floatLiteral <|> varref <?> "factor"

関数呼び出しは名前に続いて1つ以上の引数で、引数は純factor:

funcall :: MyParser Node
funcall = do
	name <- identifier
	params <- many1 primFactor
	return $ Funcall name params

変数参照は名前のみ:

varref :: MyParser Node
varref = do
	name <- identifier
	return $ Ident name

電卓に関数定義を追加する

構文木を作って評価できるようになったので、電卓に関数定義とその呼び出しを追加する。

まずはパーサに関数定義の構文を追加する。Haskellの関数定義風に、「関数名 引数 ... = 本体」という形式にする:

defun :: MyParser Node
defun = do
	name <- identifier
	args <- many1 identifier
	lexeme $ char '='
	e <- expr
	return $ Defun name args e

次は実行時の変数テーブルの変更。今まではDoubleの値しか入れないようにしていたが、関数も格納できるようにする:

-- 値
data Value =
		DValue Double                    -- 直値
	|	Lambda [String] Node             -- 関数
	|	Native Int ([Double] -> Double)  -- ネイティブ関数

-- 環境
type Environment = [(String, Value)]

評価時に関数定義が現れたら、変数テーブルに定義を代入する:

eval (Defun name args body) = do
	updateState (\st -> st { global = doAssign name (Lambda args body) (global st) })
	return true
  • なにか値を返さないといけないので、trueを返してみる

関数呼び出し時には、今までは変数テーブルとは別の組み込み関数用テーブルを参照していたのを、変数テーブルから関数名で引っ張ってくるようにして、関数だったら仮引数に実パラメータを束縛して関数本体を評価、ネイティブ関数だったら引数を渡して呼び出す:

eval (Funcall fname params) = do
	realparams <- evalNodeList params
	st <- getState
	case (lookup fname (global st)) of
		Nothing -> fail $ "undefined variable: " ++ fname
		Just v  -> callfn v realparams
	where
		callfn (Lambda args body) realparams
			| length realparams /= length args  = fail $ fname ++ ": illegal argnum, " ++ show (length realparams) ++ " for " ++ show (length args)
			| otherwise = do
				st <- getState
				setState $ st { global = override args realparams (global st) }
				res <- eval body
				setState st
				return res
		callfn (Native argnum f) realparams
			| length realparams /= argnum = fail $ fname ++ ": illegal argnum, " ++ show (length realparams) ++ " for " ++ show argnum
			| otherwise = return $ f realparams
		callfn _ _ = fail $ fname ++ " is not function"

		override args realparams env =
			foldl (\e (a,p) -> doAssign a (DValue p) e) env $ zip args realparams
  • グローバル変数を一時的に書き換える、動的スコープ方式

テスト:

> areaOfCircle r = pi * r ** 2
1.0
> areaOfCircle(10)
314.1592653589793
> fib n = n < 2 ? n : fib(n-1) + fib(n-2)
1.0
> fib(10)
55.0

以下、全ソース:

Main.hs
import Prelude hiding (catch)
import Control.Exception (catch)
import Text.ParserCombinators.Parsec (runParser, eof)
import System.IO

import Parser (stmt)
import Intp (intp, IntpState(..), Value(..))

repl :: String -> (String -> Bool) -> (String -> st -> (String, st)) -> st -> IO st
repl prompt bQuit eval = loop
	where
		loop st = hSetBuffering stdout NoBuffering >> putStr prompt >> getLine >>= act st
		act st s
			| bQuit s = return st
			| otherwise = catch (exec st s) (\err -> print err >> loop st)
		exec st s = do
			let (res, st') = eval s st
			putStrLn res
			loop st'

calc :: IntpState -> IO IntpState
calc = repl "> " (== ":q") parse
	where
		parse line st     = either (\err -> (show err, st)) (evaluate st) $ runParser parser () "" line
		evaluate st node  = result $ intp node st
		result (st, res)  = (show res, st)
		parser = stmt >>= \e -> eof >> return e

-- 初期の状態
initialState = IntpState genv
	where
		genv = [
			("pi", DValue pi),
			("sin", Native 1 (apply1 sin)),
			("cos", Native 1 (apply1 cos)),
			("tan", Native 1 (apply1 tan)),
			("log", Native 1 (apply1 log)),
			("sqrt", Native 1 (apply1 sqrt))
			]
		apply1 f = \[x] -> f x

main = putStrLn "type ':q' to quit." >> calc initialState >> putStrLn "Bye"
  • 組み込み関数(sin, cos, ...)と定数定義(pi)を初期状態として与えられるようになった
  • 実行時のエラーを捕捉するため、Control.Monadのcatchを使う。Preludeのcatchでは捕捉できないのでhidingする。
Parser.hs
tatement
  • 関数定義defunは文の初めにしか置けないようにする
Intp.hs
module Intp (
	intp,
	IntpState(..),
	Value(..)
) where

import Prelude hiding (EQ, LT, GT, catch)
import ST (ST, applyST, getState, setState, updateState)
import Parser (Node(..), Op(..))

-- 値
data Value =
		DValue Double                    -- 直値
	|	Lambda [String] Node             -- 関数
	|	Native Int ([Double] -> Double)  -- ネイティブ関数

instance Show Value where
	show (DValue d)   = show d
	show (Lambda _ _) = "<lambda>"
	show (Native _ _) = "<native>"

-- 環境
type Environment = [(String, Value)]

doAssign :: String -> Value -> Environment -> Environment
doAssign var val env = (var, val) : filter ((/= var) . fst) env

-- インタプリタの状態
data IntpState =
	IntpState {
		global :: Environment
		}
	deriving (Show)

-- インタープリト
intp :: Node -> IntpState -> (IntpState, Double)
intp node state = applyST (eval node) state

---------------------------------------
-- Intp

false   = 0.0
true    = 1.0
isFalse = (== false)
isTrue  = (/= false)

type MyST a = ST IntpState a

eval :: Node -> MyST Double
eval (Literal v)      = return v
eval (Arith op n1 n2) = arith op n1 n2
eval (Ident name) = do
	st <- getState
	case (lookup name (global st)) of
		Nothing -> fail $ "undefined variable: " ++ name
		Just v  ->
			case v of
				DValue x -> return x
				Lambda _ _ -> fail $ "<" ++ name ++ ":lambda>"
				Native _ _ -> fail $ "<" ++ name ++ ":native>"
eval (Assign name n) = do
	v <- eval n
	updateState (\st -> st{ global = doAssign name (DValue v) (global st) })
	return v
eval (If c t e) = do
	v <- eval c
	eval $ if isTrue v then t else e
eval (Funcall fname params) = do
	realparams <- evalNodeList params
	st <- getState
	case (lookup fname (global st)) of
		Nothing -> fail $ "undefined variable: " ++ fname
		Just v  -> callfn v realparams
	where
		callfn (Lambda args body) realparams
			| length realparams /= length args  = fail $ fname ++ ": illegal argnum, " ++ show (length realparams) ++ " for " ++ show (length args)
			| otherwise = do
				st <- getState
				setState $ st { global = override args realparams (global st) }
				res <- eval body
				setState st
				return res
		callfn (Native argnum f) realparams
			| length realparams /= argnum = fail $ fname ++ ": illegal argnum, " ++ show (length realparams) ++ " for " ++ show argnum
			| otherwise = return $ f realparams
		callfn _ _ = fail $ fname ++ " is not function"

		override args realparams env =
			foldl (\e (a,p) -> doAssign a (DValue p) e) env $ zip args realparams
eval (Defun name args body) = do
	updateState (\st -> st { global = doAssign name (Lambda args body) (global st) })
	return true

arith Add     n1 n2 = evalArith (+)  n1 n2
arith Sub     n1 n2 = evalArith (-)  n1 n2
arith Mul     n1 n2 = evalArith (*)  n1 n2
arith Div     n1 n2 = evalArith (/)  n1 n2
arith Pow     n1 n2 = evalArith (**) n1 n2
arith EQ      n1 n2 = evalBool  (==) n1 n2
arith NE      n1 n2 = evalBool  (/=) n1 n2
arith LT      n1 n2 = evalBool  (<)  n1 n2
arith LE      n1 n2 = evalBool  (<=) n1 n2
arith GT      n1 n2 = evalBool  (>)  n1 n2
arith GE      n1 n2 = evalBool  (>=) n1 n2
arith LogiAnd n1 n2 = evalShortcut isFalse n1 n2
arith LogiOr  n1 n2 = evalShortcut isTrue  n1 n2
arith Negate  n1 _  = eval n1 >>= return . negate

evalArith op n1 n2 = do
	v1 <- eval n1
	v2 <- eval n2
	return $ v1 `op` v2
evalBool  op n1 n2 = do
	v1 <- eval n1
	v2 <- eval n2
	return $ if v1 `op` v2 then true else false
evalShortcut f n1 n2 = do
	v1 <- eval n1
	if f v1 then return v1 else eval n2

evalNodeList :: [Node] -> MyST [Double]
evalNodeList []     = return []
evalNodeList (x:xs) = do
	v <- eval x
	vs <- evalNodeList xs
	return $ v:vs

ST.hs はこちら

構文木を生成し解釈する電卓

STモナド風を利用して、 比較演算子、論理演算子、三項演算子を追加する - mokeheheの日記 - haskellの電卓を構文木を生成してから評価する方式に変更する。ソースが長くなったので分割する。

Main.hs: メインルーチン
import Prelude hiding (catch)
import Control.Exception (catch)
import Text.ParserCombinators.Parsec
import System.IO

import Parser (expr)
import Intp (intp, IntpState(..))

repl :: String -> (String -> Bool) -> (String -> st -> (String, st)) -> st -> IO st
repl prompt bQuit eval = loop
	where
		loop st = hSetBuffering stdout NoBuffering >> putStr prompt >> getLine >>= act st
		act st s
			| bQuit s = return st
			| otherwise = catch (exec st s) (\err -> print err >> loop st)
		exec st s = do
			let (res, st') = eval s st
			putStrLn res
			loop st'

calc :: IntpState -> IO IntpState
calc = repl "> " (== ":q") parse
	where
		parse line st     = either (\err -> (show err, st)) (evaluate st) $ runParser parser () "" line
		evaluate st node  = result $ intp node st
		result (st, res)  = (show res, st)
		parser = expr >>= \e -> eof >> return e

-- 初期の状態
initialState = IntpState genv
	where
		genv = [
			("pi",	pi)
			]

main = putStrLn "type ':q' to quit." >> calc initialState >> putStrLn "Bye"
Parser.hs: 構文木を生成するパーサ
module Parser (
	Node(..),
	Op(..),
	expr
) where

import Prelude hiding (EQ, LT, GT)
import Text.ParserCombinators.Parsec
import Text.ParserCombinators.Parsec.Expr
import qualified Text.ParserCombinators.Parsec.Token as P
import Text.ParserCombinators.Parsec.Language

-- 演算子
data Op = Add | Sub | Mul | Div | Pow | Negate
	| EQ | NE | LT | LE | GT | GE
	| LogiAnd | LogiOr
	deriving (Show)

-- ノード
data Node =
		Literal Double
	|	Arith Op Node Node
	|	Ident String
	|	Assign String Node
	|	If Node Node Node
	|	Funcall String [Node]
	deriving (Show)

type MyParserState = ()

-- パーサ型
type MyParser a = GenParser Char MyParserState a

lexer :: P.TokenParser MyParserState
lexer = P.makeTokenParser (haskellDef { reservedOpNames = ["*","/","+","-","**", "==", "/=", "<", "<=", ">", ">=", "&&", "||", "?", ":"] })

naturalOrFloat = P.naturalOrFloat lexer
parens         = P.parens lexer
reservedOp     = P.reservedOp lexer
identifier     = P.identifier lexer
lexeme         = P.lexeme lexer

---------------------------------------
-- Parser (Generate Abstract-Syntax-Tree)

expr :: MyParser Node
expr = assignExpr

assignExpr :: MyParser Node
assignExpr = try(assign) <|> condExpr
	where
		assign = do
			var <- identifier
			lexeme $ char '='
			e <- expr
			return $ Assign var e

condExpr :: MyParser Node
condExpr = try(cond) <|> expr'
	where
		cond = do
			c <- expr'
			lexeme $ char '?'
			t <- expr
			lexeme $ char ':'
			e <- expr
			return $ If c t e

expr' :: MyParser Node
expr' = buildExpressionParser table factor <?> "expression"
	where
		table = [
			[unary "-" (flip (Arith Negate) (Literal 0)), unary "+" id],
			[op "**" (Arith Pow) AssocRight],
			[op "*" (Arith Mul) AssocLeft, op "/" (Arith Div) AssocLeft],
			[op "+" (Arith Add) AssocLeft, op "-" (Arith Sub) AssocLeft],
			[op "==" (Arith EQ) AssocNone, op "/=" (Arith NE) AssocNone, op "<" (Arith LT) AssocNone, op "<=" (Arith LE) AssocNone, op ">" (Arith GT) AssocLeft, op ">=" (Arith GE) AssocNone],
			[op "&&" (Arith LogiAnd) AssocLeft],
			[op "||" (Arith LogiOr) AssocLeft]
			]
		op s f assoc = Infix (do{ reservedOp s; return f } <?> "operator") assoc
		unary s f = Prefix (do{ reservedOp s; return f })

factor :: MyParser Node
factor = parenedExpr <|> floatLiteral <|> funcallOrVarref <?> "factor"

parenedExpr :: MyParser Node
parenedExpr = parens expr

floatLiteral :: MyParser Node
floatLiteral = naturalOrFloat >>= return . either (Literal . fromInteger) Literal

funcallOrVarref :: MyParser Node
funcallOrVarref = do
	name <- identifier
	do {
		params <- lexeme formalparams;
		return $ Funcall name params
	} <|> do
		return $ Ident name

formalparams :: MyParser [Node]
formalparams = do
	lexeme $ char '('
	params <- expr `sepBy` lexeme (char ',')
	char ')'
	return params
  • パーサの状態はひとまず必要なくなったのでユニット型に
Intp.hs: 構文木を実行するインタプリタ
module Intp (
	intp,
	IntpState(..)
) where

import Prelude hiding (EQ, LT, GT, catch)
import ST (ST, applyST, getState, updateState)
import Parser (Node(..), Op(..))

-- 環境
type Environment = [(String, Double)]

doAssign :: String -> Double -> Environment -> Environment
doAssign var val env = (var, val) : filter ((/= var) . fst) env

-- インタプリタの状態
data IntpState =
	IntpState {
		global :: Environment
		}
	deriving (Show)

-- インタープリト
intp :: Node -> IntpState -> (IntpState, Double)
intp node state = applyST (eval node) state

---------------------------------------
-- Intp

false   = 0.0
true    = 1.0
isFalse = (== false)
isTrue  = (/= false)

type MyST a = ST IntpState a

eval :: Node -> MyST Double
eval (Literal v)      = return v
eval (Arith op n1 n2) = arith op n1 n2
eval (Ident name) = do
	st <- getState
	case (lookup name (global st)) of
		Nothing -> fail $ "undefined variable: " ++ name
		Just v  -> return v
eval (Assign name n) = do
	v <- eval n
	updateState (\st -> st{ global = doAssign name v (global st) })
	return v
eval (If c t e) = do
	v <- eval c
	eval $ if isTrue v then t else e
eval (Funcall name params) = do
	realparams <- evalNodeList params
	either fail return $ applyFunc name realparams

arith Add     n1 n2 = evalArith (+)  n1 n2
arith Sub     n1 n2 = evalArith (-)  n1 n2
arith Mul     n1 n2 = evalArith (*)  n1 n2
arith Div     n1 n2 = evalArith (/)  n1 n2
arith Pow     n1 n2 = evalArith (**) n1 n2
arith EQ      n1 n2 = evalBool  (==) n1 n2
arith NE      n1 n2 = evalBool  (/=) n1 n2
arith LT      n1 n2 = evalBool  (<)  n1 n2
arith LE      n1 n2 = evalBool  (<=) n1 n2
arith GT      n1 n2 = evalBool  (>)  n1 n2
arith GE      n1 n2 = evalBool  (>=) n1 n2
arith LogiAnd n1 n2 = evalShortcut isFalse n1 n2
arith LogiOr  n1 n2 = evalShortcut isTrue  n1 n2
arith Negate  n1 _  = eval n1 >>= return . negate

evalArith op n1 n2 = do
	v1 <- eval n1
	v2 <- eval n2
	return $ v1 `op` v2
evalBool  op n1 n2 = do
	v1 <- eval n1
	v2 <- eval n2
	return $ if v1 `op` v2 then true else false
evalShortcut f n1 n2 = do
	v1 <- eval n1
	if f v1 then return v1 else eval n2

evalNodeList :: [Node] -> MyST [Double]
evalNodeList []     = return []
evalNodeList (x:xs) = do
	v <- eval x
	vs <- evalNodeList xs
	return $ v:vs 

applyFunc :: String -> [Double] -> Either String Double
applyFunc fname params = call $ lookup fname functbl
	where
		functbl = [
			("sin", (1, apply1 sin)),
			("cos", (1, apply1 cos)),
			("tan", (1, apply1 tan)),
			("log", (1, apply1 log)),
			("sqrt", (1, apply1 sqrt))
			]

		call Nothing = Left $ fname ++ ": no function"
		call (Just (argnum, fn))
			| length params /= argnum  = Left $ fname ++ ": illegal argnum, " ++ show (length params) ++ " for " ++ show argnum
			| otherwise                = Right $ fn params

		apply1 f [x]   = f x
		apply2 f [x,y] = f x y
ST.hs: STモナド
module ST (
	ST,
	applyST,
	runST,
	getState,
	setState,
	updateState
) where

newtype ST s a = ST( s -> (s, a) )

instance Monad (ST s)
  where
    -- (>>=) :: ST s a -> (a -> ST s b) -> ST s b
    (ST p) >>= k  =  ST( \s0 -> let (s1, a) = p s0
                                    (ST q) = k a
                                in q s1 )

    -- return :: a -> ST s a
    return a = ST( \s -> (s, a) )


runST :: ST s a -> s -> a
runST (ST p) s = snd $ p s

applyST :: ST s a -> s -> (s, a)
applyST (ST p) s = p s

getState :: ST st st
getState = ST( \s -> (s, s) )

setState :: st -> ST st ()
setState s' = ST( \s -> (s', ()) )

updateState :: (st -> st) -> ST st ()
updateState f = ST( \s -> (f s, ()) )

陰に状態を扱うためにSTモナド(に似たもの)を使用する

Parsecで作っている電卓に関数定義を追加しようと考えたところ、関数定義を実現するにはソースのパース時に直接計算を行ってしまわないでいったん構文木を作成して保存しておき、関数が呼び出されたときに構文木を評価して値を求める必要があることに気づいた。

Haskellで構文木を作るのはそんな難しいことではないのでサクッと修正、、、できたのだがパース時と同様に値の評価時にも状態(変数の値など)を持ち回る必要があることに気づいた。「eval node state」という具合に状態を陽に渡すようにしてもいいんだけどメンドクサイし、たとえば変数参照したときに未定義だったらエラーを返すなどの判定と分岐が必要になってしまい大変。

runParserのような仕組みで状態を裏で取り扱ってくれるうまいやりかたがないかな、と調べる。STモナドがそれっぽいんだけど、STモナドに状態を渡して結果を取り出す方法がわからなかった(えー)。

なのでMonads for the Working Haskell ProgrammerのStateTransモナドのあたりを参考に、似たようなものを定義してみる:

newtype ST s a = ST( s -> (s, a) )

instance Monad (ST s)
  where
    -- (>>=) :: ST s a -> (a -> ST s b) -> ST s b
    (ST p) >>= k  =  ST( \s0 -> let (s1, a) = p s0
                                    (ST q) = k a
                                in q s1 )

    -- return :: a -> ST s a
    return a = ST( \s -> (s, a) )

状態を渡して結果を取り出す関数:

-- 結果と状態のペアを取得
applyST :: ST s a -> s -> (s, a)
apply (ST p) s = p s

-- 結果のみを取得
runST :: ST s a -> s -> a
runST (ST p) s = snd $ p s

runParserのgetState, setState, updateStateのように、doの途中で状態を取り出したり変更したりする関数:

getState :: ST st st
getState = ST( \s -> (s, s) )

setState :: st -> ST st ()
setState s' = ST( \s -> (s', ()) )

updateState :: (st -> st) -> ST st ()
updateState f = ST( \s -> (f s, ()) )

これらを使って構文木を評価する関数を作る。まず構文木のノードや環境の定義:

-- ノード
data Node =
		Literal Double
	|	Ident String
	|	Assign String Node
	deriving (Show)

-- 環境
type Environment = [(String, Double)]

doAssign :: String -> Double -> Environment -> Environment
doAssign var val env = (var, val) : filter ((/= var) . fst) env

initialState = [
	("pi",	pi)  -- π
	]

評価を行う関数 eval と状態:

-- eval に必要な状態
type MyST a = ST Environment a

eval :: Node -> MyST Double
eval (Literal v) = return v
eval (Ident name) = do
	env <- getState
	case (lookup name env) of
		Nothing -> fail $ "undefined variable: " ++ name
		Just v  -> return v
eval (Assign name n) = do
	v <- eval n
	updateState $ doAssign name v
	return v
  • どういう仕組みかわからないけど、fail が使える

以上で、例えば変数参照は

> runST (eval (Ident "pi")) initialState
3.141592653589793

代入は

> applyST (eval (Assign "a" (Literal 123))) initialState
([("a",123.0),("pi",3.141592653589793)],123.0)

変数が未定義で途中でエラーが出るときも

> runST (eval (Assign "a" (Ident "b"))) initialState
*** Exception: undefined variable: b

とfailによって例外が出てくれる。

参考
トラックバック - http://haskell.g.hatena.ne.jp/mokehehe/20090802