src/Symantic/Parser/Machine/Generate.hs

   1 {-# LANGUAGE AllowAmbiguousTypes #-}
   2 {-# LANGUAGE StandaloneDeriving #-} -- For Show (ParsingError inp)
   3 {-# LANGUAGE TemplateHaskell #-}
   4 {-# LANGUAGE TupleSections #-}
   5 {-# LANGUAGE UnboxedTuples #-} -- For nextInput
   6 {-# LANGUAGE UndecidableInstances #-} -- For Show (ParsingError inp)
   7 module Symantic.Parser.Machine.Generate where
   8
   9 import Control.Monad (Monad(..))
  10 import Data.Bool (Bool)
  11 import Data.Char (Char)
  12 import Data.Either (Either(..), either)
  13 import Data.Function (($), (.), id, const, on)
  14 import Data.Functor (Functor, (<$>), (<$))
  15 import Data.Foldable (foldMap', toList)
  16 import Data.Int (Int)
  17 import Data.List.NonEmpty (NonEmpty(..))
  18 import Data.Map (Map)
  19 import Data.Maybe (Maybe(..))
  20 import Data.Ord (Ord(..), Ordering(..))
  21 import Data.Semigroup (Semigroup(..))
  22 import Data.Set (Set)
  23 import Data.String (String)
  24 import Data.Traversable (Traversable(..))
  25 import GHC.TypeLits (symbolVal)
  26 import Language.Haskell.TH (CodeQ)
  27 import Prelude ((+), (-), error)
  28 import Text.Show (Show(..))
  29 -- import qualified Control.Monad.Trans.State.Strict as MT
  30 import qualified Data.HashMap.Strict as HM
  31 import qualified Data.List as List
  32 import qualified Data.List.NonEmpty as NE
  33 import qualified Data.Map.Internal as Map_
  34 import qualified Data.Map.Strict as Map
  35 import qualified Data.Set as Set
  36 import qualified Language.Haskell.TH as TH
  37 import qualified Language.Haskell.TH.Syntax as TH
  38
  39 import Symantic.Univariant.Letable
  40 import Symantic.Univariant.Trans
  41 import Symantic.Parser.Grammar.Combinators (ErrorItem(..))
  42 import Symantic.Parser.Machine.Input
  43 import Symantic.Parser.Machine.Instructions
  44 import qualified Language.Haskell.TH.HideName as TH
  45 import qualified Symantic.Parser.Haskell as H
  46
  47 --import Debug.Trace
  48
  49 genCode :: TermInstr a -> CodeQ a
  50 genCode = trans
  51
  52 -- * Type 'Gen'
  53 -- | Generate the 'CodeQ' parsing the input.
  54 data Gen inp vs a = Gen
  55   { genAnalysisByLet :: LetMapFix (CallTrace -> GenAnalysis)
  56     -- ^ 'genAnalysis' for each 'defLet' and 'defJoin' of the 'Machine'.
  57   , genAnalysis :: LetMapTo (CallTrace -> GenAnalysis)
  58     -- ^ Synthetized (bottom-up) static genAnalysis of the 'Machine'.
  59   , unGen ::
  60       GenCtx inp vs a ->
  61       CodeQ (Either (ParsingError inp) a)
  62   }
  63
  64 -- | @('generateCode' input mach)@ generates @TemplateHaskell@ code
  65 -- parsing the given 'input' according to the given 'Machine'.
  66 generateCode ::
  67   Ord (InputToken inp) =>
  68   Show (InputToken inp) =>
  69   TH.Lift (InputToken inp) =>
  70   -- InputToken inp ~ Char =>
  71   Input inp =>
  72   Show (Cursor inp) =>
  73   Gen inp '[] a ->
  74   CodeQ (inp -> Either (ParsingError inp) a)
  75 generateCode k = [|| \(input :: inp) ->
  76   -- Pattern bindings containing unlifted types
  77   -- should use an outermost bang pattern.
  78   let !(# init, readMore, readNext #) = $$(cursorOf [||input||]) in
  79   let finalRet = \_farInp _farExp v _inp -> Right v in
  80   let finalRaise :: forall b. (Catcher inp b)
  81         = \_failInp !farInp !farExp ->
  82         Left ParsingErrorStandard
  83         { parsingErrorOffset = offset farInp
  84         , parsingErrorUnexpected =
  85             if readMore farInp
  86             then Just (let (# c, _ #) = readNext farInp in c)
  87             else Nothing
  88         , parsingErrorExpecting = Set.fromList farExp
  89         } in
  90   $$(unGen k GenCtx
  91     { valueStack = ValueStackEmpty
  92     , catchStackByLabel = Map.empty
  93     , defaultCatch = [||finalRaise||]
  94     , callStack = []
  95     , retCode = [||finalRet||]
  96     , input = [||init||]
  97     , nextInput = [||readNext||]
  98     , moreInput = [||readMore||]
  99     -- , farthestError = [||Nothing||]
 100     , farthestInput = [||init||]
 101     , farthestExpecting = [|| [] ||]
 102     , checkedHorizon = 0
 103     , horizonStack = []
 104     , finalGenAnalysisByLet = runGenAnalysis (genAnalysisByLet k)
 105     })
 106   ||]
 107
 108 -- ** Type 'ParsingError'
 109 data ParsingError inp
 110   =  ParsingErrorStandard
 111   {  parsingErrorOffset :: Offset
 112     -- | Note that if an 'ErrorItemHorizon' greater than 1
 113     -- is amongst the 'parsingErrorExpecting'
 114     -- then this is only the 'InputToken'
 115     -- at the begining of the expected 'Horizon'.
 116   ,  parsingErrorUnexpected :: Maybe (InputToken inp)
 117   ,  parsingErrorExpecting :: Set (ErrorItem (InputToken inp))
 118   }
 119 deriving instance Show (InputToken inp) => Show (ParsingError inp)
 120
 121 -- ** Type 'ErrorLabel'
 122 type ErrorLabel = String
 123
 124 -- * Type 'GenAnalysis'
 125 data GenAnalysis = GenAnalysis
 126   { minReads :: Either ErrorLabel Horizon
 127   , mayRaise :: Map ErrorLabel ()
 128   } deriving (Show)
 129
 130 -- | Tie the knot between mutually recursive 'TH.Name's
 131 -- introduced by 'defLet' and 'defJoin'.
 132 -- and provide the empty initial 'CallTrace' stack
 133 runGenAnalysis ::
 134   LetMapFix (CallTrace -> GenAnalysis) ->
 135   LetMap GenAnalysis
 136 runGenAnalysis ga = (($ []) <$>) $ polyfix ga
 137
 138 -- | Poly-variadic fixpoint combinator.
 139 -- Used to express mutual recursion and to transparently introduce memoization.
 140 -- Used to "tie the knot" between observed sharing ('defLet', 'call', 'jump')
 141 -- and join points ('defJoin', 'refJoin').
 142 -- All mutually dependent functions are restricted to the same polymorphic type @(a)@.
 143 -- See http://okmij.org/ftp/Computation/fixed-point-combinators.html#Poly-variadic
 144 polyfix :: Functor f => f (f a -> a) -> f a
 145 polyfix fs = fix $ \finals -> ($ finals) <$> fs
 146
 147 fix :: (a -> a) -> a
 148 fix f = final where final = f final
 149
 150 type LetMap = HM.HashMap TH.Name
 151 type LetMapTo a = LetMap a -> a
 152 type LetMapFix a = LetMap (LetMap a -> a)
 153
 154 -- | Call trace stack updated by 'call' and 'refJoin'.
 155 -- Used to avoid infinite loops when tying the knot with 'polyfix'.
 156 type CallTrace = [TH.Name]
 157
 158 -- ** Type 'Offset'
 159 type Offset = Int
 160 -- ** Type 'Horizon'
 161 -- | Minimal input length required for a successful parsing.
 162 type Horizon = Offset
 163
 164 -- seqGenAnalysis =
 165 -- altGenAnalysis = List.foldl' (\acc x -> either Left (\h -> Right (either (const h) (min h) acc)) x)
 166 seqGenAnalysis :: NonEmpty GenAnalysis -> GenAnalysis
 167 seqGenAnalysis aas@(a:|as) = GenAnalysis
 168   { minReads = List.foldl' (\acc x ->
 169         acc >>= \r -> (r +) <$> minReads x
 170       ) (minReads a) as
 171   , mayRaise = sconcat (mayRaise <$> aas)
 172   }
 173 altGenAnalysis :: NonEmpty GenAnalysis -> GenAnalysis
 174 altGenAnalysis aas@(a:|as) = GenAnalysis
 175   { minReads = List.foldl' (\acc x ->
 176       either
 177         (\l -> either (const (Left  l)) Right)
 178         (\r -> either (const (Right r)) (Right . min r))
 179         acc (minReads x)
 180       ) (minReads a) as
 181   , mayRaise = sconcat (mayRaise <$> aas)
 182   }
 183
 184
 185 {-
 186 -- *** Type 'FarthestError'
 187 data FarthestError inp = FarthestError
 188   { farthestInput :: Cursor inp
 189   , farthestExpecting :: [ErrorItem (InputToken inp)]
 190   }
 191 -}
 192
 193 -- ** Type 'GenCtx'
 194 -- | This is an inherited (top-down) context
 195 -- only present at compile-time, to build TemplateHaskell splices.
 196 data GenCtx inp vs a =
 197   ( TH.Lift (InputToken inp)
 198   , Cursorable (Cursor inp)
 199   , Show (InputToken inp)
 200   ) => GenCtx
 201   { valueStack :: ValueStack vs
 202   , catchStackByLabel :: Map ErrorLabel (NonEmpty (CodeQ (Catcher inp a)))
 203     -- | Default 'Catcher' defined at the begining of the generated 'CodeQ',
 204     -- hence a constant within the 'Gen'eration.
 205   , defaultCatch :: forall b. CodeQ (Catcher inp b)
 206     -- | Used by 'checkToken' to get 'GenAnalysis' from 'genAnalysis'.
 207   , callStack :: [TH.Name]
 208   , retCode :: CodeQ (Cont inp a a)
 209   , input :: CodeQ (Cursor inp)
 210   , moreInput :: CodeQ (Cursor inp -> Bool)
 211   , nextInput :: CodeQ (Cursor inp -> (# InputToken inp, Cursor inp #))
 212   , farthestInput :: CodeQ (Cursor inp)
 213   , farthestExpecting :: CodeQ [ErrorItem (InputToken inp)]
 214     -- | Remaining horizon already checked.
 215     -- Use to factorize 'input' length checks,
 216     -- instead of checking the 'input' length
 217     -- one 'InputToken' at a time at each 'read'.
 218     -- Updated by 'checkHorizon'
 219     -- and reset elsewhere when needed.
 220   , checkedHorizon :: Horizon
 221   -- | Used by 'pushInput' and 'loadInput'
 222   -- to restore the 'Horizon' at the restored 'input'.
 223   , horizonStack :: [Horizon]
 224   -- | Output of 'runGenAnalysis'.
 225   , finalGenAnalysisByLet :: LetMap GenAnalysis
 226   }
 227
 228 -- ** Type 'ValueStack'
 229 data ValueStack vs where
 230   ValueStackEmpty :: ValueStack '[]
 231   ValueStackCons ::
 232     { valueStackHead :: TermInstr v
 233     , valueStackTail :: ValueStack vs
 234     } -> ValueStack (v ': vs)
 235
 236 instance InstrValuable Gen where
 237   pushValue x k = k
 238     { unGen = \ctx -> {-trace "unGen.pushValue" $-} unGen k ctx
 239       { valueStack = ValueStackCons x (valueStack ctx) }
 240     }
 241   popValue k = k
 242     { unGen = \ctx -> {-trace "unGen.popValue" $-} unGen k ctx
 243       { valueStack = valueStackTail (valueStack ctx) }
 244     }
 245   lift2Value f k = k
 246     { unGen = \ctx -> {-trace "unGen.lift2Value" $-} unGen k ctx
 247       { valueStack =
 248         let ValueStackCons y (ValueStackCons x vs) = valueStack ctx in
 249         ValueStackCons (f H.:@ x H.:@ y) vs
 250       }
 251     }
 252   swapValue k = k
 253     { unGen = \ctx -> {-trace "unGen.swapValue" $-} unGen k ctx
 254       { valueStack =
 255           let ValueStackCons y (ValueStackCons x vs) = valueStack ctx in
 256           ValueStackCons x (ValueStackCons y vs)
 257       }
 258     }
 259 instance InstrBranchable Gen where
 260   caseBranch kx ky = Gen
 261     { genAnalysisByLet = genAnalysisByLet kx <> genAnalysisByLet ky
 262     , genAnalysis = \final ct -> altGenAnalysis $ genAnalysis kx final ct :| [genAnalysis ky final ct]
 263     , unGen = \ctx -> {-trace "unGen.caseBranch" $-}
 264       let ValueStackCons v vs = valueStack ctx in
 265       [||
 266         case $$(genCode v) of
 267           Left  x -> $$(unGen kx ctx{ valueStack = ValueStackCons (H.Term [||x||]) vs })
 268           Right y -> $$(unGen ky ctx{ valueStack = ValueStackCons (H.Term [||y||]) vs })
 269       ||]
 270     }
 271   choicesBranch fs ks kd = Gen
 272     { genAnalysisByLet = sconcat $ genAnalysisByLet kd :| (genAnalysisByLet <$> ks)
 273     , genAnalysis = \final ct -> altGenAnalysis $ (\k -> genAnalysis k final ct) <$> (kd:|ks)
 274     , unGen = \ctx -> {-trace "unGen.choicesBranch" $-}
 275       let ValueStackCons v vs = valueStack ctx in
 276       go ctx{valueStack = vs} v fs ks
 277     }
 278     where
 279     go ctx x (f:fs') (k:ks') = [||
 280       if $$(genCode (H.optimizeTerm (f H.:@ x)))
 281       then
 282         let _ = "choicesBranch.then" in
 283         $$({-trace "unGen.choicesBranch.k" $-} unGen k ctx)
 284       else
 285         let _ = "choicesBranch.else" in
 286         $$(go ctx x fs' ks')
 287       ||]
 288     go ctx _ _ _ = unGen kd ctx
 289 instance InstrExceptionable Gen where
 290   raiseException lbl failExp = Gen
 291     { genAnalysisByLet = HM.empty
 292     , genAnalysis = \_final _ct -> GenAnalysis
 293         { minReads = Left (symbolVal lbl)
 294         , mayRaise = Map.singleton (symbolVal lbl) ()
 295         }
 296     , unGen = \ctx@GenCtx{} -> {-trace ("unGen.raiseException: "<>symbolVal lbl) $-} [||
 297       let (# farInp, farExp #) =
 298             case $$compareOffset $$(farthestInput ctx) $$(input ctx) of
 299               LT -> (# $$(input ctx), failExp #)
 300               EQ -> (# $$(farthestInput ctx), $$(farthestExpecting ctx) <> failExp #)
 301               GT -> (# $$(farthestInput ctx), $$(farthestExpecting ctx) #) in
 302         $$(NE.head $ Map.findWithDefault
 303             (NE.singleton (defaultCatch ctx))
 304             (symbolVal lbl)
 305             (catchStackByLabel ctx))
 306         $$(input ctx) farInp farExp
 307       ||]
 308     }
 309   popException lbl k = k
 310     { unGen = \ctx -> {-trace ("unGen.popException: "<>symbolVal lbl) $-}
 311       unGen k ctx{catchStackByLabel = Map.update (\case
 312           _r0:|(r1:rs) -> Just (r1:|rs)
 313           _ -> Nothing
 314         ) (symbolVal lbl) (catchStackByLabel ctx)
 315       }
 316     }
 317   catchException lbl ok ko = Gen
 318     { genAnalysisByLet = genAnalysisByLet ok <> genAnalysisByLet ko
 319     , genAnalysis = \final ct ->
 320         let ga = altGenAnalysis $ genAnalysis ok final ct :| [ genAnalysis ko final ct ] in
 321         ga { mayRaise = Map.delete (symbolVal lbl) (mayRaise ga) }
 322     , unGen = \ctx@GenCtx{} -> {-trace ("unGen.catchException: "<>symbolVal lbl) $-} [||
 323         let _ = $$(liftTypedString ("catchException lbl="<>symbolVal lbl)) in
 324         let catchHandler !failInp !farInp !farExp =
 325               let _ = $$(liftTypedString ("catchException.ko lbl="<>symbolVal lbl)) in
 326               $$({-trace ("unGen.catchException.ko: "<>symbolVal lbl) $-} unGen ko ctx
 327                 -- Push 'input' and 'checkedHorizon'
 328                 -- as they were when entering 'catchException'.
 329                 { valueStack =
 330                     ValueStackCons (H.Term (input ctx)) $
 331                     valueStack ctx
 332                 , horizonStack =
 333                     checkedHorizon ctx : horizonStack ctx
 334                 -- Note that 'catchStackByLabel' is reset.
 335                 -- Move the input to the failing position.
 336                 , input = [||failInp||]
 337                 -- The 'checkedHorizon' at the 'raiseException's
 338                 -- are not known here.
 339                 -- Nor whether 'failInp' is after
 340                 -- 'checkedHorizon' 'ctx' or not.
 341                 , checkedHorizon = 0
 342                 -- Set the farthestInput to the farthest computed by 'fail'.
 343                 , farthestInput = [||farInp||]
 344                 , farthestExpecting = [||farExp||]
 345                 })
 346         in
 347         $$({-trace ("unGen.catchException.ok: "<>symbolVal lbl) $-} unGen ok ctx
 348         { catchStackByLabel = Map.insertWith (<>) (symbolVal lbl)
 349             (NE.singleton [||catchHandler||]) (catchStackByLabel ctx)
 350         }
 351       ) ||]
 352     }
 353
 354 -- ** Type 'Catcher'
 355 type Catcher inp a =
 356   {-failureInput-}Cursor inp ->
 357   {-farthestInput-}Cursor inp ->
 358   {-farthestExpecting-}[ErrorItem (InputToken inp)] ->
 359   Either (ParsingError inp) a
 360 instance InstrInputable Gen where
 361   pushInput k = k
 362     { unGen = \ctx ->
 363         {-trace "unGen.pushInput" $-}
 364         unGen k ctx
 365           { valueStack = H.Term (input ctx) `ValueStackCons` valueStack ctx
 366           , horizonStack = checkedHorizon ctx : horizonStack ctx
 367           }
 368     }
 369   loadInput k = k
 370     { unGen = \ctx ->
 371         {-trace "unGen.loadInput" $-}
 372         let ValueStackCons input vs = valueStack ctx in
 373         let (h, hs) = case horizonStack ctx of
 374                         [] -> (0, [])
 375                         x:xs -> (x, xs) in
 376         unGen k ctx
 377           { valueStack = vs
 378           , horizonStack = hs
 379           , input = genCode input
 380           , checkedHorizon = h
 381           }
 382     , genAnalysis = \final ct -> GenAnalysis
 383         { minReads = 0 <$ minReads (genAnalysis k final ct)
 384         , mayRaise = mayRaise (genAnalysis k final ct)
 385         }
 386     }
 387 instance InstrCallable Gen where
 388   defLet defs k = k
 389     { unGen = \ctx@GenCtx{} ->
 390         {-trace ("unGen.defLet: defs="<>show (HM.keys defs)) $-}
 391         TH.unsafeCodeCoerce $ do
 392           decls <- traverse (makeDecl ctx) (HM.toList defs)
 393           body <- TH.unTypeQ $ TH.examineCode $
 394             {-trace "unGen.defLet.body" $-}
 395             unGen k ctx
 396           return $ TH.LetE (
 397             -- | Try to output more deterministic code to be able to golden test it,
 398             -- at the cost of more computations (at compile-time only though).
 399             List.sortBy (compare `on` TH.hideName) $
 400             toList decls
 401             ) body
 402     , genAnalysisByLet =
 403         foldMap' (\(SomeLet sub) -> genAnalysisByLet sub) defs <>
 404         ((\(SomeLet sub) -> genAnalysis sub) <$> defs) <>
 405         genAnalysisByLet k
 406     }
 407     where
 408     makeDecl ctx (n, SomeLet sub) = do
 409       body <- TH.unTypeQ $ TH.examineCode $ [|| -- buildRec in Parsley
 410         -- Called by 'call' or 'jump'.
 411         \ !ok{-from generateSuspend or retCode-}
 412           !inp
 413           !koByLabel{- 'catchStackByLabel' from the 'call'-site -} ->
 414           $$({-trace ("unGen.defLet.sub: "<>show n) $-} unGen sub ctx
 415             { valueStack = ValueStackEmpty
 416             -- Build a 'catchStackByLabel' from the one available at the 'call'-site.
 417             -- Note that all the 'mayRaise' of the 'sub'routine may not be available,
 418             -- hence 'Map.findWithDefault' is used instead of 'Map.!'.
 419             , catchStackByLabel = Map.mapWithKey
 420                 (\lbl () -> NE.singleton [||Map.findWithDefault $$(defaultCatch ctx) lbl koByLabel||])
 421                 ({-trace ("mayRaise: "<>show n) $-}
 422                   mayRaise (finalGenAnalysisByLet ctx HM.! n))
 423             , input = [||inp||]
 424             , retCode = {-trace ("unGen.defLet.sub.retCode: "<>show n) $-} [||ok||]
 425
 426             -- These are passed by the caller via 'ok' or 'ko'
 427             -- , farthestInput =
 428             -- , farthestExpecting =
 429
 430             -- Some callers can call this 'defLet'
 431             -- with zero 'checkedHorizon', hence use this minimum.
 432             -- TODO: maybe it could be improved a bit
 433             -- by taking the minimum of the checked horizons
 434             -- before all the 'call's and 'jump's to this 'defLet'.
 435             , checkedHorizon = 0
 436             })
 437         ||]
 438       let decl = TH.FunD n [TH.Clause [] (TH.NormalB body) []]
 439       return decl
 440   jump (LetName n) = Gen
 441     { genAnalysisByLet = HM.empty
 442     , genAnalysis = \final ct ->
 443         if n`List.elem`ct
 444         then GenAnalysis
 445           { minReads = Right 0
 446           , mayRaise = Map.empty
 447           }
 448         else (final HM.! n) (n:ct)
 449     , unGen = \ctx -> {-trace ("unGen.jump: "<>show n) $-} [||
 450       let _ = "jump" in
 451       $$(TH.unsafeCodeCoerce (return (TH.VarE n)))
 452         {-ok-}$$(retCode ctx)
 453         $$(input ctx)
 454         $$(liftTypedRaiseByLabel $
 455           catchStackByLabel ctx
 456           -- Pass only the labels raised by the 'defLet'.
 457           `Map.intersection`
 458           (mayRaise $ finalGenAnalysisByLet ctx HM.! n)
 459         )
 460       ||]
 461     }
 462   call (LetName n) k = k
 463     { genAnalysis = \final ct ->
 464         if n`List.elem`ct
 465         then GenAnalysis
 466           { minReads = Right 0
 467           , mayRaise = Map.empty
 468           }
 469         else seqGenAnalysis $
 470           (final HM.! n) (n:ct) :|
 471           [ genAnalysis k final ct ]
 472     , unGen = {-trace ("unGen.call: "<>show n) $-} \ctx ->
 473       -- let ks = (Map.keys (catchStackByLabel ctx)) in
 474       [||
 475       -- let _ = $$(liftTypedString $ "call exceptByLet("<>show n<>")="<>show (Map.keys (Map.findWithDefault Map.empty n (exceptByLet ctx))) <> " catchStackByLabel(ctx)="<> show ks) in
 476       $$(TH.unsafeCodeCoerce (return (TH.VarE n)))
 477         {-ok-}$$(generateSuspend k ctx{callStack = n : callStack ctx})
 478         $$(input ctx)
 479         $$(liftTypedRaiseByLabel $
 480           catchStackByLabel ctx
 481           -- Pass only the labels raised by the 'defLet'.
 482           `Map.intersection`
 483           (mayRaise $ finalGenAnalysisByLet ctx HM.! n)
 484         )
 485       ||]
 486     }
 487   ret = Gen
 488     { genAnalysisByLet = HM.empty
 489     , genAnalysis = \_final _ct -> GenAnalysis
 490         { minReads = Right 0
 491         , mayRaise = Map.empty
 492         }
 493     , unGen = \ctx -> {-trace "unGen.ret" $-} unGen ({-trace "unGen.ret.generateResume" $-} generateResume ({-trace "unGen.ret.retCode" $-} retCode ctx)) ctx
 494     }
 495
 496 -- | Like 'TH.liftString' but on 'TH.Code'.
 497 -- Useful to get a 'TH.StringL' instead of a 'TH.ListE'.
 498 liftTypedString :: String -> TH.Code TH.Q a
 499 liftTypedString = TH.unsafeCodeCoerce . TH.liftString
 500
 501 -- | Like 'TH.liftTyped' but adjusted to work on 'catchStackByLabel'
 502 -- which already contains 'CodeQ' terms.
 503 -- Moreover, only the 'Catcher' at the top of the stack
 504 -- is needed and thus generated in the resulting 'CodeQ'.
 505 --
 506 -- TODO: Use an 'Array' instead of a 'Map'?
 507 liftTypedRaiseByLabel :: TH.Lift k => Map k (NonEmpty (CodeQ a)) -> CodeQ (Map k a)
 508 liftTypedRaiseByLabel Map_.Tip = [|| Map_.Tip ||]
 509 liftTypedRaiseByLabel (Map_.Bin s k (h:|_hs) l r) =
 510   [|| Map_.Bin s k $$h $$(liftTypedRaiseByLabel l) $$(liftTypedRaiseByLabel r) ||]
 511
 512 -- ** Type 'Cont'
 513 type Cont inp v a =
 514   {-farthestInput-}Cursor inp ->
 515   {-farthestExpecting-}[ErrorItem (InputToken inp)] ->
 516   v ->
 517   Cursor inp ->
 518   Either (ParsingError inp) a
 519
 520 -- | Generate a 'retCode' 'Cont'inuation to be called with 'generateResume'.
 521 -- Used when 'call' 'ret'urns.
 522 -- The return 'v'alue is 'pushValue'-ed on the 'valueStack'.
 523 generateSuspend ::
 524   {-k-}Gen inp (v ': vs) a ->
 525   GenCtx inp vs a ->
 526   CodeQ (Cont inp v a)
 527 generateSuspend k ctx = [||
 528   let _ = $$(liftTypedString $ "suspend") in
 529   \farInp farExp v !inp ->
 530     $$({-trace "unGen.generateSuspend" $-} unGen k ctx
 531       { valueStack = ValueStackCons ({-trace "unGen.generateSuspend.value" $-} H.Term [||v||]) (valueStack ctx)
 532       , input = [||inp||]
 533       , farthestInput = [||farInp||]
 534       , farthestExpecting = [||farExp||]
 535       , checkedHorizon = 0
 536       }
 537     )
 538   ||]
 539
 540 -- | Generate a call to the 'generateSuspend' continuation.
 541 -- Used when 'call' 'ret'urns.
 542 generateResume ::
 543   CodeQ (Cont inp v a) ->
 544   Gen inp (v ': vs) a
 545 generateResume k = Gen
 546   { genAnalysisByLet = HM.empty
 547   , genAnalysis = \_final _ct -> GenAnalysis
 548       { minReads = Right 0
 549       , mayRaise = Map.empty
 550       }
 551   , unGen = \ctx -> {-trace "unGen.generateResume" $-} [||
 552     let _ = "resume" in
 553     $$k
 554       $$(farthestInput ctx)
 555       $$(farthestExpecting ctx)
 556       (let _ = "resume.genCode" in $$({-trace "unGen.generateResume.genCode" $-} genCode $ H.optimizeTerm $
 557         valueStackHead $ valueStack ctx))
 558       $$(input ctx)
 559     ||]
 560   }
 561
 562 instance InstrJoinable Gen where
 563   defJoin (LetName n) sub k = k
 564     { unGen =
 565         \ctx ->
 566         {-trace ("unGen.defJoin: "<>show n) $-}
 567         TH.unsafeCodeCoerce $ do
 568           next <- TH.unTypeQ $ TH.examineCode $ [||
 569             -- Called by 'generateResume'.
 570             \farInp farExp v !inp ->
 571               $$({-trace ("unGen.defJoin.next: "<>show n) $-} unGen sub ctx
 572                 { valueStack = ValueStackCons (H.Term [||v||]) (valueStack ctx)
 573                 , input = [||inp||]
 574                 , farthestInput = [||farInp||]
 575                 , farthestExpecting = [||farExp||]
 576                 , checkedHorizon = 0
 577                 {- FIXME:
 578                 , catchStackByLabel = Map.mapWithKey
 579                     (\lbl () -> NE.singleton [||koByLabel Map.! lbl||])
 580                     (mayRaise sub raiseLabelsByLetButSub)
 581                 -}
 582                 })
 583             ||]
 584           let decl = TH.FunD n [TH.Clause [] (TH.NormalB next) []]
 585           expr <- TH.unTypeQ (TH.examineCode ({-trace ("unGen.defJoin.expr: "<>show n) $-} unGen k ctx))
 586           return (TH.LetE [decl] expr)
 587     , genAnalysisByLet =
 588         (genAnalysisByLet sub <>) $
 589         HM.insert n (genAnalysis sub) $
 590         genAnalysisByLet k
 591     }
 592   refJoin (LetName n) = Gen
 593     { unGen = \ctx ->
 594         {-trace ("unGen.refJoin: "<>show n) $-}
 595         unGen (generateResume
 596           (TH.unsafeCodeCoerce (return (TH.VarE n)))) ctx
 597     , genAnalysisByLet = HM.empty
 598     , genAnalysis = \final ct ->
 599         if n`List.elem`ct -- FIXME: useless
 600         then GenAnalysis
 601           { minReads = Right 0
 602           , mayRaise = Map.empty
 603           }
 604         else HM.findWithDefault
 605           (error (show (n,ct,HM.keys final)))
 606           n final (n:ct)
 607     }
 608 instance InstrReadable Char Gen where
 609   read farExp p = checkHorizon . checkToken farExp p
 610
 611 checkHorizon ::
 612   TH.Lift (InputToken inp) =>
 613   {-ok-}Gen inp vs a ->
 614   Gen inp vs a
 615 checkHorizon ok = ok
 616   { genAnalysis = \final ct -> seqGenAnalysis $
 617       GenAnalysis { minReads = Right 1
 618                   , mayRaise = Map.singleton "fail" ()
 619                   } :|
 620       [ genAnalysis ok final ct ]
 621   , unGen = \ctx0@GenCtx{} ->
 622     {-trace "unGen.checkHorizon" $-}
 623     let raiseFail =
 624           NE.head (Map.findWithDefault
 625             (NE.singleton (defaultCatch ctx0))
 626             "fail" (catchStackByLabel ctx0)) in
 627     [||
 628       -- Factorize generated code for raising the "fail".
 629       let readFail = $$(raiseFail) in
 630       $$(
 631         let ctx = ctx0{catchStackByLabel =
 632                     Map.adjust (\(_r:|rs) -> [||readFail||] :| rs)
 633                       "fail" (catchStackByLabel ctx0)} in
 634         if checkedHorizon ctx >= 1
 635         then unGen ok ctx0{checkedHorizon = checkedHorizon ctx - 1}
 636         else let minHoriz =
 637                     either (\err -> 0) id $
 638                     minReads $ finalGenAnalysis ctx ok in
 639           [||
 640           if $$(moreInput ctx)
 641                $$(if minHoriz > 0
 642                  then [||$$shiftRight minHoriz $$(input ctx)||]
 643                  else input ctx)
 644           then $$(unGen ok ctx{checkedHorizon = minHoriz})
 645           else let _ = "checkHorizon.else" in
 646             -- TODO: return a resuming continuation (eg. Partial)
 647             $$(unGen (fail [ErrorItemHorizon (minHoriz + 1)]) ctx)
 648           ||]
 649       )
 650     ||]
 651   }
 652
 653 finalGenAnalysis :: GenCtx inp vs a -> Gen inp cs a -> GenAnalysis
 654 finalGenAnalysis ctx k =
 655   --(\f -> f (error "callTrace")) $
 656   (\f -> f (callStack ctx)) $
 657   genAnalysis k $
 658   ((\f _ct -> f) <$>) $
 659   finalGenAnalysisByLet ctx
 660
 661 checkToken ::
 662   Ord (InputToken inp) =>
 663   TH.Lift (InputToken inp) =>
 664   [ErrorItem (InputToken inp)] ->
 665   {-predicate-}TermInstr (InputToken inp -> Bool) ->
 666   {-ok-}Gen inp (InputToken inp ': vs) a ->
 667   Gen inp vs a
 668 checkToken farExp p ok = ok
 669   { unGen = \ctx -> {-trace "unGen.read" $-} [||
 670     let !(# c, cs #) = $$(nextInput ctx) $$(input ctx) in
 671     if $$(genCode p) c
 672     then $$(unGen ok ctx
 673       { valueStack = ValueStackCons (H.Term [||c||]) (valueStack ctx)
 674       , input = [||cs||]
 675       })
 676     else let _ = "checkToken.else" in $$(unGen (fail farExp) ctx)
 677     ||]
 678   }