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