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