]> Git — Sourcephile - haskell/symantic-parser.git/blob - src/Symantic/Parser/Grammar/Combinators.hs
grammar: add precedence to showCode
[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 DeriveGeneric #-} -- For NFData instances
9 {-# LANGUAGE DeriveAnyClass #-} -- For NFData instances
10 {-# LANGUAGE DeriveLift #-} -- For TH.Lift (Exception tok)
11 {-# LANGUAGE PatternSynonyms #-} -- For Failure
12 {-# LANGUAGE StandaloneDeriving #-} -- For Show (Exception (InputToken inp))
13 {-# LANGUAGE InstanceSigs #-}
14 {-# LANGUAGE TemplateHaskell #-}
15 {-# LANGUAGE ViewPatterns #-} -- For unSomeFailure
16 -- | Semantic of the grammar combinators used to express parsers,
17 -- in the convenient tagless-final encoding.
18 module Symantic.Parser.Grammar.Combinators where
19
20 import Data.Proxy (Proxy(..))
21 import Control.Monad (Monad(..))
22 import Control.DeepSeq (NFData(..))
23 import GHC.Generics (Generic)
24 -- import Data.Set (Set)
25 -- import GHC.TypeLits (KnownSymbol)
26 import Data.Bool (Bool(..), not, (||))
27 import Data.Char (Char)
28 import Data.Either (Either(..))
29 import Data.Eq (Eq(..))
30 import Data.Ord (Ord(..))
31 import Data.Function ((.), flip, const)
32 import Data.Int (Int)
33 import Data.Kind (Type, Constraint)
34 import Data.Maybe (Maybe(..))
35 import Data.Set (Set)
36 import Data.String (String)
37 import Text.Show (Show(..))
38 import Type.Reflection (Typeable, typeRep, eqTypeRep, (:~~:)(..), SomeTypeRep(..))
39 import qualified Data.Functor as Functor
40 import qualified Data.List as List
41 import qualified Data.Set as Set
42 import qualified Language.Haskell.TH as TH
43 import qualified Language.Haskell.TH.Syntax as TH
44
45 import qualified Symantic.Typed.Trans as Sym
46 import qualified Symantic.Typed.Lang as Prod
47 import Symantic.Parser.Grammar.Production
48
49 -- * Type 'ReprComb'
50 type ReprComb = Type -> Type
51
52 -- * Class 'CombAlternable'
53 class CombAlternable repr where
54 -- | @('alt' es l r)@ parses @(l)@ and return its return value or,
55 -- if it fails with an 'Exception' within @(es)@,
56 -- parses @(r)@ from where @(l)@ has left the input stream,
57 -- and returns its return value,
58 -- otherwise throw the 'Exception' again.
59 alt :: Exception -> repr a -> repr a -> repr a
60 throw :: ExceptionLabel -> repr a
61 -- | @('try' ra)@ records the input stream position,
62 -- then parses like @(ra)@ and either returns its value it it succeeds or fails
63 -- if it fails but with a reset of the input stream to the recorded position.
64 -- Generally used on the first alternative: @('try' rl '<|>' rr)@.
65 try :: repr a -> repr a
66 default alt ::
67 Sym.Liftable2 repr => CombAlternable (Sym.Output repr) =>
68 Exception -> repr a -> repr a -> repr a
69 default throw ::
70 Sym.Liftable repr => CombAlternable (Sym.Output repr) =>
71 ExceptionLabel -> repr a
72 default try ::
73 Sym.Liftable1 repr => CombAlternable (Sym.Output repr) =>
74 repr a -> repr a
75 alt = Sym.lift2 . alt
76 throw = Sym.lift . throw
77 try = Sym.lift1 try
78
79 failure :: SomeFailure -> repr a
80 default failure ::
81 Sym.Liftable repr => CombAlternable (Sym.Output repr) =>
82 SomeFailure -> repr a
83 failure = Sym.lift . failure
84
85 -- | @(empty)@ parses nothing, always failing to return a value.
86 empty :: repr a
87 empty = failure (SomeFailure FailureEmpty)
88
89 data instance Failure CombAlternable
90 = FailureEmpty
91 deriving (Eq, Ord, Show, TH.Lift, Generic, NFData)
92
93 -- ** Data family 'Failure'
94 -- | 'Failure's of the 'Grammar'.
95 -- This is an extensible data-type.
96 data family Failure
97 (comb :: ReprComb -> Constraint)
98 :: Type
99
100 {-
101 -- | Convenient utility to pattern-match a 'SomeFailure'.
102 pattern Failure :: Typeable comb => Failure comb -> SomeFailure
103 pattern Failure x <- (unSomeFailure -> Just x)
104 -}
105
106 -- ** Type 'SomeFailure'
107 data SomeFailure =
108 forall comb.
109 ({-Trans (Failure comb repr) repr,-}
110 Eq (Failure comb)
111 , Show (Failure comb)
112 , TH.Lift (Failure comb)
113 , NFData (Failure comb)
114 , Typeable comb
115 ) =>
116 SomeFailure (Failure comb {-repr a-})
117 instance Eq SomeFailure where
118 SomeFailure (_x::Failure x) == SomeFailure (_y::Failure y) =
119 case typeRep @x `eqTypeRep` typeRep @y of
120 Just HRefl -> True
121 Nothing -> False
122 instance Ord SomeFailure where
123 SomeFailure (_x::Failure x) `compare` SomeFailure (_y::Failure y) =
124 SomeTypeRep (typeRep @x) `compare`
125 SomeTypeRep (typeRep @y)
126 instance Show SomeFailure where
127 showsPrec p (SomeFailure x) = showsPrec p x
128 instance TH.Lift SomeFailure where
129 liftTyped (SomeFailure x) = [|| SomeFailure $$(TH.liftTyped x) ||]
130 instance NFData SomeFailure where
131 rnf (SomeFailure x) = rnf x
132
133 {-
134 instance Trans (SomeFailure repr) repr where
135 trans (SomeFailure x) = trans x
136 -}
137
138 -- | @(unSomeFailure c :: 'Maybe' ('Failure' comb repr a))@
139 -- extract the data-constructor from the given 'SomeFailure'
140 -- iif. it belongs to the @('Failure' comb repr a)@ data-instance.
141 unSomeFailure :: forall comb. Typeable comb => SomeFailure -> Maybe (Failure comb)
142 unSomeFailure (SomeFailure (c::Failure c)) =
143 case typeRep @comb `eqTypeRep` typeRep @c of
144 Just HRefl -> Just c
145 Nothing -> Nothing
146
147 -- ** Type 'Exception'
148 data Exception
149 = ExceptionLabel ExceptionLabel
150 | ExceptionFailure
151 deriving (Eq, Ord, Show, TH.Lift, Generic, NFData)
152 type ExceptionLabel = String
153 -- type Exceptions = Set Exception
154
155 -- | Like @('<|>')@ but with different returning types for the alternatives,
156 -- and a return value wrapped in an 'Either' accordingly.
157 (<+>) :: CombApplicable repr => CombAlternable repr => repr a -> repr b -> repr (Either a b)
158 p <+> q = Prod.left <$> p <|> Prod.right <$> q
159
160 (<|>) :: CombAlternable repr => repr a -> repr a -> repr a
161 (<|>) = alt ExceptionFailure
162
163 infixl 3 <|>, <+>
164
165 optionally :: CombApplicable repr => CombAlternable repr => repr a -> Production b -> repr b
166 optionally p x = p $> x <|> pure x
167
168 optional :: CombApplicable repr => CombAlternable repr => repr a -> repr ()
169 optional = flip optionally Prod.unit
170
171 option :: CombApplicable repr => CombAlternable repr => Production a -> repr a -> repr a
172 option x p = p <|> pure x
173
174 choice :: CombAlternable repr => [repr a] -> repr a
175 choice = List.foldr (<|>) empty
176 -- FIXME: Here hlint suggests to use Data.Foldable.asum,
177 -- but at this point there is no asum for our own (<|>)
178
179 maybeP :: CombApplicable repr => CombAlternable repr => repr a -> repr (Maybe a)
180 maybeP p = option Prod.nothing (Prod.just <$> p)
181
182 manyTill :: CombApplicable repr => CombAlternable repr => repr a -> repr b -> repr [a]
183 manyTill p end = let go = end $> Prod.nil <|> p <:> go in go
184
185 -- * Class 'CombApplicable'
186 -- | This is like the usual 'Functor' and 'Applicative' type classes
187 -- from the @base@ package, but using @('Production' a)@ instead of just @(a)@
188 -- to be able to use and pattern match on some usual terms of type @(a)@ (like 'Prod.id')
189 -- and thus apply some optimizations.
190 -- @(repr)@, for "representation", is the usual tagless-final abstraction
191 -- over the many semantics that this syntax (formed by the methods
192 -- of type class like this one) will be interpreted.
193 class CombApplicable repr where
194 -- | @(a2b '<$>' ra)@ parses like @(ra)@ but maps its returned value with @(a2b)@.
195 (<$>) :: Production (a -> b) -> repr a -> repr b
196 (<$>) f = (pure f <*>)
197 (<$>%) :: (Production a -> Production b) -> repr a -> repr b
198 a2b <$>% ma = Prod.lam a2b <$> ma
199
200 -- | Like '<$>' but with its arguments 'flip'-ped.
201 (<&>) :: repr a -> Production (a -> b) -> repr b
202 (<&>) = flip (<$>)
203
204 -- | @(a '<$' rb)@ parses like @(rb)@ but discards its returned value by replacing it with @(a)@.
205 (<$) :: Production a -> repr b -> repr a
206 (<$) x = (pure x <*)
207
208 -- | @(ra '$>' b)@ parses like @(ra)@ but discards its returned value by replacing it with @(b)@.
209 ($>) :: repr a -> Production b -> repr b
210 ($>) = flip (<$)
211
212 -- | @('pure' a)@ parses the empty string, always succeeding in returning @(a)@.
213 pure :: Production a -> repr a
214 default pure ::
215 Sym.Liftable repr => CombApplicable (Sym.Output repr) =>
216 Production a -> repr a
217 pure = Sym.lift . pure
218
219 -- | @(ra2b '<*>' ra)@ parses sequentially @(ra2b)@ and then @(ra)@,
220 -- and returns the application of the function returned by @(ra2b)@
221 -- to the value returned by @(ra)@.
222 (<*>) :: repr (a -> b) -> repr a -> repr b
223 default (<*>) ::
224 Sym.Liftable2 repr => CombApplicable (Sym.Output repr) =>
225 repr (a -> b) -> repr a -> repr b
226 (<*>) = Sym.lift2 (<*>)
227
228 -- | @(ra '<*' rb)@ parses sequentially @(ra)@ and then @(rb)@,
229 -- and returns like @(ra)@, discarding the return value of @(rb)@.
230 (<*) :: repr a -> repr b -> repr a
231 (<*) = liftA2 Prod.const
232
233 -- | @(ra '*>' rb)@ parses sequentially @(ra)@ and then @(rb)@,
234 -- and returns like @(rb)@, discarding the return value of @(ra)@.
235 (*>) :: repr a -> repr b -> repr b
236 x *> y = (Prod.id <$ x) <*> y
237
238 -- | Like '<*>' but with its arguments 'flip'-ped.
239 (<**>) :: repr a -> repr (a -> b) -> repr b
240 (<**>) = liftA2 (Prod.flip Prod..@ (Prod.$))
241 {-
242 (<**>) :: repr a -> repr (a -> b) -> repr b
243 (<**>) = liftA2 (\a f -> f a)
244 -}
245 -- | @('liftA2' a2b2c ra rb)@ parses sequentially @(ra)@ and then @(rb)@,
246 -- and returns the application of @(a2b2c)@ to the values returned by those parsers.
247 liftA2 :: Production (a -> b -> c) -> repr a -> repr b -> repr c
248 liftA2 f x = (<*>) (f <$> x)
249
250 infixl 4 <*>, <*, *>, <**>
251 data instance Failure CombApplicable
252
253
254 {-# INLINE (<:>) #-}
255 infixl 4 <:>
256 (<:>) :: CombApplicable repr => repr a -> repr [a] -> repr [a]
257 (<:>) = liftA2 Prod.cons
258
259 sequence :: CombApplicable repr => [repr a] -> repr [a]
260 sequence = List.foldr (<:>) (pure Prod.nil)
261
262 traverse :: CombApplicable repr => (a -> repr b) -> [a] -> repr [b]
263 traverse f = sequence . List.map f
264 -- FIXME: Here hlint suggests to use Control.Monad.mapM,
265 -- but at this point there is no mapM for our own sequence
266
267 repeat :: CombApplicable repr => Int -> repr a -> repr [a]
268 repeat n p = traverse (const p) [1..n]
269
270 between :: CombApplicable repr => repr o -> repr c -> repr a -> repr a
271 between open close p = open *> p <* close
272
273 void :: CombApplicable repr => repr a -> repr ()
274 void p = p *> unit
275
276 unit :: CombApplicable repr => repr ()
277 unit = pure Prod.unit
278
279 -- * Class 'CombFoldable'
280 class CombFoldable repr where
281 chainPre :: repr (a -> a) -> repr a -> repr a
282 chainPost :: repr a -> repr (a -> a) -> repr a
283 {-
284 default chainPre ::
285 Sym.Liftable2 repr => CombFoldable (Sym.Output repr) =>
286 repr (a -> a) -> repr a -> repr a
287 default chainPost ::
288 Sym.Liftable2 repr => CombFoldable (Sym.Output repr) =>
289 repr a -> repr (a -> a) -> repr a
290 chainPre = Sym.lift2 chainPre
291 chainPost = Sym.lift2 chainPost
292 -}
293 default chainPre ::
294 CombApplicable repr =>
295 CombAlternable repr =>
296 repr (a -> a) -> repr a -> repr a
297 default chainPost ::
298 CombApplicable repr =>
299 CombAlternable repr =>
300 repr a -> repr (a -> a) -> repr a
301 chainPre op p = go <*> p where go = (Prod..) <$> op <*> go <|> pure Prod.id
302 chainPost p op = p <**> go where go = (Prod..) <$> op <*> go <|> pure Prod.id
303 {-
304 chainPre op p = flip (foldr ($)) <$> many op <*> p
305 chainPost p op = foldl' (flip ($)) <$> p <*> many op
306 -}
307 data instance Failure CombFoldable
308
309 {-
310 conditional :: CombSelectable repr => [(Production (a -> Bool), repr b)] -> repr a -> repr b -> repr b
311 conditional cs p def = match p fs qs def
312 where (fs, qs) = List.unzip cs
313 -}
314
315 -- Parser Folds
316 pfoldr ::
317 CombApplicable repr => CombFoldable repr =>
318 Production (a -> b -> b) -> Production b -> repr a -> repr b
319 pfoldr f k p = chainPre (f <$> p) (pure k)
320
321 pfoldr1 ::
322 CombApplicable repr => CombFoldable repr =>
323 Production (a -> b -> b) -> Production b -> repr a -> repr b
324 pfoldr1 f k p = f <$> p <*> pfoldr f k p
325
326 pfoldl ::
327 CombApplicable repr => CombFoldable repr =>
328 Production (b -> a -> b) -> Production b -> repr a -> repr b
329 pfoldl f k p = chainPost (pure k) ((Prod.flip <$> pure f) <*> p)
330
331 pfoldl1 ::
332 CombApplicable repr => CombFoldable repr =>
333 Production (b -> a -> b) -> Production b -> repr a -> repr b
334 pfoldl1 f k p = chainPost (f <$> pure k <*> p) ((Prod.flip <$> pure f) <*> p)
335
336 -- Chain Combinators
337 chainl1' ::
338 CombApplicable repr => CombFoldable repr =>
339 Production (a -> b) -> repr a -> repr (b -> a -> b) -> repr b
340 chainl1' f p op = chainPost (f <$> p) (Prod.flip <$> op <*> p)
341
342 chainl1 ::
343 CombApplicable repr => CombFoldable repr =>
344 repr a -> repr (a -> a -> a) -> repr a
345 chainl1 = chainl1' Prod.id
346
347 {-
348 chainr1' :: ParserOps rep => rep (a -> b) -> repr a -> repr (a -> b -> b) -> repr b
349 chainr1' f p op = newRegister_ Prod.id $ \acc ->
350 let go = bind p $ \x ->
351 modify acc (Prod.flip (Prod..@) <$> (op <*> x)) *> go
352 <|> f <$> x
353 in go <**> get acc
354
355 chainr1 :: repr a -> repr (a -> a -> a) -> repr a
356 chainr1 = chainr1' Prod.id
357
358 chainr :: repr a -> repr (a -> a -> a) -> Production a -> repr a
359 chainr p op x = option x (chainr1 p op)
360 -}
361
362 chainl ::
363 CombApplicable repr => CombAlternable repr => CombFoldable repr =>
364 repr a -> repr (a -> a -> a) -> Production a -> repr a
365 chainl p op x = option x (chainl1 p op)
366
367 -- Derived Combinators
368 many ::
369 CombApplicable repr => CombFoldable repr =>
370 repr a -> repr [a]
371 many = pfoldr Prod.cons Prod.nil
372
373 manyN ::
374 CombApplicable repr => CombFoldable repr =>
375 Int -> repr a -> repr [a]
376 manyN n p = List.foldr (const (p <:>)) (many p) [1..n]
377
378 some ::
379 CombApplicable repr => CombFoldable repr =>
380 repr a -> repr [a]
381 some = manyN 1
382
383 skipMany ::
384 CombApplicable repr => CombFoldable repr =>
385 repr a -> repr ()
386 --skipMany p = let skipManyp = p *> skipManyp <|> unit in skipManyp
387 skipMany = void . pfoldl Prod.const Prod.unit -- the void here will encourage the optimiser to recognise that the register is unused
388
389 skipManyN ::
390 CombApplicable repr => CombFoldable repr =>
391 Int -> repr a -> repr ()
392 skipManyN n p = List.foldr (const (p *>)) (skipMany p) [1..n]
393
394 skipSome ::
395 CombApplicable repr => CombFoldable repr =>
396 repr a -> repr ()
397 skipSome = skipManyN 1
398
399 sepBy ::
400 CombApplicable repr => CombAlternable repr => CombFoldable repr =>
401 repr a -> repr b -> repr [a]
402 sepBy p sep = option Prod.nil (sepBy1 p sep)
403
404 sepBy1 ::
405 CombApplicable repr => CombAlternable repr => CombFoldable repr =>
406 repr a -> repr b -> repr [a]
407 sepBy1 p sep = p <:> many (sep *> p)
408
409 endBy ::
410 CombApplicable repr => CombAlternable repr => CombFoldable repr =>
411 repr a -> repr b -> repr [a]
412 endBy p sep = many (p <* sep)
413
414 endBy1 ::
415 CombApplicable repr => CombAlternable repr => CombFoldable repr =>
416 repr a -> repr b -> repr [a]
417 endBy1 p sep = some (p <* sep)
418
419 sepEndBy ::
420 CombApplicable repr => CombAlternable repr => CombFoldable repr =>
421 repr a -> repr b -> repr [a]
422 sepEndBy p sep = option Prod.nil (sepEndBy1 p sep)
423
424 sepEndBy1 ::
425 CombApplicable repr => CombAlternable repr => CombFoldable repr =>
426 repr a -> repr b -> repr [a]
427 sepEndBy1 p sep =
428 let seb1 = p <**> (sep *> (Prod.flip Prod..@ Prod.cons <$> option Prod.nil seb1)
429 <|> pure (Prod.flip Prod..@ Prod.cons Prod..@ Prod.nil))
430 in seb1
431
432 {-
433 sepEndBy1 :: repr a -> repr b -> repr [a]
434 sepEndBy1 p sep = newRegister_ Prod.id $ \acc ->
435 let go = modify acc ((Prod.flip (Prod..)) Prod..@ Prod.cons <$> p)
436 *> (sep *> (go <|> get acc) <|> get acc)
437 in go <*> pure Prod.nil
438 -}
439
440 -- * Class 'CombMatchable'
441 class CombMatchable repr where
442 conditional ::
443 Eq a => repr a -> [Production (a -> Bool)] -> [repr b] -> repr b -> repr b
444 default conditional ::
445 Sym.Unliftable repr => Sym.Liftable1 repr => CombMatchable (Sym.Output repr) =>
446 Eq a => repr a -> [Production (a -> Bool)] -> [repr b] -> repr b -> repr b
447 conditional a ps bs = Sym.lift1 (conditional (Sym.unlift a) ps (Sym.unlift Functor.<$> bs))
448
449 match :: Eq a => repr a -> [Production a] -> (Production a -> repr b) -> repr b -> repr b
450 match a as a2b = conditional a ((Prod.equal Prod..@) Functor.<$> as) (a2b Functor.<$> as)
451 -- match a as a2b = conditional a (((Prod.eq Prod..@ Prod.qual) Prod..@) Functor.<$> as) (a2b Functor.<$> as)
452 data instance Failure CombMatchable
453
454 -- * Class 'CombSatisfiable'
455 class CombSatisfiable tok repr where
456 -- | Like 'satisfyOrFail' but with no custom failure.
457 satisfy :: Production (tok -> Bool) -> repr tok
458 satisfy = satisfyOrFail Set.empty
459 -- | Like 'satisfy' but with a custom set of 'SomeFailure's.
460 satisfyOrFail ::
461 Set SomeFailure ->
462 Production (tok -> Bool) -> repr tok
463 default satisfyOrFail ::
464 Sym.Liftable repr => CombSatisfiable tok (Sym.Output repr) =>
465 Set SomeFailure ->
466 Production (tok -> Bool) -> repr tok
467 satisfyOrFail fs = Sym.lift . satisfyOrFail fs
468
469 data instance Failure (CombSatisfiable tok)
470 = FailureAny
471 | FailureHorizon Int -- FIXME: use Natural?
472 | FailureLabel String
473 | FailureToken tok
474 deriving (Eq, Show, Typeable, Generic, NFData)
475 -- | Global 'TH.Name' to refer to the @(InputToken inp)@ type
476 -- from TemplateHaskell code.
477 inputTokenProxy :: TH.Name
478 inputTokenProxy = TH.mkName "inputToken"
479 instance TH.Lift tok => TH.Lift (Failure (CombSatisfiable tok)) where
480 liftTyped :: forall m. TH.Quote m => Failure (CombSatisfiable tok) -> TH.Code m (Failure (CombSatisfiable tok))
481 liftTyped x = [||
482 case
483 $$(let inputToken :: TH.Code m (Proxy tok) =
484 TH.unsafeCodeCoerce (return (TH.VarE inputTokenProxy))
485 in inputToken) of
486 (Proxy :: Proxy tok') ->
487 $$(case x of
488 FailureAny -> [|| FailureAny @tok' ||]
489 FailureHorizon h -> [|| FailureHorizon @tok' h ||]
490 FailureLabel lbl -> [|| FailureLabel @tok' lbl ||]
491 FailureToken tok -> [|| FailureToken $$(TH.liftTyped tok) ||]
492 )
493 ||]
494
495 char ::
496 CombApplicable repr =>
497 CombSatisfiable Char repr =>
498 Char -> repr Char
499 char c = satisfyOrFail
500 (Set.singleton (SomeFailure (FailureToken c)))
501 ((Prod.equal Prod..@ Prod.char c))
502 $> Prod.char c
503
504 item :: forall tok repr.
505 Eq tok => Show tok => Typeable tok => TH.Lift tok => NFData tok =>
506 CombSatisfiable tok repr => repr tok
507 item = satisfyOrFail
508 (Set.singleton (SomeFailure (FailureAny @tok)))
509 (Prod.const Prod..@ Prod.bool True)
510
511 anyChar ::
512 CombAlternable repr =>
513 CombSatisfiable Char repr =>
514 repr Char
515 anyChar = item
516
517 string ::
518 CombApplicable repr => CombAlternable repr =>
519 CombSatisfiable Char repr =>
520 [Char] -> repr [Char]
521 string = try . traverse char
522
523 oneOf ::
524 Eq tok => Show tok => Typeable tok => TH.Lift tok => NFData tok =>
525 CombSatisfiable tok repr =>
526 [tok] -> repr tok
527 oneOf ts = satisfyOrFail
528 (Set.fromList (SomeFailure . FailureToken Functor.<$> ts))
529 (production
530 (`List.elem` ts)
531 [||\t -> $$(ofChars ts [||t||])||])
532
533 noneOf ::
534 TH.Lift tok => Eq tok =>
535 CombSatisfiable tok repr =>
536 [tok] -> repr tok
537 noneOf cs = satisfy (production
538 (not . (`List.elem` cs))
539 [||\c -> not $$(ofChars cs [||c||])||])
540
541 ofChars ::
542 TH.Lift tok => Eq tok =>
543 {-alternatives-}[tok] ->
544 {-input-}TH.CodeQ tok ->
545 TH.CodeQ Bool
546 ofChars = List.foldr (\tok acc ->
547 \inp -> [|| tok == $$inp || $$(acc inp) ||])
548 (const [||False||])
549
550 more ::
551 CombAlternable repr =>
552 CombApplicable repr =>
553 CombSatisfiable Char repr =>
554 CombLookable repr => repr ()
555 more = look (void (item @Char))
556
557 token ::
558 TH.Lift tok => Show tok => Eq tok => Typeable tok =>
559 CombAlternable repr =>
560 CombApplicable repr =>
561 CombSatisfiable tok repr =>
562 tok -> repr tok
563 token tok = satisfy (Prod.equal Prod..@ Prod.constant tok) $> Prod.constant tok
564 -- token tok = satisfy [ExceptionToken tok] (Prod.eq Prod..@ Prod.qual Prod..@ Prod.char tok) $> Prod.char tok
565
566 tokens ::
567 TH.Lift tok => Eq tok => Show tok => Typeable tok =>
568 CombApplicable repr => CombAlternable repr =>
569 CombSatisfiable tok repr => [tok] -> repr [tok]
570 tokens = try . traverse token
571
572 -- * Class 'CombSelectable'
573 class CombSelectable repr where
574 branch :: repr (Either a b) -> repr (a -> c) -> repr (b -> c) -> repr c
575 default branch ::
576 Sym.Liftable3 repr => CombSelectable (Sym.Output repr) =>
577 repr (Either a b) -> repr (a -> c) -> repr (b -> c) -> repr c
578 branch = Sym.lift3 branch
579 data instance Failure CombSelectable
580
581 -- * Class 'CombLookable'
582 class CombLookable repr where
583 look :: repr a -> repr a
584 negLook :: repr a -> repr ()
585 default look :: Sym.Liftable1 repr => CombLookable (Sym.Output repr) => repr a -> repr a
586 default negLook :: Sym.Liftable1 repr => CombLookable (Sym.Output repr) => repr a -> repr ()
587 look = Sym.lift1 look
588 negLook = Sym.lift1 negLook
589
590 eof :: repr ()
591 eof = Sym.lift eof
592 default eof :: Sym.Liftable repr => CombLookable (Sym.Output repr) => repr ()
593 -- eof = negLook (satisfy @Char (Prod.const Prod..@ Prod.bool True))
594 -- (item @Char)
595 data instance Failure CombLookable
596 = FailureEnd
597 deriving (Eq, Show, Typeable, TH.Lift, Generic, NFData)
598
599 -- Composite Combinators
600 -- someTill :: repr a -> repr b -> repr [a]
601 -- someTill p end = negLook end *> (p <:> manyTill p end)
602
603 {-
604 constp :: CombApplicable repr => repr a -> repr (b -> a)
605 constp = (Prod.const <$>)
606
607
608 -- Alias Operations
609 infixl 1 >>
610 (>>) :: CombApplicable repr => repr a -> repr b -> repr b
611 (>>) = (*>)
612
613 -- Monoidal Operations
614
615 infixl 4 <~>
616 (<~>) :: CombApplicable repr => repr a -> repr b -> repr (a, b)
617 (<~>) = liftA2 (Prod.runtime (,))
618
619 infixl 4 <~
620 (<~) :: CombApplicable repr => repr a -> repr b -> repr a
621 (<~) = (<*)
622
623 infixl 4 ~>
624 (~>) :: CombApplicable repr => repr a -> repr b -> repr b
625 (~>) = (*>)
626
627 -- Lift Operations
628 liftA2 ::
629 CombApplicable repr =>
630 Production (a -> b -> c) -> repr a -> repr b -> repr c
631 liftA2 f x = (<*>) (fmap f x)
632
633 liftA3 ::
634 CombApplicable repr =>
635 Production (a -> b -> c -> d) -> repr a -> repr b -> repr c -> repr d
636 liftA3 f a b c = liftA2 f a b <*> c
637
638 -}
639
640 {-
641 -- Combinators interpreters for 'Sym.Any'.
642 instance CombApplicable repr => CombApplicable (Sym.Any repr)
643 instance CombSatisfiable repr => CombSatisfiable (Sym.Any repr)
644 instance CombAlternable repr => CombAlternable (Sym.Any repr)
645 instance CombSelectable repr => CombSelectable (Sym.Any repr)
646 instance CombMatchable repr => CombMatchable (Sym.Any repr)
647 instance CombLookable repr => CombLookable (Sym.Any repr)
648 instance CombFoldable repr => CombFoldable (Sym.Any repr)
649 -}