Hatena::Grouphaskell

mokeheheの日記

2009-08-05

ラムダ関数を追加する

電卓で任意の型の値を扱えるようにする - mokeheheの日記 - haskellで関数をファーストクラスの値として扱えるようになったので、関数に渡したりできる:

> twice f x = f (f x)
<function>
> sq x = x * x
<function>
> twice sq 10
10000.0

でもグローバル関数しかないので、環境とかなにも考えなくてすんでいた。

ラムダ関数を追加しようとすると、レキシカルな環境のチェーンを作る必要がある。その場合にHaskellでどう実装したもんかとはたと困った。電卓には代入があるので環境の値が書き換えられる可能性があるので、IORefみたいに書き換えられるデータ型を使う必要があるのか?でも構文木の評価はStateモナドで行っていて、その中でIORefは使えるのか?

ちょっと難しいので、とりあえず後からの書き換えは考えず、たんに環境のチェーンだけを行ってクロージャを作れるようにしてみる。

まずはパーサにラムダ式を追加する。Haskellのラムダ式の形式「\args -> body」で:

factor = lambda <|> try(funcall) <|> primFactor

lambda = do
	lexeme $ char '\\'
	args <- many1 identifier
	lexeme $ string "->"
	e <- expr
	return $ Lambda args e

評価器の変更として、まず環境に親環境を追加:

data Environment = Environment Dictionary (Maybe Environment)

ラムダ式が出てきたときに、関数の生成にその文脈の環境を保持するように渡す:

eval (Lambda args body) = do
	st <- get
	let func = Function args body $ curenv st
	return func

関数呼び出し時は、関数のレキシカル環境を関数への実引数で拡張して本体呼び出し:

call fnode (Function args body env) params =do
	st <- get
	put $ st { curenv = Just (extend args params env) }
	res <- eval body
	put st
	return res

テスト:

