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.Parser.Haskell as H
  47
  48 -- * Type 'TermGrammar'
  49 type TermGrammar = H.Term H.ValueCode
  50
  51 -- * Type 'ReprComb'
  52 type ReprComb = Type -> Type
  53
  54 code :: TH.Lift a => a -> TermGrammar a
  55 code x = H.Term (H.ValueCode x [||x||])
  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 = H.left <$> p <|> H.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 -> TermGrammar 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 H.unit
 175
 176 option :: CombApplicable repr => CombAlternable repr => TermGrammar 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 H.nothing (H.just <$> p)
 186
 187 manyTill :: CombApplicable repr => CombAlternable repr => repr a -> repr b -> repr [a]
 188 manyTill p end = let go = end $> H.nil <|> p <:> go in go
 189
 190
 191 -- * Class 'CombApplicable'
 192 -- | This is like the usual 'Functor' and 'Applicative' type classes
 193 -- from the @base@ package, but using @('TermGrammar' a)@ instead of just @(a)@
 194 -- to be able to use and pattern match on some usual terms of type @(a)@ (like 'H.id')
 195 -- and thus apply some optimizations.
 196 -- @(repr)@, for "representation", is the usual tagless-final abstraction
 197 -- over the many semantics that this syntax (formed by the methods
 198 -- of type class like this one) will be interpreted.
 199 class CombApplicable repr where
 200   -- | @(a2b '<$>' ra)@ parses like @(ra)@ but maps its returned value with @(a2b)@.
 201   (<$>) :: TermGrammar (a -> b) -> repr a -> repr b
 202   (<$>) f = (pure f <*>)
 203
 204   -- | Like '<$>' but with its arguments 'flip'-ped.
 205   (<&>) :: repr a -> TermGrammar (a -> b) -> repr b
 206   (<&>) = flip (<$>)
 207
 208   -- | @(a '<$' rb)@ parses like @(rb)@ but discards its returned value by replacing it with @(a)@.
 209   (<$) :: TermGrammar a -> repr b -> repr a
 210   (<$) x = (pure x <*)
 211
 212   -- | @(ra '$>' b)@ parses like @(ra)@ but discards its returned value by replacing it with @(b)@.
 213   ($>) :: repr a -> TermGrammar b -> repr b
 214   ($>) = flip (<$)
 215
 216   -- | @('pure' a)@ parses the empty string, always succeeding in returning @(a)@.
 217   pure :: TermGrammar a -> repr a
 218   default pure ::
 219     Sym.Liftable repr => CombApplicable (Sym.Output repr) =>
 220     TermGrammar a -> repr a
 221   pure = Sym.lift . pure
 222
 223   -- | @(ra2b '<*>' ra)@ parses sequentially @(ra2b)@ and then @(ra)@,
 224   -- and returns the application of the function returned by @(ra2b)@
 225   -- to the value returned by @(ra)@.
 226   (<*>) :: repr (a -> b) -> repr a -> repr b
 227   default (<*>) ::
 228     Sym.Liftable2 repr => CombApplicable (Sym.Output repr) =>
 229     repr (a -> b) -> repr a -> repr b
 230   (<*>) = Sym.lift2 (<*>)
 231
 232   -- | @('liftA2' a2b2c ra rb)@ parses sequentially @(ra)@ and then @(rb)@,
 233   -- and returns the application of @(a2b2c)@ to the values returned by those parsers.
 234   liftA2 :: TermGrammar (a -> b -> c) -> repr a -> repr b -> repr c
 235   liftA2 f x = (<*>) (f <$> x)
 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 H.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 = (H.id <$ x) <*> y
 246
 247   -- | Like '<*>' but with its arguments 'flip'-ped.
 248   (<**>) :: repr a -> repr (a -> b) -> repr b
 249   (<**>) = liftA2 (H.flip H..@ (H.$))
 250   {-
 251   (<**>) :: repr a -> repr (a -> b) -> repr b
 252   (<**>) = liftA2 (\a f -> f a)
 253   -}
 254 infixl 4 <$>, <&>, <$, $>, <*>, <*, *>, <**>
 255 data instance Failure CombApplicable
 256
 257 {-# INLINE (<:>) #-}
 258 infixl 4 <:>
 259 (<:>) :: CombApplicable repr => repr a -> repr [a] -> repr [a]
 260 (<:>) = liftA2 H.cons
 261
 262 sequence :: CombApplicable repr => [repr a] -> repr [a]
 263 sequence = List.foldr (<:>) (pure H.nil)
 264
 265 traverse :: CombApplicable repr => (a -> repr b) -> [a] -> repr [b]
 266 traverse f = sequence . List.map f
 267  -- FIXME: Here hlint suggests to use Control.Monad.mapM,
 268  -- but at this point there is no mapM for our own sequence
 269
 270 repeat :: CombApplicable repr => Int -> repr a -> repr [a]
 271 repeat n p = traverse (const p) [1..n]
 272
 273 between :: CombApplicable repr => repr o -> repr c -> repr a -> repr a
 274 between open close p = open *> p <* close
 275
 276 void :: CombApplicable repr => repr a -> repr ()
 277 void p = p *> unit
 278
 279 unit :: CombApplicable repr => repr ()
 280 unit = pure H.unit
 281
 282 -- * Class 'CombFoldable'
 283 class CombFoldable repr where
 284   chainPre :: repr (a -> a) -> repr a -> repr a
 285   chainPost :: repr a -> repr (a -> a) -> repr a
 286   {-
 287   default chainPre ::
 288     Sym.Liftable2 repr => CombFoldable (Sym.Output repr) =>
 289     repr (a -> a) -> repr a -> repr a
 290   default chainPost ::
 291     Sym.Liftable2 repr => CombFoldable (Sym.Output repr) =>
 292     repr a -> repr (a -> a) -> repr a
 293   chainPre = Sym.lift2 chainPre
 294   chainPost = Sym.lift2 chainPost
 295   -}
 296   default chainPre ::
 297     CombApplicable repr =>
 298     CombAlternable repr =>
 299     repr (a -> a) -> repr a -> repr a
 300   default chainPost ::
 301     CombApplicable repr =>
 302     CombAlternable repr =>
 303     repr a -> repr (a -> a) -> repr a
 304   chainPre op p = go <*> p where go = (H..) <$> op <*> go <|> pure H.id
 305   chainPost p op = p <**> go where go = (H..) <$> op <*> go <|> pure H.id
 306   {-
 307   chainPre op p = flip (foldr ($)) <$> many op <*> p
 308   chainPost p op = foldl' (flip ($)) <$> p <*> many op
 309   -}
 310 data instance Failure CombFoldable
 311
 312 {-
 313 conditional :: CombSelectable repr => [(TermGrammar (a -> Bool), repr b)] -> repr a -> repr b -> repr b
 314 conditional cs p def = match p fs qs def
 315   where (fs, qs) = List.unzip cs
 316 -}
 317
 318 -- Parser Folds
 319 pfoldr ::
 320  CombApplicable repr => CombFoldable repr =>
 321  TermGrammar (a -> b -> b) -> TermGrammar b -> repr a -> repr b
 322 pfoldr f k p = chainPre (f <$> p) (pure k)
 323
 324 pfoldr1 ::
 325  CombApplicable repr => CombFoldable repr =>
 326  TermGrammar (a -> b -> b) -> TermGrammar b -> repr a -> repr b
 327 pfoldr1 f k p = f <$> p <*> pfoldr f k p
 328
 329 pfoldl ::
 330  CombApplicable repr => CombFoldable repr =>
 331  TermGrammar (b -> a -> b) -> TermGrammar b -> repr a -> repr b
 332 pfoldl f k p = chainPost (pure k) ((H.flip <$> pure f) <*> p)
 333
 334 pfoldl1 ::
 335  CombApplicable repr => CombFoldable repr =>
 336  TermGrammar (b -> a -> b) -> TermGrammar b -> repr a -> repr b
 337 pfoldl1 f k p = chainPost (f <$> pure k <*> p) ((H.flip <$> pure f) <*> p)
 338
 339 -- Chain Combinators
 340 chainl1' ::
 341  CombApplicable repr => CombFoldable repr =>
 342  TermGrammar (a -> b) -> repr a -> repr (b -> a -> b) -> repr b
 343 chainl1' f p op = chainPost (f <$> p) (H.flip <$> op <*> p)
 344
 345 chainl1 ::
 346  CombApplicable repr => CombFoldable repr =>
 347  repr a -> repr (a -> a -> a) -> repr a
 348 chainl1 = chainl1' H.id
 349
 350 {-
 351 chainr1' :: ParserOps rep => rep (a -> b) -> repr a -> repr (a -> b -> b) -> repr b
 352 chainr1' f p op = newRegister_ H.id $ \acc ->
 353   let go = bind p $ \x ->
 354            modify acc (H.flip (H..@) <$> (op <*> x)) *> go
 355        <|> f <$> x
 356   in go <**> get acc
 357
 358 chainr1 :: repr a -> repr (a -> a -> a) -> repr a
 359 chainr1 = chainr1' H.id
 360
 361 chainr :: repr a -> repr (a -> a -> a) -> TermGrammar a -> repr a
 362 chainr p op x = option x (chainr1 p op)
 363 -}
 364
 365 chainl ::
 366  CombApplicable repr => CombAlternable repr => CombFoldable repr =>
 367  repr a -> repr (a -> a -> a) -> TermGrammar a -> repr a
 368 chainl p op x = option x (chainl1 p op)
 369
 370 -- Derived Combinators
 371 many ::
 372  CombApplicable repr => CombFoldable repr =>
 373  repr a -> repr [a]
 374 many = pfoldr H.cons H.nil
 375
 376 manyN ::
 377  CombApplicable repr => CombFoldable repr =>
 378  Int -> repr a -> repr [a]
 379 manyN n p = List.foldr (const (p <:>)) (many p) [1..n]
 380
 381 some ::
 382  CombApplicable repr => CombFoldable repr =>
 383  repr a -> repr [a]
 384 some = manyN 1
 385
 386 skipMany ::
 387  CombApplicable repr => CombFoldable repr =>
 388  repr a -> repr ()
 389 --skipMany p = let skipManyp = p *> skipManyp <|> unit in skipManyp
 390 skipMany = void . pfoldl H.const H.unit -- the void here will encourage the optimiser to recognise that the register is unused
 391
 392 skipManyN ::
 393  CombApplicable repr => CombFoldable repr =>
 394  Int -> repr a -> repr ()
 395 skipManyN n p = List.foldr (const (p *>)) (skipMany p) [1..n]
 396
 397 skipSome ::
 398  CombApplicable repr => CombFoldable repr =>
 399  repr a -> repr ()
 400 skipSome = skipManyN 1
 401
 402 sepBy ::
 403  CombApplicable repr => CombAlternable repr => CombFoldable repr =>
 404  repr a -> repr b -> repr [a]
 405 sepBy p sep = option H.nil (sepBy1 p sep)
 406
 407 sepBy1 ::
 408  CombApplicable repr => CombAlternable repr => CombFoldable repr =>
 409  repr a -> repr b -> repr [a]
 410 sepBy1 p sep = p <:> many (sep *> p)
 411
 412 endBy ::
 413  CombApplicable repr => CombAlternable repr => CombFoldable repr =>
 414  repr a -> repr b -> repr [a]
 415 endBy p sep = many (p <* sep)
 416
 417 endBy1 ::
 418  CombApplicable repr => CombAlternable repr => CombFoldable repr =>
 419  repr a -> repr b -> repr [a]
 420 endBy1 p sep = some (p <* sep)
 421
 422 sepEndBy ::
 423  CombApplicable repr => CombAlternable repr => CombFoldable repr =>
 424  repr a -> repr b -> repr [a]
 425 sepEndBy p sep = option H.nil (sepEndBy1 p sep)
 426
 427 sepEndBy1 ::
 428  CombApplicable repr => CombAlternable repr => CombFoldable repr =>
 429  repr a -> repr b -> repr [a]
 430 sepEndBy1 p sep =
 431   let seb1 = p <**> (sep *> (H.flip H..@ H.cons <$> option H.nil seb1)
 432                  <|> pure (H.flip H..@ H.cons H..@ H.nil))
 433   in seb1
 434
 435 {-
 436 sepEndBy1 :: repr a -> repr b -> repr [a]
 437 sepEndBy1 p sep = newRegister_ H.id $ \acc ->
 438   let go = modify acc ((H.flip (H..)) H..@ H.cons <$> p)
 439          *> (sep *> (go <|> get acc) <|> get acc)
 440   in go <*> pure H.nil
 441 -}
 442
 443 -- * Class 'CombMatchable'
 444 class CombMatchable repr where
 445   conditional ::
 446     Eq a => repr a -> [TermGrammar (a -> Bool)] -> [repr b] -> repr b -> repr b
 447   default conditional ::
 448     Sym.Unliftable repr => Sym.Liftable1 repr => CombMatchable (Sym.Output repr) =>
 449     Eq a => repr a -> [TermGrammar (a -> Bool)] -> [repr b] -> repr b -> repr b
 450   conditional a ps bs = Sym.lift1 (conditional (Sym.unlift a) ps (Sym.unlift Functor.<$> bs))
 451
 452   match :: Eq a => repr a -> [TermGrammar a] -> (TermGrammar a -> repr b) -> repr b -> repr b
 453   match a as a2b = conditional a ((H.eq H..@) Functor.<$> as) (a2b Functor.<$> as)
 454   -- match a as a2b = conditional a (((H.eq H..@ H.qual) H..@) Functor.<$> as) (a2b Functor.<$> as)
 455 data instance Failure CombMatchable
 456
 457 -- * Class 'CombSatisfiable'
 458 class CombSatisfiable tok repr where
 459   -- | Like 'satisfyOrFail' but with no custom failure.
 460   satisfy :: TermGrammar (tok -> Bool) -> repr tok
 461   satisfy = satisfyOrFail Set.empty
 462   -- | Like 'satisfy' but with a custom set of 'SomeFailure's.
 463   satisfyOrFail ::
 464     Set SomeFailure ->
 465     TermGrammar (tok -> Bool) -> repr tok
 466   default satisfyOrFail ::
 467     Sym.Liftable repr => CombSatisfiable tok (Sym.Output repr) =>
 468     Set SomeFailure ->
 469     TermGrammar (tok -> Bool) -> repr tok
 470   satisfyOrFail fs = Sym.lift . satisfyOrFail fs
 471
 472 data instance Failure (CombSatisfiable tok)
 473   =  FailureAny
 474   |  FailureHorizon Int -- FIXME: use Natural?
 475   |  FailureLabel String
 476   |  FailureToken tok
 477   deriving (Eq, Show, Typeable, Generic, NFData)
 478 -- | Global 'TH.Name' to refer to the @(InputToken inp)@ type
 479 -- from TemplateHaskell code.
 480 inputTokenProxy :: TH.Name
 481 inputTokenProxy = TH.mkName "inputToken"
 482 instance TH.Lift tok => TH.Lift (Failure (CombSatisfiable tok)) where
 483   liftTyped :: forall m. TH.Quote m => Failure (CombSatisfiable tok) -> TH.Code m (Failure (CombSatisfiable tok))
 484   liftTyped x = [||
 485     case
 486       $$(let inputToken :: TH.Code m (Proxy tok) =
 487               TH.unsafeCodeCoerce (return (TH.VarE inputTokenProxy))
 488       in inputToken) of
 489       (Proxy :: Proxy tok') ->
 490         $$(case x of
 491           FailureAny -> [|| FailureAny @tok' ||]
 492           FailureHorizon h -> [|| FailureHorizon @tok' h ||]
 493           FailureLabel lbl -> [|| FailureLabel @tok' lbl ||]
 494           FailureToken tok -> [|| FailureToken $$(TH.liftTyped tok) ||]
 495         )
 496     ||]
 497
 498 char ::
 499   CombApplicable repr =>
 500   CombSatisfiable Char repr =>
 501   Char -> repr Char
 502 char c = satisfyOrFail (Set.singleton (SomeFailure (FailureToken c)))
 503                        (H.eq H..@ H.char c) $> H.char c
 504
 505 item :: forall tok repr.
 506   Eq tok => Show tok => Typeable tok => TH.Lift tok => NFData tok =>
 507   CombSatisfiable tok repr => repr tok
 508 item = satisfyOrFail (Set.singleton (SomeFailure (FailureAny @tok)))
 509                      (H.const H..@ H.bool True)
 510
 511 anyChar ::
 512   CombAlternable repr =>
 513   CombSatisfiable Char repr =>
 514   repr Char
 515 anyChar = item
 516
 517 string ::
 518   CombApplicable repr => CombAlternable repr =>
 519   CombSatisfiable Char repr =>
 520   [Char] -> repr [Char]
 521 string = try . traverse char
 522
 523 oneOf ::
 524   Eq tok => Show tok => Typeable tok => TH.Lift tok => NFData tok =>
 525   CombSatisfiable tok repr =>
 526   [tok] -> repr tok
 527 oneOf ts = satisfyOrFail
 528   (Set.fromList (SomeFailure . FailureToken Functor.<$> ts))
 529   (Sym.trans H.ValueCode
 530     { value = (`List.elem` ts)
 531     , code = [||\t -> $$(ofChars ts [||t||])||] })
 532
 533 noneOf ::
 534   TH.Lift tok => Eq tok =>
 535   CombSatisfiable tok repr =>
 536   [tok] -> repr tok
 537 noneOf cs = satisfy (Sym.trans H.ValueCode
 538   { value = not . (`List.elem` cs)
 539   , code = [||\c -> not $$(ofChars cs [||c||])||]
 540   })
 541
 542 ofChars ::
 543   TH.Lift tok => Eq tok =>
 544   {-alternatives-}[tok] ->
 545   {-input-}TH.CodeQ tok ->
 546   TH.CodeQ Bool
 547 ofChars = List.foldr (\tok acc ->
 548   \inp -> [|| tok == $$inp || $$(acc inp) ||])
 549   (const [||False||])
 550
 551 more ::
 552   CombAlternable repr =>
 553   CombApplicable repr =>
 554   CombSatisfiable Char repr =>
 555   CombLookable repr => repr ()
 556 more = look (void (item @Char))
 557
 558 token ::
 559   TH.Lift tok => Show tok => Eq tok =>
 560   CombAlternable repr =>
 561   CombApplicable repr =>
 562   CombSatisfiable tok repr =>
 563   tok -> repr tok
 564 token tok = satisfy (H.eq H..@ H.char tok) $> H.char tok
 565 -- token tok = satisfy [ExceptionToken tok] (H.eq H..@ H.qual H..@ H.char tok) $> H.char tok
 566
 567 tokens ::
 568   TH.Lift tok => Eq tok => Show tok =>
 569   CombApplicable repr => CombAlternable repr =>
 570   CombSatisfiable tok repr => [tok] -> repr [tok]
 571 tokens = try . traverse token
 572
 573 -- * Class 'CombSelectable'
 574 class CombSelectable repr where
 575   branch :: repr (Either a b) -> repr (a -> c) -> repr (b -> c) -> repr c
 576   default branch ::
 577     Sym.Liftable3 repr => CombSelectable (Sym.Output repr) =>
 578     repr (Either a b) -> repr (a -> c) -> repr (b -> c) -> repr c
 579   branch = Sym.lift3 branch
 580 data instance Failure CombSelectable
 581
 582 -- * Class 'CombLookable'
 583 class CombLookable repr where
 584   look :: repr a -> repr a
 585   negLook :: repr a -> repr ()
 586   default look :: Sym.Liftable1 repr => CombLookable (Sym.Output repr) => repr a -> repr a
 587   default negLook :: Sym.Liftable1 repr => CombLookable (Sym.Output repr) => repr a -> repr ()
 588   look = Sym.lift1 look
 589   negLook = Sym.lift1 negLook
 590
 591   eof :: repr ()
 592   eof = Sym.lift eof
 593   default eof :: Sym.Liftable repr => CombLookable (Sym.Output repr) => repr ()
 594   -- eof = negLook (satisfy @Char (H.const H..@ H.bool True))
 595              -- (item @Char)
 596 data instance Failure CombLookable
 597   = FailureEnd
 598   deriving (Eq, Show, Typeable, TH.Lift, Generic, NFData)
 599
 600 -- Composite Combinators
 601 -- someTill :: repr a -> repr b -> repr [a]
 602 -- someTill p end = negLook end *> (p <:> manyTill p end)
 603
 604 {-
 605 constp :: CombApplicable repr => repr a -> repr (b -> a)
 606 constp = (H.const <$>)
 607
 608
 609 -- Alias Operations
 610 infixl 1 >>
 611 (>>) :: CombApplicable repr => repr a -> repr b -> repr b
 612 (>>) = (*>)
 613
 614 -- Monoidal Operations
 615
 616 infixl 4 <~>
 617 (<~>) :: CombApplicable repr => repr a -> repr b -> repr (a, b)
 618 (<~>) = liftA2 (H.runtime (,))
 619
 620 infixl 4 <~
 621 (<~) :: CombApplicable repr => repr a -> repr b -> repr a
 622 (<~) = (<*)
 623
 624 infixl 4 ~>
 625 (~>) :: CombApplicable repr => repr a -> repr b -> repr b
 626 (~>) = (*>)
 627
 628 -- Lift Operations
 629 liftA2 ::
 630  CombApplicable repr =>
 631  TermGrammar (a -> b -> c) -> repr a -> repr b -> repr c
 632 liftA2 f x = (<*>) (fmap f x)
 633
 634 liftA3 ::
 635  CombApplicable repr =>
 636  TermGrammar (a -> b -> c -> d) -> repr a -> repr b -> repr c -> repr d
 637 liftA3 f a b c = liftA2 f a b <*> c
 638
 639 -}
 640
 641 {-
 642 -- Combinators interpreters for 'Sym.Any'.
 643 instance CombApplicable repr => CombApplicable (Sym.Any repr)
 644 instance CombSatisfiable repr => CombSatisfiable (Sym.Any repr)
 645 instance CombAlternable repr => CombAlternable (Sym.Any repr)
 646 instance CombSelectable repr => CombSelectable (Sym.Any repr)
 647 instance CombMatchable repr => CombMatchable (Sym.Any repr)
 648 instance CombLookable repr => CombLookable (Sym.Any repr)
 649 instance CombFoldable repr => CombFoldable (Sym.Any repr)
 650 -}