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 'Unlifted' 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(..), Ordering(..))
  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.Unlifted repr) =>
  68     Exception -> repr a -> repr a -> repr a
  69   default throw ::
  70     Sym.Liftable repr => CombAlternable (Sym.Unlifted repr) =>
  71     ExceptionLabel -> repr a
  72   default try ::
  73     Sym.Liftable1 repr => CombAlternable (Sym.Unlifted 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.Unlifted 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   , 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 Trans (SomeFailure repr) repr where
 144   trans (SomeFailure x) = trans 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     Sym.Liftable repr => CombApplicable (Sym.Unlifted repr) =>
 225     Production a -> repr a
 226   pure = Sym.lift . 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     Sym.Liftable2 repr => CombApplicable (Sym.Unlifted repr) =>
 234     repr (a -> b) -> repr a -> repr b
 235   (<*>) = Sym.lift2 (<*>)
 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   {-
 293   default chainPre ::
 294     Sym.Liftable2 repr => CombFoldable (Sym.Unlifted repr) =>
 295     repr (a -> a) -> repr a -> repr a
 296   default chainPost ::
 297     Sym.Liftable2 repr => CombFoldable (Sym.Unlifted repr) =>
 298     repr a -> repr (a -> a) -> repr a
 299   chainPre = Sym.lift2 chainPre
 300   chainPost = Sym.lift2 chainPost
 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   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     Eq a => repr a -> [Production (a -> Bool)] -> [repr b] -> repr b -> repr b
 453   default conditional ::
 454     Sym.Unliftable repr => Sym.Liftable1 repr => CombMatchable (Sym.Unlifted repr) =>
 455     Eq a => repr a -> [Production (a -> Bool)] -> [repr b] -> repr b -> repr b
 456   conditional a ps bs = Sym.lift1 (conditional (Sym.unlift a) ps (Sym.unlift Functor.<$> bs))
 457
 458   match :: Eq a => repr a -> [Production a] -> (Production a -> repr b) -> repr b -> repr b
 459   match a as a2b = conditional a ((Prod.equal Prod..@) Functor.<$> as) (a2b Functor.<$> as)
 460   -- match a as a2b = conditional a (((Prod.eq Prod..@ Prod.qual) Prod..@) Functor.<$> as) (a2b Functor.<$> as)
 461 data instance Failure CombMatchable
 462
 463 -- * Class 'CombSatisfiable'
 464 class CombSatisfiable tok repr where
 465   -- | Like 'satisfyOrFail' but with no custom failure.
 466   satisfy :: Production (tok -> Bool) -> repr tok
 467   satisfy = satisfyOrFail Set.empty
 468   -- | Like 'satisfy' but with a custom set of 'SomeFailure's.
 469   satisfyOrFail ::
 470     Set SomeFailure ->
 471     Production (tok -> Bool) -> repr tok
 472   default satisfyOrFail ::
 473     Sym.Liftable repr => CombSatisfiable tok (Sym.Unlifted repr) =>
 474     Set SomeFailure ->
 475     Production (tok -> Bool) -> repr tok
 476   satisfyOrFail fs = Sym.lift . satisfyOrFail fs
 477
 478 data instance Failure (CombSatisfiable tok)
 479   =  FailureAny
 480      -- FIXME: this 'Failure' is a bit special since multiple ones
 481      -- with different 'Horizon's makes no sense.
 482      -- This should likely be treated separately in 'ParsingError'.
 483   |  FailureHorizon Int -- FIXME: use Natural?
 484   |  FailureLabel String
 485   |  FailureToken tok
 486   deriving (Eq, Ord, Show, Typeable, Generic, NFData)
 487 -- | Global 'TH.Name' to refer to the @(InputToken inp)@ type
 488 -- from TemplateHaskell code.
 489 inputTokenProxy :: TH.Name
 490 inputTokenProxy = TH.mkName "inputToken"
 491 instance TH.Lift tok => TH.Lift (Failure (CombSatisfiable tok)) where
 492   liftTyped :: forall m. TH.Quote m => Failure (CombSatisfiable tok) -> TH.Code m (Failure (CombSatisfiable tok))
 493   liftTyped x = [||
 494     case
 495       $$(let inputToken :: TH.Code m (Proxy tok) =
 496               TH.unsafeCodeCoerce (return (TH.VarE inputTokenProxy))
 497       in inputToken) of
 498       (Proxy :: Proxy tok') ->
 499         $$(case x of
 500           FailureAny -> [|| FailureAny @tok' ||]
 501           FailureHorizon h -> [|| FailureHorizon @tok' h ||]
 502           FailureLabel lbl -> [|| FailureLabel @tok' lbl ||]
 503           FailureToken tok -> [|| FailureToken $$(TH.liftTyped tok) ||]
 504         )
 505     ||]
 506
 507 char ::
 508   CombApplicable repr =>
 509   CombSatisfiable Char repr =>
 510   Char -> repr Char
 511 char c = satisfyOrFail
 512            (Set.singleton (SomeFailure (FailureToken c)))
 513            (Prod.equal Prod..@ Prod.char c)
 514          $> Prod.char c
 515
 516 item :: forall tok repr.
 517   Ord tok => Show tok => Typeable tok => TH.Lift tok => NFData tok =>
 518   CombSatisfiable tok repr => repr tok
 519 item = satisfyOrFail
 520         (Set.singleton (SomeFailure (FailureAny @tok)))
 521         (Prod.const Prod..@ Prod.bool True)
 522
 523 anyChar ::
 524   CombAlternable repr =>
 525   CombSatisfiable Char repr =>
 526   repr Char
 527 anyChar = item
 528
 529 string ::
 530   CombApplicable repr => CombAlternable repr =>
 531   CombSatisfiable Char repr =>
 532   [Char] -> repr [Char]
 533 string = try . traverse char
 534
 535 oneOf ::
 536   Ord tok => Show tok => Typeable tok => TH.Lift tok => NFData tok =>
 537   CombSatisfiable tok repr =>
 538   [tok] -> repr tok
 539 oneOf ts = satisfyOrFail
 540   (Set.fromList (SomeFailure . FailureToken Functor.<$> ts))
 541   (production
 542     (`List.elem` ts)
 543     [||\t -> $$(ofChars ts [||t||])||])
 544
 545 noneOf ::
 546   TH.Lift tok => Eq tok =>
 547   CombSatisfiable tok repr =>
 548   [tok] -> repr tok
 549 noneOf cs = satisfy (production
 550   (not . (`List.elem` cs))
 551   [||\c -> not $$(ofChars cs [||c||])||])
 552
 553 ofChars ::
 554   TH.Lift tok => Eq tok =>
 555   {-alternatives-}[tok] ->
 556   {-input-}TH.CodeQ tok ->
 557   TH.CodeQ Bool
 558 ofChars = List.foldr (\tok acc ->
 559   \inp -> [|| tok == $$inp || $$(acc inp) ||])
 560   (const [||False||])
 561
 562 more ::
 563   CombAlternable repr =>
 564   CombApplicable repr =>
 565   CombSatisfiable Char repr =>
 566   CombLookable repr => repr ()
 567 more = look (void (item @Char))
 568
 569 token ::
 570   TH.Lift tok => Show tok => Eq tok => Typeable tok =>
 571   CombAlternable repr =>
 572   CombApplicable repr =>
 573   CombSatisfiable tok repr =>
 574   tok -> repr tok
 575 token tok = satisfy (Prod.equal Prod..@ Prod.constant tok) $> Prod.constant tok
 576 -- token tok = satisfy [ExceptionToken tok] (Prod.eq Prod..@ Prod.qual Prod..@ Prod.char tok) $> Prod.char tok
 577
 578 tokens ::
 579   TH.Lift tok => Eq tok => Show tok => Typeable tok =>
 580   CombApplicable repr => CombAlternable repr =>
 581   CombSatisfiable tok repr => [tok] -> repr [tok]
 582 tokens = try . traverse token
 583
 584 -- * Class 'CombSelectable'
 585 class CombSelectable repr where
 586   branch :: repr (Either a b) -> repr (a -> c) -> repr (b -> c) -> repr c
 587   default branch ::
 588     Sym.Liftable3 repr => CombSelectable (Sym.Unlifted repr) =>
 589     repr (Either a b) -> repr (a -> c) -> repr (b -> c) -> repr c
 590   branch = Sym.lift3 branch
 591 data instance Failure CombSelectable
 592
 593 -- * Class 'CombLookable'
 594 class CombLookable repr where
 595   look :: repr a -> repr a
 596   negLook :: repr a -> repr ()
 597   default look :: Sym.Liftable1 repr => CombLookable (Sym.Unlifted repr) => repr a -> repr a
 598   default negLook :: Sym.Liftable1 repr => CombLookable (Sym.Unlifted repr) => repr a -> repr ()
 599   look = Sym.lift1 look
 600   negLook = Sym.lift1 negLook
 601
 602   eof :: repr ()
 603   eof = Sym.lift eof
 604   default eof :: Sym.Liftable repr => CombLookable (Sym.Unlifted repr) => repr ()
 605   -- eof = negLook (satisfy @Char (Prod.const Prod..@ Prod.bool True))
 606              -- (item @Char)
 607 data instance Failure CombLookable
 608   = FailureEnd
 609   deriving (Eq, Ord, Show, Typeable, TH.Lift, Generic, NFData)
 610
 611 -- Composite Combinators
 612 -- someTill :: repr a -> repr b -> repr [a]
 613 -- someTill p end = negLook end *> (p <:> manyTill p end)
 614
 615 {-
 616 constp :: CombApplicable repr => repr a -> repr (b -> a)
 617 constp = (Prod.const <$>)
 618
 619
 620 -- Alias Operations
 621 infixl 1 >>
 622 (>>) :: CombApplicable repr => repr a -> repr b -> repr b
 623 (>>) = (*>)
 624
 625 -- Monoidal Operations
 626
 627 infixl 4 <~>
 628 (<~>) :: CombApplicable repr => repr a -> repr b -> repr (a, b)
 629 (<~>) = liftA2 (Prod.runtime (,))
 630
 631 infixl 4 <~
 632 (<~) :: CombApplicable repr => repr a -> repr b -> repr a
 633 (<~) = (<*)
 634
 635 infixl 4 ~>
 636 (~>) :: CombApplicable repr => repr a -> repr b -> repr b
 637 (~>) = (*>)
 638
 639 -- Lift Operations
 640 liftA2 ::
 641  CombApplicable repr =>
 642  Production (a -> b -> c) -> repr a -> repr b -> repr c
 643 liftA2 f x = (<*>) (fmap f x)
 644
 645 liftA3 ::
 646  CombApplicable repr =>
 647  Production (a -> b -> c -> d) -> repr a -> repr b -> repr c -> repr d
 648 liftA3 f a b c = liftA2 f a b <*> c
 649
 650 -}
 651
 652 {-
 653 -- Combinators interpreters for 'Sym.Any'.
 654 instance CombApplicable repr => CombApplicable (Sym.Any repr)
 655 instance CombSatisfiable repr => CombSatisfiable (Sym.Any repr)
 656 instance CombAlternable repr => CombAlternable (Sym.Any repr)
 657 instance CombSelectable repr => CombSelectable (Sym.Any repr)
 658 instance CombMatchable repr => CombMatchable (Sym.Any repr)
 659 instance CombLookable repr => CombLookable (Sym.Any repr)
 660 instance CombFoldable repr => CombFoldable (Sym.Any repr)
 661 -}