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