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