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 (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.ObserveSharing
  55 import Symantic.Parser.Grammar.Combinators
  56   ( UnscopedRegister(..)
  57   , Exception(..)
  58   , Failure(..)
  59   , SomeFailure(..)
  60   , inputTokenProxy
  61   )
  62 import Symantic.Parser.Machine.Input
  63 import Symantic.Parser.Machine.Instructions
  64 import qualified Language.Haskell.TH.HideName as TH
  65 import qualified Symantic.Lang as Prod
  66 import qualified Symantic.Optimize as Prod
  67
  68 --import Debug.Trace
  69
  70 -- | Convenient utility to generate some final 'TH.CodeQ'.
  71 genCode :: Splice a -> CodeQ a
  72 genCode = derive . Prod.normalOrderReduction
  73
  74 -- * Type 'Gen'
  75 -- | Generate the 'CodeQ' parsing the input.
  76 data Gen inp vs a = Gen
  77   { genAnalysisByLet :: OpenRecs TH.Name (CallTrace -> GenAnalysis)
  78     -- ^ 'genAnalysis' for each 'defLet' and 'defJoin' of the 'Machine'.
  79   , genAnalysis :: OpenRec TH.Name (CallTrace -> GenAnalysis)
  80     -- ^ Synthetized (bottom-up) static genAnalysis of the 'Machine'.
  81   , unGen :: forall st.
  82       GenCtx st inp vs a ->
  83       CodeQ (ST st (Either (ParsingError inp) a))
  84   }
  85
  86 {-# INLINE returnST #-}
  87 returnST :: forall s a. a -> ST s a
  88 returnST = return @(ST s)
  89
  90 -- | @('generateCode' input mach)@ generates @TemplateHaskell@ code
  91 -- parsing the given 'input' according to the given 'Machine'.
  92 generateCode ::
  93   {-
  94   Eq (InputToken inp) =>
  95   NFData (InputToken inp) =>
  96   Show (InputToken inp) =>
  97   Typeable (InputToken inp) =>
  98   TH.Lift (InputToken inp) =>
  99   -}
 100   -- InputToken inp ~ Char =>
 101   --forall inp a.
 102   Inputable inp =>
 103   Show (Cursor inp) =>
 104   Gen inp '[] a ->
 105   CodeQ (inp -> Either (ParsingError inp) a)
 106 generateCode Gen{unGen=k, ..} = [|| \(input :: inp) ->
 107     -- Pattern bindings containing unlifted types
 108     -- should use an outermost bang pattern.
 109     let !(# init, readMore, readNext #) = $$(cursorOf [||input||])
 110         finalRet = \_farInp _farExp v _inp -> returnST $ Right v
 111         finalRaise :: forall st b. (Catcher st inp b)
 112           = \ !exn _failInp !farInp !farExp ->
 113           returnST $ Left ParsingError
 114           { parsingErrorOffset = offset farInp
 115           , parsingErrorException = exn
 116           , parsingErrorUnexpected =
 117               if readMore farInp
 118               then Just (let (# c, _ #) = readNext farInp in c)
 119               else Nothing
 120           , parsingErrorExpecting = farExp
 121           }
 122     in runST $$(
 123       let
 124         -- | Defines 'inputTokenProxy' so that the TemplateHaskell code
 125         -- can refer to @(InputToken inp)@ through it.
 126         defInputTokenProxy :: TH.CodeQ a -> TH.CodeQ a
 127         defInputTokenProxy exprCode =
 128           TH.unsafeCodeCoerce [|
 129             let $(return (TH.VarP inputTokenProxy)) = Proxy :: Proxy (InputToken inp) in
 130             $(TH.unTypeQ (TH.examineCode exprCode))
 131           |]
 132       in
 133       defInputTokenProxy $
 134       k GenCtx
 135         { valueStack = ValueStackEmpty
 136         , catchStackByLabel = Map.empty :: Map Exception (NonEmpty (TH.CodeQ (Catcher s inp a)))
 137         , defaultCatch = [||finalRaise||]
 138         , analysisCallStack = []
 139         , returnCall = [||finalRet||] :: CodeQ (Return s inp a a)
 140         , input = [||init||]
 141         , nextInput = [||readNext||]
 142         , moreInput = [||readMore||]
 143         -- , farthestError = [||Nothing||]
 144         , farthestInput = [||init||]
 145         , farthestExpecting = [||Set.empty||]
 146         , checkedHorizon = 0
 147         , horizonStack = []
 148         , finalGenAnalysisByLet = runOpenRecs genAnalysisByLet
 149         }
 150       )
 151     ||]
 152
 153 -- ** Type 'ParsingError'
 154 data ParsingError inp
 155   =  ParsingError
 156   {  parsingErrorOffset :: Offset
 157   ,  parsingErrorException :: Exception
 158      -- | Note: if a 'FailureHorizon' greater than 1
 159      -- is amongst the 'parsingErrorExpecting'
 160      -- then 'parsingErrorUnexpected' is only the 'InputToken'
 161      -- at the begining of the expected 'Horizon'.
 162   ,  parsingErrorUnexpected :: Maybe (InputToken inp)
 163   ,  parsingErrorExpecting :: Set SomeFailure
 164   } deriving (Generic)
 165 deriving instance NFData (InputToken inp) => NFData (ParsingError inp)
 166 --deriving instance Show (InputToken inp) => Show (ParsingError inp)
 167 instance Show (InputToken inp) => Show (ParsingError inp) where
 168   showsPrec p ParsingError{..} =
 169     showParen (p >= 11) $
 170       showString "ParsingErrorStandard {" .
 171       showString "parsingErrorOffset = " .
 172       showsPrec 0 parsingErrorOffset .
 173       showCommaSpace .
 174       showString "parsingErrorException = " .
 175       showsPrec 0 parsingErrorException .
 176       showCommaSpace .
 177       showString "parsingErrorUnexpected = " .
 178       showsPrec 0 parsingErrorUnexpected .
 179       showCommaSpace .
 180       showString "parsingErrorExpecting = fromList " .
 181       showsPrec 0 (
 182         -- Sort on the string representation
 183         -- because the 'Ord' of the 'SomeFailure'
 184         -- is based upon hashes ('typeRepFingerprint')
 185         -- depending on packages' ABI and whether
 186         -- cabal-install's setup is --inplace or not,
 187         -- and that would be too unstable for golden tests.
 188         List.sortBy (compare `on` show) $
 189         Set.toList parsingErrorExpecting
 190       ) .
 191       showString "}"
 192
 193 -- ** Type 'ErrorLabel'
 194 type ErrorLabel = String
 195
 196 -- * Type 'GenAnalysis'
 197 data GenAnalysis = GenAnalysis
 198   { minReads :: Either Exception Horizon
 199   , mayRaise :: Map Exception ()
 200   } deriving (Show)
 201
 202 -- ** Type 'Offset'
 203 type Offset = Int
 204 -- ** Type 'Horizon'
 205 -- | Minimal input length required for a successful parsing.
 206 type Horizon = Offset
 207
 208 -- altGenAnalysis = List.foldl' (\acc x -> either Left (\h -> Right (either (const h) (min h) acc)) x)
 209 -- | Merge given 'GenAnalysis' as sequences.
 210 seqGenAnalysis :: NonEmpty GenAnalysis -> GenAnalysis
 211 seqGenAnalysis aas@(a:|as) = GenAnalysis
 212   { minReads = List.foldl' (\acc x ->
 213         acc >>= \r -> (r +) <$> minReads x
 214       ) (minReads a) as
 215   , mayRaise = sconcat (mayRaise <$> 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   }
 233
 234
 235 {-
 236 -- *** Type 'FarthestError'
 237 data FarthestError inp = FarthestError
 238   { farthestInput :: Cursor inp
 239   , farthestExpecting :: [Failure (InputToken inp)]
 240   }
 241 -}
 242
 243 -- ** Type 'GenCtx'
 244 -- | This is an inherited (top-down) context
 245 -- only present at compile-time, to build TemplateHaskell splices.
 246 data GenCtx st inp vs a =
 247   ( Cursorable (Cursor inp)
 248   {-
 249   , TH.Lift (InputToken inp)
 250   , Show (InputToken inp)
 251   , Eq (InputToken inp)
 252   , Typeable (InputToken inp)
 253   , NFData (InputToken inp)
 254   -}
 255   ) => GenCtx
 256   { valueStack :: ValueStack vs
 257   , catchStackByLabel :: Map Exception (NonEmpty (CodeQ (Catcher st inp a)))
 258     -- | Default 'Catcher' defined at the begining of the generated 'CodeQ',
 259     -- hence a constant within the 'Gen'eration.
 260   , defaultCatch :: forall b. CodeQ (Catcher st inp b)
 261     -- | Used by 'checkToken' to get 'GenAnalysis' from 'genAnalysis'.
 262   , analysisCallStack :: [TH.Name]
 263   , returnCall :: CodeQ (Return st inp a a)
 264   , input :: CodeQ (Cursor inp)
 265   , moreInput :: CodeQ (Cursor inp -> Bool)
 266   , nextInput :: CodeQ (Cursor inp -> (# InputToken inp, Cursor inp #))
 267   , farthestInput :: CodeQ (Cursor inp)
 268   , farthestExpecting :: CodeQ (Set SomeFailure)
 269     -- | Remaining horizon already checked.
 270     -- Use to factorize 'input' length checks,
 271     -- instead of checking the 'input' length
 272     -- one 'InputToken' at a time at each 'read'.
 273     -- Updated by 'checkHorizon'
 274     -- and reset elsewhere when needed.
 275   , checkedHorizon :: Horizon
 276   -- | Used by 'pushInput' and 'loadInput'
 277   -- to restore the 'Horizon' at the restored 'input'.
 278   , horizonStack :: [Horizon]
 279   -- | Output of 'runOpenRecs'.
 280   , finalGenAnalysisByLet :: LetRecs TH.Name GenAnalysis
 281   }
 282
 283 -- ** Type 'ValueStack'
 284 data ValueStack vs where
 285   ValueStackEmpty :: ValueStack '[]
 286   ValueStackCons ::
 287     { valueStackHead :: Splice v
 288     , valueStackTail :: ValueStack vs
 289     } -> ValueStack (v ': vs)
 290
 291 instance InstrValuable Gen where
 292   pushValue x k = k
 293     { unGen = \ctx -> {-trace "unGen.pushValue" $-} unGen k ctx
 294       { valueStack = ValueStackCons x (valueStack ctx) }
 295     }
 296   popValue k = k
 297     { unGen = \ctx -> {-trace "unGen.popValue" $-} unGen k ctx
 298       { valueStack = valueStackTail (valueStack ctx) }
 299     }
 300   lift2Value f k = k
 301     { unGen = \ctx -> {-trace "unGen.lift2Value" $-} unGen k ctx
 302       { valueStack =
 303         let ValueStackCons y (ValueStackCons x vs) = valueStack ctx in
 304         ValueStackCons (f Prod..@ x Prod..@ y) vs
 305       }
 306     }
 307   swapValue k = k
 308     { unGen = \ctx -> {-trace "unGen.swapValue" $-} unGen k ctx
 309       { valueStack =
 310           let ValueStackCons y (ValueStackCons x vs) = valueStack ctx in
 311           ValueStackCons x (ValueStackCons y vs)
 312       }
 313     }
 314 instance InstrBranchable Gen where
 315   caseBranch kx ky = Gen
 316     { genAnalysisByLet = genAnalysisByLet kx <> genAnalysisByLet ky
 317     , genAnalysis = \final ct -> altGenAnalysis $ genAnalysis kx final ct :| [genAnalysis ky final ct]
 318     , unGen = \ctx -> {-trace "unGen.caseBranch" $-}
 319       let ValueStackCons v vs = valueStack ctx in
 320       [||
 321         case $$(genCode v) of
 322           Left  x -> $$(unGen kx ctx{ valueStack = ValueStackCons (splice [||x||]) vs })
 323           Right y -> $$(unGen ky ctx{ valueStack = ValueStackCons (splice [||y||]) vs })
 324       ||]
 325     }
 326   choicesBranch bs default_ = Gen
 327     { genAnalysisByLet = sconcat $ genAnalysisByLet default_ :| (genAnalysisByLet . snd <$> bs)
 328     , genAnalysis = \final ct -> altGenAnalysis $
 329         (\k -> genAnalysis k final ct)
 330         <$> (default_:|(snd <$> bs))
 331     , unGen = \ctx0 -> {-trace "unGen.choicesBranch" $-}
 332       let ValueStackCons v vs = valueStack ctx0 in
 333       let ctx = ctx0{valueStack = vs} in
 334       let
 335         go x ((p,b):bs') = [||
 336           if $$(genCode (p Prod..@ x))
 337           then
 338             let _ = "choicesBranch.then" in
 339             $$({-trace "unGen.choicesBranch.b" $-} unGen b ctx)
 340           else
 341             let _ = "choicesBranch.else" in
 342             $$(go x bs')
 343           ||]
 344         go _ _ = unGen default_ ctx
 345       in go v bs
 346     }
 347 instance InstrExceptionable Gen where
 348   raise exn = Gen
 349     { genAnalysisByLet = HM.empty
 350     , genAnalysis = \_final _ct -> GenAnalysis
 351         { minReads = Left (ExceptionLabel exn)
 352         , mayRaise = Map.singleton (ExceptionLabel exn) ()
 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 _ct -> GenAnalysis
 365         { minReads = Left ExceptionFailure
 366         , mayRaise = Map.singleton ExceptionFailure ()
 367         }
 368     , unGen = \ctx@GenCtx{} -> {-trace ("unGen.fail: "<>show exn) $-}
 369       if null fs
 370       then [|| -- Raise without updating the farthest error.
 371           $$(raiseException ctx ExceptionFailure)
 372             ExceptionFailure
 373             {-failInp-}$$(input ctx)
 374             $$(farthestInput ctx)
 375             $$(farthestExpecting ctx)
 376         ||]
 377       else raiseFailure ctx [||fs||]
 378     }
 379   commit exn k = k
 380     { unGen = \ctx -> {-trace ("unGen.commit: "<>show exn) $-}
 381       unGen k ctx{catchStackByLabel =
 382         Map.update (\case
 383             _r0:|(r1:rs) -> Just (r1:|rs)
 384             _ -> Nothing
 385           )
 386         exn (catchStackByLabel ctx)
 387       }
 388     }
 389   catch exn ok ko = Gen
 390     { genAnalysisByLet = genAnalysisByLet ok <> genAnalysisByLet ko
 391     , genAnalysis = \final ct ->
 392         let okGA = genAnalysis ok final ct in
 393         altGenAnalysis $
 394           okGA{ mayRaise = Map.delete exn (mayRaise okGA) } :|
 395           [ genAnalysis ko final ct ]
 396     , unGen = \ctx@GenCtx{} -> {-trace ("unGen.catch: "<>show exn) $-} [||
 397         let _ = $$(liftTypedString ("catch "<>show exn)) in
 398         let catchHandler !_exn !failInp !farInp !farExp =
 399               let _ = $$(liftTypedString ("catch.ko "<>show exn)) in
 400               $$({-trace ("unGen.catch.ko: "<>show exn) $-} unGen ko ctx
 401                 -- Push 'input' and 'checkedHorizon'
 402                 -- as they were when entering 'catch',
 403                 -- they will be available to 'loadInput', if any.
 404                 { valueStack =
 405                     ValueStackCons (splice (input ctx)) $
 406                     --ValueStackCons (Prod.var [||exn||]) $
 407                     valueStack ctx
 408                 , horizonStack =
 409                     checkedHorizon ctx : horizonStack ctx
 410                 -- Note that 'catchStackByLabel' is reset.
 411                 -- Move the input to the failing position.
 412                 , input = [||failInp||]
 413                 -- The 'checkedHorizon' at the 'raise's are not known here.
 414                 -- Nor whether 'failInp' is after 'checkedHorizon' or not.
 415                 -- Hence fallback to a safe value.
 416                 , checkedHorizon = 0
 417                 -- Set the farthestInput to the farthest computed in 'fail'.
 418                 , farthestInput = [||farInp||]
 419                 , farthestExpecting = [||farExp||]
 420                 })
 421         in
 422         $$({-trace ("unGen.catch.ok: "<>show es) $-} unGen ok ctx
 423         { catchStackByLabel =
 424             Map.insertWith (<>) exn
 425               (NE.singleton [||catchHandler||])
 426               (catchStackByLabel ctx)
 427         }
 428       ) ||]
 429     }
 430 instance InstrInputable Gen where
 431   pushInput k = k
 432     { unGen = \ctx ->
 433         {-trace "unGen.pushInput" $-}
 434         unGen k ctx
 435           { valueStack = splice (input ctx) `ValueStackCons` valueStack ctx
 436           , horizonStack = checkedHorizon ctx : horizonStack ctx
 437           }
 438     }
 439   loadInput k = k
 440     { unGen = \ctx ->
 441         {-trace "unGen.loadInput" $-}
 442         let ValueStackCons input vs = valueStack ctx in
 443         let (h, hs) = case horizonStack ctx of
 444                         [] -> (0, [])
 445                         x:xs -> (x, xs) in
 446         unGen k ctx
 447           { valueStack = vs
 448           , horizonStack = hs
 449           , input = genCode input
 450           , checkedHorizon = h
 451           }
 452     , genAnalysis = \final ct -> GenAnalysis
 453         { minReads = 0 <$ minReads (genAnalysis k final ct)
 454         , mayRaise = mayRaise (genAnalysis k final ct)
 455         }
 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       body <- TH.unTypeQ $ TH.examineCode $ [|| -- buildRec in Parsley
 482         -- TODO: takeFreeRegisters
 483         -- Called by 'call' or 'jump'.
 484         \ !callReturn{-from generateSuspend or returnCall-}
 485           !callInput
 486           !callCatchStackByLabel{- 'catchStackByLabel' from the 'call'-site -} ->
 487           $$({-trace ("unGen.defLet.sub: "<>show subName) $-} unGen sub ctx
 488             { valueStack = ValueStackEmpty
 489             -- Build a 'catchStackByLabel' for the 'mayRaise' of the subroutine,
 490             -- where each 'Catcher' calls the one passed by the 'call'-site (in 'callCatchStackByLabel').
 491             -- Note that currently the 'call'-site can supply in 'callCatchStackByLabel'
 492             -- a subset of the 'mayRaise' needed by this subroutine,
 493             -- because 'Map.findWithDefault' is used instead of 'Map.!'.
 494             , catchStackByLabel = Map.mapWithKey
 495                 (\lbl () -> NE.singleton [||Map.findWithDefault $$(defaultCatch ctx) lbl callCatchStackByLabel||])
 496                 ({-trace ("mayRaise: "<>show subName) $-}
 497                   mayRaise (finalGenAnalysisByLet ctx HM.! subName))
 498             , input = [||callInput||]
 499             , returnCall = {-trace ("unGen.defLet.sub.returnCall: "<>show subName) $-} [||callReturn||]
 500
 501             -- These are passed by the caller via 'callReturn' 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 subName [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-}$$(returnCall 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{analysisCallStack = n : analysisCallStack ctx})
 553         $$(input ctx)
 554         $$(liftTypedRaiseByLabel $
 555           -- FIXME: maybe it should rather pass all the 'mayRaise' of 'n'
 556           -- and 'defaultCatch' be removed from 'makeDecl''s 'catchStackByLabel'.
 557           catchStackByLabel ctx
 558           -- Pass only the labels raised by the 'defLet'.
 559           `Map.intersection`
 560           (mayRaise $ finalGenAnalysisByLet ctx HM.! n)
 561         )
 562       ||]
 563     }
 564   ret = Gen
 565     { genAnalysisByLet = HM.empty
 566     , genAnalysis = \_final _ct -> GenAnalysis
 567         { minReads = Right 0
 568         , mayRaise = Map.empty
 569         }
 570     , unGen = \ctx -> {-trace "unGen.ret" $-}
 571       {-trace "unGen.ret.generateResume" $-}
 572       generateResume ({-trace "unGen.ret.returnCall" $-} returnCall ctx) ctx
 573     }
 574
 575 -- | Like 'TH.liftString' but on 'TH.Code'.
 576 -- Useful to get a 'TH.StringL' instead of a 'TH.ListE'.
 577 liftTypedString :: String -> TH.Code TH.Q a
 578 liftTypedString = TH.unsafeCodeCoerce . TH.liftString
 579
 580 -- | Like 'TH.liftTyped' but adjusted to work on 'catchStackByLabel'
 581 -- which already contains 'CodeQ' terms.
 582 -- Moreover, only the 'Catcher' at the top of the stack
 583 -- is needed and thus generated in the resulting 'CodeQ'.
 584 --
 585 -- TODO: Use an 'Array' instead of a 'Map'?
 586 liftTypedRaiseByLabel :: TH.Lift k => Map k (NonEmpty (CodeQ a)) -> CodeQ (Map k a)
 587 liftTypedRaiseByLabel Map_.Tip = [|| Map_.Tip ||]
 588 liftTypedRaiseByLabel (Map_.Bin s k (h:|_hs) l r) =
 589   [|| Map_.Bin s k $$h $$(liftTypedRaiseByLabel l) $$(liftTypedRaiseByLabel r) ||]
 590
 591 instance TH.Lift a => TH.Lift (Set a) where
 592   liftTyped Set_.Tip = [|| Set_.Tip ||]
 593   liftTyped (Set_.Bin s a l r) = [|| Set_.Bin $$(TH.liftTyped s) $$(TH.liftTyped a) $$(TH.liftTyped l) $$(TH.liftTyped r) ||]
 594
 595 -- ** Type 'Return'
 596 type Return st inp v a =
 597   {-farthestInput-}Cursor inp ->
 598   {-farthestExpecting-}(Set SomeFailure) ->
 599   v ->
 600   Cursor inp ->
 601   ST st (Either (ParsingError inp) a)
 602
 603 -- | Generate a 'returnCall' 'Return'inuation to be called with 'generateResume'.
 604 -- Used when 'call' 'ret'urns.
 605 -- The return 'v'alue is 'pushValue'-ed on the 'valueStack'.
 606 generateSuspend ::
 607   {-k-}Gen inp (v ': vs) a ->
 608   GenCtx st inp vs a ->
 609   CodeQ (Return st inp v a)
 610 generateSuspend k ctx = [||
 611   let _ = $$(liftTypedString $ "suspend") in
 612   \farInp farExp v !inp ->
 613     $$({-trace "unGen.generateSuspend" $-} unGen k ctx
 614       { valueStack = ValueStackCons ({-trace "unGen.generateSuspend.value" $-} splice [||v||]) (valueStack ctx)
 615       , input = [||inp||]
 616       , farthestInput = [||farInp||]
 617       , farthestExpecting = [||farExp||]
 618       , checkedHorizon = 0
 619       }
 620     )
 621   ||]
 622
 623 -- | Generate a call to the 'generateSuspend' continuation.
 624 -- Used when 'call' 'ret'urns.
 625 generateResume ::
 626   CodeQ (Return st inp v a) ->
 627   GenCtx st inp (v ': vs) a ->
 628   CodeQ (ST st (Either (ParsingError inp) a))
 629 generateResume k = \ctx -> {-trace "generateResume" $-} [||
 630   let _ = "resume" in
 631   $$k
 632     $$(farthestInput ctx)
 633     $$(farthestExpecting ctx)
 634     (let _ = "resume.genCode" in $$({-trace "generateResume.genCode" $-}
 635       genCode $ valueStackHead $ valueStack ctx))
 636     $$(input ctx)
 637   ||]
 638
 639 -- ** Type 'Catcher'
 640 type Catcher st inp a =
 641   Exception ->
 642   {-failInp-}Cursor inp ->
 643   {-farInp-}Cursor inp ->
 644   {-farExp-}(Set SomeFailure) ->
 645   ST st (Either (ParsingError inp) a)
 646
 647 instance InstrJoinable Gen where
 648   defJoin (LetName n) sub k = k
 649     { unGen = \ctx ->
 650         {-trace ("unGen.defJoin: "<>show n) $-}
 651         TH.unsafeCodeCoerce [|
 652           let $(return (TH.VarP n)) = $(TH.unTypeQ $ TH.examineCode [||
 653                 -- Called by 'generateResume'.
 654                 \farInp farExp v !inp ->
 655                   $$({-trace ("unGen.defJoin.next: "<>show n) $-} unGen sub ctx
 656                     { valueStack = ValueStackCons (splice [||v||]) (valueStack ctx)
 657                     , input = [||inp||]
 658                     , farthestInput = [||farInp||]
 659                     , farthestExpecting = [||farExp||]
 660                     , checkedHorizon = 0
 661                     {- FIXME:
 662                     , catchStackByLabel = Map.mapWithKey
 663                         (\lbl () -> NE.singleton [||koByLabel Map.! lbl||])
 664                         (mayRaise sub raiseLabelsByLetButSub)
 665                     -}
 666                     })
 667                 ||])
 668           in $(TH.unTypeQ $ TH.examineCode $
 669             {-trace ("unGen.defJoin.expr: "<>show n) $-}
 670             unGen k ctx)
 671         |]
 672     , genAnalysisByLet =
 673         (genAnalysisByLet sub <>) $
 674         HM.insert n (genAnalysis sub) $
 675         genAnalysisByLet k
 676     }
 677   refJoin (LetName n) = Gen
 678     { unGen = \ctx ->
 679         {-trace ("unGen.refJoin: "<>show n) $-}
 680         generateResume
 681           (TH.unsafeCodeCoerce (return (TH.VarE n))) ctx
 682     , genAnalysisByLet = HM.empty
 683     , genAnalysis = \final ct ->
 684         if n`List.elem`ct -- FIXME: useless
 685         then GenAnalysis
 686           { minReads = Right 0
 687           , mayRaise = Map.empty
 688           }
 689         else HM.findWithDefault
 690           (error (show (n,ct,HM.keys final)))
 691           n final (n:ct)
 692     }
 693 instance InstrReadable Char Gen where
 694   read fs p = checkHorizon . checkToken fs p
 695 instance InstrReadable Word8 Gen where
 696   read fs p = checkHorizon . checkToken fs p
 697 instance InstrIterable Gen where
 698   iter (LetName jumpName) loop done = Gen
 699     { genAnalysisByLet =
 700       HM.insert jumpName (genAnalysis loop) $
 701       genAnalysisByLet loop <>
 702       genAnalysisByLet done
 703     , genAnalysis = \final ct ->
 704       GenAnalysis
 705         { minReads = minReads (genAnalysis done final ct)
 706         , mayRaise =
 707             Map.delete ExceptionFailure
 708               (mayRaise (genAnalysis loop final ct)) <>
 709             mayRaise (genAnalysis done final ct)
 710         }
 711     , unGen = \ctx -> TH.unsafeCodeCoerce [|
 712         let _ = "iter" in
 713         let
 714             {-
 715             Exception ->
 716             {-failInp-}Cursor inp ->
 717             {-farInp-}Cursor inp ->
 718             {-farExp-}(Set SomeFailure) ->
 719             ST st (Either (ParsingError inp) a)
 720             -}
 721           catchHandler loopInput !_exn !failInp !farInp !farExp =
 722             $(TH.unTypeCode $ {-trace ("unGen.catch.ko: "<>show exn) $-} unGen done ctx
 723                 -- Push 'input' and 'checkedHorizon'
 724                 -- as they were when entering 'catch',
 725                 -- they will be available to 'loadInput', if any.
 726                 { valueStack = ValueStackCons (splice (TH.unsafeCodeCoerce [|loopInput|])) (valueStack ctx)
 727                 , horizonStack = checkedHorizon ctx : horizonStack ctx
 728                 -- Note that 'catchStackByLabel' is reset.
 729                 -- Move the input to the failing position.
 730                 , input = TH.unsafeCodeCoerce [|failInp|]
 731                 -- The 'checkedHorizon' at the 'raise's are not known here.
 732                 -- Nor whether 'failInp' is after 'checkedHorizon' or not.
 733                 -- Hence fallback to a safe value.
 734                 , checkedHorizon = 0
 735                 -- Set the farthestInput to the farthest computed in 'fail'.
 736                 , farthestInput = TH.unsafeCodeCoerce [|farInp|]
 737                 , farthestExpecting = TH.unsafeCodeCoerce [|farExp|]
 738                 })
 739           $(return $ TH.VarP jumpName) = \_callReturn callInput callCatchStackByLabel ->
 740             $(TH.unTypeCode $ unGen loop ctx
 741               { valueStack = ValueStackEmpty
 742               , catchStackByLabel =
 743                 {-
 744                 Map.mapWithKey
 745                   (\lbl () -> NE.singleton $ TH.unsafeCodeCoerce [|
 746                     Map.findWithDefault $(TH.unTypeCode $ defaultCatch ctx) lbl koByLabel
 747                   |])
 748                   (mayRaise (finalGenAnalysisByLet ctx HM.! jumpName))
 749                 -}
 750                 Map.insertWith (<>) ExceptionFailure
 751                   (NE.singleton $ TH.unsafeCodeCoerce [|catchHandler callInput|])
 752                   (catchStackByLabel ctx)
 753               , input = TH.unsafeCodeCoerce [|callInput|]
 754               -- FIXME: promote to compile time error?
 755               , returnCall = TH.unsafeCodeCoerce [|error "invalid return"|]
 756               , checkedHorizon = 0
 757               })
 758         in $(TH.unTypeCode $ unGen (jump (LetName jumpName)) ctx{valueStack=ValueStackEmpty})
 759        |]
 760     }
 761 instance InstrRegisterable Gen where
 762   newRegister (UnscopedRegister r) k = k
 763     { unGen = \ctx ->
 764       let ValueStackCons v vs = valueStack ctx in
 765       TH.unsafeCodeCoerce [|
 766       do
 767         let dupv = $(TH.unTypeCode $ genCode v)
 768         $(return (TH.VarP r)) <- ST.newSTRef dupv
 769         $(TH.unTypeCode $ unGen k ctx{valueStack=vs})
 770       |]
 771     }
 772   readRegister (UnscopedRegister r) k = k
 773     { unGen = \ctx -> [|| do
 774         sr <- ST.readSTRef $$(TH.unsafeCodeCoerce (return (TH.VarE r)))
 775         $$(unGen k ctx{valueStack=ValueStackCons (splice [||sr||]) (valueStack ctx)})
 776       ||]
 777     }
 778   writeRegister (UnscopedRegister r) k = k
 779     { unGen = \ctx ->
 780       let ValueStackCons v vs = valueStack ctx in
 781       [|| do
 782         let dupv = $$(genCode v)
 783         ST.writeSTRef $$(TH.unsafeCodeCoerce (return (TH.VarE r))) dupv
 784         $$(unGen k ctx{valueStack=vs})
 785       ||]
 786     }
 787
 788 checkHorizon ::
 789   forall inp vs a.
 790   -- Those constraints are not used anyway
 791   -- because (TH.Lift SomeFailure) uses 'inputTokenProxy'.
 792   Ord (InputToken inp) =>
 793   Show (InputToken inp) =>
 794   TH.Lift (InputToken inp) =>
 795   NFData (InputToken inp) =>
 796   Typeable (InputToken inp) =>
 797   {-ok-}Gen inp vs a ->
 798   Gen inp vs a
 799 checkHorizon ok = ok
 800   { genAnalysis = \final ct -> seqGenAnalysis $
 801       GenAnalysis { minReads = Right 1
 802                   , mayRaise = Map.singleton ExceptionFailure ()
 803                   } :|
 804       [ genAnalysis ok final ct ]
 805   , unGen = \ctx0@GenCtx{} ->
 806     {-trace "unGen.checkHorizon" $-}
 807     let raiseFail = raiseException ctx0 ExceptionFailure in
 808     [||
 809       -- Factorize generated code for raising the "fail".
 810       let readFail = $$(raiseFail) in
 811       $$(
 812         let ctx = ctx0{catchStackByLabel =
 813                     Map.adjust (\(_r:|rs) -> [||readFail||] :| rs)
 814                       ExceptionFailure (catchStackByLabel ctx0)} in
 815         if checkedHorizon ctx >= 1
 816         then unGen ok ctx0{checkedHorizon = checkedHorizon ctx - 1}
 817         else let minHoriz =
 818                     either (\_err -> 0) id $
 819                     minReads $ finalGenAnalysis ctx ok in
 820           [||
 821           if $$(moreInput ctx)
 822                $$(if minHoriz > 0
 823                  then [||$$shiftRight minHoriz $$(input ctx)||]
 824                  else input ctx)
 825           then $$(unGen ok ctx{checkedHorizon = minHoriz})
 826           else let _ = "checkHorizon.else" in
 827             -- TODO: return a resuming continuation (eg. Partial)
 828             $$(unGen (fail (Set.singleton $ SomeFailure $ FailureHorizon @(InputToken inp) (minHoriz + 1))) ctx)
 829           ||]
 830       )
 831     ||]
 832   }
 833
 834 -- | @('raiseFailure' ctx fs)@ raises 'ExceptionFailure'
 835 -- with farthest parameters set to or updated with @(fs)@
 836 -- according to the relative position of 'input' wrt. 'farthestInput'.
 837 raiseFailure ::
 838   Cursorable (Cursor inp) =>
 839   GenCtx st inp cs a ->
 840   TH.CodeQ (Set SomeFailure) ->
 841   TH.CodeQ (ST st (Either (ParsingError inp) a))
 842 raiseFailure ctx fs = [||
 843   let failExp = $$fs in
 844   let (# farInp, farExp #) =
 845         case $$compareOffset $$(farthestInput ctx) $$(input ctx) of
 846           LT -> (# $$(input ctx), failExp #)
 847           EQ -> (# $$(farthestInput ctx), failExp <> $$(farthestExpecting ctx) #)
 848           GT -> (# $$(farthestInput ctx), $$(farthestExpecting ctx) #)
 849   in $$(raiseException ctx ExceptionFailure)
 850     ExceptionFailure
 851     {-failInp-}$$(input ctx) farInp farExp
 852   ||]
 853 -- | @('raiseException' ctx exn)@ raises exception @(exn)@
 854 -- using any entry in 'catchStackByLabel', or 'defaultCatch' if none.
 855 raiseException ::
 856   GenCtx st inp vs a -> Exception ->
 857   CodeQ (Exception -> Cursor inp -> Cursor inp -> Set SomeFailure -> ST st (Either (ParsingError inp) a))
 858 raiseException ctx exn =
 859   NE.head $ Map.findWithDefault
 860     (NE.singleton (defaultCatch ctx))
 861     exn (catchStackByLabel ctx)
 862
 863 finalGenAnalysis :: GenCtx st inp vs a -> Gen inp cs a -> GenAnalysis
 864 finalGenAnalysis ctx k =
 865   --(\f -> f (error "callTrace")) $
 866   (\f -> f (analysisCallStack ctx)) $
 867   genAnalysis k $
 868   ((\f _ct -> f) <$>) $
 869   finalGenAnalysisByLet ctx
 870
 871 checkToken ::
 872   Set SomeFailure ->
 873   {-predicate-}Splice (InputToken inp -> Bool) ->
 874   {-ok-}Gen inp (InputToken inp ': vs) a ->
 875   Gen inp vs a
 876 checkToken fs p ok = ok
 877   { unGen = \ctx -> {-trace "unGen.read" $-} [||
 878     let !(# c, cs #) = $$(nextInput ctx) $$(input ctx) in
 879     $$(genCode $
 880       Prod.ifThenElse
 881         (p Prod..@ splice [||c||])
 882         (splice $ unGen ok ctx
 883           { valueStack = ValueStackCons (splice [||c||]) (valueStack ctx)
 884           , input = [||cs||]
 885           })
 886         (splice [||
 887           let _ = "checkToken.else" in
 888           $$(unGen (fail fs) ctx)
 889         ||])
 890     )||]
 891   }