content: -- 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)
  