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