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