Monadic Parser Combinators

四角い車輪を再発明してしまった。
今後はParsecを使おうと思っていたのだが，Monadic Parser Combinatorsってどんな感じに実装するのかが気になってしまった。そこで，自分なりに考えてParsecのソースを見て確認しよう，そしてそれで終わり，という予定だったのだが，なんか自分でも書きたくなってしまったのだ。

module Parser where
import Data.Char
import Control.Monad

newtype Parser a b = Parser ([a] -> [([a],b)])

instance Monad (Parser a) where
  Parser p >>= k = Parser (\xs -> let (xs',vs) = unzip $ p xs
                                      ms = map k vs
                                  in concat (map (\(Parser q,x) -> q x) (zip ms xs')))
  return v = Parser (\xs -> [(xs,v)])
  fail s = Parser (\_ -> [])

instance MonadPlus (Parser a) where
  mzero = Parser (\_ -> [])
  Parser p `mplus` Parser q = Parser (\xs -> p xs ++ q xs)

instance Functor (Parser a) where
  fmap f (Parser p) = Parser (\xs -> map (\(x,v) -> (x,f v)) (p xs))

infixr 1 <|>
(<|>) :: Parser a b -> Parser a b -> Parser a b
(<|>) = mplus


runParser :: Parser a b -> [a] -> [b]
runParser p xs = testParser p xs >>= return . snd
testParser :: Parser a b -> [a] -> [([a],b)]
testParser (Parser p) xs = p xs

many :: Parser a b -> Parser a [b]
many p = do { x <- p
            ; xs <- many p
            ; return (x:xs)
            }
        <|> return []

many1 :: Parser a b -> Parser a [b]
many1 p = do { x <- p
             ; xs <- (many1 p <|> return [])
             ; return (x:xs)
             }

bound :: (Int,Int) -> Parser a b -> Parser a [b]
bound (0,0) p = return []
bound (0,max) p = do { x <- p
                     ; xs <- bound (0,max-1) p
                     ; return (x:xs)
                     }
                 <|> return []
bound (min,max) p = do { x <- p
                       ; xs <- bound (min-1,max-1) p
                       ; return (x:xs)
                       }

times :: Int -> Parser a b -> Parser a [b]
times n p = bound (n,n) p

empty :: b -> Parser a b
empty v = Parser (\xs -> [(xs,v)])

satisfy :: (a -> Bool) -> Parser a a
satisfy pred = Parser (\xs -> case xs of
                                [] -> []
                                (x:xs) -> if pred x
                                           then [(xs,x)]
                                           else [])

oneOf :: (Eq a) => [a] -> Parser a a
oneOf s = let s' = map (\e -> satisfy  (e ==)) s
          in foldr1 (<|>) s'

char :: Char -> Parser Char Char
char c = satisfy (c ==)

space :: Parser Char Char
space = satisfy isSpace

alpha :: Parser Char Char
alpha = satisfy isAlpha

alphaNum :: Parser Char Char
alphaNum = satisfy isAlphaNum

digit :: Parser Char Char
digit = satisfy isDigit

digits :: Parser Char String
digits = many1 digit

int :: Parser Char Int
int = do { ds <- digits
         ; return ((read ds)::Int)
         }

newtypeを使うのは初めて。以下はメモ。
dataとは違いコンストラクタはひとつしかもてない。そのためパターンマッチ自体にコストはかからないとのこと。また，コンストラクタのフィールドはひとつであり，それより少なくても多くてもいけない。

newtype T = C a

とした場合，Tはaの別名と考えられる。typeとの違いは，newtypeなら再帰的に定義できるということ。GHCなら"-XTypeSynonymInstances"を使えば，typeでもinstance化できるらしい。

Parsecとは違い"A<|>B"はAが消費しようがしまいがBは実行される。というか，Aが成功でも失敗でもBは実行される。なので，manyの結果は，

runParser (many (char 'a')) "aaaa"
-- => ["aaaa","aaa","aa","a",""]

となる。通常は最長一致で使うことが多いので問題はそれほどないと思うのだがどうだろう。後で試してみるべきだろうなあ。

エラー処理に関しては一切考慮していないが，それについて考えるのもなかなかおもしろそうだ。エラー処理いれればペンダゴンくらいにはなるかな？