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