src/Symantic/Parser/Machine/Generate.hs

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