src/Symantic/Parser/Machine/Generate.hs

   1 {-# LANGUAGE AllowAmbiguousTypes #-}
   2 {-# LANGUAGE DeriveAnyClass #-} -- For NFData instances
   3 {-# LANGUAGE DeriveGeneric #-} -- For NFData instances
   4 {-# LANGUAGE StandaloneDeriving #-} -- For Show (ParsingError inp)
   5 {-# LANGUAGE ConstraintKinds #-} -- For Dict
   6 {-# LANGUAGE TemplateHaskell #-}
   7 {-# LANGUAGE TupleSections #-}
   8 {-# LANGUAGE MagicHash #-}
   9 {-# LANGUAGE UnboxedTuples #-} -- For nextInput
  10 {-# LANGUAGE UndecidableInstances #-} -- For Show (ParsingError inp)
  11 {-# OPTIONS_GHC -fno-warn-orphans #-}
  12 module Symantic.Parser.Machine.Generate where
  13
  14 import Control.DeepSeq (NFData(..))
  15 import Control.Monad (Monad(..))
  16 import Control.Monad.ST (ST, RealWorld)
  17 import Data.Bool (Bool(..), otherwise)
  18 import Data.Char (Char)
  19 import Data.Either (Either(..))
  20 import Data.Eq (Eq(..))
  21 import Data.Foldable (foldr, toList, null)
  22 import Data.Function (($), (.), on)
  23 import Data.Functor ((<$>))
  24 import Data.Int (Int)
  25 import Data.List.NonEmpty (NonEmpty(..))
  26 import Data.Map (Map)
  27 import Data.Maybe (Maybe(..))
  28 import Data.Ord (Ord(..), Ordering(..))
  29 import Data.Proxy (Proxy(..))
  30 import Data.Semigroup (Semigroup(..))
  31 import Data.Set (Set)
  32 import Data.String (String)
  33 import Data.Traversable (Traversable(..))
  34 import Data.Tuple (snd)
  35 import Data.Typeable (Typeable)
  36 import Data.Word (Word8)
  37 import GHC.Generics (Generic)
  38 import GHC.Show (showCommaSpace)
  39 import Language.Haskell.TH (CodeQ)
  40 import Prelude ((+), (-), error)
  41 import Text.Show (Show(..), showParen, showString)
  42 import qualified Data.HashMap.Strict as HM
  43 import qualified Data.List as List
  44 import qualified Data.List.NonEmpty as NE
  45 import qualified Data.Map.Internal as Map_
  46 import qualified Data.Map.Strict as Map
  47 import qualified Data.Set as Set
  48 import qualified Data.Set.Internal as Set_
  49 import qualified Data.STRef as ST
  50 import qualified Language.Haskell.TH as TH
  51 import qualified Language.Haskell.TH.Syntax as TH
  52
  53 import qualified Symantic.Semantics.Data as Sym
  54 import Symantic.Syntaxes.Derive
  55 import Symantic.Semantics.SharingObserver
  56 import qualified Symantic.Parser.Grammar as Gram
  57 import Symantic.Parser.Grammar.Combinators
  58   ( UnscopedRegister(..)
  59   , Exception(..)
  60   , Failure(..)
  61   , SomeFailure(..)
  62   , unSomeFailure
  63   , inputTokenProxy
  64   )
  65 import Symantic.Parser.Machine.Input
  66 import Symantic.Parser.Machine.Instructions
  67 import qualified Language.Haskell.TH.HideName as TH
  68 import qualified Symantic.Syntaxes.Classes as Prod
  69 import qualified Symantic.Semantics.Data as Prod
  70
  71 --import Debug.Trace
  72
  73 -- | Convenient utility to generate some final 'TH.CodeQ'.
  74 genCode :: Splice a -> CodeQ a
  75 genCode = derive . Prod.normalOrderReduction
  76
  77 -- * Type 'Gen'
  78 -- | Generate the 'CodeQ' parsing the input.
  79 data Gen inp vs a = Gen
  80   { genAnalysisByLet :: OpenRecs TH.Name GenAnalysis
  81     -- ^ 'genAnalysis' for each 'defLet' and 'defJoin' of the 'Machine'.
  82   , genAnalysis :: OpenRec TH.Name GenAnalysis
  83     -- ^ Synthetized (bottom-up) static genAnalysis of the 'Machine'.
  84   , unGen ::
  85       GenCtx inp vs a ->
  86       CodeQ (ST RealWorld (Result inp a))
  87   }
  88
  89 {-# INLINE returnST #-}
  90 returnST :: forall s a. a -> ST s a
  91 returnST = return @(ST s)
  92
  93 -- | @('generateCode' input mach)@ generates @TemplateHaskell@ code
  94 -- parsing the given input according to the given 'Machine'.
  95 generateCode ::
  96   -- Not really used constraints,
  97   -- just to please 'checkHorizon'.
  98   Ord (InputToken inp) =>
  99   Show (InputToken inp) =>
 100   TH.Lift (InputToken inp) =>
 101   NFData (InputToken inp) =>
 102   Typeable (InputToken inp) =>
 103   Inputable inp =>
 104   Show (InputPosition inp) =>
 105   Gen inp '[] a ->
 106   CodeQ (inp -> ST RealWorld (Result inp a))
 107 generateCode gen =
 108     let Gen{unGen=k, ..} = checkHorizon gen in
 109     [|| \(input :: inp) ->
 110     -- Pattern bindings containing unlifted types
 111     -- should use an outermost bang pattern.
 112     let !(# initBuffer, initPos, readMore, readNext, append #) = $$(cursorOf [||input||])
 113         finalRet = \_farInp _farExp v _inp _buf _end -> returnST $ ResultDone v
 114         finalRaise :: ForallOnException inp -- forall b. (OnException inp b)
 115           = ForallOnException $ \ !exn _failInp !farInp !farExp buf end ->
 116           returnST $ ResultError ParsingError
 117           { parsingErrorOffset = position farInp
 118           , parsingErrorException = exn
 119           , parsingErrorUnexpected =
 120               if readMore buf farInp
 121               then Just (let (# c, _ #) = readNext buf farInp in c)
 122               else Nothing
 123           , parsingErrorExpecting =
 124               let (minHoriz, res) =
 125                     Set.foldr (\f (minH, acc) ->
 126                       case unSomeFailure f of
 127                         Just (FailureHorizon h :: Failure (Gram.CombSatisfiable (InputToken inp)))
 128                           | Just old <- minH -> (Just (min old h), acc)
 129                           | otherwise -> (Just h, acc)
 130                         _ -> (minH, f:acc)
 131                       ) (Nothing, []) farExp in
 132               Set.fromList $ case minHoriz of
 133                 Just h -> SomeFailure (FailureHorizon @(InputToken inp) h) : res
 134                 Nothing -> res
 135           }
 136     in $$(
 137       let
 138         -- | Defines 'inputTokenProxy' so that the TemplateHaskell code
 139         -- can refer to @(InputToken inp)@ through it.
 140         defInputTokenProxy :: TH.CodeQ a -> TH.CodeQ a
 141         defInputTokenProxy exprCode =
 142           TH.unsafeCodeCoerce [|
 143             let $(return (TH.VarP inputTokenProxy)) = Proxy :: Proxy (InputToken inp) in
 144             $(TH.unTypeQ (TH.examineCode exprCode))
 145           |]
 146       in
 147       defInputTokenProxy $
 148       k GenCtx
 149         { valueStack = ValueStackEmpty
 150         , onExceptionStackByLabel = Map.empty :: Map Exception (NonEmpty (TH.CodeQ (OnException inp a)))
 151         , defaultCatch = [||unForallOnException finalRaise||]
 152         , onReturn = [||finalRet||] :: CodeQ (OnReturn inp a a)
 153         , input = [||initPos||]
 154         , inputBuffer = [||initBuffer||]
 155         , inputEnded = [||False||]
 156         , nextInput = [||readNext||]
 157         , moreInput = [||readMore||]
 158         , appendInput = [||append||]
 159         -- , farthestError = [||Nothing||]
 160         , farthestInput = [||initPos||]
 161         , farthestExpecting = [||Set.empty||]
 162         , checkedHorizon = 0
 163         , analysisByLet = mutualFix genAnalysisByLet
 164         }
 165       )
 166     ||]
 167
 168 -- ** Type 'ParsingError'
 169 data ParsingError inp
 170   =  ParsingError
 171   {  parsingErrorOffset :: Offset
 172   ,  parsingErrorException :: Exception
 173      -- | Note: if a 'FailureHorizon' greater than 1
 174      -- is amongst the 'parsingErrorExpecting'
 175      -- then 'parsingErrorUnexpected' is only the 'InputToken'
 176      -- at the begining of the expected 'Horizon'.
 177   ,  parsingErrorUnexpected :: Maybe (InputToken inp)
 178   ,  parsingErrorExpecting :: Set SomeFailure
 179   } deriving (Generic)
 180 deriving instance NFData (InputToken inp) => NFData (ParsingError inp)
 181 --deriving instance Show (InputToken inp) => Show (ParsingError inp)
 182 instance Show (InputToken inp) => Show (ParsingError inp) where
 183   showsPrec p ParsingError{..} =
 184     showParen (p >= 11) $
 185       showString "ParsingErrorStandard {" .
 186       showString "parsingErrorOffset = " .
 187       showsPrec 0 parsingErrorOffset .
 188       showCommaSpace .
 189       showString "parsingErrorException = " .
 190       showsPrec 0 parsingErrorException .
 191       showCommaSpace .
 192       showString "parsingErrorUnexpected = " .
 193       showsPrec 0 parsingErrorUnexpected .
 194       showCommaSpace .
 195       showString "parsingErrorExpecting = fromList " .
 196       showsPrec 0 (
 197         -- Sort on the string representation
 198         -- because the 'Ord' of the 'SomeFailure'
 199         -- is based upon hashes ('typeRepFingerprint')
 200         -- depending on packages' ABI and whether
 201         -- cabal-install's setup is --inplace or not,
 202         -- and that would be too unstable for golden tests.
 203         List.sortBy (compare `on` show) $
 204         Set.toList parsingErrorExpecting
 205       ) .
 206       showString "}"
 207
 208 -- ** Type 'ErrorLabel'
 209 type ErrorLabel = String
 210
 211 -- * Type 'GenAnalysis'
 212 data GenAnalysis = GenAnalysis
 213   { minReads :: Horizon
 214     -- ^ The minimun number of input tokens to read
 215     -- on the current 'input' to reach a success.
 216   , mayRaise :: Map Exception ()
 217     -- ^ The 'Exception's that may be raised depending on the 'input'.
 218   , alwaysRaise :: Set Exception
 219     -- ^ The 'Exception's raised whatever is or happen to the 'input'.
 220   , freeRegs :: Set TH.Name
 221     -- ^ The free registers that are used.
 222   } deriving (Show)
 223
 224 -- ** Type 'Offset'
 225 type Offset = Int
 226 -- ** Type 'Horizon'
 227 -- | Minimal input length required for a successful parsing.
 228 type Horizon = Offset
 229
 230 -- | Merge given 'GenAnalysis' as sequences.
 231 seqGenAnalysis :: NonEmpty GenAnalysis -> GenAnalysis
 232 seqGenAnalysis aas@(a:|as) = GenAnalysis
 233   { minReads = List.foldl' (\acc -> (acc +) . minReads) (minReads a) as
 234   , mayRaise = sconcat (mayRaise <$> aas)
 235   , alwaysRaise = sconcat (alwaysRaise <$> aas)
 236   , freeRegs = sconcat (freeRegs <$> aas)
 237   }
 238 -- | Merge given 'GenAnalysis' as alternatives.
 239 altGenAnalysis :: NonEmpty GenAnalysis -> GenAnalysis
 240 altGenAnalysis aas = GenAnalysis
 241   { minReads =
 242       case
 243         (`NE.filter` aas) $ \a ->
 244           -- If an alternative 'alwaysRaise's 'ExceptionFailure' whatever its 'input' is,
 245           -- it __should__ remain semantically the same (up to the exact 'Failure's)
 246           -- to raise an 'ExceptionFailure' even before knowing
 247           -- whether that alternative branch will be taken or not,
 248           -- hence an upstream 'checkHorizon' is allowed to raise an 'ExceptionFailure'
 249           -- based only upon the 'minReads' of such alternatives:
 250           Set.toList (alwaysRaise a) /= [ExceptionFailure]
 251       of
 252       [] -> 0
 253       a:as -> List.foldl' (\acc -> min acc . minReads) (minReads a) as
 254   , mayRaise = sconcat (mayRaise <$> aas)
 255   , alwaysRaise = foldr Set.intersection Set.empty (alwaysRaise <$> aas)
 256   , freeRegs = sconcat (freeRegs <$> aas)
 257   }
 258
 259
 260
 261 {-
 262 -- *** Type 'FarthestError'
 263 data FarthestError inp = FarthestError
 264   { farthestInput :: InputPosition inp
 265   , farthestExpecting :: [Failure (InputToken inp)]
 266   }
 267 -}
 268
 269 -- ** Type 'ForallOnException'
 270 newtype ForallOnException inp = ForallOnException {
 271   unForallOnException :: forall b. OnException inp b
 272   }
 273
 274 -- ** Type 'GenCtx'
 275 -- | This is an inherited (top-down) context
 276 -- only present at compile-time, to build TemplateHaskell splices.
 277 data GenCtx inp vs a =
 278   ( Inputable inp -- for partialCont
 279   -- For checkHorizon
 280   , TH.Lift (InputToken inp)
 281   , Show (InputToken inp)
 282   , Eq (InputToken inp)
 283   , Ord (InputToken inp)
 284   , Typeable (InputToken inp)
 285   , NFData (InputToken inp)
 286   ) => GenCtx
 287   { valueStack :: ValueStack vs
 288   , onExceptionStackByLabel :: Map Exception (NonEmpty (CodeQ (OnException inp a)))
 289     -- | Default 'OnException' defined at the begining of the generated 'CodeQ',
 290     -- hence a constant within the 'Gen'eration.
 291   , defaultCatch :: forall b. CodeQ (OnException inp b)
 292   , onReturn :: CodeQ (OnReturn inp a a)
 293   , inputBuffer :: CodeQ (InputBuffer inp)
 294   , inputEnded :: CodeQ Bool
 295   , input :: CodeQ (InputPosition inp)
 296   , moreInput :: CodeQ (InputBuffer inp -> InputPosition inp -> Bool)
 297   , nextInput :: CodeQ (InputBuffer inp -> InputPosition inp -> (# InputToken inp, InputPosition inp #))
 298   , appendInput :: CodeQ (InputBuffer inp -> inp -> InputBuffer inp)
 299   , farthestInput :: CodeQ (InputPosition inp)
 300   , farthestExpecting :: CodeQ (Set SomeFailure)
 301     -- | Remaining horizon already checked.
 302     -- Use to factorize 'input' length checks,
 303     -- instead of checking the 'input' length
 304     -- one 'InputToken' at a time at each 'read'.
 305     -- Updated by 'checkHorizon'
 306     -- and reset elsewhere when needed.
 307   , checkedHorizon :: Horizon
 308   -- | Output of 'mutualFix'.
 309   , analysisByLet :: LetRecs TH.Name GenAnalysis
 310   }
 311
 312 -- ** Type 'ValueStack'
 313 data ValueStack vs where
 314   ValueStackEmpty :: ValueStack '[]
 315   ValueStackCons ::
 316     { valueStackHead :: Splice v
 317     , valueStackTail :: ValueStack vs
 318     } -> ValueStack (v ': vs)
 319
 320 instance InstrComment Gen where
 321   comment msg k = k
 322     { unGen = \ctx -> {-trace "unGen.comment" $-}
 323       [||
 324         let _ = $$(liftTypedString $ "comment: "<>msg) in
 325         $$(unGen k ctx)
 326       ||]
 327     }
 328 instance InstrValuable Gen where
 329   pushValue x k = k
 330     { unGen = \ctx -> {-trace "unGen.pushValue" $-}
 331       [||
 332       let _ = "pushValue" in
 333       $$(unGen k ctx
 334         { valueStack = ValueStackCons x (valueStack ctx) })
 335       ||]
 336     }
 337   popValue k = k
 338     { unGen = \ctx -> {-trace "unGen.popValue" $-}
 339       [||
 340       let _ = "popValue" in
 341       $$(unGen k ctx
 342         { valueStack = valueStackTail (valueStack ctx) })
 343       ||]
 344     }
 345   lift2Value f k = k
 346     { unGen = \ctx -> {-trace "unGen.lift2Value" $-}
 347       [||
 348       let _ = $$(liftTypedString ("lift2Value checkedHorizon="<>show (checkedHorizon ctx))) in
 349       $$(unGen k ctx
 350         { valueStack =
 351           let ValueStackCons y (ValueStackCons x vs) = valueStack ctx in
 352           ValueStackCons (f Prod..@ x Prod..@ y) vs
 353         })
 354       ||]
 355     }
 356   swapValue k = k
 357     { unGen = \ctx -> {-trace "unGen.swapValue" $-} unGen k ctx
 358       { valueStack =
 359           let ValueStackCons y (ValueStackCons x vs) = valueStack ctx in
 360           ValueStackCons x (ValueStackCons y vs)
 361       }
 362     }
 363 instance InstrBranchable Gen where
 364   caseBranch kx ky = Gen
 365     { genAnalysisByLet = genAnalysisByLet kx <> genAnalysisByLet ky
 366     , genAnalysis = \final -> altGenAnalysis $
 367         genAnalysis kx final :|
 368         [genAnalysis ky final]
 369     , unGen = \ctx -> {-trace "unGen.caseBranch" $-}
 370       let ValueStackCons v vs = valueStack ctx in
 371       [||
 372         case $$(genCode v) of
 373           Left  x -> $$(unGen kx ctx{ valueStack = ValueStackCons (splice [||x||]) vs })
 374           Right y -> $$(unGen ky ctx{ valueStack = ValueStackCons (splice [||y||]) vs })
 375       ||]
 376     }
 377   choicesBranch bs default_ = Gen
 378     { genAnalysisByLet = sconcat $ genAnalysisByLet default_ :| (genAnalysisByLet . snd <$> bs)
 379     , genAnalysis = \final -> altGenAnalysis $
 380         (\k -> genAnalysis k final)
 381         <$> (default_:|(snd <$> bs))
 382     , unGen = \ctx0 -> {-trace "unGen.choicesBranch" $-}
 383       let ValueStackCons v vs = valueStack ctx0 in
 384       let ctx = ctx0{valueStack = vs} in
 385       let
 386         go x ((p,b):bs') = [||
 387           if $$(genCode (p Prod..@ x))
 388           then
 389             let _ = $$(liftTypedString ("choicesBranch checkedHorizon="<>show (checkedHorizon ctx))) in
 390             $$({-trace "unGen.choicesBranch.b" $-} unGen b ctx)
 391           else
 392             let _ = "choicesBranch.else" in
 393             $$(go x bs')
 394           ||]
 395         go _ _ = unGen default_ ctx
 396       in go v bs
 397     }
 398 instance InstrExceptionable Gen where
 399   raise exn = Gen
 400     { genAnalysisByLet = HM.empty
 401     , genAnalysis = \_final -> GenAnalysis
 402         { minReads = 0
 403         , mayRaise = Map.singleton (ExceptionLabel exn) ()
 404         , alwaysRaise = Set.singleton (ExceptionLabel exn)
 405         , freeRegs = Set.empty
 406         }
 407     , unGen = \ctx@GenCtx{} -> {-trace ("unGen.raise: "<>show exn) $-} [||
 408         $$(raiseException ctx (ExceptionLabel exn))
 409           (ExceptionLabel $$(TH.liftTyped exn))
 410           {-failInp-}$$(input ctx)
 411           {-farInp-}$$(input ctx)
 412           $$(farthestExpecting ctx)
 413           $$(inputBuffer ctx)
 414           $$(inputEnded ctx)
 415       ||]
 416     }
 417   fail fs = Gen
 418     { genAnalysisByLet = HM.empty
 419     , genAnalysis = \_final -> GenAnalysis
 420         { minReads = 0
 421         , mayRaise = Map.singleton ExceptionFailure ()
 422         , alwaysRaise = Set.singleton ExceptionFailure
 423         , freeRegs = Set.empty
 424         }
 425     , unGen = \ctx@GenCtx{} -> {-trace ("unGen.fail: "<>show exn) $-}
 426       if null fs
 427       then [|| -- Raise without updating the farthest error.
 428           $$(raiseException ctx ExceptionFailure)
 429             ExceptionFailure
 430             {-failInp-}$$(input ctx)
 431             $$(farthestInput ctx)
 432             $$(farthestExpecting ctx)
 433             $$(inputBuffer ctx)
 434             $$(inputEnded ctx)
 435         ||]
 436       else raiseFailure ctx [||fs||]
 437     }
 438   commit exn k = k
 439     { unGen = \ctx -> {-trace ("unGen.commit: "<>show exn) $-}
 440       [||
 441       let _ = "commit" in
 442       $$(unGen k ctx{onExceptionStackByLabel =
 443         Map.update (\case
 444             _r0:|(r1:rs) -> Just (r1:|rs)
 445             _ -> Nothing
 446           )
 447         exn (onExceptionStackByLabel ctx)
 448       })
 449       ||]
 450     }
 451   catch exn k onExn = Gen
 452     { genAnalysisByLet = genAnalysisByLet k <> genAnalysisByLet onExn
 453     , genAnalysis = \final ->
 454         let kAnalysis = genAnalysis k final in
 455         let onExnAnalysis = genAnalysis onExn final in
 456         altGenAnalysis $
 457           kAnalysis
 458             { mayRaise = Map.delete exn (mayRaise kAnalysis)
 459             , alwaysRaise = Set.delete exn (alwaysRaise kAnalysis)
 460             } :|
 461           [ onExnAnalysis ]
 462     , unGen = \ctx@GenCtx{} -> {-trace ("unGen.catch: "<>show exn) $-} [||
 463         let _ = $$(liftTypedString ("catch "<>show exn<>" checkedHorizon="<>show (checkedHorizon ctx))) in
 464         let onException = $$(onExceptionCode (input ctx) (checkedHorizon ctx) onExn ctx) in
 465         $$(unGen k ctx
 466         { onExceptionStackByLabel =
 467             Map.insertWith (<>) exn
 468               (NE.singleton [||onException||])
 469               (onExceptionStackByLabel ctx)
 470         }
 471       ) ||]
 472     }
 473 -- ** Class 'SpliceInputable'
 474 -- | Record an 'input' and a 'checkedHorizon' together
 475 -- to be able to put both of them on the 'valueStack',
 476 -- and having them moved together by operations
 477 -- on the 'valueStack' (eg. 'lift2Value').
 478 -- Used by 'saveInput' and 'loadInput'.
 479 class SpliceInputable repr where
 480   inputSave :: CodeQ inp -> Horizon -> repr inp
 481 data instance Sym.Data SpliceInputable repr a where
 482   InputSave :: CodeQ inp -> Horizon -> Sym.Data SpliceInputable repr inp
 483 instance SpliceInputable (Sym.Data SpliceInputable repr) where
 484   inputSave = InputSave
 485 instance SpliceInputable repr => SpliceInputable (Sym.SomeData repr) where
 486   inputSave inp = Sym.SomeData . InputSave inp
 487 instance SpliceInputable TH.CodeQ where
 488   inputSave inp _hor = inp
 489 instance SpliceInputable repr => Derivable (Sym.Data SpliceInputable repr) where
 490   derive = \case
 491     InputSave inp hor -> inputSave inp hor
 492 instance InstrInputable Gen where
 493   saveInput k = k
 494     { unGen = \ctx ->
 495         {-trace "unGen.saveInput" $-}
 496         [||
 497         let _ = $$(liftTypedString $ "saveInput checkedHorizon="<>show (checkedHorizon ctx)) in
 498         $$(unGen k ctx
 499           { valueStack = inputSave (input ctx) (checkedHorizon ctx) `ValueStackCons` valueStack ctx
 500           })
 501         ||]
 502     }
 503   loadInput k = k
 504     { unGen = \ctx@GenCtx{} ->
 505         {-trace "unGen.loadInput" $-}
 506         let ValueStackCons v vs = valueStack ctx in
 507         let (input, checkedHorizon) = case v of
 508               Sym.Data (InputSave i h) -> (i, h)
 509               -- This case should never happen if 'saveInput' is used.
 510               i -> (genCode i, 0) in
 511         [||
 512         let _ = $$(liftTypedString $ "loadInput checkedHorizon="<>show checkedHorizon) in
 513         $$(unGen (checkHorizon k) ctx
 514           { valueStack = vs
 515           , input
 516           , checkedHorizon
 517           })
 518         ||]
 519     , genAnalysis = \final ->
 520         let analysis = genAnalysis k final in
 521         -- The input is reset and thus any previous 'checkHorizon'
 522         -- cannot check after this 'loadInput'.
 523         analysis{minReads = 0}
 524     }
 525 instance InstrCallable Gen where
 526   defLet defs k = k
 527     { unGen = \ctx@GenCtx{} ->
 528         {-trace ("unGen.defLet: defs="<>show (HM.keys defs)) $-}
 529         TH.unsafeCodeCoerce $ do
 530           decls <- traverse (makeDecl ctx) (HM.toList defs)
 531           body <- TH.unTypeQ $ TH.examineCode $
 532             {-trace "unGen.defLet.body" $-}
 533             unGen k ctx
 534           return $ TH.LetE (
 535             -- | Use 'List.sortBy' to output more deterministic code
 536             -- to be able to golden test it, at the cost of more computations
 537             -- (at compile-time only though).
 538             List.sortBy (compare `on` TH.hideName) $
 539             toList decls
 540             ) body
 541     , genAnalysisByLet =
 542         HM.unions
 543           $ genAnalysisByLet k
 544           : ((\(SomeLet sub) -> genAnalysis sub) <$> defs)
 545           : ((\(SomeLet sub) -> genAnalysisByLet sub) <$> HM.elems defs)
 546     }
 547     where
 548     makeDecl ctx (subName, SomeLet sub) = do
 549       let subAnalysis = analysisByLet ctx HM.! subName
 550       body <- takeFreeRegs (freeRegs subAnalysis) $
 551         TH.unTypeQ $ TH.examineCode $ [|| -- buildRec in Parsley
 552         -- Called by 'call' or 'jump'.
 553         \ !callerOnReturn{- From onReturnCode -}
 554           !callerInput
 555           !callerBuffer
 556           !callerEnd
 557           !callerOnExceptionStackByLabel{- from the 'call'er's 'onExceptionStackByLabel' -} ->
 558           $$({-trace ("unGen.defLet.sub: "<>show subName) $-} unGen sub ctx
 559             { valueStack = ValueStackEmpty
 560             -- Build an 'onExceptionStackByLabel' for the 'mayRaise' exceptions of the subroutine,
 561             -- where each 'OnException' calls the one passed
 562             -- by the 'call'er (in 'callerOnExceptionStackByLabel').
 563             --
 564             -- Note that as it currently is, the 'call'er is not required
 565             -- to supply an 'OnException' stack for all the 'mayRaise' exceptions of the subroutine,
 566             -- because 'Map.findWithDefault' is used instead of 'Map.!'.
 567             , onExceptionStackByLabel = Map.mapWithKey
 568                 (\lbl () -> NE.singleton [||
 569                   Map.findWithDefault $$(defaultCatch ctx) lbl callerOnExceptionStackByLabel
 570                 ||])
 571                 ({-trace ("mayRaise: "<>show subName) $ -}mayRaise subAnalysis)
 572             , input = [||callerInput||]
 573             , inputBuffer = [||callerBuffer||]
 574             , inputEnded = [||callerEnd||]
 575             , onReturn = {-trace ("unGen.defLet.sub.onReturn: "<>show subName) $-} [||callerOnReturn||]
 576
 577             -- These are passed by the caller via 'callerOnReturn' or 'ko'
 578             -- , farthestInput =
 579             -- , farthestExpecting =
 580
 581             -- Some callers can call this declaration
 582             -- with zero 'checkedHorizon', hence use this minimum.
 583             -- TODO: maybe it could be improved a bit
 584             -- by taking the minimum of the checked horizons
 585             -- before all the 'call's and 'jump's to this declaration.
 586             , checkedHorizon = 0
 587             })
 588         ||]
 589       let decl = TH.FunD subName [TH.Clause [] (TH.NormalB body) []]
 590       return decl
 591   jump isRec (LetName subName) = Gen
 592     { genAnalysisByLet = HM.empty
 593     , genAnalysis = \final ->
 594         if isRec
 595         then GenAnalysis
 596           { minReads = 0
 597           , mayRaise = Map.empty
 598           , alwaysRaise = Set.empty
 599           , freeRegs = Set.empty
 600           }
 601         else final HM.! subName
 602     , unGen = \ctx -> {-trace ("unGen.jump: "<>show subName) $-}
 603       let subAnalysis = analysisByLet ctx HM.! subName in
 604       [||
 605       let _ = "jump" in
 606       $$(TH.unsafeCodeCoerce $
 607         giveFreeRegs (freeRegs subAnalysis) $
 608         return (TH.VarE subName))
 609         {-ok-}$$(onReturn ctx)
 610         $$(input ctx)
 611         $$(inputBuffer ctx)
 612         $$(inputEnded ctx)
 613         $$(liftTypedRaiseByLabel $
 614           onExceptionStackByLabel ctx
 615           -- Pass only the labels raised by the 'defLet'.
 616           `Map.intersection`
 617           (mayRaise subAnalysis)
 618         )
 619       ||]
 620     }
 621   call isRec (LetName subName) k = k
 622     { genAnalysis = \final ->
 623         if isRec
 624         then GenAnalysis
 625           { minReads = 0
 626           , mayRaise = Map.empty
 627           , alwaysRaise = Set.empty
 628           , freeRegs = Set.empty
 629           }
 630         else seqGenAnalysis $ (final HM.! subName) :| [ genAnalysis k final ]
 631     , unGen = {-trace ("unGen.call: "<>show subName) $-} \ctx ->
 632       -- let ks = (Map.keys (onExceptionStackByLabel ctx)) in
 633       let subAnalysis = analysisByLet ctx HM.! subName in
 634       [||
 635       -- let _ = $$(liftTypedString $ "call exceptByLet("<>show subName<>")="<>show (Map.keys (Map.findWithDefault Map.empty subName (exceptByLet ctx))) <> " onExceptionStackByLabel(ctx)="<> show ks) in
 636       $$(TH.unsafeCodeCoerce $
 637         giveFreeRegs (freeRegs subAnalysis) $
 638         return (TH.VarE subName))
 639         {-ok-}$$(onReturnCode k ctx)
 640         $$(input ctx)
 641         $$(inputBuffer ctx)
 642         $$(inputEnded ctx)
 643         $$(liftTypedRaiseByLabel $
 644           -- FIXME: maybe it should rather pass all the 'mayRaise' of 'subName'
 645           -- and 'defaultCatch' be removed from 'makeDecl''s 'onExceptionStackByLabel'.
 646           onExceptionStackByLabel ctx
 647           -- Pass only the labels raised by the 'defLet'.
 648           `Map.intersection`
 649           (mayRaise subAnalysis)
 650         )
 651       ||]
 652     }
 653   ret = Gen
 654     { genAnalysisByLet = HM.empty
 655     , genAnalysis = \_final -> GenAnalysis
 656         { minReads = 0
 657         , mayRaise = Map.empty
 658         , alwaysRaise = Set.empty
 659         , freeRegs = Set.empty
 660         }
 661     , unGen = \ctx -> {-trace "unGen.ret" $-}
 662       {-trace "unGen.ret.returnCode" $-}
 663       returnCode ({-trace "unGen.ret.onReturn" $-} onReturn ctx) ctx
 664     }
 665
 666 takeFreeRegs :: TH.Quote m => Set TH.Name -> m TH.Exp -> m TH.Exp
 667 takeFreeRegs frs k = go (Set.toList frs)
 668   where
 669   go [] = k
 670   go (r:rs) = [| \ $(return (TH.VarP r)) -> $(go rs) |]
 671
 672 giveFreeRegs :: TH.Quote m => Set TH.Name -> m TH.Exp -> m TH.Exp
 673 giveFreeRegs frs k = go (Set.toList frs)
 674   where
 675   go [] = k
 676   go (r:rs) = [| $(go rs) $(return (TH.VarE r)) |]
 677
 678 -- | Like 'TH.liftString' but on 'TH.Code'.
 679 -- Useful to get a 'TH.StringL' instead of a 'TH.ListE'.
 680 liftTypedString :: String -> TH.Code TH.Q a
 681 liftTypedString = TH.unsafeCodeCoerce . TH.liftString
 682
 683 -- | Like 'TH.liftTyped' but adjusted to work on 'onExceptionStackByLabel'
 684 -- which already contains 'CodeQ' terms.
 685 -- Moreover, only the 'OnException' at the top of the stack
 686 -- is needed and thus generated in the resulting 'CodeQ'.
 687 --
 688 -- TODO: Use an 'Array' instead of a 'Map'?
 689 liftTypedRaiseByLabel :: TH.Lift k => Map k (NonEmpty (CodeQ a)) -> CodeQ (Map k a)
 690 liftTypedRaiseByLabel Map_.Tip = [|| Map_.Tip ||]
 691 liftTypedRaiseByLabel (Map_.Bin s k (h:|_hs) l r) =
 692   [|| Map_.Bin s k $$h $$(liftTypedRaiseByLabel l) $$(liftTypedRaiseByLabel r) ||]
 693
 694 instance TH.Lift a => TH.Lift (Set a) where
 695   liftTyped Set_.Tip = [|| Set_.Tip ||]
 696   liftTyped (Set_.Bin s a l r) = [|| Set_.Bin $$(TH.liftTyped s) $$(TH.liftTyped a) $$(TH.liftTyped l) $$(TH.liftTyped r) ||]
 697
 698 -- ** Type 'OnReturn'
 699 -- | A continuation generated by 'onReturnCode' and later called by 'returnCode'.
 700 type OnReturn inp v a =
 701   {-farthestInput-}InputPosition inp ->
 702   {-farthestExpecting-}Set SomeFailure ->
 703   v ->
 704   InputPosition inp ->
 705   InputBuffer inp ->
 706   Bool ->
 707   ST RealWorld (Result inp a)
 708
 709 -- | Generate an 'OnReturn' continuation to be called with 'returnCode'.
 710 -- Used when 'call' 'ret'urns.
 711 -- The return 'v'alue is 'pushValue'-ed on the 'valueStack'.
 712 onReturnCode ::
 713   {-k-}Gen inp (v ': vs) a ->
 714   GenCtx inp vs a ->
 715   CodeQ (OnReturn inp v a)
 716 onReturnCode k ctx = [||
 717   let _ = $$(liftTypedString $ "onReturn") in
 718   \farInp farExp v !inp buf end ->
 719     $$({-trace "unGen.onReturnCode" $-} unGen k ctx
 720       { valueStack = ValueStackCons ({-trace "unGen.onReturnCode.value" $-} splice [||v||]) (valueStack ctx)
 721       , input = [||inp||]
 722       , inputBuffer = [||buf||]
 723       , inputEnded = [||end||]
 724       , farthestInput = [||farInp||]
 725       , farthestExpecting = [||farExp||]
 726       , checkedHorizon = 0
 727       }
 728     )
 729   ||]
 730
 731 -- | Generate a call to the 'onReturnCode' continuation.
 732 -- Used when 'call' 'ret'urns.
 733 returnCode ::
 734   CodeQ (OnReturn inp v a) ->
 735   GenCtx inp (v ': vs) a ->
 736   CodeQ (ST RealWorld (Result inp a))
 737 returnCode k = \ctx -> {-trace "returnCode" $-} [||
 738   let _ = "resume" in
 739   $$k
 740     $$(farthestInput ctx)
 741     $$(farthestExpecting ctx)
 742     (let _ = "resume.genCode" in $$({-trace "returnCode.genCode" $-}
 743       genCode $ valueStackHead $ valueStack ctx))
 744     $$(input ctx)
 745     $$(inputBuffer ctx)
 746     $$(inputEnded ctx)
 747   ||]
 748
 749 -- ** Type 'OnException'
 750 -- | A continuation generated by 'catch' and later called by 'raise' or 'fail'.
 751 type OnException inp a =
 752   Exception ->
 753   {-failInp-}InputPosition inp ->
 754   {-farInp-}InputPosition inp ->
 755   {-farExp-}Set SomeFailure ->
 756   {-buffer-}InputBuffer inp ->
 757   {-end-}Bool ->
 758   ST RealWorld (Result inp a)
 759
 760 -- TODO: some static infos should be attached to 'OnException'
 761 -- to avoid comparing inputs when they're the same
 762 -- and to improve 'checkedHorizon'.
 763 onExceptionCode ::
 764   CodeQ (InputPosition inp) -> Horizon ->
 765   Gen inp (InputPosition inp : vs) a ->
 766   GenCtx inp vs a -> TH.CodeQ (OnException inp a)
 767 onExceptionCode resetInput resetCheckedHorizon k ctx = [||
 768   let _ = $$(liftTypedString $ "onException") in
 769   \ !_exn !failInp !farInp !farExp buf end ->
 770     $$(unGen k ctx
 771       -- Push 'input' and 'checkedHorizon'
 772       -- as they were when entering the 'catch' or 'iter',
 773       -- they will be available to 'loadInput', if any.
 774       { valueStack = inputSave resetInput resetCheckedHorizon
 775                      `ValueStackCons` valueStack ctx
 776       -- Note that 'onExceptionStackByLabel' is reset.
 777       -- Move the input to the failing position.
 778       , input = [||failInp||]
 779       , inputBuffer = [||buf||]
 780       , inputEnded = [||end||]
 781       -- The 'checkedHorizon' at the 'raise's are not known here.
 782       -- Nor whether 'failInp' is after 'checkedHorizon' or not.
 783       -- Hence fallback to a safe value.
 784       , checkedHorizon = 0
 785       -- Set those to the farthest error computed in 'raiseFailure'.
 786       , farthestInput = [||farInp||]
 787       , farthestExpecting = [||farExp||]
 788       })
 789   ||]
 790
 791 instance InstrJoinable Gen where
 792   defJoin (LetName n) sub k = k
 793     { unGen = \ctx ->
 794         {-trace ("unGen.defJoin: "<>show n) $-}
 795         TH.unsafeCodeCoerce [|
 796           let $(return (TH.VarP n)) = $(TH.unTypeQ $ TH.examineCode [||
 797                 -- Called by 'returnCode'.
 798                 \farInp farExp v !inp buf end ->
 799                   $$({-trace ("unGen.defJoin.next: "<>show n) $-} unGen sub ctx
 800                     { valueStack = ValueStackCons (splice [||v||]) (valueStack ctx)
 801                     , input = [||inp||]
 802                     , inputBuffer = [||buf||]
 803                     , inputEnded = [||end||]
 804                     , farthestInput = [||farInp||]
 805                     , farthestExpecting = [||farExp||]
 806                     , checkedHorizon = 0
 807                     {- FIXME:
 808                     , onExceptionStackByLabel = Map.mapWithKey
 809                         (\lbl () -> NE.singleton [||koByLabel Map.! lbl||])
 810                         (mayRaise sub raiseLabelsByLetButSub)
 811                     -}
 812                     })
 813                 ||])
 814           in $(TH.unTypeQ $ TH.examineCode $
 815             {-trace ("unGen.defJoin.expr: "<>show n) $-}
 816             unGen k ctx)
 817         |]
 818     , genAnalysisByLet =
 819         (genAnalysisByLet sub <>) $
 820         HM.insert n (genAnalysis sub) $
 821         genAnalysisByLet k
 822     }
 823   refJoin (LetName n) = Gen
 824     { unGen = \ctx ->
 825         {-trace ("unGen.refJoin: "<>show n) $-}
 826         returnCode
 827           (TH.unsafeCodeCoerce (return (TH.VarE n))) ctx
 828     , genAnalysisByLet = HM.empty
 829     , genAnalysis = \final ->
 830         HM.findWithDefault
 831           (error (show (n,HM.keys final)))
 832           n final
 833     }
 834 instance InstrReadable Char Gen where
 835   read fs p = checkHorizon . checkToken fs p
 836 instance InstrReadable Word8 Gen where
 837   read fs p = checkHorizon . checkToken fs p
 838 instance InstrIterable Gen where
 839   iter (LetName loopJump) loop done = Gen
 840     { genAnalysisByLet = HM.unions
 841         [ -- No need to give 'freeRegs' when 'call'ing 'loopJump'
 842           -- because they're passed when 'call'ing 'iter'.
 843           -- This avoids to passing those registers around.
 844           HM.singleton loopJump (\final -> (genAnalysis loop final){freeRegs = Set.empty})
 845         , genAnalysisByLet loop
 846         , genAnalysisByLet done
 847         ]
 848     , genAnalysis = \final ->
 849       let loopAnalysis = genAnalysis loop final in
 850       let doneAnalysis = genAnalysis done final in
 851       GenAnalysis
 852         { minReads = minReads doneAnalysis
 853         , mayRaise =
 854             Map.delete ExceptionFailure (mayRaise loopAnalysis) <>
 855             mayRaise doneAnalysis
 856         , alwaysRaise =
 857             Set.delete ExceptionFailure (alwaysRaise loopAnalysis) <>
 858             alwaysRaise doneAnalysis
 859         , freeRegs = freeRegs loopAnalysis <> freeRegs doneAnalysis
 860         }
 861     , unGen = \ctx -> TH.unsafeCodeCoerce [|
 862         let _ = "iter" in
 863         let
 864           onException loopInput = $(TH.unTypeCode $ onExceptionCode
 865             (TH.unsafeCodeCoerce [|loopInput|]) 0 done ctx)
 866           $(return $ TH.VarP loopJump) = \_callerOnReturn callerInput callerBuffer callerEnded callerOnExceptionStackByLabel ->
 867             $(TH.unTypeCode $ unGen loop ctx
 868               { valueStack = ValueStackEmpty
 869               , onExceptionStackByLabel =
 870                   Map.insertWith (<>) ExceptionFailure
 871                     (NE.singleton $ TH.unsafeCodeCoerce [|onException callerInput|])
 872                     (onExceptionStackByLabel ctx)
 873               , input = TH.unsafeCodeCoerce [|callerInput|]
 874               , inputBuffer = TH.unsafeCodeCoerce [|callerBuffer|]
 875               , inputEnded = TH.unsafeCodeCoerce [|callerEnded|]
 876               -- FIXME: promote to compile time error?
 877               , onReturn = TH.unsafeCodeCoerce [|error "invalid onReturn"|]
 878               , checkedHorizon = 0
 879               })
 880         in $(TH.unTypeCode $ unGen (jump True (LetName loopJump)) ctx{valueStack=ValueStackEmpty})
 881        |]
 882     }
 883 instance InstrRegisterable Gen where
 884   newRegister (UnscopedRegister r) k = k
 885     { genAnalysis = \final ->
 886       let analysis = genAnalysis k final in
 887       analysis{freeRegs = Set.delete r $ freeRegs analysis}
 888     , unGen = \ctx ->
 889       let ValueStackCons v vs = valueStack ctx in
 890       TH.unsafeCodeCoerce [|
 891       do
 892         let dupv = $(TH.unTypeCode $ genCode v)
 893         $(return (TH.VarP r)) <- ST.newSTRef dupv
 894         $(TH.unTypeCode $ unGen k ctx{valueStack=vs})
 895       |]
 896     }
 897   readRegister (UnscopedRegister r) k = k
 898     { genAnalysis = \final ->
 899       let analysis = genAnalysis k final in
 900       analysis{freeRegs = Set.insert r $ freeRegs analysis}
 901     , unGen = \ctx -> [|| do
 902         sr <- ST.readSTRef $$(TH.unsafeCodeCoerce (return (TH.VarE r)))
 903         $$(unGen k ctx{valueStack=ValueStackCons (splice [||sr||]) (valueStack ctx)})
 904       ||]
 905     }
 906   writeRegister (UnscopedRegister r) k = k
 907     { genAnalysis = \final ->
 908       let analysis = genAnalysis k final in
 909       analysis{freeRegs = Set.insert r $ freeRegs analysis}
 910     , unGen = \ctx ->
 911       let ValueStackCons v vs = valueStack ctx in
 912       [|| do
 913         let dupv = $$(genCode v)
 914         ST.writeSTRef $$(TH.unsafeCodeCoerce (return (TH.VarE r))) dupv
 915         $$(unGen k ctx{valueStack=vs})
 916       ||]
 917     }
 918
 919 checkHorizon ::
 920   forall inp vs a.
 921   -- Those constraints are not used anyway
 922   -- because (TH.Lift SomeFailure) uses 'inputTokenProxy'.
 923   Ord (InputToken inp) =>
 924   Show (InputToken inp) =>
 925   TH.Lift (InputToken inp) =>
 926   NFData (InputToken inp) =>
 927   Typeable (InputToken inp) =>
 928   {-ok-}Gen inp vs a ->
 929   Gen inp vs a
 930 checkHorizon ok = ok
 931   { genAnalysis = \final -> seqGenAnalysis $
 932       GenAnalysis { minReads = 0
 933                   , mayRaise = Map.singleton ExceptionFailure ()
 934                   , alwaysRaise = Set.empty
 935                   , freeRegs = Set.empty
 936                   } :|
 937       [ genAnalysis ok final ]
 938   , unGen = \ctx0@GenCtx{} ->
 939     if checkedHorizon ctx0 >= 1
 940     then
 941       [||
 942         let _ = $$(liftTypedString $ "checkHorizon.oldCheck: checkedHorizon="<>show (checkedHorizon ctx0)) in
 943         $$(unGen ok ctx0{checkedHorizon = checkedHorizon ctx0 - 1})
 944       ||]
 945     else
 946       let minHoriz = minReads $ genAnalysis ok $ analysisByLet ctx0 in
 947       if minHoriz == 0
 948       then
 949         [||
 950           let _ = "checkHorizon.noCheck" in
 951           $$(unGen ok ctx0)
 952         ||]
 953       else
 954         [||
 955           let partialCont buf =
 956                 -- Factorize generated code for raising the "fail".
 957                 let readFail = $$(raiseException ctx0{inputBuffer=[||buf||]} ExceptionFailure) in
 958                 $$(
 959                   let ctx = ctx0
 960                         { onExceptionStackByLabel =
 961                             Map.adjust (\(_r:|rs) -> [||readFail||] :| rs)
 962                               ExceptionFailure (onExceptionStackByLabel ctx0)
 963                         , inputBuffer = [||buf||]
 964                         } in
 965                   [||
 966                     let _ = $$(liftTypedString $ "checkHorizon.newCheck: checkedHorizon="<>show (checkedHorizon ctx)<>" minHoriz="<>show minHoriz) in
 967                     if $$(moreInput ctx) buf
 968                          $$(if minHoriz > 1
 969                            then [||$$shiftRight $$(TH.liftTyped (minHoriz - 1)) $$(input ctx)||]
 970                            else input ctx)
 971                     then $$(unGen ok ctx{checkedHorizon = minHoriz})
 972                     else
 973                       let _ = $$(liftTypedString $ "checkHorizon.newCheck.fail") in
 974                       let noMoreInput = $$(unGen (fail (Set.singleton $ SomeFailure $ FailureHorizon @(InputToken inp) minHoriz)) ctx{inputEnded=[||True||]}) in
 975                       if $$(inputEnded ctx)
 976                       then noMoreInput
 977                       else returnST $ ResultPartial $ \newInput ->
 978                         if nullInput newInput
 979                         then noMoreInput
 980                         else partialCont ($$(appendInput ctx) buf newInput)
 981                         -- $$(raiseFailure ctx [||Set.singleton $ SomeFailure $ FailureHorizon @(InputToken inp) minHoriz||])
 982                   ||]
 983                 )
 984           in partialCont $$(inputBuffer ctx0)
 985         ||]
 986   }
 987
 988 -- * Type 'Result'
 989 data Result inp a
 990   =  ResultDone a
 991   |  ResultError (ParsingError inp)
 992   |  ResultPartial (inp -> ST RealWorld (Result inp a))
 993
 994 -- | @('raiseFailure' ctx fs)@ raises 'ExceptionFailure'
 995 -- with farthest parameters set to or updated with @(fs)@
 996 -- according to the relative position of 'input' wrt. 'farthestInput'.
 997 raiseFailure ::
 998   Positionable (InputPosition inp) =>
 999   GenCtx inp cs a ->
1000   TH.CodeQ (Set SomeFailure) ->
1001   TH.CodeQ (ST RealWorld (Result inp a))
1002 raiseFailure ctx fs = [||
1003   let failExp = $$fs in
1004   let (# farInp, farExp #) =
1005         case $$comparePosition $$(farthestInput ctx) $$(input ctx) of
1006           LT -> (# $$(input ctx), failExp #)
1007           EQ -> (# $$(farthestInput ctx), failExp <> $$(farthestExpecting ctx) #)
1008           GT -> (# $$(farthestInput ctx), $$(farthestExpecting ctx) #)
1009   in $$(raiseException ctx ExceptionFailure)
1010     ExceptionFailure
1011     {-failInp-}$$(input ctx) farInp farExp $$(inputBuffer ctx) $$(inputEnded ctx)
1012   ||]
1013 -- | @('raiseException' ctx exn)@ raises exception @(exn)@
1014 -- using any entry in 'onExceptionStackByLabel', or 'defaultCatch' if none.
1015 raiseException ::
1016   GenCtx inp vs a -> Exception ->
1017   CodeQ (OnException inp a)
1018 raiseException ctx exn =
1019   NE.head $ Map.findWithDefault
1020     (NE.singleton (defaultCatch ctx))
1021     exn (onExceptionStackByLabel ctx)
1022
1023 checkToken ::
1024   Set SomeFailure ->
1025   {-predicate-}Splice (InputToken inp -> Bool) ->
1026   {-ok-}Gen inp (InputToken inp ': vs) a ->
1027   Gen inp vs a
1028 checkToken fs p ok = ok
1029   { genAnalysis = \final -> seqGenAnalysis $
1030       GenAnalysis { minReads = 1
1031                   , mayRaise = Map.singleton ExceptionFailure ()
1032                   , alwaysRaise = Set.empty
1033                   , freeRegs = Set.empty
1034                   } :|
1035       [ genAnalysis ok final ]
1036   , unGen = \ctx -> {-trace "unGen.read" $-} [||
1037     let _ = "checkToken" in
1038     let !(# c, cs #) = $$(nextInput ctx) $$(inputBuffer ctx) $$(input ctx) in
1039     $$(genCode $
1040       Prod.ifThenElse
1041         (p Prod..@ splice [||c||])
1042         (splice $ unGen ok ctx
1043           { valueStack = ValueStackCons (splice [||c||]) (valueStack ctx)
1044           , input = [||cs||]
1045           })
1046         (splice [||
1047           let _ = "checkToken.fail" in
1048           $$(unGen (fail fs) ctx)
1049         ||])
1050     )||]
1051   }