> make_adder x = \y -> x + y
<function>
> twice (make_adder 1) 100
102.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(..), emptyDictionary, doAssign, Environment(..))

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) (\exc -> print exc >> 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 (res, st)  = (show res, st)
		parser = stmt >>= \e -> eof >> return e

-- 初期の状態
initialState = IntpState dic Nothing
	where
		dic =
			doAssign "pi"    (DDouble pi) $
			doAssign "true"  (DBool True) $
			doAssign "false" (DBool False) $
			doAssign "sin"   (Native 1 (apply1 sin)) $
			doAssign "cos"   (Native 1 (apply1 cos)) $
			doAssign "tan"   (Native 1 (apply1 tan)) $
			doAssign "log"   (Native 1 (apply1 log)) $
			doAssign "sqrt"  (Native 1 (apply1 sqrt)) $
			emptyDictionary
		apply1 f = \[x] -> f x

main = putStrLn "type ':q' to quit." >> calc initialState >> putStrLn "Bye"
Parser.hs
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 "-" (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 = lambda <|> try(funcall) <|> primFactor

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

primFactor :: MyParser Node
primFactor = (parens expr) <|> floatLiteral <|> varref <?> "factor"

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

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

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

lambda :: MyParser Node
lambda = do
	lexeme $ char '\\'
	args <- many1 identifier
	lexeme $ string "->"
	e <- expr
	return $ Lambda args e
Intp.hs
module Intp (
	intp,
	IntpState(..),
	emptyDictionary,
	doAssign,
	Environment(..),
	Value(..)
) where

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

-- 値
data Value =
		DDouble Double                      -- 直値
	|	DBool Bool                          -- 真偽値
	|	Function [String] Node (Maybe Environment)  -- 関数
	|	Native Int ([Double] -> Double)     -- ネイティブ関数

instance Show Value where
	show (DDouble d)        = show d
	show (DBool True)       = "true"
	show (DBool False)      = "false"
	show (Function _ _ _)   = "<function>"
	show (Native _ _)       = "<native>"

instance Eq Value where
	(DDouble d1) == (DDouble d2)  = d1 == d2
	(DBool   b1) == (DBool   b2)  = b1 == b2
	_           == _              = False

instance Ord Value where
	(DDouble d1) <  (DDouble d2)  = d1 <  d2
	(DBool   b1) <  (DBool   b2)  = b1 <  b2
	(DDouble d1) <= (DDouble d2)  = d1 <= d2
	(DBool   b1) <= (DBool   b2)  = b1 <= b2
	(DDouble d1) >  (DDouble d2)  = d1 >  d2
	(DBool   b1) >  (DBool   b2)  = b1 >  b2
	(DDouble d1) >= (DDouble d2)  = d1 >= d2
	(DBool   b1) >= (DBool   b2)  = b1 >= b2

-- 辞書
type Dictionary = [(String, Value)]

emptyDictionary :: Dictionary
emptyDictionary = []

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

-- 環境
data Environment = Environment Dictionary (Maybe Environment)
	deriving (Show)

-- 最初の値がJustだったらその値、Nothingだったら次の値を返す
orMaybe :: Maybe a -> Maybe a -> Maybe a
Just v  `orMaybe` _     = Just v
Nothing `orMaybe` alter = alter

-- 変数の参照
refvar :: String -> IntpState -> Maybe Value
refvar name st = lookupFromLocal `orMaybe` lookupFromGlobal
	where
		lookupFromLocal  = curenv st >>= search
		lookupFromGlobal = lookup name (global st)
		search (Environment dic parent_env) =
			lookup name dic `orMaybe` (parent_env >>= search)

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

assignCurrentEnv :: String -> Value -> IntpState -> IntpState
assignCurrentEnv name v st =
	case (curenv st) of
		Just (Environment dic parent_env) -> st { curenv = Just (Environment (doAssign name v dic) parent_env) }
		Nothing -> st { global = doAssign name v (global st) }

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


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

false   = DBool False
true    = DBool True
isFalse = (== false)
isTrue  = (/= false)

type MyST a = State IntpState a

eval :: Node -> MyST Value
eval (Literal v)      = return $ DDouble v
eval (Arith op n1 n2) = arith op n1 n2
eval (Ident name) = do
	st <- get
	case (refvar name st) of
		Nothing -> fail $ "undefined variable: " ++ name
		Just v  -> return v
eval (Assign name n) = do
	v <- eval n
	modify $ assignCurrentEnv name v
	return v
eval (If c t e) = do
	v <- eval c
	eval $ if isTrue v then t else e
eval (Funcall fnode params) = do
	fval <- eval fnode
	evaledParams <- evalNodeList params
	call fnode fval evaledParams
eval (Defun name args body) = do
	st <- get
	let func = Function args body $ curenv st
	modify $ assignCurrentEnv name func
	return func
eval (Lambda args body) = do
	st <- get
	let func = Function args body $ curenv st
	return func

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 = evalEq    (==) n1 n2
arith NE      n1 n2 = evalEq    (/=) n1 n2
arith LT      n1 n2 = evalOrd   (<)  n1 n2
arith LE      n1 n2 = evalOrd   (<=) n1 n2
arith GT      n1 n2 = evalOrd   (>)  n1 n2
arith GE      n1 n2 = evalOrd   (>=) n1 n2
arith LogiAnd n1 n2 = evalShortcut isFalse n1 n2
arith LogiOr  n1 n2 = evalShortcut isTrue  n1 n2
arith Negate  n1 n2 = evalArith (-)  n1 n2

evalArith op n1 n2 = do
	v1 <- eval n1
	v2 <- eval n2
	case (v1, v2) of
		(DDouble d1, DDouble d2) -> return $ DDouble $ d1 `op` d2
		_                        -> fail "illegal operation"
evalEq op n1 n2 = do
	v1 <- eval n1
	v2 <- eval n2
	return $ DBool $ v1 `op` v2
evalOrd op n1 n2 = do
	v1 <- eval n1
	v2 <- eval n2
	case (v1, v2) of
		(DDouble _, DDouble _) -> return $ DBool $ v1 `op` v2
		(DBool   _, DBool   _) -> return $ DBool $ v1 `op` v2
		_                      -> fail "illegal operation"
evalShortcut f n1 n2 = do
	v1 <- eval n1
	if f v1 then return v1 else eval n2

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

call :: Node -> Value -> [Value] -> MyST Value
call fnode (Function args body env) params
	| length params /= length args  = fail $ show fnode ++ ": illegal argnum, " ++ show (length params) ++ " for " ++ show (length args)
	| otherwise = do
		st <- get
		put $ st { curenv = Just (extend args params env) }
		res <- eval body
		put st
		return res
	where
		extend args params parent_env = Environment dic parent_env
			where
				dic = foldl (\e (a,p) -> doAssign a p e) emptyDictionary $ zip args params
call fnode (Native argnum f) params
	| length params /= argnum = fail $ show fnode ++ ": illegal argnum, " ++ show (length params) ++ " for " ++ show argnum
	| otherwise = return $ DDouble $ f $ map (\(DDouble v) -> v) params
call fnode v _ = fail $ show fnode ++ " is not function"
  • Haskellの関数の定義や呼び出しの形式は、引数なしの関数が扱えない形になってるんですね。この電卓にrandとかtimeとかを用意しようかと思って愕然とした。
トラックバック - http://haskell.g.hatena.ne.jp/mokehehe/20090805

2009-08-03

電卓で任意の型の値を扱えるようにする

今までは計算の中でDoubleの値しか扱えなかったのを、任意の型を扱えるように変更する。

まずevalで返す値をDouble型から任意の型を表すValue型に変更する:

eval :: Node -> MyST Value

あとはコンパイラが出すエラーに従ってソースを修正していけばOK。Haskellはこの安心感がたまらない。また今まで比較演算子が1.0(真)や0.0(偽)を返していたところをバリアントのBool値を返すように変更する。

false   = DBool False
true    = DBool True

今までは演算ノードのevalはそのまま取り出したDouble値同士で演算すればよかったが、ちゃんと値の型を見て分岐させるように変更する。

ひとつハマったことは、比較演算子で取り出した型の値で演算を行うと型が固定されてしまって別の型に適用できなくなってしまった:

arith LT n1 n2 = evalOrd (<) n1 n2
evalOrd op n1 n2 = do
	v1 <- eval n1
	v2 <- eval n2
	case (v1, v2) of
		-- エラー:opが上の行でDouble型に適用されてしまっているため、下の行のBool型に適用できない
		(DDouble d1, DDouble d1) -> return $ DBool $ d1 `op` d2
		(DBool   b1, DBool   b1) -> return $ DBool $ b1 `op` b2
		_                        -> fail "illegal cmp"

(<)の型が(Ord a)=>a->a->Boolのまま扱われないのが謎だった。Value型をOrd型クラスにして、Value型のまま比較して回避した。Value型は関数も含んでいてderiving句が使えないのでしかたなく手書き。なぜOrdクラスのインスタンスを書くとき、(<)だけを定義すればあとはデフォルトの定義で何とかしてくれないのか?Eqクラスは(==)か(/=)のどちらかを定義すれば大丈夫なのに…。

今までは呼び出し先の関数は常に関数名で参照していたところを、先頭ノードの評価結果の関数に対してapplyするように変更:

eval (Funcall fnode params) = do
	fval <- eval fnode
	evaledParams <- evalNodeList params
	st <- get
	call fnode fval evaledParams

ネイティブ関数の呼び出しは、手抜きで引数はDouble値だと決め付けてしまっている。

true, false を定義。

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) (\exc -> print exc >> 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 (res, st)  = (show res, st)
		parser = stmt >>= \e -> eof >> return e

-- 初期の状態
initialState = IntpState genv
	where
		genv = [
			("pi", DDouble pi),
			("true",  DBool True),
			("false", DBool False),
			("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"
Parser.hs
module Parser (
	Node(..),
	Op(..),
	stmt
) 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 Node [Node]
	|	Defun String [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)

stmt :: MyParser Node
stmt = try(defun) <|> expr

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 "-" (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 = try(funcall) <|> primFactor

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

primFactor :: MyParser Node
primFactor = (parens expr) <|> floatLiteral <|> varref <?> "factor"

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

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

defun :: MyParser Node
defun = do
	name <- identifier
	args <- many1 identifier
	lexeme $ char '='
	e <- expr
	return $ Defun name args e
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 =
		DDouble Double                   -- 直値
	|	DBool Bool                       -- 真偽値
	|	Function [String] Node           -- 関数
	|	Native Int ([Double] -> Double)  -- ネイティブ関数

instance Show Value where
	show (DDouble d)    = show d
	show (DBool True)   = "true"
	show (DBool False)  = "false"
	show (Function _ _) = "<function>"
	show (Native _ _)   = "<native>"

instance Eq Value where
	(DDouble d1) == (DDouble d2)  = d1 == d2
	(DBool   b1) == (DBool   b2)  = b1 == b2
	_           == _              = False

instance Ord Value where
	(DDouble d1) <  (DDouble d2)  = d1 <  d2
	(DBool   b1) <  (DBool   b2)  = b1 <  b2
	(DDouble d1) <= (DDouble d2)  = d1 <= d2
	(DBool   b1) <= (DBool   b2)  = b1 <= b2
	(DDouble d1) >  (DDouble d2)  = d1 >  d2
	(DBool   b1) >  (DBool   b2)  = b1 >  b2
	(DDouble d1) >= (DDouble d2)  = d1 >= d2
	(DBool   b1) >= (DBool   b2)  = b1 >= b2

-- 環境
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 -> (Value, IntpState)
intp node state = runState (eval node) state

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

false   = DBool False
true    = DBool True
isFalse = (== false)
isTrue  = (/= false)

type MyST a = State IntpState a

eval :: Node -> MyST Value
eval (Literal v)      = return $ DDouble 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  -> return v
eval (Assign name n) = do
	v <- eval n
	modify (\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 fnode params) = do
	fval <- eval fnode
	evaledParams <- evalNodeList params
	st <- get
	call fnode fval evaledParams
eval (Defun name args body) = do
	modify (\st -> st { global = doAssign name f (global st) })
	return f
	where f = Function args body

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 = evalEq    (==) n1 n2
arith NE      n1 n2 = evalEq    (/=) n1 n2
arith LT      n1 n2 = evalOrd   (<)  n1 n2
arith LE      n1 n2 = evalOrd   (<=) n1 n2
arith GT      n1 n2 = evalOrd   (>)  n1 n2
arith GE      n1 n2 = evalOrd   (>=) n1 n2
arith LogiAnd n1 n2 = evalShortcut isFalse n1 n2
arith LogiOr  n1 n2 = evalShortcut isTrue  n1 n2
arith Negate  n1 n2 = evalArith (-)  n1 n2

evalArith op n1 n2 = do
	v1 <- eval n1
	v2 <- eval n2
	case (v1, v2) of
		(DDouble d1, DDouble d2) -> return $ DDouble $ d1 `op` d2
		_                        -> fail "illegal operation"
evalEq op n1 n2 = do
	v1 <- eval n1
	v2 <- eval n2
	return $ DBool $ v1 `op` v2
evalOrd op n1 n2 = do
	v1 <- eval n1
	v2 <- eval n2
	case (v1, v2) of
		(DDouble _, DDouble _) -> return $ DBool $ v1 `op` v2
		(DBool   _, DBool   _) -> return $ DBool $ v1 `op` v2
		_                      -> fail "illegal operation"
evalShortcut f n1 n2 = do
	v1 <- eval n1
	if f v1 then return v1 else eval n2

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

call :: Node -> Value -> [Value] -> MyST Value
call fnode (Function args body) params
	| length params /= length args  = fail $ show fnode ++ ": illegal argnum, " ++ show (length params) ++ " for " ++ show (length args)
	| otherwise = do
		st <- get
		put $ st { global = override args params (global st) }
		res <- eval body
		put st
		return res
	where
		override args params env =
			foldl (\e (a,p) -> doAssign a p e) env $ zip args params
call fnode (Native argnum f) params
	| length params /= argnum = fail $ show fnode ++ ": illegal argnum, " ++ show (length params) ++ " for " ++ show argnum
	| otherwise = return $ DDouble $ f $ map (\(DDouble v) -> v) params
call fnode v _ = fail $ show fnode ++ " is not function"
トラックバック - http://haskell.g.hatena.ne.jp/mokehehe/20090803

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
module Parser (
	Node(..),
	Op(..),
	stmt
) 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]
	|	Defun String [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)

stmt :: MyParser Node
stmt = try(defun) <|> expr

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

defun :: MyParser Node
defun = do
	name <- identifier
	args <- many1 identifier
	lexeme $ char '='
	e <- expr
	return $ Defun name args e
  • 関数定義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, ()) )
トラックバック - http://haskell.g.hatena.ne.jp/mokehehe/20090802

2009-07-31

比較演算子、論理演算子、三項演算子を追加する

条件分岐ができるように比較演算子などを追加する。

真偽値型を用意して比較結果はtrue/falseを返すようにしたほうがいいんだけど、型を追加して煩雑になる手間を考えるとDouble型だけの簡便さには勝てない。0.0をfalse、それ以外をtrueとする。

比較演算子の次に論理積と論理和を追加、これで一応条件分岐っぽいことができる

cond && then || else

ある程度は使える…けどthenが0だとelseが返ってしまうので完全に代替はできない。なので三項演算子「cond ? then : else」も追加する。変更点は

+ condExpr :: MyParser Double
+ condExpr = try(cond) <|> expr'
+ 	where
+ 		cond = do
+ 			c <- expr'
+ 			lexeme $ char '?'
+ 			t <- expr
+ 			lexeme $ char ':'
+ 			e <- expr
+ 			return $ if isTrue c then t else e

  expr' :: MyParser Double
  expr' = buildExpressionParser table factor <?> "expression"
  	where
  		table = [
  			[unary "-" negate, unary "+" id],
  			[op "**" (**) AssocRight],
  			[op "*" (*) AssocLeft, op "/" (/) AssocLeft],
  			[op "+" (+) AssocLeft, op "-" (-) AssocLeft],
+ 			[op "==" (cmp (==)) AssocNone, op "/=" (cmp (/=)) AssocNone, op "<" (cmp (<)) AssocNone, op "<=" (cmp (<=)) AssocNone, op ">" (cmp (>)) AssocLeft, op ">=" (cmp (>=)) AssocNone],
+ 			[op "&&" (logiand) AssocLeft],
+ 			[op "||" (logior) AssocLeft]
  			]
  		op s f assoc = Infix (do{ reservedOp s; return f } <?> "operator") assoc
  		unary s f = Prefix (do{ reservedOp s; return f })
+ 		cmp op x y = if x `op` y then true else false
+ 		logiand x y = if isFalse x then x else y
+ 		logior  x y = if isTrue  x then x else y

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

全ソース:

import Text.ParserCombinators.Parsec
import Text.ParserCombinators.Parsec.Expr
import qualified Text.ParserCombinators.Parsec.Token as P
import Text.ParserCombinators.Parsec.Language
import Control.Monad (when)
import System.IO

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

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

-- パーサの状態
data MyParserState =
	MyParserState {
		global :: Environment
		}
	deriving (Show)

-- パーサ型
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

expr = assignExpr

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

			updateState $ \st -> st{ global = doAssign var e (global st) }
			return e

condExpr :: MyParser Double
condExpr = try(cond) <|> expr'
	where
		cond = do
			c <- expr'
			lexeme $ char '?'
			t <- expr
			lexeme $ char ':'
			e <- expr
			return $ if isTrue c then t else e

expr' :: MyParser Double
expr' = buildExpressionParser table factor <?> "expression"
	where
		table = [
			[unary "-" negate, unary "+" id],
			[op "**" (**) AssocRight],
			[op "*" (*) AssocLeft, op "/" (/) AssocLeft],
			[op "+" (+) AssocLeft, op "-" (-) AssocLeft],
			[op "==" (cmp (==)) AssocNone, op "/=" (cmp (/=)) AssocNone, op "<" (cmp (<)) AssocNone, op "<=" (cmp (<=)) AssocNone, op ">" (cmp (>)) AssocLeft, op ">=" (cmp (>=)) AssocNone],
			[op "&&" (logiand) AssocLeft],
			[op "||" (logior) AssocLeft]
			]
		op s f assoc = Infix (do{ reservedOp s; return f } <?> "operator") assoc
		unary s f = Prefix (do{ reservedOp s; return f })
		cmp op x y = if x `op` y then true else false
		logiand x y = if isFalse x then x else y
		logior  x y = if isTrue  x then x else y

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

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

parenedExpr :: MyParser Double
parenedExpr = parens expr

floatLiteral :: MyParser Double
floatLiteral = do
	norf <- naturalOrFloat
	case norf of
		Left i	-> return $ fromInteger i
		Right f	-> return $ f

funcallOrVarref :: MyParser Double
funcallOrVarref = do
	name <- identifier
	do {
		params <- lexeme formalparams;
		case (applyFunc name params) of
			Right v		-> return v
			Left err	-> fail err
	} <|> do
		st <- getState;
		case lookup name (global st) of
			Nothing	-> fail $ "undefined variable: " ++ name
			Just v	-> return v

formalparams :: MyParser [Double]
formalparams = do
	lexeme $ char '('
	params <- expr `sepBy` lexeme (char ',')
	char ')'
	return params

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

repl :: String -> (String -> Bool) -> (String -> st -> (String, st)) -> st -> IO st
repl prompt bQuit eval = loop
	where
		loop st = putStr prompt >> getLine >>= act st
		act st s
			| bQuit s = return st
			| otherwise = do
				let (res, st') = eval s st
				putStrLn res
				loop st'

calc :: MyParserState -> IO MyParserState
calc = repl "> " (== ":q") eval
	where
		eval line st = do
			case (runParser stmt st "" line) of
				Left err       -> (show err, st)
				Right (v, st') -> (show v, st')
		stmt = do
			e <- expr
			eof
			st <- getState
			return (e, st)

-- 初期のパーサの状態
initialState = MyParserState genv
	where
		genv = [
			("pi",	pi)
			]

main = hSetBuffering stdout NoBuffering >> putStrLn "type ':q' to quit." >> calc initialState >>= print >> putStrLn "Bye"

変数への代入を追加する

電卓に変数への代入と参照を追加する。そのためには、パーサに状態を持たせてやる。

import Text.ParserCombinators.Parsec
import Text.ParserCombinators.Parsec.Expr
import qualified Text.ParserCombinators.Parsec.Token as P
import Text.ParserCombinators.Parsec.Language
import Control.Monad (when)
import System.IO

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

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

-- パーサの状態
data MyParserState =
	MyParserState {
		global :: Environment
		}
	deriving (Show)

-- パーサ型
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

expr = assignExpr

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

			updateState $ \st -> st{ global = doAssign var e (global st) }
			return e

expr' :: MyParser Double
expr' = buildExpressionParser table factor <?> "expression"
	where
		table = [
			[unary "-" negate, unary "+" id],
			[op "**" (**) AssocRight],
			[op "*" (*) AssocLeft, op "/" (/) AssocLeft],
			[op "+" (+) AssocLeft, op "-" (-) AssocLeft]
			]
		op s f assoc = Infix (do{ reservedOp s; return f } <?> "operator") assoc
		unary s f = Prefix (do{ reservedOp s; return f })

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

parenedExpr :: MyParser Double
parenedExpr = parens expr

floatLiteral :: MyParser Double
floatLiteral = do
	norf <- naturalOrFloat
	case norf of
		Left i	-> return $ fromInteger i
		Right f	-> return $ f

funcallOrVarref :: MyParser Double
funcallOrVarref = do
	name <- identifier
	do {
		params <- lexeme formalparams;
		case (applyFunc name params) of
			Right v		-> return v
			Left err	-> fail err
	} <|> do
		st <- getState;
		case lookup name (global st) of
			Nothing	-> fail $ "undefined variable: " ++ name
			Just v	-> return v

formalparams :: MyParser [Double]
formalparams = do
	lexeme $ char '('
	params <- expr `sepBy` lexeme (char ',')
	char ')'
	return params

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

repl :: String -> (String -> Bool) -> (String -> st -> (String, st)) -> st -> IO st
repl prompt bQuit eval = loop
	where
		loop st = putStr prompt >> getLine >>= act st
		act st s
			| bQuit s = return st
			| otherwise = do
				let (res, st') = eval s st
				putStrLn res
				loop st'

calc :: MyParserState -> IO MyParserState
calc = repl "> " (== ":q") eval
	where
		eval line st = do
			case (runParser stmt st "" line) of
				Left err       -> (show err, st)
				Right (v, st') -> (show v, st')
		stmt = do
			e <- expr
			eof
			st <- getState
			return (e, st)

-- 初期のパーサの状態
initialState = MyParserState genv
	where
		genv = [
			("pi",	pi)
			]

main = hSetBuffering stdout NoBuffering >> putStrLn "type ':q' to quit." >> calc initialState >>= print >> putStrLn "Bye"
  • パーサに状態を持たせるのは パーサの状態 - imHo(昔の自分)を参考に、今までは Parser を使ってたところを「type MyParser a = GenParser Char MyParserState a」と置いた MyParser を使うように変更
  • 代入はパーサの状態を変更する必要があり buildExpressionParser には含められない?ので assignExpr というパーサを追加
  • 代入演算子じゃなかった場合にリトライさせるために try を使う
  • 関数への実引数のパースを行う formalparams は sepBy を使うと簡単に書けた
  • 変数の値を保持する環境は簡単のため連想リストに入れてみたけど、ハッシュみたいなものがあったらそっちにしたほうがいいかも
  • 1行パースして次の行をパースするときに状態を引き継ぐ必要があるので、repl に少し手を入れた

組み込み関数の追加

組み込み関数(sin, cos, tan, log, sqrt)を追加して呼び出せるようにする。

import Text.ParserCombinators.Parsec
import Text.ParserCombinators.Parsec.Expr
import qualified Text.ParserCombinators.Parsec.Token as P
import Text.ParserCombinators.Parsec.Language
import Control.Monad (when)
import System.IO

lexer :: P.TokenParser ()
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

expr :: Parser Double
expr = buildExpressionParser table factor <?> "expression"
	where
		table = [
			[unary "-" negate, unary "+" id],
			[op "**" (**) AssocRight],
			[op "*" (*) AssocLeft, op "/" (/) AssocLeft],
			[op "+" (+) AssocLeft, op "-" (-) AssocLeft]
			]
		op s f assoc = Infix (do{ reservedOp s; return f } <?> "operator") assoc
		unary s f = Prefix (do{ reservedOp s; return f })

factor :: Parser Double
factor =
	do {
		parens expr;
	} <|> do {
		norf <- naturalOrFloat;
		case norf of
			Left i	-> return $ fromInteger i
			Right f	-> return $ f
	} <|>
		funcall
	<?>
		"factor"

funcall :: Parser Double
funcall =
	do {
		fname <- identifier;
		params <- lexeme formalparams;
		case (applyFunc fname params) of
			Right v		-> return v
			Left err	-> fail err
	}

formalparams :: Parser [Double]
formalparams = lexeme (char '(') >> params False
	where
		params bComma =
			do {
				char ')';
				return [];
			} <|> do {
				when bComma $ lexeme (char ',') >> return ();
				e <- expr;
				r <- params True;
				return $ e : r; 
			}

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

repl :: String -> (String -> Bool) -> (String -> String) -> IO ()
repl prompt bQuit eval = loop
	where
		loop = do
			putStr prompt
			s <- getLine
			if bQuit s
				then return ()
				else putStrLn (eval s) >> loop

calc :: IO ()
calc = repl "> " (== ":q") (tostring . parse stmt "")
	where
		tostring (Right v)	= show v
		tostring (Left err)	= show err
		stmt = do
			e <- expr
			eof
			return e

main = hSetBuffering stdout NoBuffering >> putStrLn "type ':q' to quit." >> calc >> putStrLn "Bye"
  • 因子に関数呼び出しを追加
  • lexemeで、空白破棄つきパーサを作れる
  • 関数は固定のテーブルになっていて後から追加できないのをなんとかしたい
トラックバック - http://haskell.g.hatena.ne.jp/mokehehe/20090731

2009-07-30

Parsecを使った電卓

Parsecを使って四則演算ができる簡単な電卓を作る。

import Text.ParserCombinators.Parsec
import Text.ParserCombinators.Parsec.Expr
import qualified Text.ParserCombinators.Parsec.Token as P
import Text.ParserCombinators.Parsec.Language
import System.IO

lexer :: P.TokenParser ()
lexer = P.makeTokenParser (haskellDef { reservedOpNames = ["*","/","+","-","**"] })

naturalOrFloat = P.naturalOrFloat lexer
parens         = P.parens lexer
reservedOp     = P.reservedOp lexer

expr :: Parser Double
expr = buildExpressionParser table factor <?> "expression"
	where
		table = [
			[unary "-" negate, unary "+" id],
			[op "**" (**) AssocRight],
			[op "*" (*) AssocLeft, op "/" (/) AssocLeft],
			[op "+" (+) AssocLeft, op "-" (-) AssocLeft]
			]
		op s f assoc = Infix (do{ reservedOp s; return f } <?> "operator") assoc
		unary s f = Prefix (do{ reservedOp s; return f })

factor :: Parser Double
factor =
	do {
		parens expr;
	} <|> do {
		norf <- naturalOrFloat;
		case norf of
			Left i	-> return $ fromInteger i
			Right f	-> return $ f
	} <?>
		"factor"

repl :: String -> (String -> Bool) -> (String -> String) -> IO ()
repl prompt bQuit eval = loop
	where
		loop = do
			putStr prompt
			s <- getLine
			if bQuit s
				then return ()
				else putStrLn (eval s) >> loop

calc :: IO ()
calc = repl "> " (== ":q") (tostring . parse stmt "")
	where
		tostring (Right v)	= show v
		tostring (Left err)	= show err
		stmt = do
			e <- expr
			eof
			return e

main = hSetBuffering stdout NoBuffering >> putStrLn "type ':q' to quit." >> calc >> putStrLn "Bye"
  • makeTokenParserで作れるlexerである程度簡単にトークンをパースできる
  • buildExpressionParserを使うと、優先度順にテーブルを作るだけで演算子の計算のパーサが簡単に作れる
  • hSetBuffering stdout NoBuffering」でプロンプトの表示をさせるようにする
トラックバック - http://haskell.g.hatena.ne.jp/mokehehe/20090730