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