Naive PEG parser without memoization

gistfile1.hs

import Data.Char

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

parse :: Parser a -> String -> ([(a,String)])
parse (Parser p) inp = p inp

instance Monad Parser where
    return val = Parser (\inp -> [(val,inp)])
    pa >>= f = Parser (\inp ->
        case parse pa inp of
            [(va,sa)] -> parse (f va) sa
            [] -> [])

(+++) :: Parser a -> Parser a -> Parser a
(+++) pa pb = Parser (\inp ->
    case parse pa inp of
        [(va,sa)] -> [(va,sa)]
        [] -> parse pb inp)

failure :: Parser a
failure = Parser (\_ -> [])

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

sat :: (Char -> Bool) -> Parser Char
sat f = do
    x <- item
    if f x then return x else failure

eq :: Char -> Parser Char
eq c = sat (\x -> x == c)

many :: Parser a -> Parser [a]
many p = (many1 p) +++ (return [])

many1 :: Parser a -> Parser [a]
many1 p = do
    x <- p
    xs <- many p
    return (x:xs)

whitespace :: Parser String
whitespace = many (sat (\c -> elem c " \n\t"))

parseNat :: Parser Integer
parseNat = do
    x <- many1 (sat isDigit)
    return (read x)

parseInt :: Parser Integer
parseInt = parseNat +++ (do
    eq '-'
    x <- parseNat
    return (-x))

parseExp :: Parser Integer
parseExp = do
    whitespace
    x <- parseInt +++ (parseOp '+') +++ (parseOp '-') +++ (parseOp '*')
    return x

parseOp :: Char -> Parser Integer
parseOp op = do
    eq '('
    whitespace
    eq op
    x <- parseExp
    y <- parseExp
    whitespace
    eq ')'
    return (case op of
        '+' -> x + y
        '-' -> x - y
        '*' -> x * y)

evalString :: String -> Integer
evalString inp = let [(result,_)] = parse parseExp inp in result