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