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