Mini Parser Combinator.

List.hs

module List where

import Control.Applicative
import Control.Monad
import Data.Char

type Name = String

data Term
    = Var Name
    | Lam Name Term
    | App Term Term
    deriving Show

data Parser a = Parser { runParser :: String -> [(a, String)] }

parse :: Parser a -> String -> a
parse p s =
    case runParser p s of
        [(x, "")] -> x
        []        -> error "no parse"
        _         -> error "ambiguous parse"

instance Functor Parser where
    fmap f p = Parser $ \s -> map (\(x, s) -> (f x, s)) (runParser p s)

instance Applicative Parser where
    pure x  = Parser $ \s -> [(x, s)]
    f <*> p = Parser $ \s ->
        [(f x, s'') | (f, s') <- runParser f s, (x, s'') <- runParser p s']

instance Monad Parser where
    p >>= f = Parser $ \s ->
        concatMap (\(x, s) -> runParser (f x) s) (runParser p s)

instance Alternative Parser where
    empty   = Parser $ \s -> []
    p <|> q = Parser $ \s ->
        case runParser p s of
            [] -> runParser q s
            x  -> x

item :: Parser Char
item = Parser $ \s ->
    case s of
        []     -> []
        (c:cs) -> [(c, cs)]

satisfy :: (Char -> Bool) -> Parser Char
satisfy cond = do
    c <- item
    guard $ cond c
    return c

skipMany :: Parser a -> Parser ()
skipMany p = do
    _ <- many p
    return ()

chainr1 :: Parser a -> Parser (a -> a -> a) -> Parser a
chainr1 p op = scan
    where
    scan = do
        x <- p
        rest x <|> return x

    rest x = do
        f <- op
        y <- scan
        return (f x y)

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

letter :: Parser Char
letter = satisfy isLetter

space :: Parser ()
space = do
    _ <- satisfy isSpace
    return ()

spaces :: Parser ()
spaces = skipMany space

expression :: Parser Term
expression = lambda <|> application <|> parens expression

lambda :: Parser Term
lambda = do
    char '\\' *> spaces
    var <- name
    char '.' *> spaces
    body <- expression
    return $ Lam var body

application :: Parser Term
application = (variable <|> parens expression) `chainr1` return App

variable :: Parser Term
variable = Var <$> name

name :: Parser Name
name = some letter <* spaces

parens :: Parser a -> Parser a
parens p = do
    char '(' *> spaces
    x <- p
    char ')' *> spaces
    return x