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)
9 import Data.List (foldl')
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))
17 data Expr = Const Integer
22 instance Functor (State s) where
23 fmap f (State g) = State $ fmap (first f) . g
25 instance Applicative (State s) where
26 pure x = State $ \s -> Just (x, s)
27 State f <*> State g = State $ \s ->
30 Just (r, s') -> fmap (first r) . g $ s'
32 instance Alternative (State s) where
33 empty = State $ const Nothing
34 State f <|> State g = State $ \s -> maybe (g s) Just (f s)
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
40 -- Parse one numerical digit.
41 digit :: Parser Integer
42 digit = State $ parseDigit
43 where parseDigit [] = Nothing
45 | isDigit c = Just (fromIntegral $ digitToInt c, cs)
48 -- Parse an integer. The integer may be prefixed with a negative sign.
50 num = maybe id (const negate) <$> optional (char '-') <*> (toInteger <$> some digit)
51 where toInteger = foldl' ((+) . (* 10)) 0
53 -- Parse a single white space character.
55 space = State $ parseSpace
56 where parseSpace [] = Nothing
58 | isSpace c = Just ((), cs)
61 -- Consume zero or more white space characters.
63 eatSpace = const () <$> many space
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)
72 -- Parse one of our two supported operator symbols.
73 op :: Parser (Expr -> Expr -> Expr)
74 op = const Add <$> (char '+') <|> const Mul <$> (char '*')
76 -- Succeed only if the end of the input has been reached.
79 where parseEof [] = Just ((),[])
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
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
95 -- Run a parser over a 'String' returning the parsed value.
96 evalParser :: Parser a -> String -> Maybe a
97 evalParser = (fmap fst .) . execParser
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)