src/Symantic/Parser/Grammar/Combinators.hs

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