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

------------------------------------------------------------------------------
--- Library with deterministic logic parser combinators.
---
--- @author Jonas Oberschweiber
--- @version August 2018
------------------------------------------------------------------------------

module DetParse where

import Prelude hiding ((<$>))

--- A parser
type Parser a = String -> [(a, String)]

--- Applies a parser to a string. If it succeeds, returns the result of the
--- parser. Returns `Nothing` if it does not.
parse :: Parser a -> String -> Maybe a
parse p s = case filter (null . snd) $ p s of
  ((x, _):_) -> Just x
  _          -> Nothing

--- A parser that always fails.
failure :: Parser a
failure = \_ -> []

--- A parser that consumes no input and results in the given value.
yield :: a -> Parser a
yield x = \s -> [(x, s)]

--- A parser that consumes no input and results in the unit value.
empty :: Parser ()
empty = yield ()

--- A parser that consumes an arbitrary single character.
anyChar :: Parser Char
anyChar = \s -> case s of
                  []      -> []
                  (c:cs)  -> [(c,cs)]

--- Builds a parser that succeeds if the predicate holds on the result of the
--- original parser.
check :: (a -> Bool) -> Parser a -> Parser a
check ok p = filter (ok . fst) . p

--- Builds a parser that consumes a specific character and results in the unit
--- value.
char :: Char -> Parser ()
char c = check (c==) anyChar *> yield ()

--- Builds a parser that consumes the given string and results in the unit
--- value.
word :: String -> Parser ()
word []     = empty
word (c:cs) = char c *> word cs

infixl 3 <|>, <!>

--- Builds a parser that tries both its argument parsers and results in the
--- result of the first one to succeed.
(<|>) :: Parser a -> Parser a -> Parser a
p <|> q = \s -> p s ++ q s

--- Builds a parser that tries its first argument parser and alternatively, if
--- the first one does not succeed, its second argument parser. In contrast to
--- `<|>`, this combinator does not backtrack. The second parser is applied to
--- the leftovers of the first parser. Use it if the alternatives are mutually
--- exclusive.
(<!>) :: Parser a -> Parser a -> Parser a
p <!> q = \s -> case p s of
                  [] -> q s
                  xs -> xs

infixl 4 <$>

--- Builds a parser that applies a function to the result of the original
--- parser.
(<$>) :: (a -> b) -> Parser a -> Parser b
f <$> p = map (\(x, s) -> (f x, s)) . p

infixl 4 <*>, <*, *>

--- Applies the function returned by the first parser to the result of the
--- second parser. Applies the parsers in order.
(<*>) :: Parser (a -> b) -> Parser a -> Parser b
p <*> q = \s -> [ (f x, s2) | (f, s1) <- p s,
                              (x, s2) <- q s1 ]

--- Builds a parser that applies both parsers in order and returns the result of
--- the first one.
(<*) :: Parser a -> Parser b -> Parser a
p <* q = (\x _ -> x) <$> p <*> q

--- Builds a parser that applies both parsers in order and returns the result of
--- the second one.
(*>) :: Parser a -> Parser b -> Parser b
p *> q = (\_ y -> y) <$> p <*> q

infixl 1 *>=

(*>=) :: Parser a -> (a -> Parser b) -> Parser b
p *>= f = \s -> [ (y, s2) | (x, s1) <- p s,
                            (y, s2) <- (f x) s1 ]

--- Builds a parser that will apply the original parser arbitrarily many times.
many :: Parser a -> Parser [a]
many p = some p <|> yield []

--- Builds a parser that will apply the original parser at least once.
some :: Parser a -> Parser [a]
some p = (:) <$> p <*> many p