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