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