Hatena::Grouphaskell

mokeheheの日記

2009-08-02

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

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