PEG電卓をやってみた

前回のポストから日数がたってしまいましたが、たまにはちゃんと最後まで書こうということで、出来上がったPEG電卓のコードを乗せておきます。

パーサーの定義が前回までのポストとは微妙に変わっていますが、大筋は同じです。こっちのほうがコンパイルして動作確認も取れてます。

電卓のほうは以前に書いた四則演算のPEG表現を素直にPEGパーサモナドで書き換えたものです…空白の処理なんかが増えてますが…

コードが長いのでこのポストはこれでおしまい。

module Main where

import System (getArgs)
import Data.List (intercalate)

ifNothing Nothing v = Just v
ifNothing (Just _) _ = Nothing

newtype Parse i o = Parse {
		runParse :: i -> Maybe (o, i)
	}

instance Monad (Parse i) where
	(>>=) p f = Parse $ \i ->
		case (runParse p i) of
			Nothing -> Nothing
			Just (o, i') -> runParse (f o) i'
	return o = Parse $ \i -> Just (o, i)
	fail _ = Parse $ \_ -> Nothing

_char :: (a -> Bool) -> [a] -> Maybe ([a], [a])
_char _  = Nothing
_char f (c:cs) =
	if (f c) then Just ([c], cs)
		else Nothing

eofP :: Parse [a] [a]
eofP = Parse $ \i -> f i
	where
		f  = Just(, )
		f _ = Nothing

charP :: Eq a => a -> Parse [a] [a]
charP ch = Parse $ \str -> _char (ch ==) str

strP :: Eq a => [a] -> Parse [a] [a]
strP str = foldr seqP emptyP $ map (charP) str

anyOfP :: Eq a => [a] -> Parse [a] [a]
anyOfP chs = Parse $ \str -> _char ( (flip elem) chs) str

anyButP :: Eq a => [a] -> Parse [a] [a]
anyButP chs = Parse $ \str -> _char (not.(flip elem) chs) str

anyP :: Parse [a] [a]
anyP = Parse $ \str -> _char (\_ -> True) str

followedP :: Parse i [o] -> Parse i [o]
followedP pf = Parse $ \i -> (runParse pf i) >> return ([ ], i)

notFollowedP :: Parse i [o] -> Parse i [o]
notFollowedP nf = Parse $ \i -> ifNothing (runParse nf i) ([ ], i)

ifP:: Parse i o -> (o -> Parse i o) -> Parse i o -> Parse i o
ifP p ps pf = Parse $ \i ->
	case (runParse p i) of
		Nothing -> runParse pf i
		Just (o, i') -> runParse (ps o) i'

emptyP :: Parse a [b]
emptyP = return  []

optP :: Parse i [o] -> Parse i [o]
optP p = ifP p return emptyP

repeatP :: Parse i [o] ->  Parse i [o]
repeatP p = ifP p (\o -> (repeatP p) >>= return.(o++)) emptyP

repeatP1 :: Parse i [o] -> Parse i [o]
repeatP1 p = seqP p (repeatP p)

choiceP :: Parse i o -> Parse i o -> Parse i o
choiceP p q = ifP p return q

seqP :: Parse i [o] -> Parse i [o] -> Parse i [o]
seqP p q = do
	v <- p
	w <- q
	return (v ++ w)
	
type StrParser = Parse String String
digitP :: StrParser
digitP = anyOfP ['1'..'9']

digit0P :: StrParser
digit0P = anyOfP ['0'..'9']

unaryP = charP '-'

numberP :: StrParser
numberP = ( (charP '0') `seqP` (notFollowedP digitP) )
	`choiceP` 
	( (optP unaryP) `seqP` digitP `seqP` (repeatP digit0P) )

numPI :: Parse String [Int]
numPI = do
	num <- numberP
	return [read num]

blankChP :: StrParser
blankChP = anyOfP " \t"

blankP = repeatP blankChP

blockPI = do
	(charP '(') `seqP` blankP
	val <- expPI 
	blankP `seqP` (charP ')') `seqP` blankP
	return val

addDecPI = addPI `choiceP` decPI

numBlkMulDivPI = mulPI `choiceP` divPI `choiceP` numBlkPI

numBlkPI :: Parse String [Int]
numBlkPI = blockPI `choiceP` numPI

addPI :: Parse String [Int]
addPI = do
	(val1:_) <- numBlkMulDivPI
	blankP `seqP` (charP '+') `seqP` blankP 
	(val2:_) <- expPI
	return [val1 + val2] 

decPI :: Parse String [Int]
decPI = do
	(val1:_) <- numBlkMulDivPI
	blankP `seqP` (charP '+') `seqP` blankP 
	(val2:_) <- expPI
	return [val1 - val2]

mulPI :: Parse String [Int]
mulPI = do
	(val1:_) <- numBlkPI 
	blankP `seqP` (charP '*') `seqP` blankP 
	(val2:_) <- numBlkMulDivPI 
	return [val1 * val2]

divPI :: Parse String [Int]
divPI = do
	(val1:_) <- numBlkPI
	blankP `seqP` (charP '/') `seqP` blankP 
	(val2:_) <- numBlkMulDivPI
	return [val1 `div` val2]

expPI = do
	blankP
	(addDecPI `choiceP` numBlkMulDivPI)

main = getArgs >>= putStrLn.show.head.fst.unJust.
	compute.intercalate " "
	where
		unJust (Just a) = a
		compute = runParse expPI