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: 構文木を生成するパーサ
n
  • パーサの状態はひとまず必要なくなったのでユニット型に
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