パーサ練習。ファンクタ則、アプリカティブ則、モナド則の検証はしていない。

Calc.hs

module Calc where

import ToyParser

choiceChar :: Char -> Char -> Parser Char Char
choiceChar a b = char a </> char b

valueP :: Parser Char Int
valueP = num </> (char '(' +> exprP <+ char ')')

productP :: Parser Char Int
productP = valueP <+> many ((choiceChar '*' '/') <+> valueP) <#> c
  where
    c (l, []) = l
    c (l, (('*', r):xs)) = c (l * r, xs)
    c (l, (('/', r):xs)) = c (l `div` r, xs)

sumP :: Parser Char Int
sumP = productP <+> many ((choiceChar '+' '-') <+> productP) <#> c
  where
    c (l, []) = l
    c (l, (('+', r):xs)) = c (l + r, xs)
    c (l, (('-', r):xs)) = c (l - r, xs)

exprP :: Parser Char Int
exprP = sumP

ToyParser.hs

module ToyParser where

import Data.Char
import Control.Applicative hiding (many)
import Control.Monad ()

newtype Parser s a = Parser { runParser :: [s] -> [(a, [s])] }

instance Functor (Parser s) where
  fmap f (Parser p) = Parser $ \ls -> do
                                       (r, pls) <- p ls
                                       return (f r, pls)

instance Applicative (Parser s) where
  pure = success
  Parser pf <*> Parser q = Parser $ \input -> do
                                              (pfr, pfls) <- pf input
                                              (qr, qls) <- q pfls
                                              return (pfr qr, qls)

instance Monad (Parser s) where
  return = pure
  Parser p >>= f = Parser $ \ls -> do
                                   (pr, pls) <- p ls
                                   let Parser g = f pr
                                   g pls

infixl 6 <+>
(<+>) :: Parser s a -> Parser s b -> Parser s (a, b)
Parser p <+> Parser q = Parser $ \ls -> do
                                        (pr, pls) <- p ls
                                        (qr, qls) <- q pls
                                        return ((pr, qr), qls)

infixl 6 <+
(<+) :: Parser s a -> Parser s b -> Parser s a
p <+ q = p <+> q <#> \(r, _) -> r

infixl 6 +>
(+>) :: Parser s a -> Parser s b -> Parser s b
p +> q = p <+> q <#> \(_, r) -> r

infixl 3 </>
(</>) :: Parser s a -> Parser s a -> Parser s a
Parser p </> Parser q = Parser $ \ls -> case p ls of
                                            (pr, pls):_ -> [(pr, pls)]
                                            _ -> q ls

infixl 5 <#>
(<#>) :: Parser s a -> (a -> b) -> Parser s b
(<#>) = flip fmap

success :: a -> Parser s a
success a = Parser $ \ls -> [(a, ls)]

failure :: Parser s a
failure = Parser $ \_ -> []

satisfy :: (s -> Bool) -> Parser s s
satisfy f = Parser $ p
  where
    p (x:xs) | f x = [(x, xs)]
    p _ = []

char :: Eq s => s -> Parser s s
char s = satisfy (== s)

token :: Eq s => [s] -> Parser s [s]
token t = Parser $ \ls -> if t == take n ls then [(t, drop n ls)] else []
  where n = length t

many :: Parser s a -> Parser s [a]
many p = p <+> many p <#> (\(x, xs) -> x:xs) </> success []

many1 :: Parser s a -> Parser s [a]
many1 p = p <+> many p <#> \(x, xs) -> x:xs

option :: (Eq s) => s -> Parser s s
option s = char s </> success s

num :: Parser Char Int
num = many1 (satisfy isDigit) <#> read