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.Data as Sym
  54 import Symantic.Derive
  55 import Symantic.ObserveSharing
  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.Class as Prod
  69 import qualified Symantic.Optimize 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 :: forall b. (OnException inp b)
 115           = \ !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 = [||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 'GenCtx'
 270 -- | This is an inherited (top-down) context
 271 -- only present at compile-time, to build TemplateHaskell splices.
 272 data GenCtx inp vs a =
 273   ( Inputable inp -- for partialCont
 274   -- For checkHorizon
 275   , TH.Lift (InputToken inp)
 276   , Show (InputToken inp)
 277   , Eq (InputToken inp)
 278   , Ord (InputToken inp)
 279   , Typeable (InputToken inp)
 280   , NFData (InputToken inp)
 281   ) => GenCtx
 282   { valueStack :: ValueStack vs
 283   , onExceptionStackByLabel :: Map Exception (NonEmpty (CodeQ (OnException inp a)))
 284     -- | Default 'OnException' defined at the begining of the generated 'CodeQ',
 285     -- hence a constant within the 'Gen'eration.
 286   , defaultCatch :: forall b. CodeQ (OnException inp b)
 287   , onReturn :: CodeQ (OnReturn inp a a)
 288   , inputBuffer :: CodeQ (InputBuffer inp)
 289   , inputEnded :: CodeQ Bool
 290   , input :: CodeQ (InputPosition inp)
 291   , moreInput :: CodeQ (InputBuffer inp -> InputPosition inp -> Bool)
 292   , nextInput :: CodeQ (InputBuffer inp -> InputPosition inp -> (# InputToken inp, InputPosition inp #))
 293   , appendInput :: CodeQ (InputBuffer inp -> inp -> InputBuffer inp)
 294   , farthestInput :: CodeQ (InputPosition inp)
 295   , farthestExpecting :: CodeQ (Set SomeFailure)
 296     -- | Remaining horizon already checked.
 297     -- Use to factorize 'input' length checks,
 298     -- instead of checking the 'input' length
 299     -- one 'InputToken' at a time at each 'read'.
 300     -- Updated by 'checkHorizon'
 301     -- and reset elsewhere when needed.
 302   , checkedHorizon :: Horizon
 303   -- | Output of 'mutualFix'.
 304   , analysisByLet :: LetRecs TH.Name GenAnalysis
 305   }
 306
 307 -- ** Type 'ValueStack'
 308 data ValueStack vs where
 309   ValueStackEmpty :: ValueStack '[]
 310   ValueStackCons ::
 311     { valueStackHead :: Splice v
 312     , valueStackTail :: ValueStack vs
 313     } -> ValueStack (v ': vs)
 314
 315 instance InstrComment Gen where
 316   comment msg k = k
 317     { unGen = \ctx -> {-trace "unGen.comment" $-}
 318       [||
 319         let _ = $$(liftTypedString $ "comment: "<>msg) in
 320         $$(unGen k ctx)
 321       ||]
 322     }
 323 instance InstrValuable Gen where
 324   pushValue x k = k
 325     { unGen = \ctx -> {-trace "unGen.pushValue" $-}
 326       [||
 327       let _ = "pushValue" in
 328       $$(unGen k ctx
 329         { valueStack = ValueStackCons x (valueStack ctx) })
 330       ||]
 331     }
 332   popValue k = k
 333     { unGen = \ctx -> {-trace "unGen.popValue" $-}
 334       [||
 335       let _ = "popValue" in
 336       $$(unGen k ctx
 337         { valueStack = valueStackTail (valueStack ctx) })
 338       ||]
 339     }
 340   lift2Value f k = k
 341     { unGen = \ctx -> {-trace "unGen.lift2Value" $-}
 342       [||
 343       let _ = $$(liftTypedString ("lift2Value checkedHorizon="<>show (checkedHorizon ctx))) in
 344       $$(unGen k ctx
 345         { valueStack =
 346           let ValueStackCons y (ValueStackCons x vs) = valueStack ctx in
 347           ValueStackCons (f Prod..@ x Prod..@ y) vs
 348         })
 349       ||]
 350     }
 351   swapValue k = k
 352     { unGen = \ctx -> {-trace "unGen.swapValue" $-} unGen k ctx
 353       { valueStack =
 354           let ValueStackCons y (ValueStackCons x vs) = valueStack ctx in
 355           ValueStackCons x (ValueStackCons y vs)
 356       }
 357     }
 358 instance InstrBranchable Gen where
 359   caseBranch kx ky = Gen
 360     { genAnalysisByLet = genAnalysisByLet kx <> genAnalysisByLet ky
 361     , genAnalysis = \final -> altGenAnalysis $
 362         genAnalysis kx final :|
 363         [genAnalysis ky final]
 364     , unGen = \ctx -> {-trace "unGen.caseBranch" $-}
 365       let ValueStackCons v vs = valueStack ctx in
 366       [||
 367         case $$(genCode v) of
 368           Left  x -> $$(unGen kx ctx{ valueStack = ValueStackCons (splice [||x||]) vs })
 369           Right y -> $$(unGen ky ctx{ valueStack = ValueStackCons (splice [||y||]) vs })
 370       ||]
 371     }
 372   choicesBranch bs default_ = Gen
 373     { genAnalysisByLet = sconcat $ genAnalysisByLet default_ :| (genAnalysisByLet . snd <$> bs)
 374     , genAnalysis = \final -> altGenAnalysis $
 375         (\k -> genAnalysis k final)
 376         <$> (default_:|(snd <$> bs))
 377     , unGen = \ctx0 -> {-trace "unGen.choicesBranch" $-}
 378       let ValueStackCons v vs = valueStack ctx0 in
 379       let ctx = ctx0{valueStack = vs} in
 380       let
 381         go x ((p,b):bs') = [||
 382           if $$(genCode (p Prod..@ x))
 383           then
 384             let _ = $$(liftTypedString ("choicesBranch checkedHorizon="<>show (checkedHorizon ctx))) in
 385             $$({-trace "unGen.choicesBranch.b" $-} unGen b ctx)
 386           else
 387             let _ = "choicesBranch.else" in
 388             $$(go x bs')
 389           ||]
 390         go _ _ = unGen default_ ctx
 391       in go v bs
 392     }
 393 instance InstrExceptionable Gen where
 394   raise exn = Gen
 395     { genAnalysisByLet = HM.empty
 396     , genAnalysis = \_final -> GenAnalysis
 397         { minReads = 0
 398         , mayRaise = Map.singleton (ExceptionLabel exn) ()
 399         , alwaysRaise = Set.singleton (ExceptionLabel exn)
 400         , freeRegs = Set.empty
 401         }
 402     , unGen = \ctx@GenCtx{} -> {-trace ("unGen.raise: "<>show exn) $-} [||
 403         $$(raiseException ctx (ExceptionLabel exn))
 404           (ExceptionLabel $$(TH.liftTyped exn))
 405           {-failInp-}$$(input ctx)
 406           {-farInp-}$$(input ctx)
 407           $$(farthestExpecting ctx)
 408           $$(inputBuffer ctx)
 409           $$(inputEnded ctx)
 410       ||]
 411     }
 412   fail fs = Gen
 413     { genAnalysisByLet = HM.empty
 414     , genAnalysis = \_final -> GenAnalysis
 415         { minReads = 0
 416         , mayRaise = Map.singleton ExceptionFailure ()
 417         , alwaysRaise = Set.singleton ExceptionFailure
 418         , freeRegs = Set.empty
 419         }
 420     , unGen = \ctx@GenCtx{} -> {-trace ("unGen.fail: "<>show exn) $-}
 421       if null fs
 422       then [|| -- Raise without updating the farthest error.
 423           $$(raiseException ctx ExceptionFailure)
 424             ExceptionFailure
 425             {-failInp-}$$(input ctx)
 426             $$(farthestInput ctx)
 427             $$(farthestExpecting ctx)
 428             $$(inputBuffer ctx)
 429             $$(inputEnded ctx)
 430         ||]
 431       else raiseFailure ctx [||fs||]
 432     }
 433   commit exn k = k
 434     { unGen = \ctx -> {-trace ("unGen.commit: "<>show exn) $-}
 435       [||
 436       let _ = "commit" in
 437       $$(unGen k ctx{onExceptionStackByLabel =
 438         Map.update (\case
 439             _r0:|(r1:rs) -> Just (r1:|rs)
 440             _ -> Nothing
 441           )
 442         exn (onExceptionStackByLabel ctx)
 443       })
 444       ||]
 445     }
 446   catch exn k onExn = Gen
 447     { genAnalysisByLet = genAnalysisByLet k <> genAnalysisByLet onExn
 448     , genAnalysis = \final ->
 449         let kAnalysis = genAnalysis k final in
 450         let onExnAnalysis = genAnalysis onExn final in
 451         altGenAnalysis $
 452           kAnalysis
 453             { mayRaise = Map.delete exn (mayRaise kAnalysis)
 454             , alwaysRaise = Set.delete exn (alwaysRaise kAnalysis)
 455             } :|
 456           [ onExnAnalysis ]
 457     , unGen = \ctx@GenCtx{} -> {-trace ("unGen.catch: "<>show exn) $-} [||
 458         let _ = $$(liftTypedString ("catch "<>show exn<>" checkedHorizon="<>show (checkedHorizon ctx))) in
 459         let onException = $$(onExceptionCode (input ctx) (checkedHorizon ctx) onExn ctx) in
 460         $$(unGen k ctx
 461         { onExceptionStackByLabel =
 462             Map.insertWith (<>) exn
 463               (NE.singleton [||onException||])
 464               (onExceptionStackByLabel ctx)
 465         }
 466       ) ||]
 467     }
 468 -- ** Class 'SpliceInputable'
 469 -- | Record an 'input' and a 'checkedHorizon' together
 470 -- to be able to put both of them on the 'valueStack',
 471 -- and having them moved together by operations
 472 -- on the 'valueStack' (eg. 'lift2Value').
 473 -- Used by 'saveInput' and 'loadInput'.
 474 class SpliceInputable repr where
 475   inputSave :: CodeQ inp -> Horizon -> repr inp
 476 data instance Sym.Data SpliceInputable repr a where
 477   InputSave :: CodeQ inp -> Horizon -> Sym.Data SpliceInputable repr inp
 478 instance SpliceInputable (Sym.Data SpliceInputable repr) where
 479   inputSave = InputSave
 480 instance SpliceInputable repr => SpliceInputable (Sym.SomeData repr) where
 481   inputSave inp = Sym.SomeData . InputSave inp
 482 instance SpliceInputable TH.CodeQ where
 483   inputSave inp _hor = inp
 484 instance SpliceInputable repr => Derivable (Sym.Data SpliceInputable repr) where
 485   derive = \case
 486     InputSave inp hor -> inputSave inp hor
 487 instance InstrInputable Gen where
 488   saveInput k = k
 489     { unGen = \ctx ->
 490         {-trace "unGen.saveInput" $-}
 491         [||
 492         let _ = $$(liftTypedString $ "saveInput checkedHorizon="<>show (checkedHorizon ctx)) in
 493         $$(unGen k ctx
 494           { valueStack = inputSave (input ctx) (checkedHorizon ctx) `ValueStackCons` valueStack ctx
 495           })
 496         ||]
 497     }
 498   loadInput k = k
 499     { unGen = \ctx@GenCtx{} ->
 500         {-trace "unGen.loadInput" $-}
 501         let ValueStackCons v vs = valueStack ctx in
 502         let (input, checkedHorizon) = case v of
 503               Sym.Data (InputSave i h) -> (i, h)
 504               -- This case should never happen if 'saveInput' is used.
 505               i -> (genCode i, 0) in
 506         [||
 507         let _ = $$(liftTypedString $ "loadInput checkedHorizon="<>show checkedHorizon) in
 508         $$(unGen (checkHorizon k) ctx
 509           { valueStack = vs
 510           , input
 511           , checkedHorizon
 512           })
 513         ||]
 514     , genAnalysis = \final ->
 515         let analysis = genAnalysis k final in
 516         -- The input is reset and thus any previous 'checkHorizon'
 517         -- cannot check after this 'loadInput'.
 518         analysis{minReads = 0}
 519     }
 520 instance InstrCallable Gen where
 521   defLet defs k = k
 522     { unGen = \ctx@GenCtx{} ->
 523         {-trace ("unGen.defLet: defs="<>show (HM.keys defs)) $-}
 524         TH.unsafeCodeCoerce $ do
 525           decls <- traverse (makeDecl ctx) (HM.toList defs)
 526           body <- TH.unTypeQ $ TH.examineCode $
 527             {-trace "unGen.defLet.body" $-}
 528             unGen k ctx
 529           return $ TH.LetE (
 530             -- | Use 'List.sortBy' to output more deterministic code
 531             -- to be able to golden test it, at the cost of more computations
 532             -- (at compile-time only though).
 533             List.sortBy (compare `on` TH.hideName) $
 534             toList decls
 535             ) body
 536     , genAnalysisByLet =
 537         HM.unions
 538           $ genAnalysisByLet k
 539           : ((\(SomeLet sub) -> genAnalysis sub) <$> defs)
 540           : ((\(SomeLet sub) -> genAnalysisByLet sub) <$> HM.elems defs)
 541     }
 542     where
 543     makeDecl ctx (subName, SomeLet sub) = do
 544       let subAnalysis = analysisByLet ctx HM.! subName
 545       body <- takeFreeRegs (freeRegs subAnalysis) $
 546         TH.unTypeQ $ TH.examineCode $ [|| -- buildRec in Parsley
 547         -- Called by 'call' or 'jump'.
 548         \ !callerOnReturn{- From onReturnCode -}
 549           !callerInput
 550           !callerBuffer
 551           !callerEnd
 552           !callerOnExceptionStackByLabel{- from the 'call'er's 'onExceptionStackByLabel' -} ->
 553           $$({-trace ("unGen.defLet.sub: "<>show subName) $-} unGen sub ctx
 554             { valueStack = ValueStackEmpty
 555             -- Build an 'onExceptionStackByLabel' for the 'mayRaise' exceptions of the subroutine,
 556             -- where each 'OnException' calls the one passed
 557             -- by the 'call'er (in 'callerOnExceptionStackByLabel').
 558             --
 559             -- Note that as it currently is, the 'call'er is not required
 560             -- to supply an 'OnException' stack for all the 'mayRaise' exceptions of the subroutine,
 561             -- because 'Map.findWithDefault' is used instead of 'Map.!'.
 562             , onExceptionStackByLabel = Map.mapWithKey
 563                 (\lbl () -> NE.singleton [||
 564                   Map.findWithDefault $$(defaultCatch ctx) lbl callerOnExceptionStackByLabel
 565                 ||])
 566                 ({-trace ("mayRaise: "<>show subName) $ -}mayRaise subAnalysis)
 567             , input = [||callerInput||]
 568             , inputBuffer = [||callerBuffer||]
 569             , inputEnded = [||callerEnd||]
 570             , onReturn = {-trace ("unGen.defLet.sub.onReturn: "<>show subName) $-} [||callerOnReturn||]
 571
 572             -- These are passed by the caller via 'callerOnReturn' or 'ko'
 573             -- , farthestInput =
 574             -- , farthestExpecting =
 575
 576             -- Some callers can call this declaration
 577             -- with zero 'checkedHorizon', hence use this minimum.
 578             -- TODO: maybe it could be improved a bit
 579             -- by taking the minimum of the checked horizons
 580             -- before all the 'call's and 'jump's to this declaration.
 581             , checkedHorizon = 0
 582             })
 583         ||]
 584       let decl = TH.FunD subName [TH.Clause [] (TH.NormalB body) []]
 585       return decl
 586   jump isRec (LetName subName) = Gen
 587     { genAnalysisByLet = HM.empty
 588     , genAnalysis = \final ->
 589         if isRec
 590         then GenAnalysis
 591           { minReads = 0
 592           , mayRaise = Map.empty
 593           , alwaysRaise = Set.empty
 594           , freeRegs = Set.empty
 595           }
 596         else final HM.! subName
 597     , unGen = \ctx -> {-trace ("unGen.jump: "<>show subName) $-}
 598       let subAnalysis = analysisByLet ctx HM.! subName in
 599       [||
 600       let _ = "jump" in
 601       $$(TH.unsafeCodeCoerce $
 602         giveFreeRegs (freeRegs subAnalysis) $
 603         return (TH.VarE subName))
 604         {-ok-}$$(onReturn ctx)
 605         $$(input ctx)
 606         $$(inputBuffer ctx)
 607         $$(inputEnded ctx)
 608         $$(liftTypedRaiseByLabel $
 609           onExceptionStackByLabel ctx
 610           -- Pass only the labels raised by the 'defLet'.
 611           `Map.intersection`
 612           (mayRaise subAnalysis)
 613         )
 614       ||]
 615     }
 616   call isRec (LetName subName) k = k
 617     { genAnalysis = \final ->
 618         if isRec
 619         then GenAnalysis
 620           { minReads = 0
 621           , mayRaise = Map.empty
 622           , alwaysRaise = Set.empty
 623           , freeRegs = Set.empty
 624           }
 625         else seqGenAnalysis $ (final HM.! subName) :| [ genAnalysis k final ]
 626     , unGen = {-trace ("unGen.call: "<>show subName) $-} \ctx ->
 627       -- let ks = (Map.keys (onExceptionStackByLabel ctx)) in
 628       let subAnalysis = analysisByLet ctx HM.! subName in
 629       [||
 630       -- let _ = $$(liftTypedString $ "call exceptByLet("<>show subName<>")="<>show (Map.keys (Map.findWithDefault Map.empty subName (exceptByLet ctx))) <> " onExceptionStackByLabel(ctx)="<> show ks) in
 631       $$(TH.unsafeCodeCoerce $
 632         giveFreeRegs (freeRegs subAnalysis) $
 633         return (TH.VarE subName))
 634         {-ok-}$$(onReturnCode k ctx)
 635         $$(input ctx)
 636         $$(inputBuffer ctx)
 637         $$(inputEnded ctx)
 638         $$(liftTypedRaiseByLabel $
 639           -- FIXME: maybe it should rather pass all the 'mayRaise' of 'subName'
 640           -- and 'defaultCatch' be removed from 'makeDecl''s 'onExceptionStackByLabel'.
 641           onExceptionStackByLabel ctx
 642           -- Pass only the labels raised by the 'defLet'.
 643           `Map.intersection`
 644           (mayRaise subAnalysis)
 645         )
 646       ||]
 647     }
 648   ret = Gen
 649     { genAnalysisByLet = HM.empty
 650     , genAnalysis = \_final -> GenAnalysis
 651         { minReads = 0
 652         , mayRaise = Map.empty
 653         , alwaysRaise = Set.empty
 654         , freeRegs = Set.empty
 655         }
 656     , unGen = \ctx -> {-trace "unGen.ret" $-}
 657       {-trace "unGen.ret.returnCode" $-}
 658       returnCode ({-trace "unGen.ret.onReturn" $-} onReturn ctx) ctx
 659     }
 660
 661 takeFreeRegs :: TH.Quote m => Set TH.Name -> m TH.Exp -> m TH.Exp
 662 takeFreeRegs frs k = go (Set.toList frs)
 663   where
 664   go [] = k
 665   go (r:rs) = [| \ $(return (TH.VarP r)) -> $(go rs) |]
 666
 667 giveFreeRegs :: TH.Quote m => Set TH.Name -> m TH.Exp -> m TH.Exp
 668 giveFreeRegs frs k = go (Set.toList frs)
 669   where
 670   go [] = k
 671   go (r:rs) = [| $(go rs) $(return (TH.VarE r)) |]
 672
 673 -- | Like 'TH.liftString' but on 'TH.Code'.
 674 -- Useful to get a 'TH.StringL' instead of a 'TH.ListE'.
 675 liftTypedString :: String -> TH.Code TH.Q a
 676 liftTypedString = TH.unsafeCodeCoerce . TH.liftString
 677
 678 -- | Like 'TH.liftTyped' but adjusted to work on 'onExceptionStackByLabel'
 679 -- which already contains 'CodeQ' terms.
 680 -- Moreover, only the 'OnException' at the top of the stack
 681 -- is needed and thus generated in the resulting 'CodeQ'.
 682 --
 683 -- TODO: Use an 'Array' instead of a 'Map'?
 684 liftTypedRaiseByLabel :: TH.Lift k => Map k (NonEmpty (CodeQ a)) -> CodeQ (Map k a)
 685 liftTypedRaiseByLabel Map_.Tip = [|| Map_.Tip ||]
 686 liftTypedRaiseByLabel (Map_.Bin s k (h:|_hs) l r) =
 687   [|| Map_.Bin s k $$h $$(liftTypedRaiseByLabel l) $$(liftTypedRaiseByLabel r) ||]
 688
 689 instance TH.Lift a => TH.Lift (Set a) where
 690   liftTyped Set_.Tip = [|| Set_.Tip ||]
 691   liftTyped (Set_.Bin s a l r) = [|| Set_.Bin $$(TH.liftTyped s) $$(TH.liftTyped a) $$(TH.liftTyped l) $$(TH.liftTyped r) ||]
 692
 693 -- ** Type 'OnReturn'
 694 -- | A continuation generated by 'onReturnCode' and later called by 'returnCode'.
 695 type OnReturn inp v a =
 696   {-farthestInput-}InputPosition inp ->
 697   {-farthestExpecting-}Set SomeFailure ->
 698   v ->
 699   InputPosition inp ->
 700   InputBuffer inp ->
 701   Bool ->
 702   ST RealWorld (Result inp a)
 703
 704 -- | Generate an 'OnReturn' continuation to be called with 'returnCode'.
 705 -- Used when 'call' 'ret'urns.
 706 -- The return 'v'alue is 'pushValue'-ed on the 'valueStack'.
 707 onReturnCode ::
 708   {-k-}Gen inp (v ': vs) a ->
 709   GenCtx inp vs a ->
 710   CodeQ (OnReturn inp v a)
 711 onReturnCode k ctx = [||
 712   let _ = $$(liftTypedString $ "onReturn") in
 713   \farInp farExp v !inp buf end ->
 714     $$({-trace "unGen.onReturnCode" $-} unGen k ctx
 715       { valueStack = ValueStackCons ({-trace "unGen.onReturnCode.value" $-} splice [||v||]) (valueStack ctx)
 716       , input = [||inp||]
 717       , inputBuffer = [||buf||]
 718       , inputEnded = [||end||]
 719       , farthestInput = [||farInp||]
 720       , farthestExpecting = [||farExp||]
 721       , checkedHorizon = 0
 722       }
 723     )
 724   ||]
 725
 726 -- | Generate a call to the 'onReturnCode' continuation.
 727 -- Used when 'call' 'ret'urns.
 728 returnCode ::
 729   CodeQ (OnReturn inp v a) ->
 730   GenCtx inp (v ': vs) a ->
 731   CodeQ (ST RealWorld (Result inp a))
 732 returnCode k = \ctx -> {-trace "returnCode" $-} [||
 733   let _ = "resume" in
 734   $$k
 735     $$(farthestInput ctx)
 736     $$(farthestExpecting ctx)
 737     (let _ = "resume.genCode" in $$({-trace "returnCode.genCode" $-}
 738       genCode $ valueStackHead $ valueStack ctx))
 739     $$(input ctx)
 740     $$(inputBuffer ctx)
 741     $$(inputEnded ctx)
 742   ||]
 743
 744 -- ** Type 'OnException'
 745 -- | A continuation generated by 'catch' and later called by 'raise' or 'fail'.
 746 type OnException inp a =
 747   Exception ->
 748   {-failInp-}InputPosition inp ->
 749   {-farInp-}InputPosition inp ->
 750   {-farExp-}Set SomeFailure ->
 751   {-buffer-}InputBuffer inp ->
 752   {-end-}Bool ->
 753   ST RealWorld (Result inp a)
 754
 755 -- TODO: some static infos should be attached to 'OnException'
 756 -- to avoid comparing inputs when they're the same
 757 -- and to improve 'checkedHorizon'.
 758 onExceptionCode ::
 759   CodeQ (InputPosition inp) -> Horizon ->
 760   Gen inp (InputPosition inp : vs) a ->
 761   GenCtx inp vs a -> TH.CodeQ (OnException inp a)
 762 onExceptionCode resetInput resetCheckedHorizon k ctx = [||
 763   let _ = $$(liftTypedString $ "onException") in
 764   \ !_exn !failInp !farInp !farExp buf end ->
 765     $$(unGen k ctx
 766       -- Push 'input' and 'checkedHorizon'
 767       -- as they were when entering the 'catch' or 'iter',
 768       -- they will be available to 'loadInput', if any.
 769       { valueStack = inputSave resetInput resetCheckedHorizon
 770                      `ValueStackCons` valueStack ctx
 771       -- Note that 'onExceptionStackByLabel' is reset.
 772       -- Move the input to the failing position.
 773       , input = [||failInp||]
 774       , inputBuffer = [||buf||]
 775       , inputEnded = [||end||]
 776       -- The 'checkedHorizon' at the 'raise's are not known here.
 777       -- Nor whether 'failInp' is after 'checkedHorizon' or not.
 778       -- Hence fallback to a safe value.
 779       , checkedHorizon = 0
 780       -- Set those to the farthest error computed in 'raiseFailure'.
 781       , farthestInput = [||farInp||]
 782       , farthestExpecting = [||farExp||]
 783       })
 784   ||]
 785
 786 instance InstrJoinable Gen where
 787   defJoin (LetName n) sub k = k
 788     { unGen = \ctx ->
 789         {-trace ("unGen.defJoin: "<>show n) $-}
 790         TH.unsafeCodeCoerce [|
 791           let $(return (TH.VarP n)) = $(TH.unTypeQ $ TH.examineCode [||
 792                 -- Called by 'returnCode'.
 793                 \farInp farExp v !inp ->
 794                   $$({-trace ("unGen.defJoin.next: "<>show n) $-} unGen sub ctx
 795                     { valueStack = ValueStackCons (splice [||v||]) (valueStack ctx)
 796                     , input = [||inp||]
 797                     , farthestInput = [||farInp||]
 798                     , farthestExpecting = [||farExp||]
 799                     , checkedHorizon = 0
 800                     {- FIXME:
 801                     , onExceptionStackByLabel = Map.mapWithKey
 802                         (\lbl () -> NE.singleton [||koByLabel Map.! lbl||])
 803                         (mayRaise sub raiseLabelsByLetButSub)
 804                     -}
 805                     })
 806                 ||])
 807           in $(TH.unTypeQ $ TH.examineCode $
 808             {-trace ("unGen.defJoin.expr: "<>show n) $-}
 809             unGen k ctx)
 810         |]
 811     , genAnalysisByLet =
 812         (genAnalysisByLet sub <>) $
 813         HM.insert n (genAnalysis sub) $
 814         genAnalysisByLet k
 815     }
 816   refJoin (LetName n) = Gen
 817     { unGen = \ctx ->
 818         {-trace ("unGen.refJoin: "<>show n) $-}
 819         returnCode
 820           (TH.unsafeCodeCoerce (return (TH.VarE n))) ctx
 821     , genAnalysisByLet = HM.empty
 822     , genAnalysis = \final ->
 823         HM.findWithDefault
 824           (error (show (n,HM.keys final)))
 825           n final
 826     }
 827 instance InstrReadable Char Gen where
 828   read fs p = checkHorizon . checkToken fs p
 829 instance InstrReadable Word8 Gen where
 830   read fs p = checkHorizon . checkToken fs p
 831 instance InstrIterable Gen where
 832   iter (LetName loopJump) loop done = Gen
 833     { genAnalysisByLet = HM.unions
 834         [ -- No need to give 'freeRegs' when 'call'ing 'loopJump'
 835           -- because they're passed when 'call'ing 'iter'.
 836           -- This avoids to passing those registers around.
 837           HM.singleton loopJump (\final -> (genAnalysis loop final){freeRegs = Set.empty})
 838         , genAnalysisByLet loop
 839         , genAnalysisByLet done
 840         ]
 841     , genAnalysis = \final ->
 842       let loopAnalysis = genAnalysis loop final in
 843       let doneAnalysis = genAnalysis done final in
 844       GenAnalysis
 845         { minReads = minReads doneAnalysis
 846         , mayRaise =
 847             Map.delete ExceptionFailure (mayRaise loopAnalysis) <>
 848             mayRaise doneAnalysis
 849         , alwaysRaise =
 850             Set.delete ExceptionFailure (alwaysRaise loopAnalysis) <>
 851             alwaysRaise doneAnalysis
 852         , freeRegs = freeRegs loopAnalysis <> freeRegs doneAnalysis
 853         }
 854     , unGen = \ctx -> TH.unsafeCodeCoerce [|
 855         let _ = "iter" in
 856         let
 857           onException loopInput = $(TH.unTypeCode $ onExceptionCode
 858             (TH.unsafeCodeCoerce [|loopInput|]) 0 done ctx)
 859           $(return $ TH.VarP loopJump) = \_callerOnReturn callerInput callerBuffer callerEnded callerOnExceptionStackByLabel ->
 860             $(TH.unTypeCode $ unGen loop ctx
 861               { valueStack = ValueStackEmpty
 862               , onExceptionStackByLabel =
 863                   Map.insertWith (<>) ExceptionFailure
 864                     (NE.singleton $ TH.unsafeCodeCoerce [|onException callerInput|])
 865                     (onExceptionStackByLabel ctx)
 866               , input = TH.unsafeCodeCoerce [|callerInput|]
 867               , inputBuffer = TH.unsafeCodeCoerce [|callerBuffer|]
 868               , inputEnded = TH.unsafeCodeCoerce [|callerEnded|]
 869               -- FIXME: promote to compile time error?
 870               , onReturn = TH.unsafeCodeCoerce [|error "invalid onReturn"|]
 871               , checkedHorizon = 0
 872               })
 873         in $(TH.unTypeCode $ unGen (jump True (LetName loopJump)) ctx{valueStack=ValueStackEmpty})
 874        |]
 875     }
 876 instance InstrRegisterable Gen where
 877   newRegister (UnscopedRegister r) k = k
 878     { genAnalysis = \final ->
 879       let analysis = genAnalysis k final in
 880       analysis{freeRegs = Set.delete r $ freeRegs analysis}
 881     , unGen = \ctx ->
 882       let ValueStackCons v vs = valueStack ctx in
 883       TH.unsafeCodeCoerce [|
 884       do
 885         let dupv = $(TH.unTypeCode $ genCode v)
 886         $(return (TH.VarP r)) <- ST.newSTRef dupv
 887         $(TH.unTypeCode $ unGen k ctx{valueStack=vs})
 888       |]
 889     }
 890   readRegister (UnscopedRegister r) k = k
 891     { genAnalysis = \final ->
 892       let analysis = genAnalysis k final in
 893       analysis{freeRegs = Set.insert r $ freeRegs analysis}
 894     , unGen = \ctx -> [|| do
 895         sr <- ST.readSTRef $$(TH.unsafeCodeCoerce (return (TH.VarE r)))
 896         $$(unGen k ctx{valueStack=ValueStackCons (splice [||sr||]) (valueStack ctx)})
 897       ||]
 898     }
 899   writeRegister (UnscopedRegister r) k = k
 900     { genAnalysis = \final ->
 901       let analysis = genAnalysis k final in
 902       analysis{freeRegs = Set.insert r $ freeRegs analysis}
 903     , unGen = \ctx ->
 904       let ValueStackCons v vs = valueStack ctx in
 905       [|| do
 906         let dupv = $$(genCode v)
 907         ST.writeSTRef $$(TH.unsafeCodeCoerce (return (TH.VarE r))) dupv
 908         $$(unGen k ctx{valueStack=vs})
 909       ||]
 910     }
 911
 912 checkHorizon ::
 913   forall inp vs a.
 914   -- Those constraints are not used anyway
 915   -- because (TH.Lift SomeFailure) uses 'inputTokenProxy'.
 916   Ord (InputToken inp) =>
 917   Show (InputToken inp) =>
 918   TH.Lift (InputToken inp) =>
 919   NFData (InputToken inp) =>
 920   Typeable (InputToken inp) =>
 921   {-ok-}Gen inp vs a ->
 922   Gen inp vs a
 923 checkHorizon ok = ok
 924   { genAnalysis = \final -> seqGenAnalysis $
 925       GenAnalysis { minReads = 0
 926                   , mayRaise = Map.singleton ExceptionFailure ()
 927                   , alwaysRaise = Set.empty
 928                   , freeRegs = Set.empty
 929                   } :|
 930       [ genAnalysis ok final ]
 931   , unGen = \ctx0@GenCtx{} ->
 932     if checkedHorizon ctx0 >= 1
 933     then
 934       [||
 935         let _ = $$(liftTypedString $ "checkHorizon.oldCheck: checkedHorizon="<>show (checkedHorizon ctx0)) in
 936         $$(unGen ok ctx0{checkedHorizon = checkedHorizon ctx0 - 1})
 937       ||]
 938     else
 939       let minHoriz = minReads $ genAnalysis ok $ analysisByLet ctx0 in
 940       if minHoriz == 0
 941       then
 942         [||
 943           let _ = "checkHorizon.noCheck" in
 944           $$(unGen ok ctx0)
 945         ||]
 946       else
 947         [||
 948           let partialCont buf =
 949                 -- Factorize generated code for raising the "fail".
 950                 let readFail = $$(raiseException ctx0{inputBuffer=[||buf||]} ExceptionFailure) in
 951                 $$(
 952                   let ctx = ctx0
 953                         { onExceptionStackByLabel =
 954                             Map.adjust (\(_r:|rs) -> [||readFail||] :| rs)
 955                               ExceptionFailure (onExceptionStackByLabel ctx0)
 956                         , inputBuffer = [||buf||]
 957                         } in
 958                   [||
 959                     let _ = $$(liftTypedString $ "checkHorizon.newCheck: checkedHorizon="<>show (checkedHorizon ctx)<>" minHoriz="<>show minHoriz) in
 960                     if $$(moreInput ctx) buf
 961                          $$(if minHoriz > 1
 962                            then [||$$shiftRight $$(TH.liftTyped (minHoriz - 1)) $$(input ctx)||]
 963                            else input ctx)
 964                     then $$(unGen ok ctx{checkedHorizon = minHoriz})
 965                     else
 966                       let _ = $$(liftTypedString $ "checkHorizon.newCheck.fail") in
 967                       let noMoreInput = $$(unGen (fail (Set.singleton $ SomeFailure $ FailureHorizon @(InputToken inp) minHoriz)) ctx{inputEnded=[||True||]}) in
 968                       if $$(inputEnded ctx)
 969                       then noMoreInput
 970                       else returnST $ ResultPartial $ \newInput ->
 971                         if nullInput newInput
 972                         then noMoreInput
 973                         else partialCont ($$(appendInput ctx) buf newInput)
 974                         -- $$(raiseFailure ctx [||Set.singleton $ SomeFailure $ FailureHorizon @(InputToken inp) minHoriz||])
 975                   ||]
 976                 )
 977           in partialCont $$(inputBuffer ctx0)
 978         ||]
 979   }
 980
 981 -- * Type 'Result'
 982 data Result inp a
 983   =  ResultDone a
 984   |  ResultError (ParsingError inp)
 985   |  ResultPartial (inp -> ST RealWorld (Result inp a))
 986
 987 -- | @('raiseFailure' ctx fs)@ raises 'ExceptionFailure'
 988 -- with farthest parameters set to or updated with @(fs)@
 989 -- according to the relative position of 'input' wrt. 'farthestInput'.
 990 raiseFailure ::
 991   Positionable (InputPosition inp) =>
 992   GenCtx inp cs a ->
 993   TH.CodeQ (Set SomeFailure) ->
 994   TH.CodeQ (ST RealWorld (Result inp a))
 995 raiseFailure ctx fs = [||
 996   let failExp = $$fs in
 997   let (# farInp, farExp #) =
 998         case $$comparePosition $$(farthestInput ctx) $$(input ctx) of
 999           LT -> (# $$(input ctx), failExp #)
1000           EQ -> (# $$(farthestInput ctx), failExp <> $$(farthestExpecting ctx) #)
1001           GT -> (# $$(farthestInput ctx), $$(farthestExpecting ctx) #)
1002   in $$(raiseException ctx ExceptionFailure)
1003     ExceptionFailure
1004     {-failInp-}$$(input ctx) farInp farExp $$(inputBuffer ctx) $$(inputEnded ctx)
1005   ||]
1006 -- | @('raiseException' ctx exn)@ raises exception @(exn)@
1007 -- using any entry in 'onExceptionStackByLabel', or 'defaultCatch' if none.
1008 raiseException ::
1009   GenCtx inp vs a -> Exception ->
1010   CodeQ (OnException inp a)
1011 raiseException ctx exn =
1012   NE.head $ Map.findWithDefault
1013     (NE.singleton (defaultCatch ctx))
1014     exn (onExceptionStackByLabel ctx)
1015
1016 checkToken ::
1017   Set SomeFailure ->
1018   {-predicate-}Splice (InputToken inp -> Bool) ->
1019   {-ok-}Gen inp (InputToken inp ': vs) a ->
1020   Gen inp vs a
1021 checkToken fs p ok = ok
1022   { genAnalysis = \final -> seqGenAnalysis $
1023       GenAnalysis { minReads = 1
1024                   , mayRaise = Map.singleton ExceptionFailure ()
1025                   , alwaysRaise = Set.empty
1026                   , freeRegs = Set.empty
1027                   } :|
1028       [ genAnalysis ok final ]
1029   , unGen = \ctx -> {-trace "unGen.read" $-} [||
1030     let _ = "checkToken" in
1031     let !(# c, cs #) = $$(nextInput ctx) $$(inputBuffer ctx) $$(input ctx) in
1032     $$(genCode $
1033       Prod.ifThenElse
1034         (p Prod..@ splice [||c||])
1035         (splice $ unGen ok ctx
1036           { valueStack = ValueStackCons (splice [||c||]) (valueStack ctx)
1037           , input = [||cs||]
1038           })
1039         (splice [||
1040           let _ = "checkToken.fail" in
1041           $$(unGen (fail fs) ctx)
1042         ||])
1043     )||]
1044   }