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