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