]> Git — Sourcephile - haskell/symantic-parser.git/blob - src/Symantic/Parser/Grammar/Combinators.hs
9282027edb864bb464fceb227cf4bfef8bc42934
[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 'LiftDerived'* constraint and the same type class but on the 'Derived' repr,
3 -- this setup avoids to define the method with boilerplate code when its default
4 -- definition with 'liftDerived'* and 'derive' 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 DerivingStrategies #-} -- For UnscopedRegister
12 {-# LANGUAGE PatternSynonyms #-} -- For Failure
13 {-# LANGUAGE StandaloneDeriving #-} -- For Show (Exception (InputToken inp))
14 {-# LANGUAGE InstanceSigs #-}
15 {-# LANGUAGE TemplateHaskell #-}
16 {-# LANGUAGE ViewPatterns #-} -- For unSomeFailure
17 -- | Semantic of the grammar combinators used to express parsers,
18 -- in the convenient tagless-final encoding.
19 module Symantic.Parser.Grammar.Combinators where
20
21 import Data.Proxy (Proxy(..))
22 import Control.Monad (Monad(..))
23 import Control.DeepSeq (NFData(..))
24 import GHC.Generics (Generic)
25 -- import Data.Set (Set)
26 -- import GHC.TypeLits (KnownSymbol)
27 import Data.Bifunctor (second)
28 import Data.Bool (Bool(..), not, (||))
29 import Data.Char (Char)
30 import Data.Either (Either(..))
31 import Data.Eq (Eq(..))
32 import Data.Function ((.), flip, const, fix)
33 import Data.Ord (Ord(..), Ordering(..))
34 import Data.Int (Int)
35 import Data.Kind (Type, Constraint)
36 import Data.Maybe (Maybe(..))
37 import Data.Set (Set)
38 import Data.String (String)
39 import Text.Show (Show(..))
40 import Type.Reflection (Typeable, typeRep, eqTypeRep, (:~~:)(..), SomeTypeRep(..))
41 import qualified Data.Functor as Functor
42 import qualified Data.List as List
43 import qualified Data.Set as Set
44 import qualified Language.Haskell.TH as TH
45 import qualified Language.Haskell.TH.Syntax as TH
46
47 import Symantic.Syntaxes.Derive
48 import qualified Symantic.Syntaxes.Classes as Prod
49 import Symantic.Parser.Grammar.Production
50
51 -- * Type 'ReprComb'
52 type ReprComb = Type -> Type
53
54 -- * Class 'CombAlternable'
55 class CombAlternable repr where
56 -- | @('alt' es l r)@ parses @(l)@ and return its return value or,
57 -- if it fails with an 'Exception' within @(es)@,
58 -- parses @(r)@ from where @(l)@ has left the input stream,
59 -- and returns its return value,
60 -- otherwise throw the 'Exception' again.
61 alt :: Exception -> repr a -> repr a -> repr a
62 throw :: ExceptionLabel -> repr a
63 -- | @('try' ra)@ records the input stream position,
64 -- then parses like @(ra)@ and either returns its value it it succeeds or fails
65 -- if it fails but with a reset of the input stream to the recorded position.
66 -- Generally used on the first alternative: @('try' rl '<|>' rr)@.
67 try :: repr a -> repr a
68 default alt ::
69 FromDerived2 CombAlternable repr =>
70 Exception -> repr a -> repr a -> repr a
71 default throw ::
72 FromDerived CombAlternable repr =>
73 ExceptionLabel -> repr a
74 default try ::
75 FromDerived1 CombAlternable repr =>
76 repr a -> repr a
77 alt = liftDerived2 . alt
78 throw = liftDerived . throw
79 try = liftDerived1 try
80
81 failure :: SomeFailure -> repr a
82 default failure ::
83 FromDerived CombAlternable repr =>
84 SomeFailure -> repr a
85 failure = liftDerived . failure
86
87 -- | @(empty)@ parses nothing, always failing to return a value.
88 empty :: repr a
89 empty = failure (SomeFailure FailureEmpty)
90
91 data instance Failure CombAlternable
92 = FailureEmpty
93 deriving (Eq, Ord, Show, TH.Lift, Generic, NFData)
94
95 -- ** Data family 'Failure'
96 -- | 'Failure's of the 'Grammar'.
97 -- This is an extensible data-type.
98 data family Failure
99 (comb :: ReprComb -> Constraint)
100 :: Type
101
102 {-
103 -- | Convenient utility to pattern-match a 'SomeFailure'.
104 pattern Failure :: Typeable comb => Failure comb -> SomeFailure
105 pattern Failure x <- (unSomeFailure -> Just x)
106 -}
107
108 -- ** Type 'SomeFailure'
109 data SomeFailure =
110 forall comb.
111 ( Eq (Failure comb)
112 , Ord (Failure comb)
113 , Show (Failure comb)
114 , TH.Lift (Failure comb)
115 , NFData (Failure comb)
116 , Typeable comb
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 Derivable (SomeFailure repr) where
144 derive (SomeFailure x) = derive 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 -- | ExceptionEnd
161 deriving (Eq, Ord, Show, TH.Lift, Generic, NFData)
162 type ExceptionLabel = String
163 -- type Exceptions = Set Exception
164
165 -- | Like @('<|>')@ but with different returning types for the alternatives,
166 -- and a return value wrapped in an 'Either' accordingly.
167 (<+>) :: CombApplicable repr => CombAlternable repr => repr a -> repr b -> repr (Either a b)
168 p <+> q = Prod.left <$> p <|> Prod.right <$> q
169
170 (<|>) :: CombAlternable repr => repr a -> repr a -> repr a
171 (<|>) = alt ExceptionFailure
172
173 infixl 3 <|>, <+>
174
175 optionally :: CombApplicable repr => CombAlternable repr => repr a -> Production '[] b -> repr b
176 optionally p x = p $> x <|> pure x
177
178 optional :: CombApplicable repr => CombAlternable repr => repr a -> repr ()
179 optional = flip optionally (Prod.constant ())
180
181 option :: CombApplicable repr => CombAlternable repr => Production '[] a -> repr a -> repr a
182 option x p = p <|> pure x
183
184 choice :: CombAlternable repr => [repr a] -> repr a
185 choice = List.foldr (<|>) empty
186 -- FIXME: Here hlint suggests to use Data.Foldable.asum,
187 -- but at this point there is no asum for our own (<|>)
188
189 maybeP :: CombApplicable repr => CombAlternable repr => repr a -> repr (Maybe a)
190 maybeP p = option Prod.nothing (Prod.just <$> p)
191
192 manyTill :: CombApplicable repr => CombAlternable repr => repr a -> repr b -> repr [a]
193 manyTill p end = let go = end $> Prod.nil <|> p <:> go in go
194
195 -- * Class 'CombApplicable'
196 -- | This is like the usual 'Functor' and 'Applicative' type classes
197 -- from the @base@ package, but using @('Production' vs a)@ instead of just @(a)@
198 -- to be able to use and pattern match on some usual terms of type @(a)@ (like 'Prod.id')
199 -- and thus apply some optimizations.
200 -- @(repr)@, for "representation", is the usual tagless-final abstraction
201 -- over the many semantics that this syntax (formed by the methods
202 -- of type class like this one) will be interpreted.
203 class CombApplicable repr where
204 -- | @(a2b '<$>' ra)@ parses like @(ra)@ but maps its returned value with @(a2b)@.
205 (<$>) :: Production '[] (a -> b) -> repr a -> repr b
206 (<$>) f = (pure f <*>)
207 (<$>%) :: (Production '[] a -> Production '[] b) -> repr a -> repr b
208 a2b <$>% ma = Prod.lam a2b <$> ma
209
210 -- | Like '<$>' but with its arguments 'flip'-ped.
211 (<&>) :: repr a -> Production '[] (a -> b) -> repr b
212 (<&>) = flip (<$>)
213
214 -- | @(a '<$' rb)@ parses like @(rb)@ but discards its returned value by replacing it with @(a)@.
215 (<$) :: Production '[] a -> repr b -> repr a
216 (<$) x = (pure x <*)
217
218 -- | @(ra '$>' b)@ parses like @(ra)@ but discards its returned value by replacing it with @(b)@.
219 ($>) :: repr a -> Production '[] b -> repr b
220 ($>) = flip (<$)
221
222 -- | @('pure' a)@ parses the empty string, always succeeding in returning @(a)@.
223 pure :: Production '[] a -> repr a
224 default pure ::
225 FromDerived CombApplicable repr =>
226 Production '[] a -> repr a
227 pure = liftDerived . pure
228
229 -- | @(ra2b '<*>' ra)@ parses sequentially @(ra2b)@ and then @(ra)@,
230 -- and returns the application of the function returned by @(ra2b)@
231 -- to the value returned by @(ra)@.
232 (<*>) :: repr (a -> b) -> repr a -> repr b
233 default (<*>) ::
234 FromDerived2 CombApplicable repr =>
235 repr (a -> b) -> repr a -> repr b
236 (<*>) = liftDerived2 (<*>)
237
238 -- | @(ra '<*' rb)@ parses sequentially @(ra)@ and then @(rb)@,
239 -- and returns like @(ra)@, discarding the return value of @(rb)@.
240 (<*) :: repr a -> repr b -> repr a
241 (<*) = liftA2 Prod.const
242
243 -- | @(ra '*>' rb)@ parses sequentially @(ra)@ and then @(rb)@,
244 -- and returns like @(rb)@, discarding the return value of @(ra)@.
245 (*>) :: repr a -> repr b -> repr b
246 x *> y = (Prod.id <$ x) <*> y
247
248 -- | Like '<*>' but with its arguments 'flip'-ped.
249 (<**>) :: repr a -> repr (a -> b) -> repr b
250 (<**>) = liftA2 (Prod.flip Prod..@ (Prod.$))
251 {-
252 (<**>) :: repr a -> repr (a -> b) -> repr b
253 (<**>) = liftA2 (\a f -> f a)
254 -}
255 -- | @('liftA2' a2b2c ra rb)@ parses sequentially @(ra)@ and then @(rb)@,
256 -- and returns the application of @(a2b2c)@ to the values returned by those parsers.
257 liftA2 :: Production '[] (a -> b -> c) -> repr a -> repr b -> repr c
258 liftA2 f x = (<*>) (f <$> x)
259
260 infixl 4 <*>, <*, *>, <**>
261 data instance Failure CombApplicable
262
263
264 {-# INLINE (<:>) #-}
265 infixl 4 <:>
266 (<:>) :: CombApplicable repr => repr a -> repr [a] -> repr [a]
267 (<:>) = liftA2 Prod.cons
268
269 sequence :: CombApplicable repr => [repr a] -> repr [a]
270 sequence = List.foldr (<:>) (pure Prod.nil)
271
272 traverse :: CombApplicable repr => (a -> repr b) -> [a] -> repr [b]
273 traverse f = sequence . List.map f
274 -- FIXME: Here hlint suggests to use Control.Monad.mapM,
275 -- but at this point there is no mapM for our own sequence
276
277 repeat :: CombApplicable repr => Int -> repr a -> repr [a]
278 repeat n p = traverse (const p) [1..n]
279
280 between :: CombApplicable repr => repr o -> repr c -> repr a -> repr a
281 between open close p = open *> p <* close
282
283 void :: CombApplicable repr => repr a -> repr ()
284 void p = p *> unit
285
286 unit :: CombApplicable repr => repr ()
287 unit = pure (Prod.constant ())
288
289 -- * Class 'CombFoldable'
290 class CombFoldable repr where
291 chainPre :: repr (a -> a) -> repr a -> repr a
292 chainPost :: repr a -> repr (a -> a) -> repr a
293 chainPre = liftDerived2 chainPre
294 chainPost = liftDerived2 chainPost
295 default chainPre ::
296 FromDerived2 CombFoldable repr =>
297 repr (a -> a) -> repr a -> repr a
298 default chainPost ::
299 FromDerived2 CombFoldable repr =>
300 repr a -> repr (a -> a) -> repr a
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 {-
314 chainPre op p = flip (foldr ($)) <$> many op <*> p
315 chainPost p op = foldl' (flip ($)) <$> p <*> many op
316 -}
317 data instance Failure CombFoldable
318
319 {-
320 conditional :: CombSelectable repr => [(Production '[] (a -> Bool), repr b)] -> repr a -> repr b -> repr b
321 conditional cs p def = match p fs qs def
322 where (fs, qs) = List.unzip cs
323 -}
324
325 -- Parser Folds
326 pfoldr ::
327 CombApplicable repr => CombFoldable repr =>
328 Production '[] (a -> b -> b) -> Production '[] b -> repr a -> repr b
329 pfoldr f k p = chainPre (f <$> p) (pure k)
330
331 pfoldr1 ::
332 CombApplicable repr => CombFoldable repr =>
333 Production '[] (a -> b -> b) -> Production '[] b -> repr a -> repr b
334 pfoldr1 f k p = f <$> p <*> pfoldr f k p
335
336 pfoldl ::
337 CombApplicable repr => CombFoldable repr =>
338 Production '[] (b -> a -> b) -> Production '[] b -> repr a -> repr b
339 pfoldl f k p = chainPost (pure k) ((Prod.flip <$> pure f) <*> p)
340
341 pfoldl1 ::
342 CombApplicable repr => CombFoldable repr =>
343 Production '[] (b -> a -> b) -> Production '[] b -> repr a -> repr b
344 pfoldl1 f k p = chainPost (f <$> pure k <*> p) ((Prod.flip <$> pure f) <*> p)
345
346 -- Chain Combinators
347 chainl1' ::
348 CombApplicable repr => CombFoldable repr =>
349 Production '[] (a -> b) -> repr a -> repr (b -> a -> b) -> repr b
350 chainl1' f p op = chainPost (f <$> p) (Prod.flip <$> op <*> p)
351
352 chainl1 ::
353 CombApplicable repr => CombFoldable repr =>
354 repr a -> repr (a -> a -> a) -> repr a
355 chainl1 = chainl1' Prod.id
356
357 {-
358 chainr1' :: ParserOps rep => rep (a -> b) -> repr a -> repr (a -> b -> b) -> repr b
359 chainr1' f p op = newRegister_ Prod.id $ \acc ->
360 let go = bind p $ \x ->
361 modify acc (Prod.flip (Prod..@) <$> (op <*> x)) *> go
362 <|> f <$> x
363 in go <**> get acc
364
365 chainr1 :: repr a -> repr (a -> a -> a) -> repr a
366 chainr1 = chainr1' Prod.id
367
368 chainr :: repr a -> repr (a -> a -> a) -> Production '[] a -> repr a
369 chainr p op x = option x (chainr1 p op)
370 -}
371
372 chainl ::
373 CombApplicable repr => CombAlternable repr => CombFoldable repr =>
374 repr a -> repr (a -> a -> a) -> Production '[] a -> repr a
375 chainl p op x = option x (chainl1 p op)
376
377 -- Derived Combinators
378 many ::
379 CombApplicable repr => CombFoldable repr =>
380 repr a -> repr [a]
381 many = pfoldr Prod.cons Prod.nil
382
383 manyN ::
384 CombApplicable repr => CombFoldable repr =>
385 Int -> repr a -> repr [a]
386 manyN n p = List.foldr (const (p <:>)) (many p) [1..n]
387
388 some ::
389 CombApplicable repr => CombFoldable repr =>
390 repr a -> repr [a]
391 some = manyN 1
392
393 skipMany ::
394 CombApplicable repr => CombFoldable repr =>
395 repr a -> repr ()
396 --skipMany p = let skipManyp = p *> skipManyp <|> unit in skipManyp
397 skipMany = void . pfoldl Prod.const Prod.unit -- the void here will encourage the optimiser to recognise that the register is unused
398
399 skipManyN ::
400 CombApplicable repr => CombFoldable repr =>
401 Int -> repr a -> repr ()
402 skipManyN n p = List.foldr (const (p *>)) (skipMany p) [1..n]
403
404 skipSome ::
405 CombApplicable repr => CombFoldable repr =>
406 repr a -> repr ()
407 skipSome = skipManyN 1
408
409 sepBy ::
410 CombApplicable repr => CombAlternable repr => CombFoldable repr =>
411 repr a -> repr b -> repr [a]
412 sepBy p sep = option Prod.nil (sepBy1 p sep)
413
414 sepBy1 ::
415 CombApplicable repr => CombAlternable repr => CombFoldable repr =>
416 repr a -> repr b -> repr [a]
417 sepBy1 p sep = p <:> many (sep *> p)
418
419 endBy ::
420 CombApplicable repr => CombAlternable repr => CombFoldable repr =>
421 repr a -> repr b -> repr [a]
422 endBy p sep = many (p <* sep)
423
424 endBy1 ::
425 CombApplicable repr => CombAlternable repr => CombFoldable repr =>
426 repr a -> repr b -> repr [a]
427 endBy1 p sep = some (p <* sep)
428
429 sepEndBy ::
430 CombApplicable repr => CombAlternable repr => CombFoldable repr =>
431 repr a -> repr b -> repr [a]
432 sepEndBy p sep = option Prod.nil (sepEndBy1 p sep)
433
434 sepEndBy1 ::
435 CombApplicable repr => CombAlternable repr => CombFoldable repr =>
436 repr a -> repr b -> repr [a]
437 sepEndBy1 p sep =
438 let seb1 = p <**> (sep *> (Prod.flip Prod..@ Prod.cons <$> option Prod.nil seb1)
439 <|> pure (Prod.flip Prod..@ Prod.cons Prod..@ Prod.nil))
440 in seb1
441
442 {-
443 sepEndBy1 :: repr a -> repr b -> repr [a]
444 sepEndBy1 p sep = newRegister_ Prod.id $ \acc ->
445 let go = modify acc ((Prod.flip (Prod..)) Prod..@ Prod.cons <$> p)
446 *> (sep *> (go <|> get acc) <|> get acc)
447 in go <*> pure Prod.nil
448 -}
449
450 -- * Class 'CombMatchable'
451 class CombMatchable repr where
452 conditional ::
453 repr a -> [(Production '[] (a -> Bool), repr b)] -> repr b -> repr b
454 conditional a bs = liftDerived1
455 (conditional (derive a) (second derive Functor.<$> bs))
456 default conditional ::
457 FromDerived1 CombMatchable repr => Derivable repr =>
458 repr a -> [(Production '[] (a -> Bool), repr b)] -> repr b -> repr b
459 data instance Failure CombMatchable
460
461 match ::
462 CombMatchable repr =>
463 Eq a => TH.Lift a =>
464 repr a -> [Production '[] a] -> (Production '[] a -> repr b) -> repr b -> repr b
465 match a as p = conditional a
466 ((\v ->
467 ( Prod.lam (v Prod.==)
468 , p v
469 )
470 ) Functor.<$> as)
471
472 predicate ::
473 CombMatchable repr =>
474 Production '[] (a -> Bool) -> repr a -> repr b -> repr b -> repr b
475 predicate p a b = conditional a [(p, b)]
476
477 infixl 4 <?:>
478 (<?:>) ::
479 CombMatchable repr =>
480 repr Bool -> (repr a, repr a) -> repr a
481 cond <?:> (p, q) = predicate Prod.id cond p q
482
483 -- * Class 'CombSatisfiable'
484 class CombSatisfiable tok repr where
485 -- | Like 'satisfyOrFail' but with no custom failure.
486 satisfy :: Production '[] (tok -> Bool) -> repr tok
487 satisfy = satisfyOrFail Set.empty
488 -- | Like 'satisfy' but with a custom set of 'SomeFailure's.
489 satisfyOrFail ::
490 Set SomeFailure ->
491 Production '[] (tok -> Bool) -> repr tok
492 default satisfyOrFail ::
493 FromDerived (CombSatisfiable tok) repr =>
494 Set SomeFailure ->
495 Production '[] (tok -> Bool) -> repr tok
496 satisfyOrFail fs = liftDerived . satisfyOrFail fs
497
498 data instance Failure (CombSatisfiable tok)
499 = FailureAny
500 -- FIXME: this 'Failure' is a bit special since multiple ones
501 -- with different 'Horizon's makes no sense.
502 -- This should likely be treated separately in 'ParsingError'.
503 | FailureHorizon Int -- FIXME: use Natural?
504 | FailureLabel String
505 | FailureToken tok
506 deriving (Eq, Ord, Show, Typeable, Generic, NFData)
507 -- | Global 'TH.Name' to refer to the @(InputToken inp)@ type
508 -- from TemplateHaskell code.
509 inputTokenProxy :: TH.Name
510 inputTokenProxy = TH.mkName "inputToken"
511 instance TH.Lift tok => TH.Lift (Failure (CombSatisfiable tok)) where
512 liftTyped :: forall m. TH.Quote m => Failure (CombSatisfiable tok) -> TH.Code m (Failure (CombSatisfiable tok))
513 liftTyped x = [||
514 case
515 $$(let inputToken :: TH.Code m (Proxy tok) =
516 TH.unsafeCodeCoerce (return (TH.VarE inputTokenProxy))
517 in inputToken) of
518 (Proxy :: Proxy tok') ->
519 $$(case x of
520 FailureAny -> [|| FailureAny @tok' ||]
521 FailureHorizon h -> [|| FailureHorizon @tok' h ||]
522 FailureLabel lbl -> [|| FailureLabel @tok' lbl ||]
523 FailureToken tok -> [|| FailureToken $$(TH.liftTyped tok) ||]
524 )
525 ||]
526
527 char ::
528 CombApplicable repr =>
529 CombSatisfiable Char repr =>
530 Char -> repr Char
531 char c = satisfyOrFail
532 (Set.singleton (SomeFailure (FailureToken c)))
533 (Prod.equal Prod..@ Prod.constant c)
534 $> Prod.constant c
535
536 item :: forall tok repr.
537 Ord tok => Show tok => Typeable tok => TH.Lift tok => NFData tok =>
538 CombSatisfiable tok repr => repr tok
539 item = satisfyOrFail
540 (Set.singleton (SomeFailure (FailureAny @tok)))
541 (Prod.const Prod..@ Prod.constant True)
542
543 anyChar ::
544 CombAlternable repr =>
545 CombSatisfiable Char repr =>
546 repr Char
547 anyChar = item
548
549 string ::
550 CombApplicable repr => CombAlternable repr =>
551 CombSatisfiable Char repr =>
552 [Char] -> repr [Char]
553 string = try . traverse char
554
555 oneOf ::
556 Ord tok => Show tok => Typeable tok => TH.Lift tok => NFData tok =>
557 CombSatisfiable tok repr =>
558 [tok] -> repr tok
559 oneOf ts = satisfyOrFail
560 (Set.fromList (SomeFailure . FailureToken Functor.<$> ts))
561 (production
562 (`List.elem` ts)
563 [||\t -> $$(ofChars ts [||t||])||])
564
565 noneOf ::
566 TH.Lift tok => Eq tok =>
567 CombSatisfiable tok repr =>
568 [tok] -> repr tok
569 noneOf cs = satisfy (production
570 (not . (`List.elem` cs))
571 [||\c -> not $$(ofChars cs [||c||])||])
572
573 ofChars ::
574 TH.Lift tok => Eq tok =>
575 {-alternatives-}[tok] ->
576 {-input-}TH.CodeQ tok ->
577 TH.CodeQ Bool
578 ofChars = List.foldr
579 (\tok acc inp -> [|| tok == $$inp || $$(acc inp) ||])
580 (const [||False||])
581
582 more ::
583 CombAlternable repr =>
584 CombApplicable repr =>
585 CombSatisfiable Char repr =>
586 CombLookable repr => repr ()
587 more = look (void (item @Char))
588
589 token ::
590 TH.Lift tok => Show tok => Eq tok => Typeable tok =>
591 CombAlternable repr =>
592 CombApplicable repr =>
593 CombSatisfiable tok repr =>
594 tok -> repr tok
595 token tok = satisfy (Prod.equal Prod..@ Prod.constant tok) $> Prod.constant tok
596 -- token tok = satisfy [ExceptionToken tok] (Prod.eq Prod..@ Prod.qual Prod..@ Prod.char tok) $> Prod.char tok
597
598 tokens ::
599 TH.Lift tok => Eq tok => Show tok => Typeable tok =>
600 CombApplicable repr => CombAlternable repr =>
601 CombSatisfiable tok repr => [tok] -> repr [tok]
602 tokens = try . traverse token
603
604 -- * Class 'CombSelectable'
605 class CombSelectable repr where
606 branch :: repr (Either a b) -> repr (a -> c) -> repr (b -> c) -> repr c
607 default branch ::
608 FromDerived3 CombSelectable repr =>
609 repr (Either a b) -> repr (a -> c) -> repr (b -> c) -> repr c
610 branch = liftDerived3 branch
611 data instance Failure CombSelectable
612
613 when ::
614 CombMatchable repr =>
615 CombSelectable repr =>
616 Prod.Constantable () repr =>
617 repr Bool -> repr () -> repr ()
618 when p q = p <?:> (q, Prod.constant ())
619
620 while ::
621 CombMatchable repr =>
622 CombSelectable repr =>
623 Prod.Constantable () repr =>
624 repr Bool -> repr ()
625 while x = fix (when x)
626
627 -- * Class 'CombLookable'
628 class CombLookable repr where
629 look :: repr a -> repr a
630 negLook :: repr a -> repr ()
631 default look ::
632 FromDerived1 CombLookable repr =>
633 repr a -> repr a
634 default negLook ::
635 FromDerived1 CombLookable repr =>
636 repr a -> repr ()
637 look = liftDerived1 look
638 negLook = liftDerived1 negLook
639
640 eof :: repr ()
641 eof = liftDerived eof
642 default eof ::
643 FromDerived CombLookable repr =>
644 repr ()
645 -- eof = negLook (satisfy @Char (Prod.const Prod..@ Prod.bool True))
646 -- (item @Char)
647 data instance Failure CombLookable
648 = FailureEnd
649 deriving (Eq, Ord, Show, Typeable, TH.Lift, Generic, NFData)
650
651 -- Composite Combinators
652 -- someTill :: repr a -> repr b -> repr [a]
653 -- someTill p end = negLook end *> (p <:> manyTill p end)
654
655 {-
656 constp :: CombApplicable repr => repr a -> repr (b -> a)
657 constp = (Prod.const <$>)
658
659
660 -- Alias Operations
661 infixl 1 >>
662 (>>) :: CombApplicable repr => repr a -> repr b -> repr b
663 (>>) = (*>)
664
665 -- Monoidal Operations
666
667 infixl 4 <~>
668 (<~>) :: CombApplicable repr => repr a -> repr b -> repr (a, b)
669 (<~>) = liftA2 (Prod.runtime (,))
670
671 infixl 4 <~
672 (<~) :: CombApplicable repr => repr a -> repr b -> repr a
673 (<~) = (<*)
674
675 infixl 4 ~>
676 (~>) :: CombApplicable repr => repr a -> repr b -> repr b
677 (~>) = (*>)
678
679 -- Lift Operations
680 liftA2 ::
681 CombApplicable repr =>
682 Production '[] (a -> b -> c) -> repr a -> repr b -> repr c
683 liftA2 f x = (<*>) (fmap f x)
684
685 liftA3 ::
686 CombApplicable repr =>
687 Production '[] (a -> b -> c -> d) -> repr a -> repr b -> repr c -> repr d
688 liftA3 f a b c = liftA2 f a b <*> c
689
690 -}
691
692 {-
693 -- Combinators interpreters for 'Sym.Any'.
694 instance CombApplicable repr => CombApplicable (Sym.Any repr)
695 instance CombSatisfiable repr => CombSatisfiable (Sym.Any repr)
696 instance CombAlternable repr => CombAlternable (Sym.Any repr)
697 instance CombSelectable repr => CombSelectable (Sym.Any repr)
698 instance CombMatchable repr => CombMatchable (Sym.Any repr)
699 instance CombLookable repr => CombLookable (Sym.Any repr)
700 instance CombFoldable repr => CombFoldable (Sym.Any repr)
701 -}
702
703 -- * Type 'Register'
704 newtype Register r a = Register { unRegister :: UnscopedRegister a }
705 deriving (Eq, Show)
706
707 -- ** Type 'UnscopedRegister'
708 newtype UnscopedRegister r = UnscopedRegister { unUnscopedRegister :: TH.Name }
709 deriving (Eq)
710 deriving newtype Show
711
712
713 {-
714 put_ :: ParserOps rep => Register r a -> rep a -> Parser ()
715 put_ r = put r . pure
716
717 gets_ :: ParserOps rep => Register r a -> rep (a -> b) -> Parser b
718 gets_ r = gets r . pure
719
720 modify_ :: ParserOps rep => Register r a -> rep (a -> a) -> Parser ()
721 modify_ r = modify r . pure
722 -}
723
724 gets ::
725 CombApplicable repr =>
726 CombRegisterable repr =>
727 Register r a -> repr (a -> b) -> repr b
728 gets r p = p <*> get r
729
730 modify ::
731 CombApplicable repr =>
732 CombRegisterable repr =>
733 Register r a -> repr (a -> a) -> repr ()
734 modify r p = put r (gets r p)
735
736 move ::
737 CombRegisterable repr =>
738 Register r1 a -> Register r2 a -> repr ()
739 move dst src = put dst (get src)
740
741 bind ::
742 CombRegisterable repr =>
743 repr a -> (repr a -> repr b) -> repr b
744 bind p f = new p (f . get)
745
746 local ::
747 CombApplicable repr =>
748 CombRegisterable repr =>
749 Register r a -> repr a -> repr b -> repr b
750 local r p q = bind (get r) (\x -> put r p *> q <* put r x)
751
752 swap ::
753 CombApplicable repr =>
754 CombRegisterable repr =>
755 Register r1 a -> Register r2 a -> repr ()
756 swap r1 r2 = bind (get r1) (\x -> move r1 r2 *> put r2 x)
757
758 rollback ::
759 CombAlternable repr =>
760 CombApplicable repr =>
761 CombRegisterable repr =>
762 Register r a -> repr b -> repr b
763 rollback r p = bind (get r) (\x -> p <|> put r x *> empty)
764
765 for ::
766 CombApplicable repr =>
767 CombMatchable repr =>
768 CombSelectable repr =>
769 CombRegisterable repr =>
770 Prod.Constantable () repr =>
771 repr a -> repr (a -> Bool) -> repr (a -> a) -> repr () -> repr ()
772 for init cond step body =
773 new init (\i ->
774 let cond' = gets i cond in
775 when cond' (while (body *> modify i step *> cond'))
776 )
777
778
779 -- ** Class 'CombRegisterable'
780 class CombRegisterable (repr::ReprComb) where
781 new :: repr a -> (forall r. Register r a -> repr b) -> repr b
782 get :: Register r a -> repr a
783 put :: Register r a -> repr a -> repr ()
784 default new ::
785 FromDerived CombRegisterable repr => Derivable repr =>
786 repr a -> (forall r. Register r a -> repr b) -> repr b
787 default get ::
788 FromDerived CombRegisterable repr =>
789 Register r a -> repr a
790 default put ::
791 FromDerived1 CombRegisterable repr =>
792 Register r a -> repr a -> repr ()
793 new ini f = liftDerived (new (derive ini) (derive . f))
794 get = liftDerived . get
795 put = liftDerived1 . put