src/Symantic/Parser/Grammar/Combinators.hs

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