src/Symantic/Parser/Machine/Generate.hs

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