src/Symantic/Parser/Machine/Generate.hs

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