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