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