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