src/Symantic/Parser/Machine/Generate.hs

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