blob: 64e0b8401c128f1e907816c2e4a25d9cba9e3d52 (
plain)
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
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
|
{-# LANGUAGE FlexibleInstances #-}
module Parser.Core where
import Control.Applicative
import Data.Char
newtype Parser a = Parser { runParser :: String -> Either String (a, String) }
runParserStrict :: Parser a -> String -> Either String a
runParserStrict p input = case runParser p input of
Right (a, "") -> Right a
Right (_, rest) -> Left $ "Unconsumed input: \"" ++ rest ++ "\""
Left err -> Left err
-------------------------------------------------------------------------------
-- Parser instances
-------------------------------------------------------------------------------
instance Functor Parser where
-- fmap :: (a -> b) -> Parser a -> Parser b
fmap f (Parser p) = Parser $
\s -> do (x, s') <- p s
return (f x, s')
instance Applicative Parser where
-- pure :: a -> Parser a
pure x = Parser (\s -> Right (x, s))
-- (<*>) :: Parser (a -> b) -> Parser a -> Parser b
(Parser pf) <*> (Parser p) = Parser $
\s -> do (f, s') <- pf s
(x, s'') <- p s'
return (f x, s'')
instance Monad Parser where
-- return :: a -> Parser a
return x = pure x
-- (>>=) :: Parser a -> (a -> Parser b) -> Parser b
(Parser p1) >>= f = Parser $
\s -> do (x, s') <- p1 s
runParser (f x) s'
-- instance for Either String so that it can be used in the Alternative for Parser
instance Alternative (Either String) where
-- empty :: Either String a
empty = Left ""
-- (<|>) :: Either String a -> Either String a -> Either String a
Left _ <|> x2 = x2
x1 <|> _ = x1
instance Alternative Parser where
-- empty :: Parser a
empty = Parser (\_ -> Left "Empty")
-- (<|>) :: Parser a -> Parser a -> Parser a
(Parser p1) <|> (Parser p2) = Parser $ \s -> p1 s <|> p2 s
-------------------------------------------------------------------------------
-- Parser creation helper
-------------------------------------------------------------------------------
-- Create a parser of one character which must respect a predicate
satisfyChar :: (Char -> Bool) -> Parser Char
satisfyChar predicate = Parser p
where p [] = Left "Expected input"
p (c:cs) = if predicate c then Right (c, cs)
else Left $ "Unexpected char '" ++ [c] ++ "'"
char :: Char -> Parser Char
char c = satisfyChar (c ==)
string :: String -> Parser String
string s = sequenceA $ char <$> s
sepBy :: Parser a -> Parser b -> Parser [a]
sepBy x sepatator = (:) <$> x <*> (many (sepatator *> x))
-- Parse one or more occurences of p separated by op
-- Apply op in a left associative maner on each value in p
chainl1 :: Parser a -> Parser (a -> a -> a) -> Parser a
chainl1 p op = p >>= rest
where rest prev = do f <- op
operand <- p
rest (f prev operand)
<|> return prev
infixOp :: String -> (a -> a -> a) -> Parser (a -> a -> a)
infixOp operatorStr f = string operatorStr *> pure f
-- Surround parser with opening and closing string
between :: String -> String -> Parser a -> Parser a
between open close p = string open *> p <* string close
parenthesis :: Parser a -> Parser a
parenthesis p = between "(" ")" p
-- try to apply parsers returns the first one that succeeds
choice :: [Parser a] -> Parser a
choice [] = empty
choice (p:ps) = p <|> choice ps
verify :: (a -> Bool) -> a -> Parser a
verify predicate x = if predicate x then pure x else empty
-- Parse a string of alpha character
-- Convert to lower case and check that the label isn't `i`
varLabelP :: Parser String
varLabelP = (map toLower <$> some (satisfyChar isAlpha)) >>= verify (/= "i")
funLabelP :: Parser String
funLabelP = map toLower <$> some (satisfyChar isAlpha)
floatP :: Parser Float
floatP = signed unsignedP
where
unsignedP :: Parser Float
unsignedP = read <$> p
where p = do pos <- digitsP
_ <- char '.'
dec <- digitsP
return (pos ++ "." ++ dec)
<|> digitsP
digitsP = some $ satisfyChar isDigit -- at least one digit to avoid read exception
signed :: Num a => Parser a -> Parser a
signed p = do _ <- char '-'
x <- p
return (-x)
<|> p
|
