src/Symantic/Parser/Grammar/Combinators.hs

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