hw5/Parser.hs

   1 -- Applicative parser for infix arithmetic expressions without any
   2 -- dependency on hackage. Builds an explicit representation of the
   3 -- syntax tree to fold over using client-supplied semantics.
   4 module Parser (parseExp) where
   5 import Control.Applicative hiding (Const)
   6 import Control.Arrow
   7 import Data.Char
   8 import Data.Monoid
   9 import Data.List (foldl')
  10
  11 -- Building block of a computation with some state of type @s@
  12 -- threaded through it, possibly resulting in a value of type @r@
  13 -- along with some updated state.
  14 newtype State s r = State (s -> Maybe (r, s))
  15
  16 -- Expressions
  17 data Expr = Const Integer
  18           | Add Expr Expr
  19           | Mul Expr Expr
  20             deriving Show
  21
  22 instance Functor (State s) where
  23     fmap f (State g) = State $ fmap (first f) . g
  24
  25 instance Applicative (State s) where
  26     pure x = State $ \s -> Just (x, s)
  27     State f <*> State g = State $ \s ->
  28                           case f s of
  29                             Nothing -> Nothing
  30                             Just (r, s') -> fmap (first r) . g $ s'
  31
  32 instance Alternative (State s) where
  33     empty = State $ const Nothing
  34     State f <|> State g = State $ \s -> maybe (g s) Just (f s)
  35
  36 -- A parser threads some 'String' state through a computation that
  37 -- produces some value of type @a@.
  38 type Parser a = State String a
  39
  40 -- Parse one numerical digit.
  41 digit :: Parser Integer
  42 digit = State $ parseDigit
  43     where parseDigit [] = Nothing
  44           parseDigit s@(c:cs)
  45               | isDigit c = Just (fromIntegral $ digitToInt c, cs)
  46               | otherwise = Nothing
  47
  48 -- Parse an integer. The integer may be prefixed with a negative sign.
  49 num :: Parser Integer
  50 num = maybe id (const negate) <$> optional (char '-') <*> (toInteger <$> some digit)
  51     where toInteger = foldl' ((+) . (* 10)) 0
  52
  53 -- Parse a single white space character.
  54 space :: Parser ()
  55 space = State $ parseSpace
  56     where parseSpace [] = Nothing
  57           parseSpace s@(c:cs)
  58               | isSpace c = Just ((), cs)
  59               | otherwise = Nothing
  60
  61 -- Consume zero or more white space characters.
  62 eatSpace :: Parser ()
  63 eatSpace = const () <$> many space
  64
  65 -- Parse a specific character.
  66 char :: Char -> Parser Char
  67 char c = State parseChar
  68     where parseChar [] = Nothing
  69           parseChar (x:xs) | x == c = Just (c, xs)
  70                            | otherwise = Nothing
  71
  72 -- Parse one of our two supported operator symbols.
  73 op :: Parser (Expr -> Expr -> Expr)
  74 op = const Add <$> (char '+') <|> const Mul <$> (char '*')
  75
  76 -- Succeed only if the end of the input has been reached.
  77 eof :: Parser ()
  78 eof = State parseEof
  79     where parseEof [] = Just ((),[])
  80           parseEof _  = Nothing
  81
  82 -- Parse an infix arithmetic expression consisting of integers, plus
  83 -- signs, multiplication signs, and parentheses.
  84 parseExpr :: Parser Expr
  85 parseExpr = eatSpace *>
  86             ((buildOp <$> nonOp <*> (eatSpace *> op) <*> parseExpr) <|> nonOp)
  87     where buildOp x op y = x `op` y
  88           nonOp = char '(' *> parseExpr <* char ')' <|> Const <$> num
  89
  90 -- Run a parser over a 'String' returning the parsed value and the
  91 -- remaining 'String' data.
  92 execParser :: Parser a -> String -> Maybe (a, String)
  93 execParser (State f) = f
  94
  95 -- Run a parser over a 'String' returning the parsed value.
  96 evalParser :: Parser a -> String -> Maybe a
  97 evalParser = (fmap fst .) . execParser
  98
  99 -- Parse an arithmetic expression using the supplied semantics for
 100 -- integral constants, addition, and multiplication.
 101 parseExp :: (Integer -> a) -> (a -> a -> a) -> (a -> a -> a) -> String -> Maybe a
 102 parseExp con add mul = (convert <$>) . evalParser (parseExpr <* eof)
 103     where convert (Const x) = con x
 104           convert (Add x y) = add (convert x) (convert y)
 105           convert (Mul x y) = mul (convert x) (convert y)