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