src/Symantic/Parser/Machine/Generate.hs

   1 {-# LANGUAGE AllowAmbiguousTypes #-}
   2 {-# LANGUAGE StandaloneDeriving #-} -- For Show (ParsingError inp)
   3 {-# LANGUAGE TemplateHaskell #-}
   4 {-# LANGUAGE UnboxedTuples #-} -- For nextInput
   5 {-# LANGUAGE UndecidableInstances #-} -- For Show (ParsingError inp)
   6 module Symantic.Parser.Machine.Generate where
   7
   8 import Control.Monad (Monad(..))
   9 import Data.Bool (Bool)
  10 import Data.Char (Char)
  11 import Data.Either (Either(..))
  12 import Data.Function (($), (.))
  13 import Data.Functor ((<$>))
  14 import Data.Int (Int)
  15 import Data.List (minimum)
  16 import Data.List.NonEmpty (NonEmpty(..))
  17 import Data.Map (Map)
  18 import Data.Maybe (Maybe(..))
  19 import Data.Monoid (Monoid(..))
  20 import Data.Ord (Ord(..), Ordering(..))
  21 import Data.Semigroup (Semigroup(..))
  22 import Data.Set (Set)
  23 import Data.String (String)
  24 import Language.Haskell.TH (CodeQ, Code(..))
  25 import Prelude ((+), (-))
  26 import Text.Show (Show(..))
  27 import GHC.TypeLits (symbolVal)
  28 import qualified Data.List.NonEmpty as NE
  29 import qualified Data.Map.Internal as Map_
  30 import qualified Data.Map.Strict as Map
  31 import qualified Data.Set as Set
  32 import qualified Language.Haskell.TH as TH
  33 import qualified Language.Haskell.TH.Syntax as TH
  34
  35 import Symantic.Univariant.Trans
  36 import Symantic.Parser.Grammar.Combinators (ErrorItem(..))
  37 import Symantic.Parser.Machine.Input
  38 import Symantic.Parser.Machine.Instructions
  39 import qualified Symantic.Parser.Haskell as H
  40 import Debug.Trace (trace)
  41 import Prelude (undefined)
  42
  43 genCode :: TermInstr a -> CodeQ a
  44 genCode = trans
  45
  46 -- * Type 'Gen'
  47 -- | Generate the 'CodeQ' parsing the input.
  48 data Gen inp vs a = Gen
  49   { minHorizon :: Map TH.Name Horizon -> Horizon
  50     -- ^ Synthetized (bottom-up) minimal input length
  51     -- required by the parser to not fail.
  52     -- This requires a 'minHorizonByName'
  53     -- containing the minimal 'Horizon's of all the 'TH.Name's
  54     -- this parser 'call's, 'jump's or 'refJoin's to.
  55   , raisedLabels :: Map TH.Name (Map ErrorLabel ()) -> Map ErrorLabel ()
  56   , unGen ::
  57       GenCtx inp vs a ->
  58       CodeQ (Either (ParsingError inp) a)
  59   }
  60
  61 -- ** Type 'ParsingError'
  62 data ParsingError inp
  63   =  ParsingErrorStandard
  64   {  parsingErrorOffset :: Offset
  65     -- | Note that if an 'ErrorItemHorizon' greater than 1
  66     -- is amongst the 'parsingErrorExpecting'
  67     -- then this is only the 'InputToken'
  68     -- at the begining of the expected 'Horizon'.
  69   ,  parsingErrorUnexpected :: Maybe (InputToken inp)
  70   ,  parsingErrorExpecting :: Set (ErrorItem (InputToken inp))
  71   }
  72 deriving instance Show (InputToken inp) => Show (ParsingError inp)
  73
  74 -- ** Type 'ErrorLabel'
  75 type ErrorLabel = String
  76
  77 -- ** Type 'Offset'
  78 type Offset = Int
  79
  80 -- ** Type 'Horizon'
  81 -- | Synthetized minimal input length
  82 -- required for a successful parsing.
  83 -- Used with 'checkedHorizon' to factorize input length checks,
  84 -- instead of checking the input length
  85 -- one 'InputToken' at a time at each 'read'.
  86 type Horizon = Offset
  87
  88 -- ** Type 'Cont'
  89 type Cont inp v a =
  90   {-farthestInput-}Cursor inp ->
  91   {-farthestExpecting-}[ErrorItem (InputToken inp)] ->
  92   v ->
  93   Cursor inp ->
  94   Either (ParsingError inp) a
  95
  96 -- ** Type 'Catcher'
  97 type Catcher inp a =
  98   {-failureInput-}Cursor inp ->
  99   {-farthestInput-}Cursor inp ->
 100   {-farthestExpecting-}[ErrorItem (InputToken inp)] ->
 101   Either (ParsingError inp) a
 102
 103 {-
 104 -- *** Type 'FarthestError'
 105 data FarthestError inp = FarthestError
 106   { farthestInput :: Cursor inp
 107   , farthestExpecting :: [ErrorItem (InputToken inp)]
 108   }
 109 -}
 110
 111 -- | @('generateCode' input mach)@ generates @TemplateHaskell@ code
 112 -- parsing the given 'input' according to the given 'Machine'.
 113 generateCode ::
 114   Ord (InputToken inp) =>
 115   Show (InputToken inp) =>
 116   TH.Lift (InputToken inp) =>
 117   -- InputToken inp ~ Char =>
 118   Input inp =>
 119   Show (Cursor inp) =>
 120   Gen inp '[] a ->
 121   CodeQ (inp -> Either (ParsingError inp) a)
 122 generateCode k = [|| \(input :: inp) ->
 123   -- Pattern bindings containing unlifted types
 124   -- should use an outermost bang pattern.
 125   let !(# init, readMore, readNext #) = $$(cursorOf [||input||]) in
 126   let finalRet = \_farInp _farExp v _inp -> Right v in
 127   let finalRaise :: forall b. (Catcher inp b)
 128         = \_failInp !farInp !farExp ->
 129         Left ParsingErrorStandard
 130         { parsingErrorOffset = offset farInp
 131         , parsingErrorUnexpected =
 132             if readMore farInp
 133             then Just (let (# c, _ #) = readNext farInp in c)
 134             else Nothing
 135         , parsingErrorExpecting = Set.fromList farExp
 136         } in
 137   $$(unGen k GenCtx
 138     { valueStack = ValueStackEmpty
 139     , catchStackByLabel = Map.empty
 140     , defaultCatch = [||finalRaise||]
 141     , retCode = [||finalRet||]
 142     , input = [||init||]
 143     , nextInput = [||readNext||]
 144     , moreInput = [||readMore||]
 145     -- , farthestError = [||Nothing||]
 146     , farthestInput = [||init||]
 147     , farthestExpecting = [|| [] ||]
 148     , checkedHorizon = 0
 149     , minHorizonByName = Map.empty
 150     , raiseLabelsByName = Map.empty
 151     })
 152   ||]
 153
 154 -- ** Type 'GenCtx'
 155 -- | This is an inherited (top-down) context
 156 -- only present at compile-time, to build TemplateHaskell splices.
 157 data GenCtx inp vs a =
 158   ( TH.Lift (InputToken inp)
 159   , Cursorable (Cursor inp)
 160   , Show (InputToken inp)
 161   ) => GenCtx
 162   { valueStack :: ValueStack vs
 163   , catchStackByLabel :: Map ErrorLabel (NonEmpty (CodeQ (Catcher inp a)))
 164     -- | Default 'Catcher' defined at the begining of the generated 'CodeQ',
 165     -- hence a constant within the 'Gen'eration.
 166   , defaultCatch :: forall b. CodeQ (Catcher inp b)
 167   , retCode :: CodeQ (Cont inp a a)
 168   , input :: CodeQ (Cursor inp)
 169   , moreInput :: CodeQ (Cursor inp -> Bool)
 170   , nextInput :: CodeQ (Cursor inp -> (# InputToken inp, Cursor inp #))
 171   , farthestInput :: CodeQ (Cursor inp)
 172   , farthestExpecting :: CodeQ [ErrorItem (InputToken inp)]
 173     -- | Remaining horizon already checked.
 174     -- Updated by 'checkHorizon'
 175     -- and reset elsewhere when needed.
 176   , checkedHorizon :: Horizon
 177     -- | Minimal horizon for each 'subroutine' or 'defJoin'.
 178     -- This can be done as an inherited attribute because
 179     -- 'OverserveSharing' introduces 'def' as an ancestor node
 180     -- of all the 'ref's pointing to it.
 181     -- Same for 'defJoin' and its 'refJoin's.
 182   , minHorizonByName :: Map TH.Name Horizon
 183   , raiseLabelsByName :: Map TH.Name (Map ErrorLabel ())
 184   }
 185
 186 -- ** Type 'ValueStack'
 187 data ValueStack vs where
 188   ValueStackEmpty :: ValueStack '[]
 189   ValueStackCons ::
 190     { valueStackHead :: TermInstr v
 191     , valueStackTail :: ValueStack vs
 192     } -> ValueStack (v ': vs)
 193
 194 instance Stackable Gen where
 195   push x k = k
 196     { unGen = \ctx -> unGen k ctx
 197       { valueStack = ValueStackCons x (valueStack ctx) }
 198     }
 199   pop k = k
 200     { unGen = \ctx -> unGen k ctx
 201       { valueStack = valueStackTail (valueStack ctx) }
 202     }
 203   liftI2 f k = k
 204     { unGen = \ctx -> unGen k ctx
 205       { valueStack =
 206         let ValueStackCons y (ValueStackCons x xs) = valueStack ctx in
 207         ValueStackCons (f H.:@ x H.:@ y) xs
 208       }
 209     }
 210   swap k = k
 211     { unGen = \ctx -> unGen k ctx
 212       { valueStack =
 213           let ValueStackCons y (ValueStackCons x xs) = valueStack ctx in
 214           ValueStackCons x (ValueStackCons y xs)
 215       }
 216     }
 217 instance Branchable Gen where
 218   caseI kx ky = Gen
 219     { minHorizon = \hs -> minHorizon kx hs `min` minHorizon ky hs
 220     , raisedLabels = \hs -> raisedLabels kx hs <> raisedLabels ky hs
 221     , unGen = \ctx ->
 222       let ValueStackCons v vs = valueStack ctx in
 223       [||
 224         case $$(genCode v) of
 225           Left  x -> $$(unGen kx ctx{ valueStack = ValueStackCons (H.Term [||x||]) vs })
 226           Right y -> $$(unGen ky ctx{ valueStack = ValueStackCons (H.Term [||y||]) vs })
 227       ||]
 228     }
 229   choices fs ks kd = Gen
 230     { minHorizon = \hs -> minimum $
 231         minHorizon kd hs :
 232         (($ hs) . minHorizon <$> ks)
 233     , raisedLabels = \hs -> mconcat $
 234         raisedLabels kd hs :
 235         (($ hs) . raisedLabels <$> ks)
 236     , unGen = \ctx ->
 237       let ValueStackCons v vs = valueStack ctx in
 238       go ctx{valueStack = vs} v fs ks
 239     }
 240     where
 241     go ctx x (f:fs') (k:ks') = [||
 242       if $$(genCode (f H.:@ x))
 243       then $$(unGen k ctx)
 244       else $$(go ctx x fs' ks')
 245       ||]
 246     go ctx _ _ _ = unGen kd ctx
 247 instance Raisable Gen where
 248   raise lbl failExp = Gen
 249     { minHorizon = \_hs -> 0
 250     , raisedLabels = \_hs -> Map.singleton (symbolVal lbl) ()
 251     , unGen = \ctx@GenCtx{} -> [||
 252       let (# farInp, farExp #) =
 253             case $$compareOffset $$(farthestInput ctx) $$(input ctx) of
 254               LT -> (# $$(input ctx), failExp #)
 255               EQ -> (# $$(farthestInput ctx), ($$(farthestExpecting ctx) <> failExp) #)
 256               GT -> (# $$(farthestInput ctx), $$(farthestExpecting ctx) #) in
 257         $$(NE.head (Map.findWithDefault (NE.singleton (defaultCatch ctx)) (symbolVal lbl) (catchStackByLabel ctx)))
 258         $$(input ctx) farInp farExp
 259       ||]
 260     }
 261   popThrow lbl k = k
 262     { unGen = \ctx ->
 263       unGen k ctx{catchStackByLabel = Map.update (\case
 264           _r0:|(r1:rs) -> Just (r1:|rs)
 265           _ -> Nothing
 266         ) (symbolVal lbl) (catchStackByLabel ctx)
 267       }
 268     }
 269   catchThrow lbl ok ko = Gen
 270     { minHorizon = \hs -> minHorizon ok hs `min` minHorizon ko hs
 271     , raisedLabels = \hs -> raisedLabels ok hs <> raisedLabels ko hs
 272     , unGen = \ctx@GenCtx{} -> [|| let _ = "catch lbl="<> $$(TH.liftTyped (symbolVal lbl)) in $$(unGen ok ctx
 273         { catchStackByLabel = Map.insertWith (<>) (symbolVal lbl)
 274             (NE.singleton ([|| \ !failInp !farInp !farExp ->
 275               $$(unGen ko ctx
 276                 -- Push the input as it was when entering the catchFail.
 277                 { valueStack = ValueStackCons (H.Term (input ctx)) (valueStack ctx)
 278                 -- Move the input to the failing position.
 279                 , input = [||failInp||]
 280                 -- Set the farthestInput to the farthest computed by 'fail'
 281                 , farthestInput = [||farInp||]
 282                 , farthestExpecting = [||farExp||]
 283                 })
 284             ||])) (catchStackByLabel ctx)
 285         }
 286       ) ||]
 287     }
 288 instance Inputable Gen where
 289   loadInput k = k
 290     { unGen = \ctx ->
 291       let ValueStackCons input vs = valueStack ctx in
 292       unGen k ctx
 293         { valueStack = vs
 294         , input = genCode input
 295         , checkedHorizon = 0
 296         }
 297     }
 298   pushInput k = k
 299     { unGen = \ctx ->
 300       unGen k ctx{valueStack = ValueStackCons (H.Term (input ctx)) (valueStack ctx)}
 301     }
 302 instance Routinable Gen where
 303   subroutine (LetName n) sub k = k
 304     { unGen = \ctx@GenCtx{} -> Code $ TH.unsafeTExpCoerce $ do
 305       -- 'sub' is recursively 'call'able within 'sub',
 306       -- but its maximal 'minHorizon' is not known yet.
 307       let minHorizonByNameButSub = Map.insert n 0 (minHorizonByName ctx)
 308       let raiseLabelsByNameButSub = Map.insert n Map.empty (raiseLabelsByName ctx)
 309       body <- TH.unTypeQ $ TH.examineCode $ [|| -- buildRec in Parsley
 310         -- Called by 'call' or 'jump'.
 311         \ !ok{-from generateSuspend or retCode-}
 312           !inp
 313           !koByLabel{- 'catchStackByLabel' from the 'call'-site -} ->
 314           $$(unGen sub ctx
 315             { valueStack = ValueStackEmpty
 316             -- Build a 'catchStackByLabel' from the one available at the 'call'-site.
 317             -- Note that all the 'raisedLabels' of the 'sub'routine may not be available,
 318             -- hence 'Map.findWithDefault' is used instead of 'Map.!'.
 319             , catchStackByLabel = Map.mapWithKey
 320                 (\lbl () -> NE.singleton [||Map.findWithDefault $$(defaultCatch ctx) lbl koByLabel||])
 321                 (raisedLabels sub raiseLabelsByNameButSub)
 322             , input = [||inp||]
 323             , retCode = [||ok||]
 324
 325             -- These are passed by the caller via 'ok' or 'ko'
 326             -- , farthestInput =
 327             -- , farthestExpecting =
 328
 329             -- Some callers can call this subroutine
 330             -- with zero checkedHorizon, hence use this minimum.
 331             -- TODO: maybe it could be improved a bit
 332             -- by taking the minimum of the checked horizons
 333             -- before all the 'call's and 'jump's to this subroutine.
 334             , checkedHorizon = 0
 335             , minHorizonByName = minHorizonByNameButSub
 336             , raiseLabelsByName = raiseLabelsByNameButSub
 337             })
 338         ||]
 339       let decl = TH.FunD n [TH.Clause [] (TH.NormalB body) []]
 340       expr <- TH.unTypeQ (TH.examineCode (unGen k ctx
 341         { minHorizonByName =
 342             -- 'sub' is 'call'able within 'k'.
 343             Map.insert n
 344               (minHorizon sub minHorizonByNameButSub)
 345               (minHorizonByName ctx)
 346         , raiseLabelsByName =
 347             Map.insert n
 348               (raisedLabels sub raiseLabelsByNameButSub)
 349               (raiseLabelsByName ctx)
 350         }))
 351       return (TH.LetE [decl] expr)
 352     }
 353   jump (LetName n) = Gen
 354     { minHorizon = (Map.! n)
 355     , raisedLabels = (Map.! n)
 356     , unGen = \ctx -> [||
 357       let _ = "jump" in
 358       $$(Code (TH.unsafeTExpCoerce (return (TH.VarE n))))
 359         {-ok-}$$(retCode ctx)
 360         $$(input ctx)
 361         $$(liftTypedRaiseByLabel $
 362           catchStackByLabel ctx
 363           -- Pass only the labels raised by the 'subroutine'.
 364           `Map.intersection`
 365           (raiseLabelsByName ctx Map.! n)
 366           )
 367       ||]
 368     }
 369   call (LetName n) k = k
 370     { minHorizon = (Map.! n)
 371     , raisedLabels = (Map.! n)
 372     , unGen = \ctx -> let ks = (Map.keys (catchStackByLabel ctx)) in [||
 373       let _ = $$(TH.liftTyped $ "call raiseLabelsByName("<>show n<>")="<>show (Map.keys (raiseLabelsByName ctx Map.! n)) <> " catchStackByLabel(ctx)="<> show ks) in
 374       $$(Code (TH.unsafeTExpCoerce (return (TH.VarE n))))
 375         {-ok-}$$(generateSuspend k ctx)
 376         $$(input ctx)
 377         $$(liftTypedRaiseByLabel $
 378           catchStackByLabel ctx
 379           -- Pass only the labels raised by the 'subroutine'.
 380           `Map.intersection`
 381           (raiseLabelsByName ctx Map.! n)
 382         )
 383       ||]
 384     }
 385   ret = Gen
 386     { minHorizon = \_hs -> 0
 387     , raisedLabels = \_hs -> Map.empty
 388     , unGen = \ctx -> unGen (generateResume (retCode ctx)) ctx
 389     }
 390
 391 -- | Like 'TH.liftTyped' but adjusted to work on 'catchStackByLabel'
 392 -- which already contains 'CodeQ' terms.
 393 -- Moreover, only the 'Catcher' at the top of the stack
 394 -- is needed and thus generated in the resulting 'CodeQ'.
 395 --
 396 -- TODO: Use an 'Array' instead of a 'Map'?
 397 liftTypedRaiseByLabel :: TH.Lift k => Map k (NonEmpty (CodeQ a)) -> CodeQ (Map k a)
 398 liftTypedRaiseByLabel Map_.Tip = [|| Map_.Tip ||]
 399 liftTypedRaiseByLabel (Map_.Bin s k (h:|_hs) l r) =
 400   [|| Map_.Bin s k $$h $$(liftTypedRaiseByLabel l) $$(liftTypedRaiseByLabel r) ||]
 401
 402 -- | Generate a 'retCode' 'Cont'inuation to be called with 'generateResume'.
 403 -- Used when 'call' 'ret'urns.
 404 -- The return 'v'alue is 'push'ed on the 'valueStack'.
 405 generateSuspend ::
 406   {-k-}Gen inp (v ': vs) a ->
 407   GenCtx inp vs a ->
 408   CodeQ (Cont inp v a)
 409 generateSuspend k ctx = [||
 410   let _ = $$(TH.liftTyped $ "suspend raise=" <> show (raiseLabelsByName ctx)) in
 411   \farInp farExp v !inp ->
 412     $$(unGen k ctx
 413       { valueStack = ValueStackCons (H.Term [||v||]) (valueStack ctx)
 414       , input = [||inp||]
 415       , farthestInput = [||farInp||]
 416       , farthestExpecting = [||farExp||]
 417       , checkedHorizon = 0
 418       }
 419     )
 420   ||]
 421
 422 -- | Generate a call to the 'generateSuspend' continuation.
 423 -- Used when 'call' 'ret'urns.
 424 generateResume ::
 425   CodeQ (Cont inp v a) ->
 426   Gen inp (v ': vs) a
 427 generateResume k = Gen
 428   { minHorizon = \_hs -> 0
 429   , raisedLabels = \_hs -> Map.empty
 430   , unGen = \ctx -> [||
 431     let _ = "resume" in
 432     $$k
 433       $$(farthestInput ctx)
 434       $$(farthestExpecting ctx)
 435       (let _ = "resume.genCode" in $$(genCode (valueStackHead (valueStack ctx))))
 436       $$(input ctx)
 437     ||]
 438   }
 439
 440 instance Joinable Gen where
 441   defJoin (LetName n) joined k = k
 442     { unGen = \ctx -> Code $ TH.unsafeTExpCoerce $ do
 443       body <- TH.unTypeQ $ TH.examineCode $ [||
 444         -- Called by 'generateResume'.
 445         \farInp farExp v !inp ->
 446           $$(unGen joined ctx
 447             { valueStack = ValueStackCons (H.Term [||v||]) (valueStack ctx)
 448             , input = [||inp||]
 449             , farthestInput = [||farInp||]
 450             , farthestExpecting = [||farExp||]
 451             , checkedHorizon = 0
 452             {- FIXME:
 453             , catchStackByLabel = Map.mapWithKey
 454                 (\lbl () -> NE.singleton [||koByLabel Map.! lbl||])
 455                 (raisedLabels joined raiseLabelsByNameButSub)
 456             -}
 457             })
 458         ||]
 459       let decl = TH.FunD n [TH.Clause [] (TH.NormalB body) []]
 460       expr <- TH.unTypeQ (TH.examineCode (unGen k ctx
 461         { minHorizonByName =
 462             -- 'joined' is 'refJoin'able within 'k'.
 463             Map.insert n
 464               -- By definition (in 'joinNext')
 465               -- 'joined' is not recursively 'refJoin'able within 'joined',
 466               -- hence no need to prevent against recursivity
 467               -- as has to be done in 'subroutine'.
 468               (minHorizon joined (minHorizonByName ctx))
 469               (minHorizonByName ctx)
 470         , raiseLabelsByName =
 471             Map.insert n
 472               (raisedLabels joined (raiseLabelsByName ctx))
 473               (raiseLabelsByName ctx)
 474         }))
 475       return (TH.LetE [decl] expr)
 476     }
 477   refJoin (LetName n) = (generateResume (Code (TH.unsafeTExpCoerce (return (TH.VarE n)))))
 478     { minHorizon = (Map.! n)
 479     , raisedLabels = (Map.! n)
 480     }
 481 instance Readable Char Gen where
 482   read farExp p = checkHorizon . checkToken farExp p
 483
 484 checkHorizon ::
 485   TH.Lift (InputToken inp) =>
 486   {-ok-}Gen inp vs a ->
 487   Gen inp vs a
 488 checkHorizon ok = ok
 489   { minHorizon = \hs -> 1 + minHorizon ok hs
 490   , raisedLabels = \hs -> Map.insert "fail" () $ raisedLabels ok hs
 491   , unGen = \ctx0@GenCtx{} ->
 492     let raiseByLbl =
 493           NE.head (Map.findWithDefault (NE.singleton (defaultCatch ctx0)) "fail" (catchStackByLabel ctx0)) in
 494     [||
 495       -- Factorize failure code
 496       let readFail = $$(raiseByLbl) in
 497       $$(
 498         let ctx = ctx0{catchStackByLabel = Map.adjust (\(_r:|rs) -> [||readFail||] :| rs) "fail" (catchStackByLabel ctx0)} in
 499         if checkedHorizon ctx >= 1
 500         then unGen ok ctx0{checkedHorizon = checkedHorizon ctx - 1}
 501         else let minHoriz = minHorizon ok (minHorizonByName ctx) in
 502           [||
 503           if $$(moreInput ctx)
 504                $$(if minHoriz > 0
 505                  then [||$$shiftRight minHoriz $$(input ctx)||]
 506                  else input ctx)
 507           then $$(unGen ok ctx{checkedHorizon = minHoriz})
 508           else let _ = "checkHorizon.else" in
 509             -- TODO: return a resuming continuation (eg. Partial)
 510             $$(unGen (fail [ErrorItemHorizon (minHoriz + 1)]) ctx)
 511           ||]
 512       )
 513     ||]
 514   }
 515
 516 checkToken ::
 517   Ord (InputToken inp) =>
 518   TH.Lift (InputToken inp) =>
 519   [ErrorItem (InputToken inp)] ->
 520   {-predicate-}TermInstr (InputToken inp -> Bool) ->
 521   {-ok-}Gen inp (InputToken inp ': vs) a ->
 522   Gen inp vs a
 523 checkToken farExp p ok = ok
 524   { raisedLabels = \hs -> Map.insert "fail" () $ raisedLabels ok hs
 525   , unGen = \ctx -> [||
 526     let !(# c, cs #) = $$(nextInput ctx) $$(input ctx) in
 527     if $$(genCode p) c
 528     then $$(unGen ok ctx
 529       { valueStack = ValueStackCons (H.Term [||c||]) (valueStack ctx)
 530       , input = [||cs||]
 531       })
 532     else let _ = "checkToken.else" in $$(unGen (fail farExp) ctx)
 533     ||]
 534   }