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風モナドは一切いらなくなった。まあ自分で書いたことによって裏側の動作がわかったのでよしとする。

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

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