Hatena::Grouphaskell

mokeheheの日記

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