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   , freeRegs :: Set TH.Name
 199   } deriving (Show)
 200
 201 -- ** Type 'Offset'
 202 type Offset = Int
 203 -- ** Type 'Horizon'
 204 -- | Minimal input length required for a successful parsing.
 205 type Horizon = Offset
 206
 207 -- altGenAnalysis = List.foldl' (\acc x -> either Left (\h -> Right (either (const h) (min h) acc)) x)
 208 -- | Merge given 'GenAnalysis' as sequences.
 209 seqGenAnalysis :: NonEmpty GenAnalysis -> GenAnalysis
 210 seqGenAnalysis aas@(a:|as) = GenAnalysis
 211   { minReads = List.foldl' (\acc x ->
 212         acc >>= \r -> (r +) <$> minReads x
 213       ) (minReads a) as
 214   , mayRaise = sconcat (mayRaise <$> aas)
 215   , freeRegs = sconcat (freeRegs <$> aas)
 216   }
 217 -- | Merge given 'GenAnalysis' as alternatives.
 218 altGenAnalysis :: NonEmpty GenAnalysis -> GenAnalysis
 219 altGenAnalysis aas@(a:|as) = GenAnalysis
 220   { minReads = List.foldl' (\acc x ->
 221       case acc of
 222         Left l ->
 223           case minReads x of
 224             Left{} -> Left l
 225             Right r -> Right r
 226         Right r ->
 227           case minReads x of
 228             Left{} -> Right r
 229             Right r' -> Right (min r r')
 230       ) (minReads a) as
 231   , mayRaise = sconcat (mayRaise <$> aas)
 232   , freeRegs = sconcat (freeRegs <$> aas)
 233   }
 234
 235
 236 {-
 237 -- *** Type 'FarthestError'
 238 data FarthestError inp = FarthestError
 239   { farthestInput :: Cursor inp
 240   , farthestExpecting :: [Failure (InputToken inp)]
 241   }
 242 -}
 243
 244 -- ** Type 'GenCtx'
 245 -- | This is an inherited (top-down) context
 246 -- only present at compile-time, to build TemplateHaskell splices.
 247 data GenCtx st inp vs a =
 248   ( Cursorable (Cursor inp)
 249   {-
 250   , TH.Lift (InputToken inp)
 251   , Show (InputToken inp)
 252   , Eq (InputToken inp)
 253   , Typeable (InputToken inp)
 254   , NFData (InputToken inp)
 255   -}
 256   ) => GenCtx
 257   { valueStack :: ValueStack vs
 258   , catchStackByLabel :: Map Exception (NonEmpty (CodeQ (Catcher st inp a)))
 259     -- | Default 'Catcher' defined at the begining of the generated 'CodeQ',
 260     -- hence a constant within the 'Gen'eration.
 261   , defaultCatch :: forall b. CodeQ (Catcher st inp b)
 262   , returnCall :: CodeQ (Return st inp a a)
 263   , input :: CodeQ (Cursor inp)
 264   , moreInput :: CodeQ (Cursor inp -> Bool)
 265   , nextInput :: CodeQ (Cursor inp -> (# InputToken inp, Cursor inp #))
 266   , farthestInput :: CodeQ (Cursor inp)
 267   , farthestExpecting :: CodeQ (Set SomeFailure)
 268     -- | Remaining horizon already checked.
 269     -- Use to factorize 'input' length checks,
 270     -- instead of checking the 'input' length
 271     -- one 'InputToken' at a time at each 'read'.
 272     -- Updated by 'checkHorizon'
 273     -- and reset elsewhere when needed.
 274   , checkedHorizon :: Horizon
 275   -- | Used by 'pushInput' and 'loadInput'
 276   -- to restore the 'Horizon' at the restored 'input'.
 277   , horizonStack :: [Horizon]
 278   -- | Output of 'mutualFix'.
 279   , finalGenAnalysisByLet :: LetRecs TH.Name GenAnalysis
 280   }
 281
 282 -- ** Type 'ValueStack'
 283 data ValueStack vs where
 284   ValueStackEmpty :: ValueStack '[]
 285   ValueStackCons ::
 286     { valueStackHead :: Splice v
 287     , valueStackTail :: ValueStack vs
 288     } -> ValueStack (v ': vs)
 289
 290 instance InstrValuable Gen where
 291   pushValue x k = k
 292     { unGen = \ctx -> {-trace "unGen.pushValue" $-} unGen k ctx
 293       { valueStack = ValueStackCons x (valueStack ctx) }
 294     }
 295   popValue k = k
 296     { unGen = \ctx -> {-trace "unGen.popValue" $-} unGen k ctx
 297       { valueStack = valueStackTail (valueStack ctx) }
 298     }
 299   lift2Value f k = k
 300     { unGen = \ctx -> {-trace "unGen.lift2Value" $-} unGen k ctx
 301       { valueStack =
 302         let ValueStackCons y (ValueStackCons x vs) = valueStack ctx in
 303         ValueStackCons (f Prod..@ x Prod..@ y) vs
 304       }
 305     }
 306   swapValue k = k
 307     { unGen = \ctx -> {-trace "unGen.swapValue" $-} unGen k ctx
 308       { valueStack =
 309           let ValueStackCons y (ValueStackCons x vs) = valueStack ctx in
 310           ValueStackCons x (ValueStackCons y vs)
 311       }
 312     }
 313 instance InstrBranchable Gen where
 314   caseBranch kx ky = Gen
 315     { genAnalysisByLet = genAnalysisByLet kx <> genAnalysisByLet ky
 316     , genAnalysis = \final -> altGenAnalysis $ genAnalysis kx final :| [genAnalysis ky final]
 317     , unGen = \ctx -> {-trace "unGen.caseBranch" $-}
 318       let ValueStackCons v vs = valueStack ctx in
 319       [||
 320         case $$(genCode v) of
 321           Left  x -> $$(unGen kx ctx{ valueStack = ValueStackCons (splice [||x||]) vs })
 322           Right y -> $$(unGen ky ctx{ valueStack = ValueStackCons (splice [||y||]) vs })
 323       ||]
 324     }
 325   choicesBranch bs default_ = Gen
 326     { genAnalysisByLet = sconcat $ genAnalysisByLet default_ :| (genAnalysisByLet . snd <$> bs)
 327     , genAnalysis = \final -> altGenAnalysis $
 328         (\k -> genAnalysis k final)
 329         <$> (default_:|(snd <$> bs))
 330     , unGen = \ctx0 -> {-trace "unGen.choicesBranch" $-}
 331       let ValueStackCons v vs = valueStack ctx0 in
 332       let ctx = ctx0{valueStack = vs} in
 333       let
 334         go x ((p,b):bs') = [||
 335           if $$(genCode (p Prod..@ x))
 336           then
 337             let _ = "choicesBranch.then" in
 338             $$({-trace "unGen.choicesBranch.b" $-} unGen b ctx)
 339           else
 340             let _ = "choicesBranch.else" in
 341             $$(go x bs')
 342           ||]
 343         go _ _ = unGen default_ ctx
 344       in go v bs
 345     }
 346 instance InstrExceptionable Gen where
 347   raise exn = Gen
 348     { genAnalysisByLet = HM.empty
 349     , genAnalysis = \_final -> GenAnalysis
 350         { minReads = Left (ExceptionLabel exn)
 351         , mayRaise = Map.singleton (ExceptionLabel exn) ()
 352         , freeRegs = Set.empty
 353         }
 354     , unGen = \ctx@GenCtx{} -> {-trace ("unGen.raise: "<>show exn) $-} [||
 355         $$(raiseException ctx (ExceptionLabel exn))
 356           (ExceptionLabel $$(TH.liftTyped exn))
 357           {-failInp-}$$(input ctx)
 358           {-farInp-}$$(input ctx)
 359           $$(farthestExpecting ctx)
 360       ||]
 361     }
 362   fail fs = Gen
 363     { genAnalysisByLet = HM.empty
 364     , genAnalysis = \_final -> GenAnalysis
 365         { minReads = Left ExceptionFailure
 366         , mayRaise = Map.singleton ExceptionFailure ()
 367         , freeRegs = Set.empty
 368         }
 369     , unGen = \ctx@GenCtx{} -> {-trace ("unGen.fail: "<>show exn) $-}
 370       if null fs
 371       then [|| -- Raise without updating the farthest error.
 372           $$(raiseException ctx ExceptionFailure)
 373             ExceptionFailure
 374             {-failInp-}$$(input ctx)
 375             $$(farthestInput ctx)
 376             $$(farthestExpecting ctx)
 377         ||]
 378       else raiseFailure ctx [||fs||]
 379     }
 380   commit exn k = k
 381     { unGen = \ctx -> {-trace ("unGen.commit: "<>show exn) $-}
 382       unGen k ctx{catchStackByLabel =
 383         Map.update (\case
 384             _r0:|(r1:rs) -> Just (r1:|rs)
 385             _ -> Nothing
 386           )
 387         exn (catchStackByLabel ctx)
 388       }
 389     }
 390   catch exn ok ko = Gen
 391     { genAnalysisByLet = genAnalysisByLet ok <> genAnalysisByLet ko
 392     , genAnalysis = \final ->
 393         let okAnalysis = genAnalysis ok final in
 394         altGenAnalysis $
 395           okAnalysis{ mayRaise = Map.delete exn (mayRaise okAnalysis) } :|
 396           [ genAnalysis ko final ]
 397     , unGen = \ctx@GenCtx{} -> {-trace ("unGen.catch: "<>show exn) $-} [||
 398         let _ = $$(liftTypedString ("catch "<>show exn)) in
 399         let catchHandler !_exn !failInp !farInp !farExp =
 400               let _ = $$(liftTypedString ("catch.ko "<>show exn)) in
 401               $$({-trace ("unGen.catch.ko: "<>show exn) $-} unGen ko ctx
 402                 -- Push 'input' and 'checkedHorizon'
 403                 -- as they were when entering 'catch',
 404                 -- they will be available to 'loadInput', if any.
 405                 { valueStack =
 406                     ValueStackCons (splice (input ctx)) $
 407                     --ValueStackCons (Prod.var [||exn||]) $
 408                     valueStack ctx
 409                 , horizonStack =
 410                     checkedHorizon ctx : horizonStack ctx
 411                 -- Note that 'catchStackByLabel' is reset.
 412                 -- Move the input to the failing position.
 413                 , input = [||failInp||]
 414                 -- The 'checkedHorizon' at the 'raise's are not known here.
 415                 -- Nor whether 'failInp' is after 'checkedHorizon' or not.
 416                 -- Hence fallback to a safe value.
 417                 , checkedHorizon = 0
 418                 -- Set the farthestInput to the farthest computed in 'fail'.
 419                 , farthestInput = [||farInp||]
 420                 , farthestExpecting = [||farExp||]
 421                 })
 422         in
 423         $$({-trace ("unGen.catch.ok: "<>show es) $-} unGen ok ctx
 424         { catchStackByLabel =
 425             Map.insertWith (<>) exn
 426               (NE.singleton [||catchHandler||])
 427               (catchStackByLabel ctx)
 428         }
 429       ) ||]
 430     }
 431 instance InstrInputable Gen where
 432   pushInput k = k
 433     { unGen = \ctx ->
 434         {-trace "unGen.pushInput" $-}
 435         unGen k ctx
 436           { valueStack = splice (input ctx) `ValueStackCons` valueStack ctx
 437           , horizonStack = checkedHorizon ctx : horizonStack ctx
 438           }
 439     }
 440   loadInput k = k
 441     { unGen = \ctx ->
 442         {-trace "unGen.loadInput" $-}
 443         let ValueStackCons input vs = valueStack ctx in
 444         let (h, hs) = case horizonStack ctx of
 445                         [] -> (0, [])
 446                         x:xs -> (x, xs) in
 447         unGen k ctx
 448           { valueStack = vs
 449           , horizonStack = hs
 450           , input = genCode input
 451           , checkedHorizon = h
 452           }
 453     , genAnalysis = \final ->
 454         let analysis = genAnalysis k final in
 455         analysis{minReads = 0 <$ minReads analysis}
 456     }
 457 instance InstrCallable Gen where
 458   defLet defs k = k
 459     { unGen = \ctx@GenCtx{} ->
 460         {-trace ("unGen.defLet: defs="<>show (HM.keys defs)) $-}
 461         TH.unsafeCodeCoerce $ do
 462           decls <- traverse (makeDecl ctx) (HM.toList defs)
 463           body <- TH.unTypeQ $ TH.examineCode $
 464             {-trace "unGen.defLet.body" $-}
 465             unGen k ctx
 466           return $ TH.LetE (
 467             -- | Use 'List.sortBy' to output more deterministic code
 468             -- to be able to golden test it, at the cost of more computations
 469             -- (at compile-time only though).
 470             List.sortBy (compare `on` TH.hideName) $
 471             toList decls
 472             ) body
 473     , genAnalysisByLet =
 474         HM.unions
 475           $ genAnalysisByLet k
 476           : ((\(SomeLet sub) -> genAnalysis sub) <$> defs)
 477           : ((\(SomeLet sub) -> genAnalysisByLet sub) <$> HM.elems defs)
 478     }
 479     where
 480     makeDecl ctx (subName, SomeLet sub) = do
 481       let analysis = finalGenAnalysisByLet ctx HM.! subName
 482       body <- takeFreeRegs (freeRegs analysis) $
 483         TH.unTypeQ $ TH.examineCode $ [|| -- buildRec in Parsley
 484         -- Called by 'call' or 'jump'.
 485         \ !callReturn{-from generateSuspend or returnCall-}
 486           !callInput
 487           !callCatchStackByLabel{- 'catchStackByLabel' from the 'call'-site -} ->
 488           $$({-trace ("unGen.defLet.sub: "<>show subName) $-} unGen sub ctx
 489             { valueStack = ValueStackEmpty
 490             -- Build a 'catchStackByLabel' for the 'mayRaise' of the subroutine,
 491             -- where each 'Catcher' calls the one passed by the 'call'-site (in 'callCatchStackByLabel').
 492             -- Note that currently the 'call'-site can supply in 'callCatchStackByLabel'
 493             -- a subset of the 'mayRaise' needed by this subroutine,
 494             -- because 'Map.findWithDefault' is used instead of 'Map.!'.
 495             , catchStackByLabel = Map.mapWithKey
 496                 (\lbl () -> NE.singleton [||Map.findWithDefault $$(defaultCatch ctx) lbl callCatchStackByLabel||])
 497                 ({-trace ("mayRaise: "<>show subName) $-}
 498                   mayRaise analysis)
 499             , input = [||callInput||]
 500             , returnCall = {-trace ("unGen.defLet.sub.returnCall: "<>show subName) $-} [||callReturn||]
 501
 502             -- These are passed by the caller via 'callReturn' or 'ko'
 503             -- , farthestInput =
 504             -- , farthestExpecting =
 505
 506             -- Some callers can call this 'defLet'
 507             -- with zero 'checkedHorizon', hence use this minimum.
 508             -- TODO: maybe it could be improved a bit
 509             -- by taking the minimum of the checked horizons
 510             -- before all the 'call's and 'jump's to this 'defLet'.
 511             , checkedHorizon = 0
 512             })
 513         ||]
 514       let decl = TH.FunD subName [TH.Clause [] (TH.NormalB body) []]
 515       return decl
 516   jump isRec (LetName subName) = Gen
 517     { genAnalysisByLet = HM.empty
 518     , genAnalysis = \final ->
 519         if isRec
 520         then GenAnalysis
 521           { minReads = Right 0
 522           , mayRaise = Map.empty
 523           , freeRegs = Set.empty
 524           }
 525         else final HM.! subName
 526     , unGen = \ctx -> {-trace ("unGen.jump: "<>show subName) $-}
 527       let analysis = finalGenAnalysisByLet ctx HM.! subName in
 528       [||
 529       let _ = "jump" in
 530       $$(TH.unsafeCodeCoerce $
 531         giveFreeRegs (freeRegs analysis) $
 532         return (TH.VarE subName))
 533         {-ok-}$$(returnCall ctx)
 534         $$(input ctx)
 535         $$(liftTypedRaiseByLabel $
 536           catchStackByLabel ctx
 537           -- Pass only the labels raised by the 'defLet'.
 538           `Map.intersection`
 539           (mayRaise analysis)
 540         )
 541       ||]
 542     }
 543   call isRec (LetName subName) k = k
 544     { genAnalysis = \final ->
 545         if isRec
 546         then GenAnalysis
 547           { minReads = Right 0
 548           , mayRaise = Map.empty
 549           , freeRegs = Set.empty
 550           }
 551         else seqGenAnalysis $ (final HM.! subName) :| [ genAnalysis k final ]
 552     , unGen = {-trace ("unGen.call: "<>show subName) $-} \ctx ->
 553       -- let ks = (Map.keys (catchStackByLabel ctx)) in
 554       let analysis = finalGenAnalysisByLet ctx HM.! subName in
 555       [||
 556       -- let _ = $$(liftTypedString $ "call exceptByLet("<>show subName<>")="<>show (Map.keys (Map.findWithDefault Map.empty subName (exceptByLet ctx))) <> " catchStackByLabel(ctx)="<> show ks) in
 557       $$(TH.unsafeCodeCoerce $
 558         giveFreeRegs (freeRegs analysis) $
 559         return (TH.VarE subName))
 560         {-ok-}$$(generateSuspend k ctx)
 561         $$(input ctx)
 562         $$(liftTypedRaiseByLabel $
 563           -- FIXME: maybe it should rather pass all the 'mayRaise' of 'subName'
 564           -- and 'defaultCatch' be removed from 'makeDecl''s 'catchStackByLabel'.
 565           catchStackByLabel ctx
 566           -- Pass only the labels raised by the 'defLet'.
 567           `Map.intersection`
 568           (mayRaise analysis)
 569         )
 570       ||]
 571     }
 572   ret = Gen
 573     { genAnalysisByLet = HM.empty
 574     , genAnalysis = \_final -> GenAnalysis
 575         { minReads = Right 0
 576         , mayRaise = Map.empty
 577         , freeRegs = Set.empty
 578         }
 579     , unGen = \ctx -> {-trace "unGen.ret" $-}
 580       {-trace "unGen.ret.generateResume" $-}
 581       generateResume ({-trace "unGen.ret.returnCall" $-} returnCall ctx) ctx
 582     }
 583
 584 takeFreeRegs :: TH.Quote m => Set TH.Name -> m TH.Exp -> m TH.Exp
 585 takeFreeRegs frs k = go (Set.toList frs)
 586   where
 587   go [] = k
 588   go (r:rs) = [| \ $(return (TH.VarP r)) -> $(go rs) |]
 589
 590 giveFreeRegs :: TH.Quote m => Set TH.Name -> m TH.Exp -> m TH.Exp
 591 giveFreeRegs frs k = go (Set.toList frs)
 592   where
 593   go [] = k
 594   go (r:rs) = [| $(go rs) $(return (TH.VarE r)) |]
 595
 596 -- | Like 'TH.liftString' but on 'TH.Code'.
 597 -- Useful to get a 'TH.StringL' instead of a 'TH.ListE'.
 598 liftTypedString :: String -> TH.Code TH.Q a
 599 liftTypedString = TH.unsafeCodeCoerce . TH.liftString
 600
 601 -- | Like 'TH.liftTyped' but adjusted to work on 'catchStackByLabel'
 602 -- which already contains 'CodeQ' terms.
 603 -- Moreover, only the 'Catcher' at the top of the stack
 604 -- is needed and thus generated in the resulting 'CodeQ'.
 605 --
 606 -- TODO: Use an 'Array' instead of a 'Map'?
 607 liftTypedRaiseByLabel :: TH.Lift k => Map k (NonEmpty (CodeQ a)) -> CodeQ (Map k a)
 608 liftTypedRaiseByLabel Map_.Tip = [|| Map_.Tip ||]
 609 liftTypedRaiseByLabel (Map_.Bin s k (h:|_hs) l r) =
 610   [|| Map_.Bin s k $$h $$(liftTypedRaiseByLabel l) $$(liftTypedRaiseByLabel r) ||]
 611
 612 instance TH.Lift a => TH.Lift (Set a) where
 613   liftTyped Set_.Tip = [|| Set_.Tip ||]
 614   liftTyped (Set_.Bin s a l r) = [|| Set_.Bin $$(TH.liftTyped s) $$(TH.liftTyped a) $$(TH.liftTyped l) $$(TH.liftTyped r) ||]
 615
 616 -- ** Type 'Return'
 617 type Return st inp v a =
 618   {-farthestInput-}Cursor inp ->
 619   {-farthestExpecting-}(Set SomeFailure) ->
 620   v ->
 621   Cursor inp ->
 622   ST st (Either (ParsingError inp) a)
 623
 624 -- | Generate a 'returnCall' 'Return'inuation to be called with 'generateResume'.
 625 -- Used when 'call' 'ret'urns.
 626 -- The return 'v'alue is 'pushValue'-ed on the 'valueStack'.
 627 generateSuspend ::
 628   {-k-}Gen inp (v ': vs) a ->
 629   GenCtx st inp vs a ->
 630   CodeQ (Return st inp v a)
 631 generateSuspend k ctx = [||
 632   let _ = $$(liftTypedString $ "suspend") in
 633   \farInp farExp v !inp ->
 634     $$({-trace "unGen.generateSuspend" $-} unGen k ctx
 635       { valueStack = ValueStackCons ({-trace "unGen.generateSuspend.value" $-} splice [||v||]) (valueStack ctx)
 636       , input = [||inp||]
 637       , farthestInput = [||farInp||]
 638       , farthestExpecting = [||farExp||]
 639       , checkedHorizon = 0
 640       }
 641     )
 642   ||]
 643
 644 -- | Generate a call to the 'generateSuspend' continuation.
 645 -- Used when 'call' 'ret'urns.
 646 generateResume ::
 647   CodeQ (Return st inp v a) ->
 648   GenCtx st inp (v ': vs) a ->
 649   CodeQ (ST st (Either (ParsingError inp) a))
 650 generateResume k = \ctx -> {-trace "generateResume" $-} [||
 651   let _ = "resume" in
 652   $$k
 653     $$(farthestInput ctx)
 654     $$(farthestExpecting ctx)
 655     (let _ = "resume.genCode" in $$({-trace "generateResume.genCode" $-}
 656       genCode $ valueStackHead $ valueStack ctx))
 657     $$(input ctx)
 658   ||]
 659
 660 -- ** Type 'Catcher'
 661 type Catcher st inp a =
 662   Exception ->
 663   {-failInp-}Cursor inp ->
 664   {-farInp-}Cursor inp ->
 665   {-farExp-}(Set SomeFailure) ->
 666   ST st (Either (ParsingError inp) a)
 667
 668 instance InstrJoinable Gen where
 669   defJoin (LetName n) sub k = k
 670     { unGen = \ctx ->
 671         {-trace ("unGen.defJoin: "<>show n) $-}
 672         TH.unsafeCodeCoerce [|
 673           let $(return (TH.VarP n)) = $(TH.unTypeQ $ TH.examineCode [||
 674                 -- Called by 'generateResume'.
 675                 \farInp farExp v !inp ->
 676                   $$({-trace ("unGen.defJoin.next: "<>show n) $-} unGen sub ctx
 677                     { valueStack = ValueStackCons (splice [||v||]) (valueStack ctx)
 678                     , input = [||inp||]
 679                     , farthestInput = [||farInp||]
 680                     , farthestExpecting = [||farExp||]
 681                     , checkedHorizon = 0
 682                     {- FIXME:
 683                     , catchStackByLabel = Map.mapWithKey
 684                         (\lbl () -> NE.singleton [||koByLabel Map.! lbl||])
 685                         (mayRaise sub raiseLabelsByLetButSub)
 686                     -}
 687                     })
 688                 ||])
 689           in $(TH.unTypeQ $ TH.examineCode $
 690             {-trace ("unGen.defJoin.expr: "<>show n) $-}
 691             unGen k ctx)
 692         |]
 693     , genAnalysisByLet =
 694         (genAnalysisByLet sub <>) $
 695         HM.insert n (genAnalysis sub) $
 696         genAnalysisByLet k
 697     }
 698   refJoin (LetName n) = Gen
 699     { unGen = \ctx ->
 700         {-trace ("unGen.refJoin: "<>show n) $-}
 701         generateResume
 702           (TH.unsafeCodeCoerce (return (TH.VarE n))) ctx
 703     , genAnalysisByLet = HM.empty
 704     , genAnalysis = \final ->
 705         HM.findWithDefault
 706           (error (show (n,HM.keys final)))
 707           n final
 708     }
 709 instance InstrReadable Char Gen where
 710   read fs p = checkHorizon . checkToken fs p
 711 instance InstrReadable Word8 Gen where
 712   read fs p = checkHorizon . checkToken fs p
 713 instance InstrIterable Gen where
 714   iter (LetName jumpName) loop done = Gen
 715     { genAnalysisByLet = HM.unions
 716         [ -- No need to give 'freeRegs' when 'call'ing 'jumpName'
 717           -- they're passed when 'call'ing 'iter'.
 718           HM.singleton jumpName (\final -> (genAnalysis loop final){freeRegs = Set.empty})
 719         , genAnalysisByLet loop
 720         , genAnalysisByLet done
 721         ]
 722     , genAnalysis = \final ->
 723       let loopAnalysis = genAnalysis loop final in
 724       let doneAnalysis = genAnalysis done final in
 725       GenAnalysis
 726         { minReads = minReads doneAnalysis
 727         , mayRaise =
 728             Map.delete ExceptionFailure (mayRaise loopAnalysis) <>
 729             mayRaise doneAnalysis
 730         , freeRegs = freeRegs loopAnalysis <> freeRegs doneAnalysis
 731         }
 732     , unGen = \ctx -> TH.unsafeCodeCoerce [|
 733         let _ = "iter" in
 734         let
 735           catchHandler loopInput !_exn !failInp !farInp !farExp =
 736             $(TH.unTypeCode $ {-trace ("unGen.catch.ko: "<>show exn) $-} unGen done ctx
 737                 -- Push 'input' and 'checkedHorizon'
 738                 -- as they were when entering 'catch',
 739                 -- they will be available to 'loadInput', if any.
 740                 { valueStack = ValueStackCons (splice (TH.unsafeCodeCoerce [|loopInput|])) (valueStack ctx)
 741                 , horizonStack = checkedHorizon ctx : horizonStack ctx
 742                 -- Note that 'catchStackByLabel' is reset.
 743                 -- Move the input to the failing position.
 744                 , input = TH.unsafeCodeCoerce [|failInp|]
 745                 -- The 'checkedHorizon' at the 'raise's are not known here.
 746                 -- Nor whether 'failInp' is after 'checkedHorizon' or not.
 747                 -- Hence fallback to a safe value.
 748                 , checkedHorizon = 0
 749                 -- Set the farthestInput to the farthest computed in 'fail'.
 750                 , farthestInput = TH.unsafeCodeCoerce [|farInp|]
 751                 , farthestExpecting = TH.unsafeCodeCoerce [|farExp|]
 752                 })
 753           $(return $ TH.VarP jumpName) = \_callReturn callInput callCatchStackByLabel ->
 754             $(TH.unTypeCode $ unGen loop ctx
 755               { valueStack = ValueStackEmpty
 756               , catchStackByLabel =
 757                 {-
 758                 Map.mapWithKey
 759                   (\lbl () -> NE.singleton $ TH.unsafeCodeCoerce [|
 760                     Map.findWithDefault $(TH.unTypeCode $ defaultCatch ctx) lbl koByLabel
 761                   |])
 762                   (mayRaise (finalGenAnalysisByLet ctx HM.! jumpName))
 763                 -}
 764                 Map.insertWith (<>) ExceptionFailure
 765                   (NE.singleton $ TH.unsafeCodeCoerce [|catchHandler callInput|])
 766                   (catchStackByLabel ctx)
 767               , input = TH.unsafeCodeCoerce [|callInput|]
 768               -- FIXME: promote to compile time error?
 769               , returnCall = TH.unsafeCodeCoerce [|error "invalid return"|]
 770               , checkedHorizon = 0
 771               })
 772         in $(TH.unTypeCode $ unGen (jump True (LetName jumpName)) ctx{valueStack=ValueStackEmpty})
 773        |]
 774     }
 775 instance InstrRegisterable Gen where
 776   newRegister (UnscopedRegister r) k = k
 777     { genAnalysis = \final ->
 778       let analysis = genAnalysis k final in
 779       analysis{freeRegs = Set.delete r $ freeRegs analysis}
 780     , unGen = \ctx ->
 781       let ValueStackCons v vs = valueStack ctx in
 782       TH.unsafeCodeCoerce [|
 783       do
 784         let dupv = $(TH.unTypeCode $ genCode v)
 785         $(return (TH.VarP r)) <- ST.newSTRef dupv
 786         $(TH.unTypeCode $ unGen k ctx{valueStack=vs})
 787       |]
 788     }
 789   readRegister (UnscopedRegister r) k = k
 790     { genAnalysis = \final ->
 791       let analysis = genAnalysis k final in
 792       analysis{freeRegs = Set.insert r $ freeRegs analysis}
 793     , unGen = \ctx -> [|| do
 794         sr <- ST.readSTRef $$(TH.unsafeCodeCoerce (return (TH.VarE r)))
 795         $$(unGen k ctx{valueStack=ValueStackCons (splice [||sr||]) (valueStack ctx)})
 796       ||]
 797     }
 798   writeRegister (UnscopedRegister r) k = k
 799     { genAnalysis = \final ->
 800       let analysis = genAnalysis k final in
 801       analysis{freeRegs = Set.insert r $ freeRegs analysis}
 802     , unGen = \ctx ->
 803       let ValueStackCons v vs = valueStack ctx in
 804       [|| do
 805         let dupv = $$(genCode v)
 806         ST.writeSTRef $$(TH.unsafeCodeCoerce (return (TH.VarE r))) dupv
 807         $$(unGen k ctx{valueStack=vs})
 808       ||]
 809     }
 810
 811 checkHorizon ::
 812   forall inp vs a.
 813   -- Those constraints are not used anyway
 814   -- because (TH.Lift SomeFailure) uses 'inputTokenProxy'.
 815   Ord (InputToken inp) =>
 816   Show (InputToken inp) =>
 817   TH.Lift (InputToken inp) =>
 818   NFData (InputToken inp) =>
 819   Typeable (InputToken inp) =>
 820   {-ok-}Gen inp vs a ->
 821   Gen inp vs a
 822 checkHorizon ok = ok
 823   { genAnalysis = \final -> seqGenAnalysis $
 824       GenAnalysis { minReads = Right 1
 825                   , mayRaise = Map.singleton ExceptionFailure ()
 826                   , freeRegs = Set.empty
 827                   } :|
 828       [ genAnalysis ok final ]
 829   , unGen = \ctx0@GenCtx{} ->
 830     {-trace "unGen.checkHorizon" $-}
 831     let raiseFail = raiseException ctx0 ExceptionFailure in
 832     [||
 833       -- Factorize generated code for raising the "fail".
 834       let readFail = $$(raiseFail) in
 835       $$(
 836         let ctx = ctx0{catchStackByLabel =
 837                     Map.adjust (\(_r:|rs) -> [||readFail||] :| rs)
 838                       ExceptionFailure (catchStackByLabel ctx0)} in
 839         if checkedHorizon ctx >= 1
 840         then unGen ok ctx0{checkedHorizon = checkedHorizon ctx - 1}
 841         else let minHoriz =
 842                     either (\_err -> 0) id $
 843                     minReads $ finalGenAnalysis ctx ok in
 844           [||
 845           if $$(moreInput ctx)
 846                $$(if minHoriz > 0
 847                  then [||$$shiftRight minHoriz $$(input ctx)||]
 848                  else input ctx)
 849           then $$(unGen ok ctx{checkedHorizon = minHoriz})
 850           else let _ = "checkHorizon.else" in
 851             -- TODO: return a resuming continuation (eg. Partial)
 852             $$(unGen (fail (Set.singleton $ SomeFailure $ FailureHorizon @(InputToken inp) (minHoriz + 1))) ctx)
 853           ||]
 854       )
 855     ||]
 856   }
 857
 858 -- | @('raiseFailure' ctx fs)@ raises 'ExceptionFailure'
 859 -- with farthest parameters set to or updated with @(fs)@
 860 -- according to the relative position of 'input' wrt. 'farthestInput'.
 861 raiseFailure ::
 862   Cursorable (Cursor inp) =>
 863   GenCtx st inp cs a ->
 864   TH.CodeQ (Set SomeFailure) ->
 865   TH.CodeQ (ST st (Either (ParsingError inp) a))
 866 raiseFailure ctx fs = [||
 867   let failExp = $$fs in
 868   let (# farInp, farExp #) =
 869         case $$compareOffset $$(farthestInput ctx) $$(input ctx) of
 870           LT -> (# $$(input ctx), failExp #)
 871           EQ -> (# $$(farthestInput ctx), failExp <> $$(farthestExpecting ctx) #)
 872           GT -> (# $$(farthestInput ctx), $$(farthestExpecting ctx) #)
 873   in $$(raiseException ctx ExceptionFailure)
 874     ExceptionFailure
 875     {-failInp-}$$(input ctx) farInp farExp
 876   ||]
 877 -- | @('raiseException' ctx exn)@ raises exception @(exn)@
 878 -- using any entry in 'catchStackByLabel', or 'defaultCatch' if none.
 879 raiseException ::
 880   GenCtx st inp vs a -> Exception ->
 881   CodeQ (Exception -> Cursor inp -> Cursor inp -> Set SomeFailure -> ST st (Either (ParsingError inp) a))
 882 raiseException ctx exn =
 883   NE.head $ Map.findWithDefault
 884     (NE.singleton (defaultCatch ctx))
 885     exn (catchStackByLabel ctx)
 886
 887 finalGenAnalysis :: GenCtx st inp vs a -> Gen inp cs a -> GenAnalysis
 888 finalGenAnalysis ctx k = genAnalysis k $ finalGenAnalysisByLet ctx
 889
 890 checkToken ::
 891   Set SomeFailure ->
 892   {-predicate-}Splice (InputToken inp -> Bool) ->
 893   {-ok-}Gen inp (InputToken inp ': vs) a ->
 894   Gen inp vs a
 895 checkToken fs p ok = ok
 896   { unGen = \ctx -> {-trace "unGen.read" $-} [||
 897     let !(# c, cs #) = $$(nextInput ctx) $$(input ctx) in
 898     $$(genCode $
 899       Prod.ifThenElse
 900         (p Prod..@ splice [||c||])
 901         (splice $ unGen ok ctx
 902           { valueStack = ValueStackCons (splice [||c||]) (valueStack ctx)
 903           , input = [||cs||]
 904           })
 905         (splice [||
 906           let _ = "checkToken.else" in
 907           $$(unGen (fail fs) ctx)
 908         ||])
 909     )||]
 910   }