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