今回は簡単な電卓プログラムを例題にして「モナディック・パーサ (Monadic Parser)」について説明します。モナディック・パーサ (または関数型パーサ) は、基本となる小さなパーサを複数用意しておいて、それらを組み合わせることで目的のパーサを作成します。Haskell の場合は「モナド」を使ってパーサを組み合わせるので、モナディック・パーサと呼ばれています。
今まで作成した電卓プログラムでおわかりのように、パーサは入力データを受け取り、値と残りのデータを返します。したがって、パーサのデータ型は次のように表すことができます。
data Parser s a = Parser {runParser :: s -> (a, s)}
これは State モナドで表すことができます。モナディック・パーサはこれだけではなく、「失敗したら次のパーサを試す」という選択処理もモナドで行うようにします。これは State モナドと失敗系のモナド (Maybe, Either, List など) を合成し、MonadPlus の mplus を使って実現することができます。たとえば、リストを使う場合は次のように定義できます。
type Parser s a = StateT [s] [] a runParser = runStateT
Parser の入力データはリストで、s はリストの要素のデータ型を表します。もちろん、Maybe や Either を使ってもかまいませんが、リストと動作が異なる場合があります。これはあとで説明します。
それでは、基本的なパーサを作っていきましょう。先頭のデータを取り出す (無条件にマッチする) パーサ item は次のようになります。
リスト : 先頭のデータを取り出す
item :: Parser s s
item = get >>= \ys ->
case ys of
[] -> mzero
(x:xs) -> put xs >> return x
前回作成した電卓プログラムの関数 item にエラー処理を追加したものです。get でリストを取り出して、先頭要素を取り除いたリスト xs を put で書き込み、先頭要素 x をモナドに包んで返します。パーサにおいて return は成功を表すことに注意してください。
簡単な実行例を示します。
*Main> runParser item "abcde"
[('a',"bcde")]
*Main> runParser item ""
[]
*Main> runParser item ["ab", "cd", "ef"]
[("ab",["cd","ef"])]
*Main> runParser item [123, 456, 789]
[(123,[456,789])]
入力データが空リストの場合、リストの mzero の値 (空リスト) を返します。失敗を表す値が MonadPlus の mzero であることに注意してください。
item を使って 2 つのデータとマッチするパーサを作ることができます。
リスト : 二つの要素とマッチするパーサ
item2 :: Parser s [s]
item2 = do a <- item
b <- item
return [a, b]
item2 のデータ型で値が [s] となっていることに注意してください。あとは簡単で、モナドを使ってパーサ item を連結するだけです。item が失敗した場合、残りの処理は実行されずに空リストが返されます。
それでは実行してみましょう。
*Main> runParser item2 "abcde"
[("ab","cde")]
*Main> runParser item2 "a"
[]
*Main> runParser item2 ""
[]
*Main> runParser item2 [123, 456, 789]
[([123,456],[789])]
このように、リストの要素数が一つ以下の場合、item2 は失敗します。
次は述語 p を引数に受け取り、先頭要素 x が p を満たしていれば x を返し、そうでなければ失敗するパーサ sat (satisfy) を作ります。
リスト : 述語 p を満たす要素とマッチするパーサ
failure :: Parser s a
failure = mzero
sat :: (s -> Bool) -> Parser s s
sat p = do x <- item
if p x then return x else failure
item で要素 x を取り出し、p x が真ならば x をモナドに包んで返し、そうでなければ失敗 failure を返します。failure は mzero で表します。
簡単な実行例を示します。
*Main> runParser (sat (=='a')) "abcde"
[('a',"bcde")]
*Main> runParser (sat (=='b')) "abcde"
[]
*Main> runParser (sat isDigit) "12345"
[('1',"2345")]
*Main> runParser (sat isDigit) "abcde"
[]
*Main> runParser (sat (==123)) [123, 456, 789]
[(123,[456,789])]
*Main> runParser (sat (/=123)) [123, 456, 789]
[]
次は、パーサが失敗したら次のパーサを試す選択処理を作りましょう。選択は記号 +++ で表すことにします。
リスト : 選択 (+++) :: Parser s a -> Parser s a -> Parser s a (+++) = mplus
選択は mplus で実現できます。簡単な実行例を示しましょう。
*Main> runParser (sat (=='a') +++ sat (=='A')) "abcde"
[('a',"bcde")]
*Main> runParser (sat (=='a') +++ sat (=='A')) "Abcde"
[('A',"bcde")]
*Main> runParser (sat (=='a') +++ sat (=='A')) "zbcde"
[]
ここで StateT と合成するモナドがリストと Maybe, Either では、選択の動作が異なることに注意してください。リストの場合、左右のパーサがどちらも成功すると、それらの結果をリストに格納して返します。
簡単な例を示します。
*Main> runParser (sat isDigit +++ sat isAlphaNum) "abcde"
[('a',"bcde")]
*Main> runParser (sat isDigit +++ sat isAlphaNum) "12345"
[('1',"2345"),('1',"2345")]
左辺の条件は isDigit で右辺の条件が isAlphaNum です。先頭のデータが数字であれば左右どちらのパーサも成功するので、その結果がリストに格納されて返されます。Maybe, Either の場合、mplus は論理和と同様の動作になるので、左辺のパーサが成功すれば、右辺のパーサは実行されません。
次はパーサ p を繰り返し適用し、マッチしたデータをリストに格納して返すパーサ many, many1 を作ります。
リスト : 繰り返し
-- 0 回以上
many :: Parser s a -> Parser s [a]
many p = many1 p +++ return []
-- 1 回以上
many1 :: Parser s a -> Parser s [a]
many1 p = do x <- p
xs <- many p
return (x:xs)
many は 0 回以上の繰り返しを、many1 は 1 回以上の繰り返しを表します。正規表現でいうと、* と + に対応します。many は many1 を呼び出して 1 回以上の繰り返しを試し、失敗した場合は空リストをモナドに包んで返します。many1 はパーサ p を実行し、成功した場合は many p を呼び出します。これで 1 回以上の繰り返しを表すことができます。
それでは実行してみましょう。
*Main> runParser (many (sat isDigit)) "12 ab"
[("12"," ab"),("1","2 ab"),("","12 ab")]
*Main> runParser (many1 (sat isDigit)) "12 ab"
[("12"," ab"),("1","2 ab")]
StateT にリストを合成した場合、many, many1 はパーサ p が成功するすべてのパターンをリストに格納して返します。many (sat isDigit) で数字を求める場合、"12 ab" は "12", "1". "" の 3 通りがリストに格納されます。many1 の場合、"" は含まれません。なお、Maybe, Either を合成した場合、最長一致した結果が返されます。つまり、入力データが "12 ab" であれば "12" だけが返されます。
次は整数とマッチするパーサを作ってみましょう。
リスト : 整数とマッチするパーサ number :: Parser Char Integer number = do xs <- many1 $ sat isDigit return (read xs)
number は many1 $ sat isDigit で数字 (0 - 9) が連続している文字列を取り出し、それを read で変換してモナドに包んで返します。
簡単な実行例を示します。
*Main> runParser number "12345 67890" [(12345," 67890"),(1234,"5 67890"),(123,"45 67890"),(12,"345 67890"),(1,"2345 67890")]
整数値を求める場合は最長一致した文字列だけで十分なので、これ以降は Parser の定義を次のように変更します。
type Parser s a = StateT [s] Maybe a
実行結果は次のようになります。
*Main> runParser number "12345 67890" Just (12345," 67890")
空白文字で区切られた複数の整数を取り出すことも簡単です。次のリストを見てください。
リスト : 複数の整数とマッチするパーサ
spaces :: Parser Char String
spaces = many $ sat isSpace
token :: Parser Char a -> Parser Char a
token p = do a <- p
spaces
return a
numbers :: Parser Char [Integer]
numbers = many1 $ token $ number
spaces は連続した空白文字とマッチするパーサです。token は引数のパーサ p を実行し、そのあと spaces を実行して空白文字を取り除きます。numbers は token $ number を many1 で繰り返し評価するだけです。これで複数の整数値を取り出すことができます。
それでは実行してみましょう。
*Main> runParser numbers "123 456 789"
Just ([123,456,789],"")
*Main> runParser numbers "123 456 789 "
Just ([123,456,789],"")
*Main> runParser (do {spaces; numbers}) " 123 456 789 "
Just ([123,456,789],"")
先頭の空白文字を取り除く場合は numbers の前に spaces を実行してください。
次は整数の四則演算 (+, -, *, /) を行う処理を作ってみましょう。単項演算子 (+, -) とカッコも使用できることにします。
因子の処理は次のようになります。
リスト : 因子の処理
number :: Parser Char Integer
number = do
xs <- token $ many1 $ sat isDigit
return (read xs)
factor :: Parser Char Integer
factor = number
+++ do token $ sat ('('==)
n <- expr
token $ sat (')'==)
return n
+++ do token $ sat ('-'==)
n <- factor
return (- n)
+++ do token $ sat ('+'==)
n <- factor
return n
number は token を呼び出して整数を取り出したあと空白文字を削除するように修正します。factor は、最初に number で整数とマッチするか試します。失敗した場合は次のパーサを試します。先頭の文字が '(' であれば、式を処理する expr を呼び出し、次の文字が ')' であることを確認します。成功すれば整数 n をモナドに包んで返します。先頭の文字が '-', '+' の場合は単項演算子の処理を行います。factor を呼び出して値 n を求め、所定の処理を行ってモナドに包んで返します。
次は演算子とマッチするパーサを作ります。
リスト : 演算子とマッチするパーサ
add, sub, mul, div' :: Parser Char (Integer -> Integer -> Integer)
add = do token $ sat (=='+')
return (+)
sub = do token $ sat (=='-')
return (-)
mul = do token $ sat (=='*')
return (*)
div' = do token $ sat (=='/')
return div
add が演算子 + に、sub が演算子 - に、mul が演算子 * に、div' が演算子 / に対応します。
最後に項と式を処理する関数 term と expr を作ります。
リスト : 項と式の処理
rep :: Parser Char Integer -> Parser Char (Integer -> Integer -> Integer) -> Parser Char Integer
rep p q = do
v <- p
rep_sub v
where
rep_sub v = do {op <- q; v' <- p; rep_sub (op v v')} +++ return v
term :: Parser Char Integer
term = factor `rep` (mul +++ div')
expr :: Parser Char Integer
expr = term `rep` (add +++ sub)
rep はパーサ p, q を受け取り、rep_sub で q がマッチする場合は p を繰り返し呼び出して演算処理を行います。q がマッチしない場合は、引数 v をモナドに包んで返します。term は factor と (mul +++ 'div) を rep に渡して呼び出します。expr は term と (add +++ sub) を rep に渡して呼び出します。これで数式を計算することができます。
それでは実行してみましょう。式の終わりにはセミコロンを入力するものとします。
*Main> runParser expr "1 + 2 * 3 - 4;" Just (3,";") *Main> runParser expr "(1 + 2) * (3 - 4);" Just (-3,";") *Main> runParser expr "(1 + -2) * (3 - 4);" Just (1,";") *Main> runParser expr "(-1 + -2) * (3 - 4);" Just (3,";") *Main> runParser expr "* 3;" Nothing *Main> runParser expr "/ 3;" Nothing *Main> runParser expr "(1 + 2;" Nothing *Main> runParser expr "1 + 2);" Just (3,");") *Main> runParser expr "();" Nothing
次はこの電卓プログラムにエラー処理を追加してみましょう。モナディック・パーサの場合、選択処理に MonadPlus を利用しているので、StateT に Either モナドを合成しても、適切なエラーメッセージを表示することはできません。次のリストを見てください。
リスト : エラー処理の追加
-- パーサの定義
type Parser s a = StateT [s] (Either String) a
runParser = runStateT
-- エラー
parseErr :: String -> Parser s a
parseErr s = lift(Left s)
-- 因子
factor :: Parser Char Integer
factor = number
+++ do token $ sat ('('==)
n <- expr
x <- token $ item
case x of
')' -> return n
_ -> parseErr "')' expected"
+++ do token $ sat ('-'==)
n <- factor
return (- n)
+++ do token $ sat ('+'==)
n <- factor
return n
+++ do x <- item
parseErr ("unexpected token: " ++ show x)
左カッコに対応する右カッコが存在しない場合、エラーメッセージ "')' expected" を表示しようとして parseErr を実行します。この場合、返り値はパーサが失敗したときと同じデータ型になるので、次のパーサを試すことになります。けっきょく、最後のパーサが実行されて、関係のないエラーメッセージが表示されることになります。
実際に試してみると次のようになります。
*Main> runParser expr "(1 + 2;"
Left "unexpected token: '('"
"')' expected" と表示されずに、最後の節のエラーが表示されていることがわかります。そこで、Either モナドのかわりに、パーサの結果を格納するためのデータ型を定義し、それをモナドのインスタンスに設定することにします。次のリストを見てください。
リスト : パーサの結果を格納する -- データ型の定義 data Parse a = Fail | Err String | Some a deriving Show -- モナドのインスタンスに設定 instance Monad Parse where return x = Some x Fail >>= _ = Fail Err s >>= _ = Err s Some a >>= k = k a instance MonadPlus Parse where mzero = Fail Fail `mplus` ys = ys xs `mplus` _ = xs -- パーサの定義 type Parser s a = StateT [s] Parse a runParser = runStateT -- エラー parseErr :: String -> Parser s a parseErr s = StateT $ \_ -> Err s
データ型 Parse a は、パーサの失敗を Fail で、致命的なエラーを Err String で、パースした結果を Some a で表します。モナドの設定は簡単です。return x は Some x を返します。バインド演算子は、左辺が Fail, Err s の場合は、Fail, Err s を返します。Some a の場合は、a を右辺の関数に渡して評価するだけです。fail s は Err s ではなく Fail を返すことに注意してください。
MonadPlus も簡単で、mzero は Fail を返します。mplus は左辺が File の場合は右辺 ys を返します。それ以外の場合は右辺 xs を返します。これで左辺が Err のときは右辺を評価せずに Err を返すことができます。parseErr は throwError を使わないで、文字列 s を Err に格納して、ラムダ式で包んで返します。これでエラーを返すことができます。
このほかにも、Functor, Applicative, Alternative の設定が必要になります。プログラムは簡単なので説明は割愛します。詳細は プログラムリスト１ をお読みください。
それでは実行してみましょう。
*Main> runParser expr "(1 + 2;" Err "')' expected" *Main> runParser expr "(1 + *2;" Err "unexpected token : '*'" *Main> runParser expr "1 + *2;" Err "unexpected token : '*'"
きちんとエラーメッセージが表示されていますね。ご参考までに、電卓プログラム (3) で作成したプログラムを、モナディック・パーサを使って書き直してみました。興味のある方は プログラムリスト２ をお読みください。
今回は新しいデータ型を作成してエラーを処理しましたが、Haskell にはもっとクールな方法があるのかもしれませんね。実際には、Persec を使ったほうが簡単にプログラムできると思います。興味のある方は Parsec に挑戦してみてください。
--
-- mparser.hs : モナディック・パーサ
--
-- Copyright (C) 2013-2021 Makoto Hiroi
--
import Control.Monad.State
import Data.Char
import GHC.Base hiding (many)
-- パーサの結果を格納する
data Parse a = Fail | Err String | Some a deriving Show
instance Functor Parse where
fmap f Fail = Fail
fmap f (Err s) = Err s
fmap f (Some a) = Some (f a)
instance Applicative Parse where
pure x = Some x
Fail <*> _ = Fail
(Err s) <*> _ = Err s
(Some f) <*> x = fmap f x
instance Monad Parse where
return x = Some x
Fail >>= _ = Fail
Err s >>= _ = Err s
Some a >>= k = k a
instance Alternative Parse where
empty = Fail
Fail <|> r = r
l <|> _ = l
instance MonadPlus Parse where
mzero = Fail
Fail `mplus` ys = ys
xs `mplus` _ = xs
-- パーサの定義
type Parser s a = StateT [s] Parse a
runParser = runStateT
-- エラー
parseErr :: String -> Parser s a
parseErr s = StateT $ \_ -> Err s
-- 失敗
failure :: Parser s a
failure = mzero
--
item :: Parser s s
item = get >>= \ys ->
case ys of
[] -> mzero
(x:xs) -> put xs >> return x
--
item2 :: Parser s [s]
item2 = do a <- item
b <- item
return [a, b]
--
sat :: (s -> Bool) -> Parser s s
sat p = do x <- item
if p x then return x else failure
-- 選択
(+++) :: Parser s a -> Parser s a -> Parser s a
(+++) = mplus
-- 繰り返し
-- 0 回以上
many :: Parser s a -> Parser s [a]
many p = many1 p +++ return []
-- 1 回以上
many1 :: Parser t a -> Parser t [a]
many1 p = do x <- p
xs <- many p
return (x:xs)
-- 空白の除去
spaces :: Parser Char String
spaces = many $ sat isSpace
token :: Parser Char a -> Parser Char a
token p = do a <- p
spaces
return a
-- 整数
number :: Parser Char Integer
number = do
xs <- token $ many1 $ sat isDigit
return (read xs)
numbers :: Parser Char [Integer]
numbers = many1 $ token $ number
-- 四則演算
add, sub, mul, div' :: Parser Char (Integer -> Integer -> Integer)
add = do token $ sat (=='+')
return (+)
sub = do token $ sat (=='-')
return (-)
mul = do token $ sat (=='*')
return (*)
div' = do token $ sat (=='/')
return div
rep :: Parser Char Integer -> Parser Char (Integer -> Integer -> Integer) -> Parser Char Integer
rep p q = do
v <- p
rep_sub v
where
rep_sub v = do {op <- q; v' <- p; rep_sub (op v v')} +++ return v
-- 因子
factor :: Parser Char Integer
factor = number
+++ do token $ sat ('('==)
n <- expr
x <- token $ item
case x of
')' -> return n
_ -> parseErr "')' expected"
+++ do token $ sat ('-'==)
n <- factor
return (- n)
+++ do token $ sat ('+'==)
n <- factor
return n
+++ do x <- item
parseErr ("unexpected token : " ++ show x)
-- 項
term :: Parser Char Integer
term = factor `rep` (mul +++ div')
-- 式
expr :: Parser Char Integer
expr = term `rep` (add +++ sub)
--
-- calc3.hs : 電卓プログラム
-- (モナディック・パーサを使った場合)
--
-- Copyright (C) 2013-2021 Makoto Hiroi
--
import Data.Char
import Control.Monad.State
import System.IO
import GHC.Base hiding (many)
-- 値
data Value = INT Integer | REAL Double deriving (Show, Eq)
-- トークンの定義
data Token = Number Value -- 数値
| Ident String -- 識別子
| Add | Sub | Mul | Div -- 演算子
| Assign -- 代入演算子
| Lpar | Rpar -- カッコ
| Semic -- セミコロン
| Comma -- カンマ
| Eof -- ファイルの終了
| Others Char -- その他
deriving (Show, Eq)
-- 組み込み関数の定義
data Func = F1 (Value -> Calc Env Value)
| F2 (Value -> Value -> Calc Env Value)
-- 構文木の定義
data Expr = Num Value
| Var String
| Op1 (Value -> Value) Expr
| Op2 (Value -> Value -> Value) Expr Expr
| Agn Expr Expr
| App Func [Expr]
-- 結果を格納する
data Parse a = Fail | Err String | Some a deriving Show
instance Functor Parse where
fmap f Fail = Fail
fmap f (Err s) = Err s
fmap f (Some a) = Some (f a)
instance Applicative Parse where
pure x = Some x
Fail <*> _ = Fail
(Err s) <*> _ = Err s
(Some f) <*> x = fmap f x
instance Monad Parse where
return x = Some x
Fail >>= _ = Fail
Err s >>= _ = Err s
Some a >>= k = k a
instance Alternative Parse where
empty = Fail
Fail <|> r = r
l <|> _ = l
instance MonadPlus Parse where
mzero = Fail
Fail `mplus` ys = ys
xs `mplus` _ = xs
-- 型の定義
type Lexer = (Token, String)
type Env = [(String, Value)]
type Calc s a = StateT s Parse a
-- データを取り出す
item :: Calc [a] a
item = get >>= \ys ->
case ys of
[] -> mzero
(x:xs) -> put xs >> return x
-- 先頭データを参照する
lookahead :: Calc [a] a
lookahead = get >>= \ys ->
case ys of
[] -> mzero
(x:_) -> return x
--
failure :: Calc s a
failure = mzero
--
sat :: (a -> Bool) -> Calc [a] a
sat p = do x <- item
if p x then return x else failure
-- 選択
(+++) :: Calc s a -> Calc s a -> Calc s a
(+++) = mplus
-- エラー
calcError :: String -> Calc s a
calcError msg = StateT $ \_ -> Err msg
-- 組み込み関数の呼び出し
toREAL :: Value -> Double
toREAL (INT x) = fromIntegral x
toREAL (REAL x) = x
callf1 :: (Double -> Double) -> Value -> Calc Env Value
callf1 f v = return $ REAL (f (toREAL v))
callf2 :: (Double -> Double -> Double) -> Value -> Value -> Calc Env Value
callf2 f v1 v2 = return $ REAL (f (toREAL v1) (toREAL v2))
callfri1 :: (Double -> Integer) -> Value -> Calc Env Value
callfri1 f v = return $ INT (f (toREAL v))
callfii1 :: (Integer -> Integer) -> Value -> Calc Env Value
callfii1 f (INT n) = return $ INT (f n)
callfii1 _ _ = calcError "Args is not Integer"
callfii2 :: (Integer -> Integer -> Integer) -> Value -> Value -> Calc Env Value
callfii2 f (INT n) (INT m) = return $ INT (f n m)
callfii2 _ _ _ = calcError "Args is not Integer"
-- 階乗
fact :: Integer -> Integer
fact n = if n < 0 then 0
else if n == 0 then 1
else n * fact (n - 1)
-- 組み合わせの数
comb :: Integer -> Integer -> Integer
comb n r =
if n < r || r < 0 then 0
else if n == r || r == 0 then 1
else comb n (r - 1) * (n - r + 1) `div` r
-- 関数の定義
funcTable :: [(String, Func)]
funcTable = [("sqrt", F1 (callf1 sqrt)),
("sin", F1 (callf1 sin)),
("cos", F1 (callf1 cos)),
("tan", F1 (callf1 tan)),
("asin", F1 (callf1 asin)),
("acos", F1 (callf1 acos)),
("atan", F1 (callf1 atan)),
("exp", F1 (callf1 exp)),
("pow", F2 (callf2 (**))),
("log", F1 (callf1 log)),
("sinh", F1 (callf1 sinh)),
("cosh", F1 (callf1 cosh)),
("tanh", F1 (callf1 tanh)),
("floor", F1 (callfri1 floor)),
("ceiling", F1 (callfri1 ceiling)),
("round", F1 (callfri1 round)),
("truncate",F1 (callfri1 truncate)),
("fact", F1 (callfii1 fact)),
("comb", F2 (callfii2 comb)),
("mod", F2 (callfii2 mod)),
("gcd", F2 (callfii2 gcd)),
("lcm", F2 (callfii2 lcm))]
-- トークンの切り出し
getToken :: String -> Lexer
getToken [] = (Eof, "")
getToken (x:xs)
| isSpace x = getToken xs
| isAlpha x = let (name, ys) = span isAlphaNum (x:xs)
in (Ident name, ys)
| isDigit x = let (s, ys@(y:_)) = span isDigit (x:xs)
in if y == '.' || y == 'e' || y == 'E'
then case reads (x:xs) of
[] -> error "not number" -- ありえないエラー
[(y', ys')] -> (Number (REAL y'), ys')
else (Number (INT (read s)), ys)
| otherwise =
case x of
'=' -> (Assign, xs)
'+' -> (Add, xs)
'-' -> (Sub, xs)
'*' -> (Mul, xs)
'/' -> (Div, xs)
'(' -> (Lpar, xs)
')' -> (Rpar, xs)
';' -> (Semic, xs)
',' -> (Comma, xs)
_ -> (Others x, xs)
-- セミコロンまで読み込む
lexer :: String -> ([Token], String)
lexer xs =
let (t, ys) = getToken xs
in case t of
Semic -> ([Semic], ys)
Eof -> ([Eof], ys)
_ -> let (ts, zs) = lexer ys
in ts `seq` zs `seq` (t:ts, zs)
-- 算術演算
neg :: Value -> Value
neg (INT x) = INT (- x)
neg (REAL x) = REAL (- x)
add :: Value -> Value -> Value
add (INT x) (INT y) = INT (x + y)
add (REAL x) (REAL y) = REAL (x + y)
add (INT x) (REAL y) = REAL (fromIntegral x + y)
add (REAL x) (INT y) = REAL (x + fromIntegral y)
sub :: Value -> Value -> Value
sub (INT x) (INT y) = INT (x - y)
sub (REAL x) (REAL y) = REAL (x - y)
sub (INT x) (REAL y) = REAL (fromIntegral x - y)
sub (REAL x) (INT y) = REAL (x - fromIntegral y)
mul :: Value -> Value -> Value
mul (INT x) (INT y) = INT (x * y)
mul (REAL x) (REAL y) = REAL (x * y)
mul (INT x) (REAL y) = REAL (fromIntegral x * y)
mul (REAL x) (INT y) = REAL (x * fromIntegral y)
div' :: Value -> Value -> Value
div' (INT x) (INT y) = INT (x `div` y)
div' (REAL x) (REAL y) = REAL (x / y)
div' (INT x) (REAL y) = REAL (fromIntegral x / y)
div' (REAL x) (INT y) = REAL (x / fromIntegral y)
-- 数式の計算
factor :: Calc [Token] Expr
factor = do x <- item
case x of
Number v -> return (Num v)
_ -> failure
+++ do sat (== Lpar)
e <- expr
y <- item
case y of
Rpar -> return e
_ -> calcError "')' expected"
+++ do sat (== Sub)
e <- expr
return (Op1 neg e)
+++ do sat (== Add)
e <- expr
return e
+++ do sat (== Eof)
calcError "EOF"
+++ do x <- item
case x of
Ident name -> do
case lookup name funcTable of
Nothing -> return (Var name)
Just fn -> do args <- getArgs
if length args < argsNum fn
then calcError "not enough arguments"
else return (App fn args)
where argsNum fn = case fn of
(F1 _) -> 1
(F2 _) -> 2
_ -> calcError ("unexpected token: " ++ show x)
-- 引数の取得
getExpr :: Calc [Token] [Expr]
getExpr = do
e <- expr
x <- item
case x of
Comma -> do es <- getExpr
return (e:es)
Rpar -> return [e]
_ -> calcError ("unexpected token in argument list: " ++ show x)
getArgs :: Calc [Token] [Expr]
getArgs = do sat (== Lpar)
y <- lookahead
case y of
Rpar -> return []
_ -> getExpr
+++ calcError "'(' expected"
-- 演算子のパーサ
addp, subp, mulp, divp :: Calc [Token] (Value -> Value -> Value)
addp = do sat (Add ==)
return add
subp = do sat (Sub ==)
return sub
mulp = do sat (Mul ==)
return mul
divp = do sat (Div ==)
return div'
-- 繰り返し
rep :: Calc [Token] Expr -> Calc [Token] (Value -> Value -> Value) -> Calc [Token] Expr
rep p q = do
e <- p
iter e
where iter e = do op <- q
e' <- p
iter (Op2 op e e')
+++ return e
-- 項
term :: Calc [Token] Expr
term = factor `rep` (mulp +++ divp)
-- 式 1
expr1 :: Calc [Token] Expr
expr1 = term `rep` (addp +++ subp)
-- 式
expr :: Calc [Token] Expr
expr = do
e <- expr1
expr_sub e
where
expr_sub e = do
y <- lookahead
case y of
Assign -> case e of
Var _ -> do item
e' <- expr
return (Agn e e')
_ -> calcError "invalid assign form"
_ -> return e
expression :: Calc [Token] Expr
expression = do
e <- expr
y <- lookahead
case y of
Semic -> return e
_ -> calcError "expression error"
-- 構文木の評価
evalExpr :: Expr -> Calc Env Value
evalExpr (Num x) = return x
evalExpr (Var x) = do
env <- get
case lookup x env of
Nothing -> calcError ("unbound variable: " ++ x)
Just v -> return v
evalExpr (Agn (Var name) e) = do
v <- evalExpr e
env <- get
put ((name, v):env)
return v
evalExpr (Op1 op e) = do
v <- evalExpr e
return (op v)
evalExpr (Op2 op e1 e2) = do
v1 <- evalExpr e1
v2 <- evalExpr e2
return (op v1 v2)
evalExpr (App fn args) = do
v1 <- evalExpr (args !! 0)
case fn of
F1 f -> f v1
F2 f -> do v2 <- evalExpr (args !! 1)
f v1 v2
--
toplevel :: String -> Env -> IO ()
toplevel xs env = do
putStr "Calc> "
let (ys, xs') = lexer xs
case runStateT expression ys of
Err mes -> do putStrLn mes
toplevel xs' env
Fail -> do print "Fail"
toplevel xs' env
Some (e, _) ->
case runStateT (evalExpr e) env of
Err mes -> do putStrLn mes
if mes == "EOF"
then return ()
else toplevel xs' env
Fail -> do print "Fail"
toplevel xs' env
Some (v, env') -> do case v of
INT x -> print x
REAL x -> print x
toplevel xs' env'
main :: IO ()
main = do
xs <- hGetContents stdin
toplevel xs []