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