1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
|
-- 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)
|