]> Git — Sourcephile - haskell/symantic-parser.git/blob - src/Symantic/Parser/Grammar/Combinators.hs
wip
[haskell/symantic-parser.git] / src / Symantic / Parser / Grammar / Combinators.hs
1 {-# LANGUAGE DefaultSignatures #-}
2 -- The default type signature of type class methods are changed to introduce a Liftable constraint and the same type class but on the 'Unlift' repr, this setup avoids to define the method with boilerplate code when its default definition with lift* and 'unlift' does what is expected by an instance of the type class. This is almost as explained in: https://ro-che.info/articles/2016-02-03-finally-tagless-boilerplate
3 {-# LANGUAGE TemplateHaskell #-}
4 module Symantic.Parser.Grammar.Combinators where
5
6 import Data.Bool (Bool(..), not, (||))
7 import Data.Char (Char)
8 import Data.Either (Either(..))
9 import Data.Eq (Eq(..))
10 import Data.Function ((.), flip, const)
11 import Data.Int (Int)
12 import Data.Maybe (Maybe(..))
13 import Data.String (String)
14 import Language.Haskell.TH (TExpQ)
15 import qualified Data.List as List
16 import qualified Prelude as Pre
17
18 import Symantic.Base.Univariant
19 import qualified Symantic.Parser.Staging as Hask
20
21 -- * Class 'Applicable'
22 -- | This is like the usual 'Functor' and 'Applicative' type classes from the @base@ package, but using @('Hask.Haskell' a)@ instead of just @(a)@ to be able to use and pattern match on some usual terms of type @(a)@ (like 'Hask.id') and thus apply some optimizations.
23 -- @(repr)@ , for "representation", is the usual tagless-final abstraction over the many semantics that this syntax (formed by the methods of type class like this one) will be interpreted.
24 class Applicable repr where
25 -- | @(a2b '<$>' ra)@ parses like @(ra)@ but maps its returned value with @(a2b)@.
26 (<$>) :: Hask.Haskell (a -> b) -> repr a -> repr b
27 (<$>) f = (pure f <*>)
28
29 -- | Like '<$>' but with its arguments 'flip'-ped.
30 (<&>) :: repr a -> Hask.Haskell (a -> b) -> repr b
31 (<&>) = flip (<$>)
32
33 -- | @(a '<$' rb)@ parses like @(rb)@ but discards its returned value by replacing it with @(a)@.
34 (<$) :: Hask.Haskell a -> repr b -> repr a
35 (<$) x = (pure x <*)
36
37 -- | @(ra '$>' b)@ parses like @(ra)@ but discards its returned value by replacing it with @(b)@.
38 ($>) :: repr a -> Hask.Haskell b -> repr b
39 ($>) = flip (<$)
40
41 -- | @('pure' a)@ parses the empty string, always succeeding in returning @(a)@.
42 pure :: Hask.Haskell a -> repr a
43 default pure ::
44 Liftable repr => Applicable (Unlift repr) =>
45 Hask.Haskell a -> repr a
46 pure = lift . pure
47
48 -- | @(ra2b '<*>' ra)@ parses sequentially @(ra2b)@ and then @(ra)@, and returns the application of the function returned by @(ra2b)@ to the value returned by @(ra)@.
49 (<*>) :: repr (a -> b) -> repr a -> repr b
50 default (<*>) ::
51 Liftable repr => Applicable (Unlift repr) =>
52 repr (a -> b) -> repr a -> repr b
53 (<*>) = lift2 (<*>)
54
55 -- | @('liftA2' a2b2c ra rb)@ parses sequentially @(ra)@ and then @(rb)@, and returns the application of @(a2b2c)@ to the values returned by those parsers.
56 liftA2 :: Hask.Haskell (a -> b -> c) -> repr a -> repr b -> repr c
57 liftA2 f x = (<*>) (f <$> x)
58
59 -- | @(ra '<*' rb)@ parses sequentially @(ra)@ and then @(rb)@, and returns like @(ra)@, discarding the return value of @(rb)@.
60 (<*) :: repr a -> repr b -> repr a
61 (<*) = liftA2 Hask.const
62
63 -- | @(ra '*>' rb)@ parses sequentially @(ra)@ and then @(rb)@, and returns like @(rb)@, discarding the return value of @(ra)@.
64 (*>) :: repr a -> repr b -> repr b
65 x *> y = (Hask.id <$ x) <*> y
66
67 -- | Like '<*>' but with its arguments 'flip'-ped.
68 (<**>) :: repr a -> repr (a -> b) -> repr b
69 (<**>) = liftA2 (Hask.flip Hask..@ (Hask.$))
70 {-
71 (<**>) :: repr a -> repr (a -> b) -> repr b
72 (<**>) = liftA2 (\a f -> f a)
73 -}
74 infixl 4 <$>, <&>, <$, $>, <*>, <*, *>, <**>
75
76 -- * Class 'Alternable'
77 class Alternable repr where
78 -- | @(rl '<|>' rr)@ parses @(rl)@ and return its return value or, if it fails, parses @(rr)@ from where @(rl)@ has left the input stream, and returns its return value.
79 (<|>) :: repr a -> repr a -> repr a
80 -- | @(empty)@ parses nothing, always failing to return a value.
81 empty :: repr a
82 -- | @('try' ra)@ records the input stream position, then parses like @(ra)@ and either returns its value it it succeeds or fails if it fails but with a reset of the input stream to the recorded position.
83 -- Generally used on the first alternative: @('try' rl '<|>' rr)@.
84 try :: repr a -> repr a
85 default (<|>) ::
86 Liftable repr => Alternable (Unlift repr) =>
87 repr a -> repr a -> repr a
88 default empty ::
89 Liftable repr => Alternable (Unlift repr) =>
90 repr a
91 default try ::
92 Liftable repr => Alternable (Unlift repr) =>
93 repr a -> repr a
94 (<|>) = lift2 (<|>)
95 empty = lift empty
96 try = lift1 try
97 -- | Like @('<|>')@ but with different returning types for the alternatives, and a return value wrapped in an 'Either' accordingly.
98 (<+>) :: Applicable repr => Alternable repr => repr a -> repr b -> repr (Either a b)
99 p <+> q = Hask.left <$> p <|> Hask.right <$> q
100 infixl 3 <|>, <+>
101
102 optionally :: Applicable repr => Alternable repr => repr a -> Hask.Haskell b -> repr b
103 optionally p x = p $> x <|> pure x
104
105 optional :: Applicable repr => Alternable repr => repr a -> repr ()
106 optional = flip optionally Hask.unit
107
108 option :: Applicable repr => Alternable repr => Hask.Haskell a -> repr a -> repr a
109 option x p = p <|> pure x
110
111 choice :: Alternable repr => [repr a] -> repr a
112 choice = List.foldr (<|>) empty
113 -- FIXME: Here hlint suggests to use Data.Foldable.asum,
114 -- but at this point there is no asum for our own (<|>)
115
116 maybeP :: Applicable repr => Alternable repr => repr a -> repr (Maybe a)
117 maybeP p = option Hask.nothing (Hask.just <$> p)
118
119 manyTill :: Applicable repr => Alternable repr => repr a -> repr b -> repr [a]
120 manyTill p end = let go = end $> Hask.nil <|> p <:> go in go
121
122 -- * Class 'Selectable'
123 class Selectable repr where
124 branch :: repr (Either a b) -> repr (a -> c) -> repr (b -> c) -> repr c
125 default branch ::
126 Liftable repr => Selectable (Unlift repr) =>
127 repr (Either a b) -> repr (a -> c) -> repr (b -> c) -> repr c
128 branch = lift3 branch
129
130 class Matchable repr where
131 conditional ::
132 Eq a => [Hask.Haskell (a -> Bool)] -> [repr b] -> repr a -> repr b -> repr b
133 default conditional ::
134 Unliftable repr => Liftable repr => Matchable (Unlift repr) =>
135 Eq a => [Hask.Haskell (a -> Bool)] -> [repr b] -> repr a -> repr b -> repr b
136 conditional cs bs = lift2 (conditional cs (unlift Pre.<$> bs))
137
138 match :: Eq a => [Hask.Haskell a] -> repr a -> (Hask.Haskell a -> repr b) -> repr b -> repr b
139 match as a a2b = conditional (Hask.eq Pre.<$> as) (a2b Pre.<$> as) a
140
141 -- * Class 'Foldable'
142 class Foldable repr where
143 chainPre :: repr (a -> a) -> repr a -> repr a
144 chainPost :: repr a -> repr (a -> a) -> repr a
145 default chainPre ::
146 Liftable repr => Foldable (Unlift repr) =>
147 repr (a -> a) -> repr a -> repr a
148 default chainPost ::
149 Liftable repr => Foldable (Unlift repr) =>
150 repr a -> repr (a -> a) -> repr a
151 chainPre = lift2 chainPre
152 chainPost = lift2 chainPost
153
154 {-
155 conditional :: Selectable repr => [(Hask.Haskell (a -> Bool), repr b)] -> repr a -> repr b -> repr b
156 conditional cs p def = match p fs qs def
157 where (fs, qs) = List.unzip cs
158 -}
159
160 -- * Class 'Charable'
161 class Charable repr where
162 satisfy :: Hask.Haskell (Char -> Bool) -> repr Char
163 default satisfy ::
164 Liftable repr => Charable (Unlift repr) =>
165 Hask.Haskell (Char -> Bool) -> repr Char
166 satisfy = lift . satisfy
167
168 -- * Class 'Lookable'
169 class Lookable repr where
170 look :: repr a -> repr a
171 negLook :: repr a -> repr ()
172 default look :: Liftable repr => Lookable (Unlift repr) => repr a -> repr a
173 default negLook :: Liftable repr => Lookable (Unlift repr) => repr a -> repr ()
174 look = lift1 look
175 negLook = lift1 negLook
176
177 {-# INLINE (<:>) #-}
178 infixl 4 <:>
179 (<:>) :: Applicable repr => repr a -> repr [a] -> repr [a]
180 (<:>) = liftA2 Hask.cons
181
182 sequence :: Applicable repr => [repr a] -> repr [a]
183 sequence = List.foldr (<:>) (pure Hask.nil)
184
185 traverse :: Applicable repr => (a -> repr b) -> [a] -> repr [b]
186 traverse f = sequence . List.map f
187 -- FIXME: Here hlint suggests to use Control.Monad.mapM,
188 -- but at this point there is no mapM for our own sequence
189
190 repeat :: Applicable repr => Int -> repr a -> repr [a]
191 repeat n p = traverse (const p) [1..n]
192
193 between :: Applicable repr => repr o -> repr c -> repr a -> repr a
194 between open close p = open *> p <* close
195
196 string :: Applicable repr => Charable repr => String -> repr String
197 string = traverse char
198
199 -- oneOf :: [Char] -> repr Char
200 -- oneOf cs = satisfy (makeQ (flip elem cs) [||\c -> $$(ofChars cs [||c||])||])
201
202 noneOf :: Charable repr => String -> repr Char
203 noneOf cs = satisfy (Hask.Haskell Hask.ValueCode{..})
204 where
205 value = Hask.Value (not . flip List.elem cs)
206 code = Hask.Code [||\c -> not $$(ofChars cs [||c||])||]
207
208 ofChars :: String -> TExpQ Char -> TExpQ Bool
209 ofChars = List.foldr (\c rest qc -> [|| c == $$qc || $$(rest qc) ||]) (const [||False||])
210
211 token :: Applicable repr => Alternable repr => Charable repr => String -> repr String
212 token = try . string
213
214 eof :: Charable repr => Lookable repr => repr ()
215 eof = negLook item
216
217 more :: Applicable repr => Charable repr => Lookable repr => repr ()
218 more = look (void item)
219
220 char :: Applicable repr => Charable repr => Char -> repr Char
221 char c = satisfy (Hask.eq (Hask.char c)) $> Hask.char c
222
223 item :: Charable repr => repr Char
224 item = satisfy (Hask.const Hask..@ Hask.bool True)
225
226 -- Composite Combinators
227 -- someTill :: repr a -> repr b -> repr [a]
228 -- someTill p end = negLook end *> (p <:> manyTill p end)
229
230 void :: Applicable repr => repr a -> repr ()
231 void p = p *> unit
232
233 unit :: Applicable repr => repr ()
234 unit = pure Hask.unit
235
236 {-
237
238 constp :: Applicable repr => repr a -> repr (b -> a)
239 constp = (Hask.const <$>)
240
241
242 -- Alias Operations
243 infixl 1 >>
244 (>>) :: Applicable repr => repr a -> repr b -> repr b
245 (>>) = (*>)
246
247 -- Monoidal Operations
248
249 infixl 4 <~>
250 (<~>) :: Applicable repr => repr a -> repr b -> repr (a, b)
251 (<~>) = liftA2 (Hask.runtime (,))
252
253 infixl 4 <~
254 (<~) :: Applicable repr => repr a -> repr b -> repr a
255 (<~) = (<*)
256
257 infixl 4 ~>
258 (~>) :: Applicable repr => repr a -> repr b -> repr b
259 (~>) = (*>)
260
261 -- Lift Operations
262 liftA2 ::
263 Applicable repr =>
264 Hask.Haskell (a -> b -> c) -> repr a -> repr b -> repr c
265 liftA2 f x = (<*>) (fmap f x)
266
267 liftA3 ::
268 Applicable repr =>
269 Hask.Haskell (a -> b -> c -> d) -> repr a -> repr b -> repr c -> repr d
270 liftA3 f a b c = liftA2 f a b <*> c
271
272 -}
273
274 -- Parser Folds
275 pfoldr ::
276 Applicable repr => Foldable repr =>
277 Hask.Haskell (a -> b -> b) -> Hask.Haskell b -> repr a -> repr b
278 pfoldr f k p = chainPre (f <$> p) (pure k)
279
280 pfoldr1 ::
281 Applicable repr => Foldable repr =>
282 Hask.Haskell (a -> b -> b) -> Hask.Haskell b -> repr a -> repr b
283 pfoldr1 f k p = f <$> p <*> pfoldr f k p
284
285 pfoldl ::
286 Applicable repr => Foldable repr =>
287 Hask.Haskell (b -> a -> b) -> Hask.Haskell b -> repr a -> repr b
288 pfoldl f k p = chainPost (pure k) ((Hask.flip <$> pure f) <*> p)
289
290 pfoldl1 ::
291 Applicable repr => Foldable repr =>
292 Hask.Haskell (b -> a -> b) -> Hask.Haskell b -> repr a -> repr b
293 pfoldl1 f k p = chainPost (f <$> pure k <*> p) ((Hask.flip <$> pure f) <*> p)
294
295 -- Chain Combinators
296 chainl1' ::
297 Applicable repr => Foldable repr =>
298 Hask.Haskell (a -> b) -> repr a -> repr (b -> a -> b) -> repr b
299 chainl1' f p op = chainPost (f <$> p) (Hask.flip <$> op <*> p)
300
301 chainl1 ::
302 Applicable repr => Foldable repr =>
303 repr a -> repr (a -> a -> a) -> repr a
304 chainl1 = chainl1' Hask.id
305
306 {-
307 chainr1' :: ParserOps rep => rep (a -> b) -> repr a -> repr (a -> b -> b) -> repr b
308 chainr1' f p op = newRegister_ Hask.id $ \acc ->
309 let go = bind p $ \x ->
310 modify acc (Hask.flip (Hask..@) <$> (op <*> x)) *> go
311 <|> f <$> x
312 in go <**> get acc
313
314 chainr1 :: repr a -> repr (a -> a -> a) -> repr a
315 chainr1 = chainr1' Hask.id
316
317 chainr :: repr a -> repr (a -> a -> a) -> Hask.Haskell a -> repr a
318 chainr p op x = option x (chainr1 p op)
319 -}
320
321 chainl ::
322 Applicable repr => Alternable repr => Foldable repr =>
323 repr a -> repr (a -> a -> a) -> Hask.Haskell a -> repr a
324 chainl p op x = option x (chainl1 p op)
325
326 -- Derived Combinators
327 many ::
328 Applicable repr => Foldable repr =>
329 repr a -> repr [a]
330 many = pfoldr Hask.cons Hask.nil
331
332 manyN ::
333 Applicable repr => Foldable repr =>
334 Int -> repr a -> repr [a]
335 manyN n p = List.foldr (const (p <:>)) (many p) [1..n]
336
337 some ::
338 Applicable repr => Foldable repr =>
339 repr a -> repr [a]
340 some = manyN 1
341
342 skipMany ::
343 Applicable repr => Foldable repr =>
344 repr a -> repr ()
345 --skipMany p = let skipManyp = p *> skipManyp <|> unit in skipManyp
346 skipMany = void . pfoldl Hask.const Hask.unit -- the void here will encourage the optimiser to recognise that the register is unused
347
348 skipManyN ::
349 Applicable repr => Foldable repr =>
350 Int -> repr a -> repr ()
351 skipManyN n p = List.foldr (const (p *>)) (skipMany p) [1..n]
352
353 skipSome ::
354 Applicable repr => Foldable repr =>
355 repr a -> repr ()
356 skipSome = skipManyN 1
357
358 sepBy ::
359 Applicable repr => Alternable repr => Foldable repr =>
360 repr a -> repr b -> repr [a]
361 sepBy p sep = option Hask.nil (sepBy1 p sep)
362
363 sepBy1 ::
364 Applicable repr => Alternable repr => Foldable repr =>
365 repr a -> repr b -> repr [a]
366 sepBy1 p sep = p <:> many (sep *> p)
367
368 endBy ::
369 Applicable repr => Alternable repr => Foldable repr =>
370 repr a -> repr b -> repr [a]
371 endBy p sep = many (p <* sep)
372
373 endBy1 ::
374 Applicable repr => Alternable repr => Foldable repr =>
375 repr a -> repr b -> repr [a]
376 endBy1 p sep = some (p <* sep)
377
378 sepEndBy ::
379 Applicable repr => Alternable repr => Foldable repr =>
380 repr a -> repr b -> repr [a]
381 sepEndBy p sep = option Hask.nil (sepEndBy1 p sep)
382
383 sepEndBy1 ::
384 Applicable repr => Alternable repr => Foldable repr =>
385 repr a -> repr b -> repr [a]
386 sepEndBy1 p sep =
387 let seb1 = p <**> (sep *> (Hask.flip Hask..@ Hask.cons <$> option Hask.nil seb1)
388 <|> pure (Hask.flip Hask..@ Hask.cons Hask..@ Hask.nil))
389 in seb1
390
391 {-
392 sepEndBy1 :: repr a -> repr b -> repr [a]
393 sepEndBy1 p sep = newRegister_ Hask.id $ \acc ->
394 let go = modify acc ((Hask.flip (Hask..)) Hask..@ Hask.cons <$> p)
395 *> (sep *> (go <|> get acc) <|> get acc)
396 in go <*> pure Hask.nil
397 -}