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 ga = altGenAnalysis $ genAnalysis ok final ct :| [ genAnalysis ko final ct ] in
 359         ga { mayRaise = Map.delete exn (mayRaise ga) }
 360     , unGen = \ctx@GenCtx{} -> {-trace ("unGen.catch: "<>show exn) $-} [||
 361         let _ = $$(liftTypedString ("catch "<>show exn)) in
 362         let catchHandler !_exn !failInp !farInp !farExp =
 363               let _ = $$(liftTypedString ("catch.ko "<>show exn)) in
 364               $$({-trace ("unGen.catch.ko: "<>show exn) $-} unGen ko ctx
 365                 -- Push 'input' and 'checkedHorizon'
 366                 -- as they were when entering 'catch'.
 367                 { valueStack =
 368                     ValueStackCons (H.Term (input ctx)) $
 369                     --ValueStackCons (H.Term [||exn||]) $
 370                     valueStack ctx
 371                 , horizonStack =
 372                     checkedHorizon ctx : horizonStack ctx
 373                 -- Note that 'catchStackByLabel' is reset.
 374                 -- Move the input to the failing position.
 375                 , input = [||failInp||]
 376                 -- The 'checkedHorizon' at the 'raise's
 377                 -- are not known here.
 378                 -- Nor whether 'failInp' is after
 379                 -- 'checkedHorizon' 'ctx' or not.
 380                 , checkedHorizon = 0
 381                 -- Set the farthestInput to the farthest computed by 'fail'.
 382                 , farthestInput = [||farInp||]
 383                 , farthestExpecting = [||farExp||]
 384                 })
 385         in
 386         $$({-trace ("unGen.catch.ok: "<>show es) $-} unGen ok ctx
 387         { catchStackByLabel =
 388             Map.insertWith (<>) exn
 389               (NE.singleton [||catchHandler||])
 390               (catchStackByLabel ctx)
 391         }
 392       ) ||]
 393     }
 394
 395 -- ** Type 'Catcher'
 396 type Catcher inp a =
 397   Exception ->
 398   {-failInp-}Cursor inp ->
 399   {-farInp-}Cursor inp ->
 400   {-farExp-}(Set SomeFailure) ->
 401   Either (ParsingError inp) a
 402 instance InstrInputable Gen where
 403   pushInput k = k
 404     { unGen = \ctx ->
 405         {-trace "unGen.pushInput" $-}
 406         unGen k ctx
 407           { valueStack = H.Term (input ctx) `ValueStackCons` valueStack ctx
 408           , horizonStack = checkedHorizon ctx : horizonStack ctx
 409           }
 410     }
 411   loadInput k = k
 412     { unGen = \ctx ->
 413         {-trace "unGen.loadInput" $-}
 414         let ValueStackCons input vs = valueStack ctx in
 415         let (h, hs) = case horizonStack ctx of
 416                         [] -> (0, [])
 417                         x:xs -> (x, xs) in
 418         unGen k ctx
 419           { valueStack = vs
 420           , horizonStack = hs
 421           , input = genCode input
 422           , checkedHorizon = h
 423           }
 424     , genAnalysis = \final ct -> GenAnalysis
 425         { minReads = 0 <$ minReads (genAnalysis k final ct)
 426         , mayRaise = mayRaise (genAnalysis k final ct)
 427         }
 428     }
 429 instance InstrCallable Gen where
 430   defLet defs k = k
 431     { unGen = \ctx@GenCtx{} ->
 432         {-trace ("unGen.defLet: defs="<>show (HM.keys defs)) $-}
 433         TH.unsafeCodeCoerce $ do
 434           decls <- traverse (makeDecl ctx) (HM.toList defs)
 435           body <- TH.unTypeQ $ TH.examineCode $
 436             {-trace "unGen.defLet.body" $-}
 437             unGen k ctx
 438           return $ TH.LetE (
 439             -- | Try to output more deterministic code to be able to golden test it,
 440             -- at the cost of more computations (at compile-time only though).
 441             List.sortBy (compare `on` TH.hideName) $
 442             toList decls
 443             ) body
 444     , genAnalysisByLet =
 445         foldMap' (\(SomeLet sub) -> genAnalysisByLet sub) defs <>
 446         ((\(SomeLet sub) -> genAnalysis sub) <$> defs) <>
 447         genAnalysisByLet k
 448     }
 449     where
 450     makeDecl ctx (n, SomeLet sub) = do
 451       body <- TH.unTypeQ $ TH.examineCode $ [|| -- buildRec in Parsley
 452         -- Called by 'call' or 'jump'.
 453         \ !ok{-from generateSuspend or retCode-}
 454           !inp
 455           !koByLabel{- 'catchStackByLabel' from the 'call'-site -} ->
 456           $$({-trace ("unGen.defLet.sub: "<>show n) $-} unGen sub ctx
 457             { valueStack = ValueStackEmpty
 458             -- Build a 'catchStackByLabel' from the one available at the 'call'-site.
 459             -- Note that all the 'mayRaise' of the 'sub'routine may not be available,
 460             -- hence 'Map.findWithDefault' is used instead of 'Map.!'.
 461             , catchStackByLabel = Map.mapWithKey
 462                 (\lbl () -> NE.singleton [||Map.findWithDefault $$(defaultCatch ctx) lbl koByLabel||])
 463                 ({-trace ("mayRaise: "<>show n) $-}
 464                   mayRaise (finalGenAnalysisByLet ctx HM.! n))
 465             , input = [||inp||]
 466             , retCode = {-trace ("unGen.defLet.sub.retCode: "<>show n) $-} [||ok||]
 467
 468             -- These are passed by the caller via 'ok' or 'ko'
 469             -- , farthestInput =
 470             -- , farthestExpecting =
 471
 472             -- Some callers can call this 'defLet'
 473             -- with zero 'checkedHorizon', hence use this minimum.
 474             -- TODO: maybe it could be improved a bit
 475             -- by taking the minimum of the checked horizons
 476             -- before all the 'call's and 'jump's to this 'defLet'.
 477             , checkedHorizon = 0
 478             })
 479         ||]
 480       let decl = TH.FunD n [TH.Clause [] (TH.NormalB body) []]
 481       return decl
 482   jump (LetName n) = Gen
 483     { genAnalysisByLet = HM.empty
 484     , genAnalysis = \final ct ->
 485         if n`List.elem`ct
 486         then GenAnalysis
 487           { minReads = Right 0
 488           , mayRaise = Map.empty
 489           }
 490         else (final HM.! n) (n:ct)
 491     , unGen = \ctx -> {-trace ("unGen.jump: "<>show n) $-} [||
 492       let _ = "jump" in
 493       $$(TH.unsafeCodeCoerce (return (TH.VarE n)))
 494         {-ok-}$$(retCode ctx)
 495         $$(input ctx)
 496         $$(liftTypedRaiseByLabel $
 497           catchStackByLabel ctx
 498           -- Pass only the labels raised by the 'defLet'.
 499           `Map.intersection`
 500           (mayRaise $ finalGenAnalysisByLet ctx HM.! n)
 501         )
 502       ||]
 503     }
 504   call (LetName n) k = k
 505     { genAnalysis = \final ct ->
 506         if n`List.elem`ct
 507         then GenAnalysis
 508           { minReads = Right 0
 509           , mayRaise = Map.empty
 510           }
 511         else seqGenAnalysis $
 512           (final HM.! n) (n:ct) :|
 513           [ genAnalysis k final ct ]
 514     , unGen = {-trace ("unGen.call: "<>show n) $-} \ctx ->
 515       -- let ks = (Map.keys (catchStackByLabel ctx)) in
 516       [||
 517       -- let _ = $$(liftTypedString $ "call exceptByLet("<>show n<>")="<>show (Map.keys (Map.findWithDefault Map.empty n (exceptByLet ctx))) <> " catchStackByLabel(ctx)="<> show ks) in
 518       $$(TH.unsafeCodeCoerce (return (TH.VarE n)))
 519         {-ok-}$$(generateSuspend k ctx{callStack = n : callStack ctx})
 520         $$(input ctx)
 521         $$(liftTypedRaiseByLabel $
 522           catchStackByLabel ctx
 523           -- Pass only the labels raised by the 'defLet'.
 524           `Map.intersection`
 525           (mayRaise $ finalGenAnalysisByLet ctx HM.! n)
 526         )
 527       ||]
 528     }
 529   ret = Gen
 530     { genAnalysisByLet = HM.empty
 531     , genAnalysis = \_final _ct -> GenAnalysis
 532         { minReads = Right 0
 533         , mayRaise = Map.empty
 534         }
 535     , unGen = \ctx -> {-trace "unGen.ret" $-} unGen ({-trace "unGen.ret.generateResume" $-} generateResume ({-trace "unGen.ret.retCode" $-} retCode ctx)) ctx
 536     }
 537
 538 -- | Like 'TH.liftString' but on 'TH.Code'.
 539 -- Useful to get a 'TH.StringL' instead of a 'TH.ListE'.
 540 liftTypedString :: String -> TH.Code TH.Q a
 541 liftTypedString = TH.unsafeCodeCoerce . TH.liftString
 542
 543 -- | Like 'TH.liftTyped' but adjusted to work on 'catchStackByLabel'
 544 -- which already contains 'CodeQ' terms.
 545 -- Moreover, only the 'Catcher' at the top of the stack
 546 -- is needed and thus generated in the resulting 'CodeQ'.
 547 --
 548 -- TODO: Use an 'Array' instead of a 'Map'?
 549 liftTypedRaiseByLabel :: TH.Lift k => Map k (NonEmpty (CodeQ a)) -> CodeQ (Map k a)
 550 liftTypedRaiseByLabel Map_.Tip = [|| Map_.Tip ||]
 551 liftTypedRaiseByLabel (Map_.Bin s k (h:|_hs) l r) =
 552   [|| Map_.Bin s k $$h $$(liftTypedRaiseByLabel l) $$(liftTypedRaiseByLabel r) ||]
 553
 554 instance TH.Lift a => TH.Lift (Set a) where
 555   liftTyped Set_.Tip = [|| Set_.Tip ||]
 556   liftTyped (Set_.Bin s a l r) = [|| Set_.Bin $$(TH.liftTyped s) $$(TH.liftTyped a) $$(TH.liftTyped l) $$(TH.liftTyped r) ||]
 557
 558 -- ** Type 'Cont'
 559 type Cont inp v a =
 560   {-farthestInput-}Cursor inp ->
 561   {-farthestExpecting-}(Set SomeFailure) ->
 562   v ->
 563   Cursor inp ->
 564   Either (ParsingError inp) a
 565
 566 -- | Generate a 'retCode' 'Cont'inuation to be called with 'generateResume'.
 567 -- Used when 'call' 'ret'urns.
 568 -- The return 'v'alue is 'pushValue'-ed on the 'valueStack'.
 569 generateSuspend ::
 570   {-k-}Gen inp (v ': vs) a ->
 571   GenCtx inp vs a ->
 572   CodeQ (Cont inp v a)
 573 generateSuspend k ctx = [||
 574   let _ = $$(liftTypedString $ "suspend") in
 575   \farInp farExp v !inp ->
 576     $$({-trace "unGen.generateSuspend" $-} unGen k ctx
 577       { valueStack = ValueStackCons ({-trace "unGen.generateSuspend.value" $-} H.Term [||v||]) (valueStack ctx)
 578       , input = [||inp||]
 579       , farthestInput = [||farInp||]
 580       , farthestExpecting = [||farExp||]
 581       , checkedHorizon = 0
 582       }
 583     )
 584   ||]
 585
 586 -- | Generate a call to the 'generateSuspend' continuation.
 587 -- Used when 'call' 'ret'urns.
 588 generateResume ::
 589   CodeQ (Cont inp v a) ->
 590   Gen inp (v ': vs) a
 591 generateResume k = Gen
 592   { genAnalysisByLet = HM.empty
 593   , genAnalysis = \_final _ct -> GenAnalysis
 594       { minReads = Right 0
 595       , mayRaise = Map.empty
 596       }
 597   , unGen = \ctx -> {-trace "unGen.generateResume" $-} [||
 598     let _ = "resume" in
 599     $$k
 600       $$(farthestInput ctx)
 601       $$(farthestExpecting ctx)
 602       (let _ = "resume.genCode" in $$({-trace "unGen.generateResume.genCode" $-} genCode $ H.optimizeTerm $
 603         valueStackHead $ valueStack ctx))
 604       $$(input ctx)
 605     ||]
 606   }
 607
 608 instance InstrJoinable Gen where
 609   defJoin (LetName n) sub k = k
 610     { unGen =
 611         \ctx ->
 612         {-trace ("unGen.defJoin: "<>show n) $-}
 613         TH.unsafeCodeCoerce $ do
 614           next <- TH.unTypeQ $ TH.examineCode $ [||
 615             -- Called by 'generateResume'.
 616             \farInp farExp v !inp ->
 617               $$({-trace ("unGen.defJoin.next: "<>show n) $-} unGen sub ctx
 618                 { valueStack = ValueStackCons (H.Term [||v||]) (valueStack ctx)
 619                 , input = [||inp||]
 620                 , farthestInput = [||farInp||]
 621                 , farthestExpecting = [||farExp||]
 622                 , checkedHorizon = 0
 623                 {- FIXME:
 624                 , catchStackByLabel = Map.mapWithKey
 625                     (\lbl () -> NE.singleton [||koByLabel Map.! lbl||])
 626                     (mayRaise sub raiseLabelsByLetButSub)
 627                 -}
 628                 })
 629             ||]
 630           let decl = TH.FunD n [TH.Clause [] (TH.NormalB next) []]
 631           expr <- TH.unTypeQ (TH.examineCode ({-trace ("unGen.defJoin.expr: "<>show n) $-} unGen k ctx))
 632           return (TH.LetE [decl] expr)
 633     , genAnalysisByLet =
 634         (genAnalysisByLet sub <>) $
 635         HM.insert n (genAnalysis sub) $
 636         genAnalysisByLet k
 637     }
 638   refJoin (LetName n) = Gen
 639     { unGen = \ctx ->
 640         {-trace ("unGen.refJoin: "<>show n) $-}
 641         unGen (generateResume
 642           (TH.unsafeCodeCoerce (return (TH.VarE n)))) ctx
 643     , genAnalysisByLet = HM.empty
 644     , genAnalysis = \final ct ->
 645         if n`List.elem`ct -- FIXME: useless
 646         then GenAnalysis
 647           { minReads = Right 0
 648           , mayRaise = Map.empty
 649           }
 650         else HM.findWithDefault
 651           (error (show (n,ct,HM.keys final)))
 652           n final (n:ct)
 653     }
 654 instance InstrReadable Char Gen where
 655   read fs p = checkHorizon . checkToken fs p
 656
 657 checkHorizon ::
 658   forall inp vs a.
 659   Eq (InputToken inp) =>
 660   Ord (InputToken inp) =>
 661   Typeable (InputToken inp) =>
 662   TH.Lift (InputToken inp) =>
 663   {-ok-}Gen inp vs a ->
 664   Gen inp vs a
 665 checkHorizon ok = ok
 666   { genAnalysis = \final ct -> seqGenAnalysis $
 667       GenAnalysis { minReads = Right 1
 668                   , mayRaise = Map.singleton ExceptionFailure ()
 669                   } :|
 670       [ genAnalysis ok final ct ]
 671   , unGen = \ctx0@GenCtx{} ->
 672     {-trace "unGen.checkHorizon" $-}
 673     let raiseFail =
 674           NE.head (Map.findWithDefault
 675             (NE.singleton (defaultCatch ctx0))
 676             ExceptionFailure (catchStackByLabel ctx0)) in
 677     [||
 678       -- Factorize generated code for raising the "fail".
 679       let readFail = $$(raiseFail) in
 680       $$(
 681         let ctx = ctx0{catchStackByLabel =
 682                     Map.adjust (\(_r:|rs) -> [||readFail||] :| rs)
 683                       ExceptionFailure (catchStackByLabel ctx0)} in
 684         if checkedHorizon ctx >= 1
 685         then unGen ok ctx0{checkedHorizon = checkedHorizon ctx - 1}
 686         else let minHoriz =
 687                     either (\err -> 0) id $
 688                     minReads $ finalGenAnalysis ctx ok in
 689           [||
 690           if $$(moreInput ctx)
 691                $$(if minHoriz > 0
 692                  then [||$$shiftRight minHoriz $$(input ctx)||]
 693                  else input ctx)
 694           then $$(unGen ok ctx{checkedHorizon = minHoriz})
 695           else let _ = "checkHorizon.else" in
 696             -- TODO: return a resuming continuation (eg. Partial)
 697             $$(unGen (fail (Set.singleton $ SomeFailure $ FailureHorizon @(InputToken inp) (minHoriz + 1))) ctx)
 698           ||]
 699       )
 700     ||]
 701   }
 702
 703 raiseCode ::
 704   Cursorable (Cursor inp) =>
 705   GenCtx inp cs a ->
 706   TH.CodeQ (Set SomeFailure) ->
 707   TH.CodeQ (Either (ParsingError inp) a)
 708 raiseCode ctx fs = [||
 709   let failExp = $$fs
 710       (# farInp, farExp #) =
 711         case $$compareOffset $$(farthestInput ctx) $$(input ctx) of
 712           LT -> (# $$(input ctx), failExp #)
 713           EQ -> (# $$(farthestInput ctx), failExp <> $$(farthestExpecting ctx) #)
 714           GT -> (# $$(farthestInput ctx), $$(farthestExpecting ctx) #)
 715   in $$(NE.head $ Map.findWithDefault
 716       (NE.singleton (defaultCatch ctx))
 717       ExceptionFailure (catchStackByLabel ctx))
 718     ExceptionFailure
 719     {-failInp-}$$(input ctx) farInp farExp
 720   ||]
 721
 722 finalGenAnalysis :: GenCtx inp vs a -> Gen inp cs a -> GenAnalysis
 723 finalGenAnalysis ctx k =
 724   --(\f -> f (error "callTrace")) $
 725   (\f -> f (callStack ctx)) $
 726   genAnalysis k $
 727   ((\f _ct -> f) <$>) $
 728   finalGenAnalysisByLet ctx
 729
 730 checkToken ::
 731   Ord (InputToken inp) =>
 732   TH.Lift (InputToken inp) =>
 733   Set SomeFailure ->
 734   {-predicate-}TermInstr (InputToken inp -> Bool) ->
 735   {-ok-}Gen inp (InputToken inp ': vs) a ->
 736   Gen inp vs a
 737 checkToken fs p ok = ok
 738   { unGen = \ctx -> {-trace "unGen.read" $-} [||
 739     let !(# c, cs #) = $$(nextInput ctx) $$(input ctx) in
 740     if $$(genCode p) c
 741     then $$(unGen ok ctx
 742       { valueStack = ValueStackCons (H.Term [||c||]) (valueStack ctx)
 743       , input = [||cs||]
 744       })
 745     else let _ = "checkToken.else" in
 746       $$(unGen (fail fs) ctx)
 747     ||]
 748   }