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   -- | Like 'satisfyOrFail' but with no custom failure.
 453   satisfy :: TermGrammar (tok -> Bool) -> repr tok
 454   satisfy = satisfyOrFail Set.empty
 455   -- | Like 'satisfy' but with a custom set of 'SomeFailure's.
 456   satisfyOrFail ::
 457     Set SomeFailure ->
 458     TermGrammar (tok -> Bool) -> repr tok
 459   default satisfyOrFail ::
 460     Sym.Liftable repr => CombSatisfiable tok (Sym.Output repr) =>
 461     Set SomeFailure ->
 462     TermGrammar (tok -> Bool) -> repr tok
 463   satisfyOrFail fs = Sym.lift . satisfyOrFail fs
 464
 465 data instance Failure (CombSatisfiable tok)
 466   =  FailureAny
 467   |  FailureHorizon Int -- FIXME: use Natural?
 468   |  FailureLabel String
 469   |  FailureToken tok
 470   deriving (Eq, Show, Typeable)
 471 inputTokenProxy :: TH.Name
 472 inputTokenProxy = TH.mkName "inputToken"
 473 instance TH.Lift tok => TH.Lift (Failure (CombSatisfiable tok)) where
 474   liftTyped :: forall m. TH.Quote m => Failure (CombSatisfiable tok) -> TH.Code m (Failure (CombSatisfiable tok))
 475   liftTyped x = [||
 476     case
 477       $$(let inputToken :: TH.Code m (Proxy tok) =
 478               TH.unsafeCodeCoerce (return (TH.VarE inputTokenProxy))
 479       in inputToken) of
 480       (Proxy :: Proxy tok') ->
 481         $$(case x of
 482           FailureAny -> [|| FailureAny @tok' ||]
 483           FailureHorizon h -> [|| FailureHorizon @tok' h ||]
 484           FailureLabel lbl -> [|| FailureLabel @tok' lbl ||]
 485           FailureToken tok -> [|| FailureToken $$(TH.liftTyped tok) ||]
 486         )
 487     ||]
 488
 489 char ::
 490   CombApplicable repr =>
 491   CombSatisfiable Char repr =>
 492   Char -> repr Char
 493 char c = satisfyOrFail (Set.singleton (SomeFailure (FailureToken c)))
 494                        (H.eq H..@ H.char c) $> H.char c
 495
 496 item :: forall tok repr.
 497   Eq tok => Show tok => Typeable tok => TH.Lift tok =>
 498   CombSatisfiable tok repr => repr tok
 499 item = satisfyOrFail (Set.singleton (SomeFailure (FailureAny @tok)))
 500                      (H.const H..@ H.bool True)
 501
 502 anyChar ::
 503   CombAlternable repr =>
 504   CombSatisfiable Char repr =>
 505   repr Char
 506 anyChar = item
 507
 508 string ::
 509   CombApplicable repr => CombAlternable repr =>
 510   CombSatisfiable Char repr =>
 511   [Char] -> repr [Char]
 512 string = try . traverse char
 513
 514 oneOf ::
 515   Eq tok => Show tok => Typeable tok => TH.Lift tok =>
 516   CombSatisfiable tok repr =>
 517   [tok] -> repr tok
 518 oneOf ts = satisfyOrFail
 519   (Set.fromList (SomeFailure . FailureToken Functor.<$> ts))
 520   (Sym.trans H.ValueCode
 521     { value = (`List.elem` ts)
 522     , code = [||\t -> $$(ofChars ts [||t||])||] })
 523
 524 noneOf ::
 525   TH.Lift tok => Eq tok =>
 526   CombSatisfiable tok repr =>
 527   [tok] -> repr tok
 528 noneOf cs = satisfy (Sym.trans H.ValueCode
 529   { value = not . (`List.elem` cs)
 530   , code = [||\c -> not $$(ofChars cs [||c||])||]
 531   })
 532
 533 ofChars ::
 534   TH.Lift tok => Eq tok =>
 535   {-alternatives-}[tok] ->
 536   {-input-}TH.CodeQ tok ->
 537   TH.CodeQ Bool
 538 ofChars = List.foldr (\tok acc ->
 539   \inp -> [|| tok == $$inp || $$(acc inp) ||])
 540   (const [||False||])
 541
 542 more ::
 543   CombAlternable repr =>
 544   CombApplicable repr =>
 545   CombSatisfiable Char repr =>
 546   CombLookable repr => repr ()
 547 more = look (void (item @Char))
 548
 549 token ::
 550   TH.Lift tok => Show tok => Eq tok =>
 551   CombAlternable repr =>
 552   CombApplicable repr =>
 553   CombSatisfiable tok repr =>
 554   tok -> repr tok
 555 token tok = satisfy (H.eq H..@ H.char tok) $> H.char tok
 556 -- token tok = satisfy [ExceptionToken tok] (H.eq H..@ H.qual H..@ H.char tok) $> H.char tok
 557
 558 tokens ::
 559   TH.Lift tok => Eq tok => Show tok =>
 560   CombApplicable repr => CombAlternable repr =>
 561   CombSatisfiable tok repr => [tok] -> repr [tok]
 562 tokens = try . traverse token
 563
 564 -- * Class 'CombSelectable'
 565 class CombSelectable repr where
 566   branch :: repr (Either a b) -> repr (a -> c) -> repr (b -> c) -> repr c
 567   default branch ::
 568     Sym.Liftable3 repr => CombSelectable (Sym.Output repr) =>
 569     repr (Either a b) -> repr (a -> c) -> repr (b -> c) -> repr c
 570   branch = Sym.lift3 branch
 571 data instance Failure CombSelectable
 572
 573 -- * Class 'CombLookable'
 574 class CombLookable repr where
 575   look :: repr a -> repr a
 576   negLook :: repr a -> repr ()
 577   default look :: Sym.Liftable1 repr => CombLookable (Sym.Output repr) => repr a -> repr a
 578   default negLook :: Sym.Liftable1 repr => CombLookable (Sym.Output repr) => repr a -> repr ()
 579   look = Sym.lift1 look
 580   negLook = Sym.lift1 negLook
 581
 582   eof :: repr ()
 583   eof = Sym.lift eof
 584   default eof :: Sym.Liftable repr => CombLookable (Sym.Output repr) => repr ()
 585   -- eof = negLook (satisfy @Char (H.const H..@ H.bool True))
 586              -- (item @Char)
 587 data instance Failure CombLookable
 588   = FailureEnd
 589   deriving (Eq, Show, Typeable, TH.Lift)
 590
 591 -- Composite Combinators
 592 -- someTill :: repr a -> repr b -> repr [a]
 593 -- someTill p end = negLook end *> (p <:> manyTill p end)
 594
 595 {-
 596 constp :: CombApplicable repr => repr a -> repr (b -> a)
 597 constp = (H.const <$>)
 598
 599
 600 -- Alias Operations
 601 infixl 1 >>
 602 (>>) :: CombApplicable repr => repr a -> repr b -> repr b
 603 (>>) = (*>)
 604
 605 -- Monoidal Operations
 606
 607 infixl 4 <~>
 608 (<~>) :: CombApplicable repr => repr a -> repr b -> repr (a, b)
 609 (<~>) = liftA2 (H.runtime (,))
 610
 611 infixl 4 <~
 612 (<~) :: CombApplicable repr => repr a -> repr b -> repr a
 613 (<~) = (<*)
 614
 615 infixl 4 ~>
 616 (~>) :: CombApplicable repr => repr a -> repr b -> repr b
 617 (~>) = (*>)
 618
 619 -- Lift Operations
 620 liftA2 ::
 621  CombApplicable repr =>
 622  TermGrammar (a -> b -> c) -> repr a -> repr b -> repr c
 623 liftA2 f x = (<*>) (fmap f x)
 624
 625 liftA3 ::
 626  CombApplicable repr =>
 627  TermGrammar (a -> b -> c -> d) -> repr a -> repr b -> repr c -> repr d
 628 liftA3 f a b c = liftA2 f a b <*> c
 629
 630 -}
 631
 632 {-
 633 -- Combinators interpreters for 'Sym.Any'.
 634 instance CombApplicable repr => CombApplicable (Sym.Any repr)
 635 instance CombSatisfiable repr => CombSatisfiable (Sym.Any repr)
 636 instance CombAlternable repr => CombAlternable (Sym.Any repr)
 637 instance CombSelectable repr => CombSelectable (Sym.Any repr)
 638 instance CombMatchable repr => CombMatchable (Sym.Any repr)
 639 instance CombLookable repr => CombLookable (Sym.Any repr)
 640 instance CombFoldable repr => CombFoldable (Sym.Any repr)
 641 -}