Parser.hs

-- Applicative parser for infix arithmetic expressions without any
-- dependency on hackage. Builds an explicit representation of the
-- syntax tree to fold over using client-supplied semantics.
module Parser (parseExp) where
import Control.Applicative hiding (Const)
import Control.Arrow
import Data.Char
import Data.Monoid
import Data.List (foldl')

-- Building block of a computation with some state of type @s@
-- threaded through it, possibly resulting in a value of type @r@
-- along with some updated state.
newtype State s r = State (s -> Maybe (r, s))

-- Expressions
data Expr = Const Integer
          | Add Expr Expr
          | Mul Expr Expr
            deriving Show

instance Functor (State s) where
    fmap f (State g) = State $ fmap (first f) . g

instance Applicative (State s) where
    pure x = State $ \s -> Just (x, s)
    State f <*> State g = State $ \s ->
                          case f s of
                            Nothing -> Nothing
                            Just (r, s') -> fmap (first r) . g $ s'

instance Alternative (State s) where
    empty = State $ const Nothing
    State f <|> State g = State $ \s -> maybe (g s) Just (f s)

-- A parser threads some 'String' state through a computation that
-- produces some value of type @a@.
type Parser a = State String a

-- Parse one numerical digit.
digit :: Parser Integer
digit = State $ parseDigit
    where parseDigit [] = Nothing
          parseDigit s@(c:cs)
              | isDigit c = Just (fromIntegral $ digitToInt c, cs)
              | otherwise = Nothing

-- Parse an integer. The integer may be prefixed with a negative sign.
num :: Parser Integer
num = maybe id (const negate) <$> optional (char '-') <*> (toInteger <$> some digit)
    where toInteger = foldl' ((+) . (* 10)) 0

-- Parse a single white space character.
space :: Parser ()
space = State $ parseSpace
    where parseSpace [] = Nothing
          parseSpace s@(c:cs)
              | isSpace c = Just ((), cs)
              | otherwise = Nothing

-- Consume zero or more white space characters.
eatSpace :: Parser ()
eatSpace = const () <$> many space

-- Parse a specific character.
char :: Char -> Parser Char
char c = State parseChar
    where parseChar [] = Nothing
          parseChar (x:xs) | x == c = Just (c, xs)
                           | otherwise = Nothing

-- Parse one of our two supported operator symbols.
op :: Parser (Expr -> Expr -> Expr)
op = const Add <$> (char '+') <|> const Mul <$> (char '*')

-- Succeed only if the end of the input has been reached.
eof :: Parser ()
eof = State parseEof
    where parseEof [] = Just ((),[])
          parseEof _  = Nothing

-- Parse an infix arithmetic expression consisting of integers, plus
-- signs, multiplication signs, and parentheses.
parseExpr :: Parser Expr
parseExpr = eatSpace *>
            ((buildOp <$> nonOp <*> (eatSpace *> op) <*> parseExpr) <|> nonOp)
    where buildOp x op y = x `op` y
          nonOp = char '(' *> parseExpr <* char ')' <|> Const <$> num

-- Run a parser over a 'String' returning the parsed value and the
-- remaining 'String' data.
execParser :: Parser a -> String -> Maybe (a, String)
execParser (State f) = f

-- Run a parser over a 'String' returning the parsed value.
evalParser :: Parser a -> String -> Maybe a
evalParser = (fmap fst .) . execParser

-- Parse an arithmetic expression using the supplied semantics for
-- integral constants, addition, and multiplication.
parseExp :: (Integer -> a) -> (a -> a -> a) -> (a -> a -> a) -> String -> Maybe a
parseExp con add mul = (convert <$>) . evalParser (parseExpr <* eof)
    where convert (Const x) = con x
          convert (Add x y) = add (convert x) (convert y)
          convert (Mul x y) = mul (convert x) (convert y)