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