src/Symantic/Parser/Grammar/Combinators.hs

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