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 MagicHash #-}
   9 {-# LANGUAGE UnboxedTuples #-} -- For nextInput
  10 {-# LANGUAGE UndecidableInstances #-} -- For Show (ParsingError inp)
  11 {-# OPTIONS_GHC -fno-warn-orphans #-}
  12 module Symantic.Parser.Machine.Generate where
  13
  14 import Control.DeepSeq (NFData(..))
  15 import Control.Monad (Monad(..))
  16 import Control.Monad.ST (ST, runST)
  17 import Data.Bool (Bool(..), otherwise)
  18 import Data.Char (Char)
  19 import Data.Either (Either(..))
  20 import Data.Eq (Eq(..))
  21 import Data.Foldable (foldr, toList, null)
  22 import Data.Function (($), (.), on)
  23 import Data.Functor ((<$>))
  24 import Data.Int (Int)
  25 import Data.List.NonEmpty (NonEmpty(..))
  26 import Data.Map (Map)
  27 import Data.Maybe (Maybe(..))
  28 import Data.Ord (Ord(..), Ordering(..))
  29 import Data.Proxy (Proxy(..))
  30 import Data.Semigroup (Semigroup(..))
  31 import Data.Set (Set)
  32 import Data.String (String)
  33 import Data.Traversable (Traversable(..))
  34 import Data.Tuple (snd)
  35 import Data.Typeable (Typeable)
  36 import Data.Word (Word8)
  37 import GHC.Generics (Generic)
  38 import GHC.Show (showCommaSpace)
  39 import Language.Haskell.TH (CodeQ)
  40 import Prelude ((+), (-), error)
  41 import Text.Show (Show(..), showParen, showString)
  42 import qualified Data.HashMap.Strict as HM
  43 import qualified Data.List as List
  44 import qualified Data.List.NonEmpty as NE
  45 import qualified Data.Map.Internal as Map_
  46 import qualified Data.Map.Strict as Map
  47 import qualified Data.Set as Set
  48 import qualified Data.Set.Internal as Set_
  49 import qualified Data.STRef as ST
  50 import qualified Language.Haskell.TH as TH
  51 import qualified Language.Haskell.TH.Syntax as TH
  52
  53 import qualified Symantic.Data as Sym
  54 import Symantic.Derive
  55 import Symantic.ObserveSharing
  56 import qualified Symantic.Parser.Grammar as Gram
  57 import Symantic.Parser.Grammar.Combinators
  58   ( UnscopedRegister(..)
  59   , Exception(..)
  60   , Failure(..)
  61   , SomeFailure(..)
  62   , unSomeFailure
  63   , inputTokenProxy
  64   )
  65 import Symantic.Parser.Machine.Input
  66 import Symantic.Parser.Machine.Instructions
  67 import qualified Language.Haskell.TH.HideName as TH
  68 import qualified Symantic.Class as Prod
  69 import qualified Symantic.Optimize as Prod
  70
  71 --import Debug.Trace
  72
  73 -- | Convenient utility to generate some final 'TH.CodeQ'.
  74 genCode :: Splice a -> CodeQ a
  75 genCode = derive . Prod.normalOrderReduction
  76
  77 -- * Type 'Gen'
  78 -- | Generate the 'CodeQ' parsing the input.
  79 data Gen inp vs a = Gen
  80   { genAnalysisByLet :: OpenRecs TH.Name GenAnalysis
  81     -- ^ 'genAnalysis' for each 'defLet' and 'defJoin' of the 'Machine'.
  82   , genAnalysis :: OpenRec TH.Name GenAnalysis
  83     -- ^ Synthetized (bottom-up) static genAnalysis of the 'Machine'.
  84   , unGen :: forall st.
  85       GenCtx st inp vs a ->
  86       CodeQ (ST st (Either (ParsingError inp) a))
  87   }
  88
  89 {-# INLINE returnST #-}
  90 returnST :: forall s a. a -> ST s a
  91 returnST = return @(ST s)
  92
  93 -- | @('generateCode' input mach)@ generates @TemplateHaskell@ code
  94 -- parsing the given 'input' according to the given 'Machine'.
  95 generateCode ::
  96   -- Not really used constraints,
  97   -- just to please 'checkHorizon'.
  98   Ord (InputToken inp) =>
  99   Show (InputToken inp) =>
 100   TH.Lift (InputToken inp) =>
 101   NFData (InputToken inp) =>
 102   Typeable (InputToken inp) =>
 103   Inputable inp =>
 104   Show (Cursor inp) =>
 105   Gen inp '[] a ->
 106   CodeQ (inp -> Either (ParsingError inp) a)
 107 generateCode gen =
 108     let Gen{unGen=k, ..} = checkHorizon gen in
 109     [|| \(input :: inp) ->
 110     -- Pattern bindings containing unlifted types
 111     -- should use an outermost bang pattern.
 112     let !(# init, readMore, readNext #) = $$(cursorOf [||input||])
 113         finalRet = \_farInp _farExp v _inp -> returnST $ Right v
 114         finalRaise :: forall st b. (OnException st inp b)
 115           = \ !exn _failInp !farInp !farExp ->
 116           returnST $ Left ParsingError
 117           { parsingErrorOffset = offset farInp
 118           , parsingErrorException = exn
 119           , parsingErrorUnexpected =
 120               if readMore farInp
 121               then Just (let (# c, _ #) = readNext farInp in c)
 122               else Nothing
 123           , parsingErrorExpecting =
 124               let (minHoriz, res) =
 125                     Set.foldr (\f (minH, acc) ->
 126                       case unSomeFailure f of
 127                         Just (FailureHorizon h :: Failure (Gram.CombSatisfiable (InputToken inp)))
 128                           | Just old <- minH -> (Just (min old h), acc)
 129                           | otherwise -> (Just h, acc)
 130                         _ -> (minH, f:acc)
 131                       ) (Nothing, []) farExp in
 132               Set.fromList $ case minHoriz of
 133                 Just h -> SomeFailure (FailureHorizon @(InputToken inp) h) : res
 134                 Nothing -> res
 135           }
 136     in runST $$(
 137       let
 138         -- | Defines 'inputTokenProxy' so that the TemplateHaskell code
 139         -- can refer to @(InputToken inp)@ through it.
 140         defInputTokenProxy :: TH.CodeQ a -> TH.CodeQ a
 141         defInputTokenProxy exprCode =
 142           TH.unsafeCodeCoerce [|
 143             let $(return (TH.VarP inputTokenProxy)) = Proxy :: Proxy (InputToken inp) in
 144             $(TH.unTypeQ (TH.examineCode exprCode))
 145           |]
 146       in
 147       defInputTokenProxy $
 148       k GenCtx
 149         { valueStack = ValueStackEmpty
 150         , onExceptionStackByLabel = Map.empty :: Map Exception (NonEmpty (TH.CodeQ (OnException s inp a)))
 151         , defaultCatch = [||finalRaise||]
 152         , onReturn = [||finalRet||] :: CodeQ (OnReturn s inp a a)
 153         , input = [||init||]
 154         , nextInput = [||readNext||]
 155         , moreInput = [||readMore||]
 156         -- , farthestError = [||Nothing||]
 157         , farthestInput = [||init||]
 158         , farthestExpecting = [||Set.empty||]
 159         , checkedHorizon = 0
 160         , analysisByLet = mutualFix genAnalysisByLet
 161         }
 162       )
 163     ||]
 164
 165 -- ** Type 'ParsingError'
 166 data ParsingError inp
 167   =  ParsingError
 168   {  parsingErrorOffset :: Offset
 169   ,  parsingErrorException :: Exception
 170      -- | Note: if a 'FailureHorizon' greater than 1
 171      -- is amongst the 'parsingErrorExpecting'
 172      -- then 'parsingErrorUnexpected' is only the 'InputToken'
 173      -- at the begining of the expected 'Horizon'.
 174   ,  parsingErrorUnexpected :: Maybe (InputToken inp)
 175   ,  parsingErrorExpecting :: Set SomeFailure
 176   } deriving (Generic)
 177 deriving instance NFData (InputToken inp) => NFData (ParsingError inp)
 178 --deriving instance Show (InputToken inp) => Show (ParsingError inp)
 179 instance Show (InputToken inp) => Show (ParsingError inp) where
 180   showsPrec p ParsingError{..} =
 181     showParen (p >= 11) $
 182       showString "ParsingErrorStandard {" .
 183       showString "parsingErrorOffset = " .
 184       showsPrec 0 parsingErrorOffset .
 185       showCommaSpace .
 186       showString "parsingErrorException = " .
 187       showsPrec 0 parsingErrorException .
 188       showCommaSpace .
 189       showString "parsingErrorUnexpected = " .
 190       showsPrec 0 parsingErrorUnexpected .
 191       showCommaSpace .
 192       showString "parsingErrorExpecting = fromList " .
 193       showsPrec 0 (
 194         -- Sort on the string representation
 195         -- because the 'Ord' of the 'SomeFailure'
 196         -- is based upon hashes ('typeRepFingerprint')
 197         -- depending on packages' ABI and whether
 198         -- cabal-install's setup is --inplace or not,
 199         -- and that would be too unstable for golden tests.
 200         List.sortBy (compare `on` show) $
 201         Set.toList parsingErrorExpecting
 202       ) .
 203       showString "}"
 204
 205 -- ** Type 'ErrorLabel'
 206 type ErrorLabel = String
 207
 208 -- * Type 'GenAnalysis'
 209 data GenAnalysis = GenAnalysis
 210   { minReads :: Horizon
 211     -- ^ The minimun number of input tokens to read
 212     -- on the current 'input' to reach a success.
 213   , mayRaise :: Map Exception ()
 214     -- ^ The 'Exception's that may be raised depending on the 'input'.
 215   , alwaysRaise :: Set Exception
 216     -- ^ The 'Exception's raised whatever is or happen to the 'input'.
 217   , freeRegs :: Set TH.Name
 218     -- ^ The free registers that are used.
 219   } deriving (Show)
 220
 221 -- ** Type 'Offset'
 222 type Offset = Int
 223 -- ** Type 'Horizon'
 224 -- | Minimal input length required for a successful parsing.
 225 type Horizon = Offset
 226
 227 -- | Merge given 'GenAnalysis' as sequences.
 228 seqGenAnalysis :: NonEmpty GenAnalysis -> GenAnalysis
 229 seqGenAnalysis aas@(a:|as) = GenAnalysis
 230   { minReads = List.foldl' (\acc -> (acc +) . minReads) (minReads a) as
 231   , mayRaise = sconcat (mayRaise <$> aas)
 232   , alwaysRaise = sconcat (alwaysRaise <$> aas)
 233   , freeRegs = sconcat (freeRegs <$> aas)
 234   }
 235 -- | Merge given 'GenAnalysis' as alternatives.
 236 altGenAnalysis :: NonEmpty GenAnalysis -> GenAnalysis
 237 altGenAnalysis aas = GenAnalysis
 238   { minReads =
 239       case
 240         (`NE.filter` aas) $ \a ->
 241           -- If an alternative 'alwaysRaise's 'ExceptionFailure' whatever its 'input' is,
 242           -- it __should__ remain semantically the same (up to the exact 'Failure's)
 243           -- to raise an 'ExceptionFailure' even before knowing
 244           -- whether that alternative branch will be taken or not,
 245           -- hence an upstream 'checkHorizon' is allowed to raise an 'ExceptionFailure'
 246           -- based only upon the 'minReads' of such alternatives:
 247           Set.toList (alwaysRaise a) /= [ExceptionFailure]
 248       of
 249       [] -> 0
 250       a:as -> List.foldl' (\acc -> min acc . minReads) (minReads a) as
 251   , mayRaise = sconcat (mayRaise <$> aas)
 252   , alwaysRaise = foldr Set.intersection Set.empty (alwaysRaise <$> aas)
 253   , freeRegs = sconcat (freeRegs <$> aas)
 254   }
 255
 256
 257
 258 {-
 259 -- *** Type 'FarthestError'
 260 data FarthestError inp = FarthestError
 261   { farthestInput :: Cursor inp
 262   , farthestExpecting :: [Failure (InputToken inp)]
 263   }
 264 -}
 265
 266 -- ** Type 'GenCtx'
 267 -- | This is an inherited (top-down) context
 268 -- only present at compile-time, to build TemplateHaskell splices.
 269 data GenCtx st inp vs a =
 270   ( Cursorable (Cursor inp)
 271   -- For checkHorizon
 272   , TH.Lift (InputToken inp)
 273   , Show (InputToken inp)
 274   , Eq (InputToken inp)
 275   , Ord (InputToken inp)
 276   , Typeable (InputToken inp)
 277   , NFData (InputToken inp)
 278   ) => GenCtx
 279   { valueStack :: ValueStack vs
 280   , onExceptionStackByLabel :: Map Exception (NonEmpty (CodeQ (OnException st inp a)))
 281     -- | Default 'OnException' defined at the begining of the generated 'CodeQ',
 282     -- hence a constant within the 'Gen'eration.
 283   , defaultCatch :: forall b. CodeQ (OnException st inp b)
 284   , onReturn :: CodeQ (OnReturn st inp a a)
 285   , input :: CodeQ (Cursor inp)
 286   , moreInput :: CodeQ (Cursor inp -> Bool)
 287   , nextInput :: CodeQ (Cursor inp -> (# InputToken inp, Cursor inp #))
 288   , farthestInput :: CodeQ (Cursor inp)
 289   , farthestExpecting :: CodeQ (Set SomeFailure)
 290     -- | Remaining horizon already checked.
 291     -- Use to factorize 'input' length checks,
 292     -- instead of checking the 'input' length
 293     -- one 'InputToken' at a time at each 'read'.
 294     -- Updated by 'checkHorizon'
 295     -- and reset elsewhere when needed.
 296   , checkedHorizon :: Horizon
 297   -- | Output of 'mutualFix'.
 298   , analysisByLet :: LetRecs TH.Name GenAnalysis
 299   }
 300
 301 -- ** Type 'ValueStack'
 302 data ValueStack vs where
 303   ValueStackEmpty :: ValueStack '[]
 304   ValueStackCons ::
 305     { valueStackHead :: Splice v
 306     , valueStackTail :: ValueStack vs
 307     } -> ValueStack (v ': vs)
 308
 309 instance InstrComment Gen where
 310   comment msg k = k
 311     { unGen = \ctx -> {-trace "unGen.comment" $-}
 312       [||
 313         let _ = $$(liftTypedString $ "comment: "<>msg) in
 314         $$(unGen k ctx)
 315       ||]
 316     }
 317 instance InstrValuable Gen where
 318   pushValue x k = k
 319     { unGen = \ctx -> {-trace "unGen.pushValue" $-}
 320       [||
 321       let _ = "pushValue" in
 322       $$(unGen k ctx
 323         { valueStack = ValueStackCons x (valueStack ctx) })
 324       ||]
 325     }
 326   popValue k = k
 327     { unGen = \ctx -> {-trace "unGen.popValue" $-}
 328       [||
 329       let _ = "popValue" in
 330       $$(unGen k ctx
 331         { valueStack = valueStackTail (valueStack ctx) })
 332       ||]
 333     }
 334   lift2Value f k = k
 335     { unGen = \ctx -> {-trace "unGen.lift2Value" $-}
 336       [||
 337       let _ = $$(liftTypedString ("lift2Value checkedHorizon="<>show (checkedHorizon ctx))) in
 338       $$(unGen k ctx
 339         { valueStack =
 340           let ValueStackCons y (ValueStackCons x vs) = valueStack ctx in
 341           ValueStackCons (f Prod..@ x Prod..@ y) vs
 342         })
 343       ||]
 344     }
 345   swapValue k = k
 346     { unGen = \ctx -> {-trace "unGen.swapValue" $-} unGen k ctx
 347       { valueStack =
 348           let ValueStackCons y (ValueStackCons x vs) = valueStack ctx in
 349           ValueStackCons x (ValueStackCons y vs)
 350       }
 351     }
 352 instance InstrBranchable Gen where
 353   caseBranch kx ky = Gen
 354     { genAnalysisByLet = genAnalysisByLet kx <> genAnalysisByLet ky
 355     , genAnalysis = \final -> altGenAnalysis $
 356         genAnalysis kx final :|
 357         [genAnalysis ky final]
 358     , unGen = \ctx -> {-trace "unGen.caseBranch" $-}
 359       let ValueStackCons v vs = valueStack ctx in
 360       [||
 361         case $$(genCode v) of
 362           Left  x -> $$(unGen kx ctx{ valueStack = ValueStackCons (splice [||x||]) vs })
 363           Right y -> $$(unGen ky ctx{ valueStack = ValueStackCons (splice [||y||]) vs })
 364       ||]
 365     }
 366   choicesBranch bs default_ = Gen
 367     { genAnalysisByLet = sconcat $ genAnalysisByLet default_ :| (genAnalysisByLet . snd <$> bs)
 368     , genAnalysis = \final -> altGenAnalysis $
 369         (\k -> genAnalysis k final)
 370         <$> (default_:|(snd <$> bs))
 371     , unGen = \ctx0 -> {-trace "unGen.choicesBranch" $-}
 372       let ValueStackCons v vs = valueStack ctx0 in
 373       let ctx = ctx0{valueStack = vs} in
 374       let
 375         go x ((p,b):bs') = [||
 376           if $$(genCode (p Prod..@ x))
 377           then
 378             let _ = $$(liftTypedString ("choicesBranch checkedHorizon="<>show (checkedHorizon ctx))) in
 379             $$({-trace "unGen.choicesBranch.b" $-} unGen b ctx)
 380           else
 381             let _ = "choicesBranch.else" in
 382             $$(go x bs')
 383           ||]
 384         go _ _ = unGen default_ ctx
 385       in go v bs
 386     }
 387 instance InstrExceptionable Gen where
 388   raise exn = Gen
 389     { genAnalysisByLet = HM.empty
 390     , genAnalysis = \_final -> GenAnalysis
 391         { minReads = 0
 392         , mayRaise = Map.singleton (ExceptionLabel exn) ()
 393         , alwaysRaise = Set.singleton (ExceptionLabel exn)
 394         , freeRegs = Set.empty
 395         }
 396     , unGen = \ctx@GenCtx{} -> {-trace ("unGen.raise: "<>show exn) $-} [||
 397         $$(raiseException ctx (ExceptionLabel exn))
 398           (ExceptionLabel $$(TH.liftTyped exn))
 399           {-failInp-}$$(input ctx)
 400           {-farInp-}$$(input ctx)
 401           $$(farthestExpecting ctx)
 402       ||]
 403     }
 404   fail fs = Gen
 405     { genAnalysisByLet = HM.empty
 406     , genAnalysis = \_final -> GenAnalysis
 407         { minReads = 0
 408         , mayRaise = Map.singleton ExceptionFailure ()
 409         , alwaysRaise = Set.singleton ExceptionFailure
 410         , freeRegs = Set.empty
 411         }
 412     , unGen = \ctx@GenCtx{} -> {-trace ("unGen.fail: "<>show exn) $-}
 413       if null fs
 414       then [|| -- Raise without updating the farthest error.
 415           $$(raiseException ctx ExceptionFailure)
 416             ExceptionFailure
 417             {-failInp-}$$(input ctx)
 418             $$(farthestInput ctx)
 419             $$(farthestExpecting ctx)
 420         ||]
 421       else raiseFailure ctx [||fs||]
 422     }
 423   commit exn k = k
 424     { unGen = \ctx -> {-trace ("unGen.commit: "<>show exn) $-}
 425       [||
 426       let _ = "commit" in
 427       $$(unGen k ctx{onExceptionStackByLabel =
 428         Map.update (\case
 429             _r0:|(r1:rs) -> Just (r1:|rs)
 430             _ -> Nothing
 431           )
 432         exn (onExceptionStackByLabel ctx)
 433       })
 434       ||]
 435     }
 436   catch exn k onExn = Gen
 437     { genAnalysisByLet = genAnalysisByLet k <> genAnalysisByLet onExn
 438     , genAnalysis = \final ->
 439         let kAnalysis = genAnalysis k final in
 440         let onExnAnalysis = genAnalysis onExn final in
 441         altGenAnalysis $
 442           kAnalysis
 443             { mayRaise = Map.delete exn (mayRaise kAnalysis)
 444             , alwaysRaise = Set.delete exn (alwaysRaise kAnalysis)
 445             } :|
 446           [ onExnAnalysis ]
 447     , unGen = \ctx@GenCtx{} -> {-trace ("unGen.catch: "<>show exn) $-} [||
 448         let _ = $$(liftTypedString ("catch "<>show exn<>" checkedHorizon="<>show (checkedHorizon ctx))) in
 449         let onException = $$(onExceptionCode (input ctx) (checkedHorizon ctx) onExn ctx) in
 450         $$(unGen k ctx
 451         { onExceptionStackByLabel =
 452             Map.insertWith (<>) exn
 453               (NE.singleton [||onException||])
 454               (onExceptionStackByLabel ctx)
 455         }
 456       ) ||]
 457     }
 458 -- ** Class 'SpliceInputable'
 459 -- | Record an 'input' and a 'checkedHorizon' together
 460 -- to be able to put both of them on the 'valueStack',
 461 -- and having them moved together by operations
 462 -- on the 'valueStack' (eg. 'lift2Value').
 463 -- Used by 'saveInput' and 'loadInput'.
 464 class SpliceInputable repr where
 465   inputSave :: CodeQ inp -> Horizon -> repr inp
 466 data instance Sym.Data SpliceInputable repr a where
 467   InputSave :: CodeQ inp -> Horizon -> Sym.Data SpliceInputable repr inp
 468 instance SpliceInputable (Sym.Data SpliceInputable repr) where
 469   inputSave = InputSave
 470 instance SpliceInputable repr => SpliceInputable (Sym.SomeData repr) where
 471   inputSave inp = Sym.SomeData . InputSave inp
 472 instance SpliceInputable TH.CodeQ where
 473   inputSave inp _hor = inp
 474 instance SpliceInputable repr => Derivable (Sym.Data SpliceInputable repr) where
 475   derive = \case
 476     InputSave inp hor -> inputSave inp hor
 477 instance InstrInputable Gen where
 478   saveInput k = k
 479     { unGen = \ctx ->
 480         {-trace "unGen.saveInput" $-}
 481         [||
 482         let _ = $$(liftTypedString $ "saveInput checkedHorizon="<>show (checkedHorizon ctx)) in
 483         $$(unGen k ctx
 484           { valueStack = inputSave (input ctx) (checkedHorizon ctx) `ValueStackCons` valueStack ctx
 485           })
 486         ||]
 487     }
 488   loadInput k = k
 489     { unGen = \ctx@GenCtx{} ->
 490         {-trace "unGen.loadInput" $-}
 491         let ValueStackCons v vs = valueStack ctx in
 492         let (input, checkedHorizon) = case v of
 493               Sym.Data (InputSave i h) -> (i, h)
 494               -- This case should never happen if 'saveInput' is used.
 495               i -> (genCode i, 0) in
 496         [||
 497         let _ = $$(liftTypedString $ "loadInput checkedHorizon="<>show checkedHorizon) in
 498         $$(unGen (checkHorizon k) ctx
 499           { valueStack = vs
 500           , input
 501           , checkedHorizon
 502           })
 503         ||]
 504     , genAnalysis = \final ->
 505         let analysis = genAnalysis k final in
 506         -- The input is reset and thus any previous 'checkHorizon'
 507         -- cannot check after this 'loadInput'.
 508         analysis{minReads = 0}
 509     }
 510 instance InstrCallable Gen where
 511   defLet defs k = k
 512     { unGen = \ctx@GenCtx{} ->
 513         {-trace ("unGen.defLet: defs="<>show (HM.keys defs)) $-}
 514         TH.unsafeCodeCoerce $ do
 515           decls <- traverse (makeDecl ctx) (HM.toList defs)
 516           body <- TH.unTypeQ $ TH.examineCode $
 517             {-trace "unGen.defLet.body" $-}
 518             unGen k ctx
 519           return $ TH.LetE (
 520             -- | Use 'List.sortBy' to output more deterministic code
 521             -- to be able to golden test it, at the cost of more computations
 522             -- (at compile-time only though).
 523             List.sortBy (compare `on` TH.hideName) $
 524             toList decls
 525             ) body
 526     , genAnalysisByLet =
 527         HM.unions
 528           $ genAnalysisByLet k
 529           : ((\(SomeLet sub) -> genAnalysis sub) <$> defs)
 530           : ((\(SomeLet sub) -> genAnalysisByLet sub) <$> HM.elems defs)
 531     }
 532     where
 533     makeDecl ctx (subName, SomeLet sub) = do
 534       let subAnalysis = analysisByLet ctx HM.! subName
 535       body <- takeFreeRegs (freeRegs subAnalysis) $
 536         TH.unTypeQ $ TH.examineCode $ [|| -- buildRec in Parsley
 537         -- Called by 'call' or 'jump'.
 538         \ !callerOnReturn{-from onReturnCode-}
 539           !callerInput
 540           !callerOnExceptionStackByLabel{- 'onExceptionStackByLabel' from the 'call'-site -} ->
 541           $$({-trace ("unGen.defLet.sub: "<>show subName) $-} unGen sub ctx
 542             { valueStack = ValueStackEmpty
 543             -- Build a 'onExceptionStackByLabel' for the 'mayRaise' of the subroutine,
 544             -- where each 'OnException' calls the one passed by the 'call'-site (in 'callerOnExceptionStackByLabel').
 545             -- Note that currently the 'call'-site can supply in 'callerOnExceptionStackByLabel'
 546             -- a subset of the 'mayRaise' needed by this subroutine,
 547             -- because 'Map.findWithDefault' is used instead of 'Map.!'.
 548             , onExceptionStackByLabel = Map.mapWithKey
 549                 (\lbl () -> NE.singleton [||Map.findWithDefault $$(defaultCatch ctx) lbl callerOnExceptionStackByLabel||])
 550                 ({-trace ("mayRaise: "<>show subName) $-}
 551                   mayRaise subAnalysis)
 552             , input = [||callerInput||]
 553             , onReturn = {-trace ("unGen.defLet.sub.onReturn: "<>show subName) $-} [||callerOnReturn||]
 554
 555             -- These are passed by the caller via 'callerOnReturn' or 'ko'
 556             -- , farthestInput =
 557             -- , farthestExpecting =
 558
 559             -- Some callers can call this declaration
 560             -- with zero 'checkedHorizon', hence use this minimum.
 561             -- TODO: maybe it could be improved a bit
 562             -- by taking the minimum of the checked horizons
 563             -- before all the 'call's and 'jump's to this declaration.
 564             , checkedHorizon = 0
 565             })
 566         ||]
 567       let decl = TH.FunD subName [TH.Clause [] (TH.NormalB body) []]
 568       return decl
 569   jump isRec (LetName subName) = Gen
 570     { genAnalysisByLet = HM.empty
 571     , genAnalysis = \final ->
 572         if isRec
 573         then GenAnalysis
 574           { minReads = 0
 575           , mayRaise = Map.empty
 576           , alwaysRaise = Set.empty
 577           , freeRegs = Set.empty
 578           }
 579         else final HM.! subName
 580     , unGen = \ctx -> {-trace ("unGen.jump: "<>show subName) $-}
 581       let subAnalysis = analysisByLet ctx HM.! subName in
 582       [||
 583       let _ = "jump" in
 584       $$(TH.unsafeCodeCoerce $
 585         giveFreeRegs (freeRegs subAnalysis) $
 586         return (TH.VarE subName))
 587         {-ok-}$$(onReturn ctx)
 588         $$(input ctx)
 589         $$(liftTypedRaiseByLabel $
 590           onExceptionStackByLabel ctx
 591           -- Pass only the labels raised by the 'defLet'.
 592           `Map.intersection`
 593           (mayRaise subAnalysis)
 594         )
 595       ||]
 596     }
 597   call isRec (LetName subName) k = k
 598     { genAnalysis = \final ->
 599         if isRec
 600         then GenAnalysis
 601           { minReads = 0
 602           , mayRaise = Map.empty
 603           , alwaysRaise = Set.empty
 604           , freeRegs = Set.empty
 605           }
 606         else seqGenAnalysis $ (final HM.! subName) :| [ genAnalysis k final ]
 607     , unGen = {-trace ("unGen.call: "<>show subName) $-} \ctx ->
 608       -- let ks = (Map.keys (onExceptionStackByLabel ctx)) in
 609       let subAnalysis = analysisByLet ctx HM.! subName in
 610       [||
 611       -- let _ = $$(liftTypedString $ "call exceptByLet("<>show subName<>")="<>show (Map.keys (Map.findWithDefault Map.empty subName (exceptByLet ctx))) <> " onExceptionStackByLabel(ctx)="<> show ks) in
 612       $$(TH.unsafeCodeCoerce $
 613         giveFreeRegs (freeRegs subAnalysis) $
 614         return (TH.VarE subName))
 615         {-ok-}$$(onReturnCode k ctx)
 616         $$(input ctx)
 617         $$(liftTypedRaiseByLabel $
 618           -- FIXME: maybe it should rather pass all the 'mayRaise' of 'subName'
 619           -- and 'defaultCatch' be removed from 'makeDecl''s 'onExceptionStackByLabel'.
 620           onExceptionStackByLabel ctx
 621           -- Pass only the labels raised by the 'defLet'.
 622           `Map.intersection`
 623           (mayRaise subAnalysis)
 624         )
 625       ||]
 626     }
 627   ret = Gen
 628     { genAnalysisByLet = HM.empty
 629     , genAnalysis = \_final -> GenAnalysis
 630         { minReads = 0
 631         , mayRaise = Map.empty
 632         , alwaysRaise = Set.empty
 633         , freeRegs = Set.empty
 634         }
 635     , unGen = \ctx -> {-trace "unGen.ret" $-}
 636       {-trace "unGen.ret.returnCode" $-}
 637       returnCode ({-trace "unGen.ret.onReturn" $-} onReturn ctx) ctx
 638     }
 639
 640 takeFreeRegs :: TH.Quote m => Set TH.Name -> m TH.Exp -> m TH.Exp
 641 takeFreeRegs frs k = go (Set.toList frs)
 642   where
 643   go [] = k
 644   go (r:rs) = [| \ $(return (TH.VarP r)) -> $(go rs) |]
 645
 646 giveFreeRegs :: TH.Quote m => Set TH.Name -> m TH.Exp -> m TH.Exp
 647 giveFreeRegs frs k = go (Set.toList frs)
 648   where
 649   go [] = k
 650   go (r:rs) = [| $(go rs) $(return (TH.VarE r)) |]
 651
 652 -- | Like 'TH.liftString' but on 'TH.Code'.
 653 -- Useful to get a 'TH.StringL' instead of a 'TH.ListE'.
 654 liftTypedString :: String -> TH.Code TH.Q a
 655 liftTypedString = TH.unsafeCodeCoerce . TH.liftString
 656
 657 -- | Like 'TH.liftTyped' but adjusted to work on 'onExceptionStackByLabel'
 658 -- which already contains 'CodeQ' terms.
 659 -- Moreover, only the 'OnException' at the top of the stack
 660 -- is needed and thus generated in the resulting 'CodeQ'.
 661 --
 662 -- TODO: Use an 'Array' instead of a 'Map'?
 663 liftTypedRaiseByLabel :: TH.Lift k => Map k (NonEmpty (CodeQ a)) -> CodeQ (Map k a)
 664 liftTypedRaiseByLabel Map_.Tip = [|| Map_.Tip ||]
 665 liftTypedRaiseByLabel (Map_.Bin s k (h:|_hs) l r) =
 666   [|| Map_.Bin s k $$h $$(liftTypedRaiseByLabel l) $$(liftTypedRaiseByLabel r) ||]
 667
 668 instance TH.Lift a => TH.Lift (Set a) where
 669   liftTyped Set_.Tip = [|| Set_.Tip ||]
 670   liftTyped (Set_.Bin s a l r) = [|| Set_.Bin $$(TH.liftTyped s) $$(TH.liftTyped a) $$(TH.liftTyped l) $$(TH.liftTyped r) ||]
 671
 672 -- ** Type 'OnReturn'
 673 -- | A continuation generated by 'onReturnCode' and later called by 'returnCode'.
 674 type OnReturn st inp v a =
 675   {-farthestInput-}Cursor inp ->
 676   {-farthestExpecting-}Set SomeFailure ->
 677   v ->
 678   Cursor inp ->
 679   ST st (Either (ParsingError inp) a)
 680
 681 -- | Generate an 'OnReturn' continuation to be called with 'returnCode'.
 682 -- Used when 'call' 'ret'urns.
 683 -- The return 'v'alue is 'pushValue'-ed on the 'valueStack'.
 684 onReturnCode ::
 685   {-k-}Gen inp (v ': vs) a ->
 686   GenCtx st inp vs a ->
 687   CodeQ (OnReturn st inp v a)
 688 onReturnCode k ctx = [||
 689   let _ = $$(liftTypedString $ "onReturn") in
 690   \farInp farExp v !inp ->
 691     $$({-trace "unGen.onReturnCode" $-} unGen k ctx
 692       { valueStack = ValueStackCons ({-trace "unGen.onReturnCode.value" $-} splice [||v||]) (valueStack ctx)
 693       , input = [||inp||]
 694       , farthestInput = [||farInp||]
 695       , farthestExpecting = [||farExp||]
 696       , checkedHorizon = 0
 697       }
 698     )
 699   ||]
 700
 701 -- | Generate a call to the 'onReturnCode' continuation.
 702 -- Used when 'call' 'ret'urns.
 703 returnCode ::
 704   CodeQ (OnReturn st inp v a) ->
 705   GenCtx st inp (v ': vs) a ->
 706   CodeQ (ST st (Either (ParsingError inp) a))
 707 returnCode k = \ctx -> {-trace "returnCode" $-} [||
 708   let _ = "resume" in
 709   $$k
 710     $$(farthestInput ctx)
 711     $$(farthestExpecting ctx)
 712     (let _ = "resume.genCode" in $$({-trace "returnCode.genCode" $-}
 713       genCode $ valueStackHead $ valueStack ctx))
 714     $$(input ctx)
 715   ||]
 716
 717 -- ** Type 'OnException'
 718 -- | A continuation generated by 'catch' and later called by 'raise' or 'fail'.
 719 type OnException st inp a =
 720   Exception ->
 721   {-failInp-}Cursor inp ->
 722   {-farInp-}Cursor inp ->
 723   {-farExp-}Set SomeFailure ->
 724   ST st (Either (ParsingError inp) a)
 725
 726 -- TODO: some static infos should be attached to 'OnException'
 727 -- to avoid comparing inputs when they're the same
 728 -- and to improve 'checkedHorizon'.
 729 onExceptionCode ::
 730   CodeQ (Cursor inp) -> Horizon ->
 731   Gen inp (Cursor inp : vs) a ->
 732   GenCtx st inp vs a -> TH.CodeQ (OnException st inp a)
 733 onExceptionCode resetInput resetCheckedHorizon k ctx = [||
 734   let _ = $$(liftTypedString $ "onException") in
 735   \ !_exn !failInp !farInp !farExp ->
 736     $$(unGen k ctx
 737       -- Push 'input' and 'checkedHorizon'
 738       -- as they were when entering the 'catch' or 'iter',
 739       -- they will be available to 'loadInput', if any.
 740       { valueStack = inputSave resetInput resetCheckedHorizon
 741                      `ValueStackCons` valueStack ctx
 742       -- Note that 'onExceptionStackByLabel' is reset.
 743       -- Move the input to the failing position.
 744       , input = [||failInp||]
 745       -- The 'checkedHorizon' at the 'raise's are not known here.
 746       -- Nor whether 'failInp' is after 'checkedHorizon' or not.
 747       -- Hence fallback to a safe value.
 748       , checkedHorizon = 0
 749       -- Set those to the farthest error computed in 'raiseFailure'.
 750       , farthestInput = [||farInp||]
 751       , farthestExpecting = [||farExp||]
 752       })
 753   ||]
 754
 755 instance InstrJoinable Gen where
 756   defJoin (LetName n) sub k = k
 757     { unGen = \ctx ->
 758         {-trace ("unGen.defJoin: "<>show n) $-}
 759         TH.unsafeCodeCoerce [|
 760           let $(return (TH.VarP n)) = $(TH.unTypeQ $ TH.examineCode [||
 761                 -- Called by 'returnCode'.
 762                 \farInp farExp v !inp ->
 763                   $$({-trace ("unGen.defJoin.next: "<>show n) $-} unGen sub ctx
 764                     { valueStack = ValueStackCons (splice [||v||]) (valueStack ctx)
 765                     , input = [||inp||]
 766                     , farthestInput = [||farInp||]
 767                     , farthestExpecting = [||farExp||]
 768                     , checkedHorizon = 0
 769                     {- FIXME:
 770                     , onExceptionStackByLabel = Map.mapWithKey
 771                         (\lbl () -> NE.singleton [||koByLabel Map.! lbl||])
 772                         (mayRaise sub raiseLabelsByLetButSub)
 773                     -}
 774                     })
 775                 ||])
 776           in $(TH.unTypeQ $ TH.examineCode $
 777             {-trace ("unGen.defJoin.expr: "<>show n) $-}
 778             unGen k ctx)
 779         |]
 780     , genAnalysisByLet =
 781         (genAnalysisByLet sub <>) $
 782         HM.insert n (genAnalysis sub) $
 783         genAnalysisByLet k
 784     }
 785   refJoin (LetName n) = Gen
 786     { unGen = \ctx ->
 787         {-trace ("unGen.refJoin: "<>show n) $-}
 788         returnCode
 789           (TH.unsafeCodeCoerce (return (TH.VarE n))) ctx
 790     , genAnalysisByLet = HM.empty
 791     , genAnalysis = \final ->
 792         HM.findWithDefault
 793           (error (show (n,HM.keys final)))
 794           n final
 795     }
 796 instance InstrReadable Char Gen where
 797   read fs p = checkHorizon . checkToken fs p
 798 instance InstrReadable Word8 Gen where
 799   read fs p = checkHorizon . checkToken fs p
 800 instance InstrIterable Gen where
 801   iter (LetName loopJump) loop done = Gen
 802     { genAnalysisByLet = HM.unions
 803         [ -- No need to give 'freeRegs' when 'call'ing 'loopJump'
 804           -- because they're passed when 'call'ing 'iter'.
 805           -- This avoids to passing those registers around.
 806           HM.singleton loopJump (\final -> (genAnalysis loop final){freeRegs = Set.empty})
 807         , genAnalysisByLet loop
 808         , genAnalysisByLet done
 809         ]
 810     , genAnalysis = \final ->
 811       let loopAnalysis = genAnalysis loop final in
 812       let doneAnalysis = genAnalysis done final in
 813       GenAnalysis
 814         { minReads = minReads doneAnalysis
 815         , mayRaise =
 816             Map.delete ExceptionFailure (mayRaise loopAnalysis) <>
 817             mayRaise doneAnalysis
 818         , alwaysRaise =
 819             Set.delete ExceptionFailure (alwaysRaise loopAnalysis) <>
 820             alwaysRaise doneAnalysis
 821         , freeRegs = freeRegs loopAnalysis <> freeRegs doneAnalysis
 822         }
 823     , unGen = \ctx -> TH.unsafeCodeCoerce [|
 824         let _ = "iter" in
 825         let
 826           onException loopInput = $(TH.unTypeCode $ onExceptionCode
 827             (TH.unsafeCodeCoerce [|loopInput|]) 0 done ctx)
 828           $(return $ TH.VarP loopJump) = \_callerOnReturn callerInput callerOnExceptionStackByLabel ->
 829             $(TH.unTypeCode $ unGen loop ctx
 830               { valueStack = ValueStackEmpty
 831               , onExceptionStackByLabel =
 832                   Map.insertWith (<>) ExceptionFailure
 833                     (NE.singleton $ TH.unsafeCodeCoerce [|onException callerInput|])
 834                     (onExceptionStackByLabel ctx)
 835               , input = TH.unsafeCodeCoerce [|callerInput|]
 836               -- FIXME: promote to compile time error?
 837               , onReturn = TH.unsafeCodeCoerce [|error "invalid onReturn"|]
 838               , checkedHorizon = 0
 839               })
 840         in $(TH.unTypeCode $ unGen (jump True (LetName loopJump)) ctx{valueStack=ValueStackEmpty})
 841        |]
 842     }
 843 instance InstrRegisterable Gen where
 844   newRegister (UnscopedRegister r) k = k
 845     { genAnalysis = \final ->
 846       let analysis = genAnalysis k final in
 847       analysis{freeRegs = Set.delete r $ freeRegs analysis}
 848     , unGen = \ctx ->
 849       let ValueStackCons v vs = valueStack ctx in
 850       TH.unsafeCodeCoerce [|
 851       do
 852         let dupv = $(TH.unTypeCode $ genCode v)
 853         $(return (TH.VarP r)) <- ST.newSTRef dupv
 854         $(TH.unTypeCode $ unGen k ctx{valueStack=vs})
 855       |]
 856     }
 857   readRegister (UnscopedRegister r) k = k
 858     { genAnalysis = \final ->
 859       let analysis = genAnalysis k final in
 860       analysis{freeRegs = Set.insert r $ freeRegs analysis}
 861     , unGen = \ctx -> [|| do
 862         sr <- ST.readSTRef $$(TH.unsafeCodeCoerce (return (TH.VarE r)))
 863         $$(unGen k ctx{valueStack=ValueStackCons (splice [||sr||]) (valueStack ctx)})
 864       ||]
 865     }
 866   writeRegister (UnscopedRegister r) k = k
 867     { genAnalysis = \final ->
 868       let analysis = genAnalysis k final in
 869       analysis{freeRegs = Set.insert r $ freeRegs analysis}
 870     , unGen = \ctx ->
 871       let ValueStackCons v vs = valueStack ctx in
 872       [|| do
 873         let dupv = $$(genCode v)
 874         ST.writeSTRef $$(TH.unsafeCodeCoerce (return (TH.VarE r))) dupv
 875         $$(unGen k ctx{valueStack=vs})
 876       ||]
 877     }
 878
 879 checkHorizon ::
 880   forall inp vs a.
 881   -- Those constraints are not used anyway
 882   -- because (TH.Lift SomeFailure) uses 'inputTokenProxy'.
 883   Ord (InputToken inp) =>
 884   Show (InputToken inp) =>
 885   TH.Lift (InputToken inp) =>
 886   NFData (InputToken inp) =>
 887   Typeable (InputToken inp) =>
 888   {-ok-}Gen inp vs a ->
 889   Gen inp vs a
 890 checkHorizon ok = ok
 891   { genAnalysis = \final -> seqGenAnalysis $
 892       GenAnalysis { minReads = 0
 893                   , mayRaise = Map.singleton ExceptionFailure ()
 894                   , alwaysRaise = Set.empty
 895                   , freeRegs = Set.empty
 896                   } :|
 897       [ genAnalysis ok final ]
 898   , unGen = \ctx0@GenCtx{} ->
 899     if checkedHorizon ctx0 >= 1
 900     then
 901       [||
 902         let _ = $$(liftTypedString $ "checkHorizon.oldCheck: checkedHorizon="<>show (checkedHorizon ctx0)) in
 903         $$(unGen ok ctx0{checkedHorizon = checkedHorizon ctx0 - 1})
 904       ||]
 905     else
 906       let minHoriz = minReads $ genAnalysis ok $ analysisByLet ctx0 in
 907       if minHoriz == 0
 908       then
 909         [||
 910           let _ = "checkHorizon.noCheck" in
 911           $$(unGen ok ctx0)
 912         ||]
 913       else
 914         [||
 915           let inp = $$(input ctx0) in
 916           --let partialCont inp =
 917                 -- Factorize generated code for raising the "fail".
 918                 let readFail = $$(raiseException ctx0{input=[||inp||]} ExceptionFailure) in
 919                 $$(
 920                   let ctx = ctx0
 921                         { onExceptionStackByLabel =
 922                             Map.adjust (\(_r:|rs) -> [||readFail||] :| rs)
 923                               ExceptionFailure (onExceptionStackByLabel ctx0)
 924                         , input = [||inp||]
 925                         } in
 926                   [||
 927                     let _ = $$(liftTypedString $ "checkHorizon.newCheck: checkedHorizon="<>show (checkedHorizon ctx)<>" minHoriz="<>show minHoriz) in
 928                     if $$(moreInput ctx)
 929                          $$(if minHoriz > 1
 930                            then [||$$shiftRight $$(TH.liftTyped (minHoriz - 1)) inp||]
 931                            else [||inp||])
 932                     then $$(unGen ok ctx{checkedHorizon = minHoriz})
 933                     else
 934                       let _ = $$(liftTypedString $ "checkHorizon.newCheck.fail") in
 935                       -- TODO: return a resuming continuation (like attoparsec's Partial)
 936                       -- This could be done with a Buffer for efficient backtracking:
 937                       -- http://www.serpentine.com/blog/2014/05/31/attoparsec/
 938                       $$(unGen (fail (Set.singleton $ SomeFailure $ FailureHorizon @(InputToken inp) minHoriz)) ctx)
 939                   ||]
 940                 )
 941           --in partialCont $$(input ctx0)
 942         ||]
 943   }
 944
 945 -- | @('raiseFailure' ctx fs)@ raises 'ExceptionFailure'
 946 -- with farthest parameters set to or updated with @(fs)@
 947 -- according to the relative position of 'input' wrt. 'farthestInput'.
 948 raiseFailure ::
 949   Cursorable (Cursor inp) =>
 950   GenCtx st inp cs a ->
 951   TH.CodeQ (Set SomeFailure) ->
 952   TH.CodeQ (ST st (Either (ParsingError inp) a))
 953 raiseFailure ctx fs = [||
 954   let failExp = $$fs in
 955   let (# farInp, farExp #) =
 956         case $$compareOffset $$(farthestInput ctx) $$(input ctx) of
 957           LT -> (# $$(input ctx), failExp #)
 958           EQ -> (# $$(farthestInput ctx), failExp <> $$(farthestExpecting ctx) #)
 959           GT -> (# $$(farthestInput ctx), $$(farthestExpecting ctx) #)
 960   in $$(raiseException ctx ExceptionFailure)
 961     ExceptionFailure
 962     {-failInp-}$$(input ctx) farInp farExp
 963   ||]
 964 -- | @('raiseException' ctx exn)@ raises exception @(exn)@
 965 -- using any entry in 'onExceptionStackByLabel', or 'defaultCatch' if none.
 966 raiseException ::
 967   GenCtx st inp vs a -> Exception ->
 968   CodeQ (Exception -> Cursor inp -> Cursor inp -> Set SomeFailure -> ST st (Either (ParsingError inp) a))
 969 raiseException ctx exn =
 970   NE.head $ Map.findWithDefault
 971     (NE.singleton (defaultCatch ctx))
 972     exn (onExceptionStackByLabel ctx)
 973
 974 checkToken ::
 975   Set SomeFailure ->
 976   {-predicate-}Splice (InputToken inp -> Bool) ->
 977   {-ok-}Gen inp (InputToken inp ': vs) a ->
 978   Gen inp vs a
 979 checkToken fs p ok = ok
 980   { genAnalysis = \final -> seqGenAnalysis $
 981       GenAnalysis { minReads = 1
 982                   , mayRaise = Map.singleton ExceptionFailure ()
 983                   , alwaysRaise = Set.empty
 984                   , freeRegs = Set.empty
 985                   } :|
 986       [ genAnalysis ok final ]
 987   , unGen = \ctx -> {-trace "unGen.read" $-} [||
 988     let _ = "checkToken" in
 989     let !(# c, cs #) = $$(nextInput ctx) $$(input ctx) in
 990     $$(genCode $
 991       Prod.ifThenElse
 992         (p Prod..@ splice [||c||])
 993         (splice $ unGen ok ctx
 994           { valueStack = ValueStackCons (splice [||c||]) (valueStack ctx)
 995           , input = [||cs||]
 996           })
 997         (splice [||
 998           let _ = "checkToken.fail" in
 999           $$(unGen (fail fs) ctx)
1000         ||])
1001     )||]
1002   }