{-# LANGUAGE CPP #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} module GHC.Rename.Splice ( rnTopSpliceDecls, rnSpliceType, rnSpliceExpr, rnSplicePat, rnSpliceDecl, rnBracket, checkThLocalName , traceSplice, SpliceInfo(..) ) where #include "HsVersions.h" import GHC.Prelude import GHC.Types.Name import GHC.Types.Name.Set import GHC.Hs import GHC.Types.Name.Reader import GHC.Tc.Utils.Monad import GHC.Rename.Env import GHC.Rename.Utils ( HsDocContext(..), newLocalBndrRn ) import GHC.Rename.Unbound ( isUnboundName ) import GHC.Rename.Module ( rnSrcDecls, findSplice ) import GHC.Rename.Pat ( rnPat ) import GHC.Types.Basic ( TopLevelFlag, isTopLevel, SourceText(..) ) import GHC.Utils.Outputable import GHC.Unit.Module import GHC.Types.SrcLoc import GHC.Rename.HsType ( rnLHsType ) import Control.Monad ( unless, when ) import {-# SOURCE #-} GHC.Rename.Expr ( rnLExpr ) import GHC.Tc.Utils.Env ( checkWellStaged ) import GHC.Builtin.Names.TH ( liftName ) import GHC.Driver.Session import GHC.Data.FastString import GHC.Utils.Error ( dumpIfSet_dyn_printer, DumpFormat (..) ) import GHC.Tc.Utils.Env ( tcMetaTy ) import GHC.Driver.Hooks import GHC.Builtin.Names.TH ( quoteExpName, quotePatName, quoteDecName, quoteTypeName , decsQTyConName, expQTyConName, patQTyConName, typeQTyConName, ) import {-# SOURCE #-} GHC.Tc.Gen.Expr ( tcCheckPolyExpr ) import {-# SOURCE #-} GHC.Tc.Gen.Splice ( runMetaD , runMetaE , runMetaP , runMetaT , tcTopSpliceExpr ) import GHC.Tc.Utils.Zonk import GHCi.RemoteTypes ( ForeignRef ) import qualified Language.Haskell.TH as TH (Q) import qualified GHC.LanguageExtensions as LangExt {- ************************************************************************ * * Template Haskell brackets * * ************************************************************************ -} rnBracket :: HsExpr GhcPs -> HsBracket GhcPs -> RnM (HsExpr GhcRn, FreeVars) rnBracket :: HsExpr GhcPs -> HsBracket GhcPs -> RnM (HsExpr (GhcPass 'Renamed), Uses) rnBracket HsExpr GhcPs e HsBracket GhcPs br_body = MsgDoc -> RnM (HsExpr (GhcPass 'Renamed), Uses) -> RnM (HsExpr (GhcPass 'Renamed), Uses) forall a. MsgDoc -> TcM a -> TcM a addErrCtxt (HsBracket GhcPs -> MsgDoc quotationCtxtDoc HsBracket GhcPs br_body) (RnM (HsExpr (GhcPass 'Renamed), Uses) -> RnM (HsExpr (GhcPass 'Renamed), Uses)) -> RnM (HsExpr (GhcPass 'Renamed), Uses) -> RnM (HsExpr (GhcPass 'Renamed), Uses) forall a b. (a -> b) -> a -> b $ do { -- Check that -XTemplateHaskellQuotes is enabled and available Bool thQuotesEnabled <- Extension -> TcRnIf TcGblEnv TcLclEnv Bool forall gbl lcl. Extension -> TcRnIf gbl lcl Bool xoptM Extension LangExt.TemplateHaskellQuotes ; Bool -> IOEnv (Env TcGblEnv TcLclEnv) () -> IOEnv (Env TcGblEnv TcLclEnv) () forall (f :: * -> *). Applicative f => Bool -> f () -> f () unless Bool thQuotesEnabled (IOEnv (Env TcGblEnv TcLclEnv) () -> IOEnv (Env TcGblEnv TcLclEnv) ()) -> IOEnv (Env TcGblEnv TcLclEnv) () -> IOEnv (Env TcGblEnv TcLclEnv) () forall a b. (a -> b) -> a -> b $ MsgDoc -> IOEnv (Env TcGblEnv TcLclEnv) () forall a. MsgDoc -> TcRn a failWith ( [MsgDoc] -> MsgDoc vcat [ String -> MsgDoc text String "Syntax error on" MsgDoc -> MsgDoc -> MsgDoc <+> HsExpr GhcPs -> MsgDoc forall a. Outputable a => a -> MsgDoc ppr HsExpr GhcPs e , String -> MsgDoc text (String "Perhaps you intended to use TemplateHaskell" String -> String -> String forall a. [a] -> [a] -> [a] ++ String " or TemplateHaskellQuotes") ] ) -- Check for nested brackets ; ThStage cur_stage <- TcM ThStage getStage ; case ThStage cur_stage of { Splice SpliceType Typed -> Bool -> MsgDoc -> IOEnv (Env TcGblEnv TcLclEnv) () checkTc (HsBracket GhcPs -> Bool forall id. HsBracket id -> Bool isTypedBracket HsBracket GhcPs br_body) MsgDoc illegalUntypedBracket ; Splice SpliceType Untyped -> Bool -> MsgDoc -> IOEnv (Env TcGblEnv TcLclEnv) () checkTc (Bool -> Bool not (HsBracket GhcPs -> Bool forall id. HsBracket id -> Bool isTypedBracket HsBracket GhcPs br_body)) MsgDoc illegalTypedBracket ; RunSplice TcRef [ForeignRef (Q ())] _ -> -- See Note [RunSplice ThLevel] in GHC.Tc.Types. String -> MsgDoc -> IOEnv (Env TcGblEnv TcLclEnv) () forall a. HasCallStack => String -> MsgDoc -> a pprPanic String "rnBracket: Renaming bracket when running a splice" (HsExpr GhcPs -> MsgDoc forall a. Outputable a => a -> MsgDoc ppr HsExpr GhcPs e) ; ThStage Comp -> () -> IOEnv (Env TcGblEnv TcLclEnv) () forall (m :: * -> *) a. Monad m => a -> m a return () ; Brack {} -> MsgDoc -> IOEnv (Env TcGblEnv TcLclEnv) () forall a. MsgDoc -> TcRn a failWithTc MsgDoc illegalBracket } -- Brackets are desugared to code that mentions the TH package ; IOEnv (Env TcGblEnv TcLclEnv) () recordThUse ; case HsBracket GhcPs -> Bool forall id. HsBracket id -> Bool isTypedBracket HsBracket GhcPs br_body of Bool True -> do { String -> MsgDoc -> IOEnv (Env TcGblEnv TcLclEnv) () traceRn String "Renaming typed TH bracket" MsgDoc empty ; (HsBracket (GhcPass 'Renamed) body', Uses fvs_e) <- ThStage -> TcM (HsBracket (GhcPass 'Renamed), Uses) -> TcM (HsBracket (GhcPass 'Renamed), Uses) forall a. ThStage -> TcM a -> TcM a setStage (ThStage -> PendingStuff -> ThStage Brack ThStage cur_stage PendingStuff RnPendingTyped) (TcM (HsBracket (GhcPass 'Renamed), Uses) -> TcM (HsBracket (GhcPass 'Renamed), Uses)) -> TcM (HsBracket (GhcPass 'Renamed), Uses) -> TcM (HsBracket (GhcPass 'Renamed), Uses) forall a b. (a -> b) -> a -> b $ ThStage -> HsBracket GhcPs -> TcM (HsBracket (GhcPass 'Renamed), Uses) rn_bracket ThStage cur_stage HsBracket GhcPs br_body ; (HsExpr (GhcPass 'Renamed), Uses) -> RnM (HsExpr (GhcPass 'Renamed), Uses) forall (m :: * -> *) a. Monad m => a -> m a return (XBracket (GhcPass 'Renamed) -> HsBracket (GhcPass 'Renamed) -> HsExpr (GhcPass 'Renamed) forall p. XBracket p -> HsBracket p -> HsExpr p HsBracket NoExtField XBracket (GhcPass 'Renamed) noExtField HsBracket (GhcPass 'Renamed) body', Uses fvs_e) } Bool False -> do { String -> MsgDoc -> IOEnv (Env TcGblEnv TcLclEnv) () traceRn String "Renaming untyped TH bracket" MsgDoc empty ; IORef [PendingRnSplice] ps_var <- [PendingRnSplice] -> IOEnv (Env TcGblEnv TcLclEnv) (IORef [PendingRnSplice]) forall a env. a -> IOEnv env (IORef a) newMutVar [] ; (HsBracket (GhcPass 'Renamed) body', Uses fvs_e) <- -- See Note [Rebindable syntax and Template Haskell] Extension -> TcM (HsBracket (GhcPass 'Renamed), Uses) -> TcM (HsBracket (GhcPass 'Renamed), Uses) forall gbl lcl a. Extension -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a unsetXOptM Extension LangExt.RebindableSyntax (TcM (HsBracket (GhcPass 'Renamed), Uses) -> TcM (HsBracket (GhcPass 'Renamed), Uses)) -> TcM (HsBracket (GhcPass 'Renamed), Uses) -> TcM (HsBracket (GhcPass 'Renamed), Uses) forall a b. (a -> b) -> a -> b $ ThStage -> TcM (HsBracket (GhcPass 'Renamed), Uses) -> TcM (HsBracket (GhcPass 'Renamed), Uses) forall a. ThStage -> TcM a -> TcM a setStage (ThStage -> PendingStuff -> ThStage Brack ThStage cur_stage (IORef [PendingRnSplice] -> PendingStuff RnPendingUntyped IORef [PendingRnSplice] ps_var)) (TcM (HsBracket (GhcPass 'Renamed), Uses) -> TcM (HsBracket (GhcPass 'Renamed), Uses)) -> TcM (HsBracket (GhcPass 'Renamed), Uses) -> TcM (HsBracket (GhcPass 'Renamed), Uses) forall a b. (a -> b) -> a -> b $ ThStage -> HsBracket GhcPs -> TcM (HsBracket (GhcPass 'Renamed), Uses) rn_bracket ThStage cur_stage HsBracket GhcPs br_body ; [PendingRnSplice] pendings <- IORef [PendingRnSplice] -> IOEnv (Env TcGblEnv TcLclEnv) [PendingRnSplice] forall a env. IORef a -> IOEnv env a readMutVar IORef [PendingRnSplice] ps_var ; (HsExpr (GhcPass 'Renamed), Uses) -> RnM (HsExpr (GhcPass 'Renamed), Uses) forall (m :: * -> *) a. Monad m => a -> m a return (XRnBracketOut (GhcPass 'Renamed) -> HsBracket (GhcPass 'Renamed) -> [PendingRnSplice] -> HsExpr (GhcPass 'Renamed) forall p. XRnBracketOut p -> HsBracket (GhcPass 'Renamed) -> [PendingRnSplice] -> HsExpr p HsRnBracketOut NoExtField XRnBracketOut (GhcPass 'Renamed) noExtField HsBracket (GhcPass 'Renamed) body' [PendingRnSplice] pendings, Uses fvs_e) } } rn_bracket :: ThStage -> HsBracket GhcPs -> RnM (HsBracket GhcRn, FreeVars) rn_bracket :: ThStage -> HsBracket GhcPs -> TcM (HsBracket (GhcPass 'Renamed), Uses) rn_bracket ThStage outer_stage br :: HsBracket GhcPs br@(VarBr XVarBr GhcPs x Bool flg IdP GhcPs rdr_name) = do { Name name <- RdrName -> RnM Name lookupOccRn RdrName IdP GhcPs rdr_name ; Module this_mod <- IOEnv (Env TcGblEnv TcLclEnv) Module forall (m :: * -> *). HasModule m => m Module getModule ; Bool -> IOEnv (Env TcGblEnv TcLclEnv) () -> IOEnv (Env TcGblEnv TcLclEnv) () forall (f :: * -> *). Applicative f => Bool -> f () -> f () when (Bool flg Bool -> Bool -> Bool && Module -> Name -> Bool nameIsLocalOrFrom Module this_mod Name name) (IOEnv (Env TcGblEnv TcLclEnv) () -> IOEnv (Env TcGblEnv TcLclEnv) ()) -> IOEnv (Env TcGblEnv TcLclEnv) () -> IOEnv (Env TcGblEnv TcLclEnv) () forall a b. (a -> b) -> a -> b $ -- Type variables can be quoted in TH. See #5721. do { Maybe (TopLevelFlag, ThLevel) mb_bind_lvl <- Name -> RnM (Maybe (TopLevelFlag, ThLevel)) lookupLocalOccThLvl_maybe Name name ; case Maybe (TopLevelFlag, ThLevel) mb_bind_lvl of { Maybe (TopLevelFlag, ThLevel) Nothing -> () -> IOEnv (Env TcGblEnv TcLclEnv) () forall (m :: * -> *) a. Monad m => a -> m a return () -- Can happen for data constructors, -- but nothing needs to be done for them ; Just (TopLevelFlag top_lvl, ThLevel bind_lvl) -- See Note [Quoting names] | TopLevelFlag -> Bool isTopLevel TopLevelFlag top_lvl -> Bool -> IOEnv (Env TcGblEnv TcLclEnv) () -> IOEnv (Env TcGblEnv TcLclEnv) () forall (f :: * -> *). Applicative f => Bool -> f () -> f () when (Name -> Bool isExternalName Name name) (Name -> IOEnv (Env TcGblEnv TcLclEnv) () keepAlive Name name) | Bool otherwise -> do { String -> MsgDoc -> IOEnv (Env TcGblEnv TcLclEnv) () traceRn String "rn_bracket VarBr" (Name -> MsgDoc forall a. Outputable a => a -> MsgDoc ppr Name name MsgDoc -> MsgDoc -> MsgDoc <+> ThLevel -> MsgDoc forall a. Outputable a => a -> MsgDoc ppr ThLevel bind_lvl MsgDoc -> MsgDoc -> MsgDoc <+> ThStage -> MsgDoc forall a. Outputable a => a -> MsgDoc ppr ThStage outer_stage) ; Bool -> MsgDoc -> IOEnv (Env TcGblEnv TcLclEnv) () checkTc (ThStage -> ThLevel thLevel ThStage outer_stage ThLevel -> ThLevel -> ThLevel forall a. Num a => a -> a -> a + ThLevel 1 ThLevel -> ThLevel -> Bool forall a. Eq a => a -> a -> Bool == ThLevel bind_lvl) (HsBracket GhcPs -> MsgDoc quotedNameStageErr HsBracket GhcPs br) } } } ; (HsBracket (GhcPass 'Renamed), Uses) -> TcM (HsBracket (GhcPass 'Renamed), Uses) forall (m :: * -> *) a. Monad m => a -> m a return (XVarBr (GhcPass 'Renamed) -> Bool -> IdP (GhcPass 'Renamed) -> HsBracket (GhcPass 'Renamed) forall p. XVarBr p -> Bool -> IdP p -> HsBracket p VarBr XVarBr GhcPs XVarBr (GhcPass 'Renamed) x Bool flg Name IdP (GhcPass 'Renamed) name, Name -> Uses unitFV Name name) } rn_bracket ThStage _ (ExpBr XExpBr GhcPs x LHsExpr GhcPs e) = do { (LHsExpr (GhcPass 'Renamed) e', Uses fvs) <- LHsExpr GhcPs -> RnM (LHsExpr (GhcPass 'Renamed), Uses) rnLExpr LHsExpr GhcPs e ; (HsBracket (GhcPass 'Renamed), Uses) -> TcM (HsBracket (GhcPass 'Renamed), Uses) forall (m :: * -> *) a. Monad m => a -> m a return (XExpBr (GhcPass 'Renamed) -> LHsExpr (GhcPass 'Renamed) -> HsBracket (GhcPass 'Renamed) forall p. XExpBr p -> LHsExpr p -> HsBracket p ExpBr XExpBr GhcPs XExpBr (GhcPass 'Renamed) x LHsExpr (GhcPass 'Renamed) e', Uses fvs) } rn_bracket ThStage _ (PatBr XPatBr GhcPs x LPat GhcPs p) = HsMatchContext (GhcPass 'Renamed) -> LPat GhcPs -> (LPat (GhcPass 'Renamed) -> TcM (HsBracket (GhcPass 'Renamed), Uses)) -> TcM (HsBracket (GhcPass 'Renamed), Uses) forall a. HsMatchContext (GhcPass 'Renamed) -> LPat GhcPs -> (LPat (GhcPass 'Renamed) -> RnM (a, Uses)) -> RnM (a, Uses) rnPat HsMatchContext (GhcPass 'Renamed) forall p. HsMatchContext p ThPatQuote LPat GhcPs p ((LPat (GhcPass 'Renamed) -> TcM (HsBracket (GhcPass 'Renamed), Uses)) -> TcM (HsBracket (GhcPass 'Renamed), Uses)) -> (LPat (GhcPass 'Renamed) -> TcM (HsBracket (GhcPass 'Renamed), Uses)) -> TcM (HsBracket (GhcPass 'Renamed), Uses) forall a b. (a -> b) -> a -> b $ \ LPat (GhcPass 'Renamed) p' -> (HsBracket (GhcPass 'Renamed), Uses) -> TcM (HsBracket (GhcPass 'Renamed), Uses) forall (m :: * -> *) a. Monad m => a -> m a return (XPatBr (GhcPass 'Renamed) -> LPat (GhcPass 'Renamed) -> HsBracket (GhcPass 'Renamed) forall p. XPatBr p -> LPat p -> HsBracket p PatBr XPatBr GhcPs XPatBr (GhcPass 'Renamed) x LPat (GhcPass 'Renamed) p', Uses emptyFVs) rn_bracket ThStage _ (TypBr XTypBr GhcPs x LHsType GhcPs t) = do { (LHsType (GhcPass 'Renamed) t', Uses fvs) <- HsDocContext -> LHsType GhcPs -> RnM (LHsType (GhcPass 'Renamed), Uses) rnLHsType HsDocContext TypBrCtx LHsType GhcPs t ; (HsBracket (GhcPass 'Renamed), Uses) -> TcM (HsBracket (GhcPass 'Renamed), Uses) forall (m :: * -> *) a. Monad m => a -> m a return (XTypBr (GhcPass 'Renamed) -> LHsType (GhcPass 'Renamed) -> HsBracket (GhcPass 'Renamed) forall p. XTypBr p -> LHsType p -> HsBracket p TypBr XTypBr GhcPs XTypBr (GhcPass 'Renamed) x LHsType (GhcPass 'Renamed) t', Uses fvs) } rn_bracket ThStage _ (DecBrL XDecBrL GhcPs x [LHsDecl GhcPs] decls) = do { HsGroup GhcPs group <- [LHsDecl GhcPs] -> RnM (HsGroup GhcPs) groupDecls [LHsDecl GhcPs] decls ; TcGblEnv gbl_env <- TcRnIf TcGblEnv TcLclEnv TcGblEnv forall gbl lcl. TcRnIf gbl lcl gbl getGblEnv ; let new_gbl_env :: TcGblEnv new_gbl_env = TcGblEnv gbl_env { tcg_dus :: DefUses tcg_dus = DefUses emptyDUs } -- The emptyDUs is so that we just collect uses for this -- group alone in the call to rnSrcDecls below ; (TcGblEnv tcg_env, HsGroup (GhcPass 'Renamed) group') <- TcGblEnv -> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, HsGroup (GhcPass 'Renamed)) -> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, HsGroup (GhcPass 'Renamed)) forall gbl lcl a. gbl -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a setGblEnv TcGblEnv new_gbl_env (TcRnIf TcGblEnv TcLclEnv (TcGblEnv, HsGroup (GhcPass 'Renamed)) -> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, HsGroup (GhcPass 'Renamed))) -> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, HsGroup (GhcPass 'Renamed)) -> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, HsGroup (GhcPass 'Renamed)) forall a b. (a -> b) -> a -> b $ HsGroup GhcPs -> TcRnIf TcGblEnv TcLclEnv (TcGblEnv, HsGroup (GhcPass 'Renamed)) rnSrcDecls HsGroup GhcPs group -- Discard the tcg_env; it contains only extra info about fixity ; String -> MsgDoc -> IOEnv (Env TcGblEnv TcLclEnv) () traceRn String "rn_bracket dec" (DefUses -> MsgDoc forall a. Outputable a => a -> MsgDoc ppr (TcGblEnv -> DefUses tcg_dus TcGblEnv tcg_env) MsgDoc -> MsgDoc -> MsgDoc $$ Uses -> MsgDoc forall a. Outputable a => a -> MsgDoc ppr (DefUses -> Uses duUses (TcGblEnv -> DefUses tcg_dus TcGblEnv tcg_env))) ; (HsBracket (GhcPass 'Renamed), Uses) -> TcM (HsBracket (GhcPass 'Renamed), Uses) forall (m :: * -> *) a. Monad m => a -> m a return (XDecBrG (GhcPass 'Renamed) -> HsGroup (GhcPass 'Renamed) -> HsBracket (GhcPass 'Renamed) forall p. XDecBrG p -> HsGroup p -> HsBracket p DecBrG XDecBrG (GhcPass 'Renamed) XDecBrL GhcPs x HsGroup (GhcPass 'Renamed) group', DefUses -> Uses duUses (TcGblEnv -> DefUses tcg_dus TcGblEnv tcg_env)) } where groupDecls :: [LHsDecl GhcPs] -> RnM (HsGroup GhcPs) groupDecls :: [LHsDecl GhcPs] -> RnM (HsGroup GhcPs) groupDecls [LHsDecl GhcPs] decls = do { (HsGroup GhcPs group, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs]) mb_splice) <- [LHsDecl GhcPs] -> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs])) findSplice [LHsDecl GhcPs] decls ; case Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs]) mb_splice of { Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs]) Nothing -> HsGroup GhcPs -> RnM (HsGroup GhcPs) forall (m :: * -> *) a. Monad m => a -> m a return HsGroup GhcPs group ; Just (SpliceDecl GhcPs splice, [LHsDecl GhcPs] rest) -> do { HsGroup GhcPs group' <- [LHsDecl GhcPs] -> RnM (HsGroup GhcPs) groupDecls [LHsDecl GhcPs] rest ; let group'' :: HsGroup GhcPs group'' = HsGroup GhcPs -> HsGroup GhcPs -> HsGroup GhcPs forall (p :: Pass). HsGroup (GhcPass p) -> HsGroup (GhcPass p) -> HsGroup (GhcPass p) appendGroups HsGroup GhcPs group HsGroup GhcPs group' ; HsGroup GhcPs -> RnM (HsGroup GhcPs) forall (m :: * -> *) a. Monad m => a -> m a return HsGroup GhcPs group'' { hs_splcds :: [LSpliceDecl GhcPs] hs_splcds = SpliceDecl GhcPs -> LSpliceDecl GhcPs forall e. e -> Located e noLoc SpliceDecl GhcPs splice LSpliceDecl GhcPs -> [LSpliceDecl GhcPs] -> [LSpliceDecl GhcPs] forall a. a -> [a] -> [a] : HsGroup GhcPs -> [LSpliceDecl GhcPs] forall p. HsGroup p -> [LSpliceDecl p] hs_splcds HsGroup GhcPs group' } } }} rn_bracket ThStage _ (DecBrG {}) = String -> TcM (HsBracket (GhcPass 'Renamed), Uses) forall a. String -> a panic String "rn_bracket: unexpected DecBrG" rn_bracket ThStage _ (TExpBr XTExpBr GhcPs x LHsExpr GhcPs e) = do { (LHsExpr (GhcPass 'Renamed) e', Uses fvs) <- LHsExpr GhcPs -> RnM (LHsExpr (GhcPass 'Renamed), Uses) rnLExpr LHsExpr GhcPs e ; (HsBracket (GhcPass 'Renamed), Uses) -> TcM (HsBracket (GhcPass 'Renamed), Uses) forall (m :: * -> *) a. Monad m => a -> m a return (XTExpBr (GhcPass 'Renamed) -> LHsExpr (GhcPass 'Renamed) -> HsBracket (GhcPass 'Renamed) forall p. XTExpBr p -> LHsExpr p -> HsBracket p TExpBr XTExpBr GhcPs XTExpBr (GhcPass 'Renamed) x LHsExpr (GhcPass 'Renamed) e', Uses fvs) } quotationCtxtDoc :: HsBracket GhcPs -> SDoc quotationCtxtDoc :: HsBracket GhcPs -> MsgDoc quotationCtxtDoc HsBracket GhcPs br_body = MsgDoc -> ThLevel -> MsgDoc -> MsgDoc hang (String -> MsgDoc text String "In the Template Haskell quotation") ThLevel 2 (HsBracket GhcPs -> MsgDoc forall a. Outputable a => a -> MsgDoc ppr HsBracket GhcPs br_body) illegalBracket :: SDoc illegalBracket :: MsgDoc illegalBracket = String -> MsgDoc text String "Template Haskell brackets cannot be nested" MsgDoc -> MsgDoc -> MsgDoc <+> String -> MsgDoc text String "(without intervening splices)" illegalTypedBracket :: SDoc illegalTypedBracket :: MsgDoc illegalTypedBracket = String -> MsgDoc text String "Typed brackets may only appear in typed splices." illegalUntypedBracket :: SDoc illegalUntypedBracket :: MsgDoc illegalUntypedBracket = String -> MsgDoc text String "Untyped brackets may only appear in untyped splices." quotedNameStageErr :: HsBracket GhcPs -> SDoc quotedNameStageErr :: HsBracket GhcPs -> MsgDoc quotedNameStageErr HsBracket GhcPs br = [MsgDoc] -> MsgDoc sep [ String -> MsgDoc text String "Stage error: the non-top-level quoted name" MsgDoc -> MsgDoc -> MsgDoc <+> HsBracket GhcPs -> MsgDoc forall a. Outputable a => a -> MsgDoc ppr HsBracket GhcPs br , String -> MsgDoc text String "must be used at the same stage at which it is bound" ] {- ********************************************************* * * Splices * * ********************************************************* Note [Free variables of typed splices] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider renaming this: f = ... h = ...$(thing "f")... where the splice is a *typed* splice. The splice can expand into literally anything, so when we do dependency analysis we must assume that it might mention 'f'. So we simply treat all locally-defined names as mentioned by any splice. This is terribly brutal, but I don't see what else to do. For example, it'll mean that every locally-defined thing will appear to be used, so no unused-binding warnings. But if we miss the dependency, then we might typecheck 'h' before 'f', and that will crash the type checker because 'f' isn't in scope. Currently, I'm not treating a splice as also mentioning every import, which is a bit inconsistent -- but there are a lot of them. We might thereby get some bogus unused-import warnings, but we won't crash the type checker. Not very satisfactory really. Note [Renamer errors] ~~~~~~~~~~~~~~~~~~~~~ It's important to wrap renamer calls in checkNoErrs, because the renamer does not fail for out of scope variables etc. Instead it returns a bogus term/type, so that it can report more than one error. We don't want the type checker to see these bogus unbound variables. -} rnSpliceGen :: (HsSplice GhcRn -> RnM (a, FreeVars)) -- Outside brackets, run splice -> (HsSplice GhcRn -> (PendingRnSplice, a)) -- Inside brackets, make it pending -> HsSplice GhcPs -> RnM (a, FreeVars) rnSpliceGen :: forall a. (HsSplice (GhcPass 'Renamed) -> RnM (a, Uses)) -> (HsSplice (GhcPass 'Renamed) -> (PendingRnSplice, a)) -> HsSplice GhcPs -> RnM (a, Uses) rnSpliceGen HsSplice (GhcPass 'Renamed) -> RnM (a, Uses) run_splice HsSplice (GhcPass 'Renamed) -> (PendingRnSplice, a) pend_splice HsSplice GhcPs splice = MsgDoc -> RnM (a, Uses) -> RnM (a, Uses) forall a. MsgDoc -> TcM a -> TcM a addErrCtxt (HsSplice GhcPs -> MsgDoc spliceCtxt HsSplice GhcPs splice) (RnM (a, Uses) -> RnM (a, Uses)) -> RnM (a, Uses) -> RnM (a, Uses) forall a b. (a -> b) -> a -> b $ do { ThStage stage <- TcM ThStage getStage ; case ThStage stage of Brack ThStage pop_stage PendingStuff RnPendingTyped -> do { Bool -> MsgDoc -> IOEnv (Env TcGblEnv TcLclEnv) () checkTc Bool is_typed_splice MsgDoc illegalUntypedSplice ; (HsSplice (GhcPass 'Renamed) splice', Uses fvs) <- ThStage -> TcM (HsSplice (GhcPass 'Renamed), Uses) -> TcM (HsSplice (GhcPass 'Renamed), Uses) forall a. ThStage -> TcM a -> TcM a setStage ThStage pop_stage (TcM (HsSplice (GhcPass 'Renamed), Uses) -> TcM (HsSplice (GhcPass 'Renamed), Uses)) -> TcM (HsSplice (GhcPass 'Renamed), Uses) -> TcM (HsSplice (GhcPass 'Renamed), Uses) forall a b. (a -> b) -> a -> b $ HsSplice GhcPs -> TcM (HsSplice (GhcPass 'Renamed), Uses) rnSplice HsSplice GhcPs splice ; let (PendingRnSplice _pending_splice, a result) = HsSplice (GhcPass 'Renamed) -> (PendingRnSplice, a) pend_splice HsSplice (GhcPass 'Renamed) splice' ; (a, Uses) -> RnM (a, Uses) forall (m :: * -> *) a. Monad m => a -> m a return (a result, Uses fvs) } Brack ThStage pop_stage (RnPendingUntyped IORef [PendingRnSplice] ps_var) -> do { Bool -> MsgDoc -> IOEnv (Env TcGblEnv TcLclEnv) () checkTc (Bool -> Bool not Bool is_typed_splice) MsgDoc illegalTypedSplice ; (HsSplice (GhcPass 'Renamed) splice', Uses fvs) <- ThStage -> TcM (HsSplice (GhcPass 'Renamed), Uses) -> TcM (HsSplice (GhcPass 'Renamed), Uses) forall a. ThStage -> TcM a -> TcM a setStage ThStage pop_stage (TcM (HsSplice (GhcPass 'Renamed), Uses) -> TcM (HsSplice (GhcPass 'Renamed), Uses)) -> TcM (HsSplice (GhcPass 'Renamed), Uses) -> TcM (HsSplice (GhcPass 'Renamed), Uses) forall a b. (a -> b) -> a -> b $ HsSplice GhcPs -> TcM (HsSplice (GhcPass 'Renamed), Uses) rnSplice HsSplice GhcPs splice ; let (PendingRnSplice pending_splice, a result) = HsSplice (GhcPass 'Renamed) -> (PendingRnSplice, a) pend_splice HsSplice (GhcPass 'Renamed) splice' ; [PendingRnSplice] ps <- IORef [PendingRnSplice] -> IOEnv (Env TcGblEnv TcLclEnv) [PendingRnSplice] forall a env. IORef a -> IOEnv env a readMutVar IORef [PendingRnSplice] ps_var ; IORef [PendingRnSplice] -> [PendingRnSplice] -> IOEnv (Env TcGblEnv TcLclEnv) () forall a env. IORef a -> a -> IOEnv env () writeMutVar IORef [PendingRnSplice] ps_var (PendingRnSplice pending_splice PendingRnSplice -> [PendingRnSplice] -> [PendingRnSplice] forall a. a -> [a] -> [a] : [PendingRnSplice] ps) ; (a, Uses) -> RnM (a, Uses) forall (m :: * -> *) a. Monad m => a -> m a return (a result, Uses fvs) } ThStage _ -> do { HsSplice GhcPs -> IOEnv (Env TcGblEnv TcLclEnv) () checkTopSpliceAllowed HsSplice GhcPs splice ; (HsSplice (GhcPass 'Renamed) splice', Uses fvs1) <- TcM (HsSplice (GhcPass 'Renamed), Uses) -> TcM (HsSplice (GhcPass 'Renamed), Uses) forall r. TcM r -> TcM r checkNoErrs (TcM (HsSplice (GhcPass 'Renamed), Uses) -> TcM (HsSplice (GhcPass 'Renamed), Uses)) -> TcM (HsSplice (GhcPass 'Renamed), Uses) -> TcM (HsSplice (GhcPass 'Renamed), Uses) forall a b. (a -> b) -> a -> b $ ThStage -> TcM (HsSplice (GhcPass 'Renamed), Uses) -> TcM (HsSplice (GhcPass 'Renamed), Uses) forall a. ThStage -> TcM a -> TcM a setStage (SpliceType -> ThStage Splice SpliceType splice_type) (TcM (HsSplice (GhcPass 'Renamed), Uses) -> TcM (HsSplice (GhcPass 'Renamed), Uses)) -> TcM (HsSplice (GhcPass 'Renamed), Uses) -> TcM (HsSplice (GhcPass 'Renamed), Uses) forall a b. (a -> b) -> a -> b $ HsSplice GhcPs -> TcM (HsSplice (GhcPass 'Renamed), Uses) rnSplice HsSplice GhcPs splice -- checkNoErrs: don't attempt to run the splice if -- renaming it failed; otherwise we get a cascade of -- errors from e.g. unbound variables ; (a result, Uses fvs2) <- HsSplice (GhcPass 'Renamed) -> RnM (a, Uses) run_splice HsSplice (GhcPass 'Renamed) splice' ; (a, Uses) -> RnM (a, Uses) forall (m :: * -> *) a. Monad m => a -> m a return (a result, Uses fvs1 Uses -> Uses -> Uses `plusFV` Uses fvs2) } } where is_typed_splice :: Bool is_typed_splice = HsSplice GhcPs -> Bool forall id. HsSplice id -> Bool isTypedSplice HsSplice GhcPs splice splice_type :: SpliceType splice_type = if Bool is_typed_splice then SpliceType Typed else SpliceType Untyped -- Nested splices are fine without TemplateHaskell because they -- are not executed until the top-level splice is run. checkTopSpliceAllowed :: HsSplice GhcPs -> RnM () checkTopSpliceAllowed :: HsSplice GhcPs -> IOEnv (Env TcGblEnv TcLclEnv) () checkTopSpliceAllowed HsSplice GhcPs splice = do let (String herald, Extension ext) = HsSplice GhcPs -> (String, Extension) spliceExtension HsSplice GhcPs splice Bool extEnabled <- Extension -> TcRnIf TcGblEnv TcLclEnv Bool forall gbl lcl. Extension -> TcRnIf gbl lcl Bool xoptM Extension ext Bool -> IOEnv (Env TcGblEnv TcLclEnv) () -> IOEnv (Env TcGblEnv TcLclEnv) () forall (f :: * -> *). Applicative f => Bool -> f () -> f () unless Bool extEnabled (MsgDoc -> IOEnv (Env TcGblEnv TcLclEnv) () forall a. MsgDoc -> TcRn a failWith (MsgDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()) -> MsgDoc -> IOEnv (Env TcGblEnv TcLclEnv) () forall a b. (a -> b) -> a -> b $ String -> MsgDoc text String herald MsgDoc -> MsgDoc -> MsgDoc <+> String -> MsgDoc text String "are not permitted without" MsgDoc -> MsgDoc -> MsgDoc <+> Extension -> MsgDoc forall a. Outputable a => a -> MsgDoc ppr Extension ext) where spliceExtension :: HsSplice GhcPs -> (String, LangExt.Extension) spliceExtension :: HsSplice GhcPs -> (String, Extension) spliceExtension (HsQuasiQuote {}) = (String "Quasi-quotes", Extension LangExt.QuasiQuotes) spliceExtension (HsTypedSplice {}) = (String "Top-level splices", Extension LangExt.TemplateHaskell) spliceExtension (HsUntypedSplice {}) = (String "Top-level splices", Extension LangExt.TemplateHaskell) spliceExtension s :: HsSplice GhcPs s@(HsSpliced {}) = String -> MsgDoc -> (String, Extension) forall a. HasCallStack => String -> MsgDoc -> a pprPanic String "spliceExtension" (HsSplice GhcPs -> MsgDoc forall a. Outputable a => a -> MsgDoc ppr HsSplice GhcPs s) ------------------ -- | Returns the result of running a splice and the modFinalizers collected -- during the execution. -- -- See Note [Delaying modFinalizers in untyped splices]. runRnSplice :: UntypedSpliceFlavour -> (LHsExpr GhcTc -> TcRn res) -> (res -> SDoc) -- How to pretty-print res -- Usually just ppr, but not for [Decl] -> HsSplice GhcRn -- Always untyped -> TcRn (res, [ForeignRef (TH.Q ())]) runRnSplice :: forall res. UntypedSpliceFlavour -> (LHsExpr GhcTc -> TcRn res) -> (res -> MsgDoc) -> HsSplice (GhcPass 'Renamed) -> TcRn (res, [ForeignRef (Q ())]) runRnSplice UntypedSpliceFlavour flavour LHsExpr GhcTc -> TcRn res run_meta res -> MsgDoc ppr_res HsSplice (GhcPass 'Renamed) splice = do { HsSplice (GhcPass 'Renamed) splice' <- (Hooks -> Maybe (HsSplice (GhcPass 'Renamed) -> RnM (HsSplice (GhcPass 'Renamed)))) -> (HsSplice (GhcPass 'Renamed) -> RnM (HsSplice (GhcPass 'Renamed))) -> IOEnv (Env TcGblEnv TcLclEnv) (HsSplice (GhcPass 'Renamed) -> RnM (HsSplice (GhcPass 'Renamed))) forall (f :: * -> *) a. (Functor f, HasDynFlags f) => (Hooks -> Maybe a) -> a -> f a getHooked Hooks -> Maybe (HsSplice (GhcPass 'Renamed) -> RnM (HsSplice (GhcPass 'Renamed))) runRnSpliceHook HsSplice (GhcPass 'Renamed) -> RnM (HsSplice (GhcPass 'Renamed)) forall (m :: * -> *) a. Monad m => a -> m a return IOEnv (Env TcGblEnv TcLclEnv) (HsSplice (GhcPass 'Renamed) -> RnM (HsSplice (GhcPass 'Renamed))) -> ((HsSplice (GhcPass 'Renamed) -> RnM (HsSplice (GhcPass 'Renamed))) -> RnM (HsSplice (GhcPass 'Renamed))) -> RnM (HsSplice (GhcPass 'Renamed)) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= ((HsSplice (GhcPass 'Renamed) -> RnM (HsSplice (GhcPass 'Renamed))) -> HsSplice (GhcPass 'Renamed) -> RnM (HsSplice (GhcPass 'Renamed)) forall a b. (a -> b) -> a -> b $ HsSplice (GhcPass 'Renamed) splice) ; let the_expr :: LHsExpr (GhcPass 'Renamed) the_expr = case HsSplice (GhcPass 'Renamed) splice' of HsUntypedSplice XUntypedSplice (GhcPass 'Renamed) _ SpliceDecoration _ IdP (GhcPass 'Renamed) _ LHsExpr (GhcPass 'Renamed) e -> LHsExpr (GhcPass 'Renamed) e HsQuasiQuote XQuasiQuote (GhcPass 'Renamed) _ IdP (GhcPass 'Renamed) _ IdP (GhcPass 'Renamed) q SrcSpan qs FastString str -> UntypedSpliceFlavour -> Name -> SrcSpan -> FastString -> LHsExpr (GhcPass 'Renamed) mkQuasiQuoteExpr UntypedSpliceFlavour flavour Name IdP (GhcPass 'Renamed) q SrcSpan qs FastString str HsTypedSplice {} -> String -> MsgDoc -> LHsExpr (GhcPass 'Renamed) forall a. HasCallStack => String -> MsgDoc -> a pprPanic String "runRnSplice" (HsSplice (GhcPass 'Renamed) -> MsgDoc forall a. Outputable a => a -> MsgDoc ppr HsSplice (GhcPass 'Renamed) splice) HsSpliced {} -> String -> MsgDoc -> LHsExpr (GhcPass 'Renamed) forall a. HasCallStack => String -> MsgDoc -> a pprPanic String "runRnSplice" (HsSplice (GhcPass 'Renamed) -> MsgDoc forall a. Outputable a => a -> MsgDoc ppr HsSplice (GhcPass 'Renamed) splice) -- Typecheck the expression ; Type meta_exp_ty <- Name -> TcM Type tcMetaTy Name meta_ty_name ; LHsExpr GhcTc zonked_q_expr <- LHsExpr GhcTc -> TcM (LHsExpr GhcTc) zonkTopLExpr (LHsExpr GhcTc -> TcM (LHsExpr GhcTc)) -> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b =<< SpliceType -> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc) tcTopSpliceExpr SpliceType Untyped (LHsExpr (GhcPass 'Renamed) -> Type -> TcM (LHsExpr GhcTc) tcCheckPolyExpr LHsExpr (GhcPass 'Renamed) the_expr Type meta_exp_ty) -- Run the expression ; TcRef [ForeignRef (Q ())] mod_finalizers_ref <- [ForeignRef (Q ())] -> TcRnIf TcGblEnv TcLclEnv (TcRef [ForeignRef (Q ())]) forall a gbl lcl. a -> TcRnIf gbl lcl (TcRef a) newTcRef [] ; res result <- ThStage -> TcRn res -> TcRn res forall a. ThStage -> TcM a -> TcM a setStage (TcRef [ForeignRef (Q ())] -> ThStage RunSplice TcRef [ForeignRef (Q ())] mod_finalizers_ref) (TcRn res -> TcRn res) -> TcRn res -> TcRn res forall a b. (a -> b) -> a -> b $ LHsExpr GhcTc -> TcRn res run_meta LHsExpr GhcTc zonked_q_expr ; [ForeignRef (Q ())] mod_finalizers <- TcRef [ForeignRef (Q ())] -> TcRnIf TcGblEnv TcLclEnv [ForeignRef (Q ())] forall a gbl lcl. TcRef a -> TcRnIf gbl lcl a readTcRef TcRef [ForeignRef (Q ())] mod_finalizers_ref ; SpliceInfo -> IOEnv (Env TcGblEnv TcLclEnv) () traceSplice (SpliceInfo :: String -> Maybe (LHsExpr (GhcPass 'Renamed)) -> Bool -> MsgDoc -> SpliceInfo SpliceInfo { spliceDescription :: String spliceDescription = String what , spliceIsDecl :: Bool spliceIsDecl = Bool is_decl , spliceSource :: Maybe (LHsExpr (GhcPass 'Renamed)) spliceSource = LHsExpr (GhcPass 'Renamed) -> Maybe (LHsExpr (GhcPass 'Renamed)) forall a. a -> Maybe a Just LHsExpr (GhcPass 'Renamed) the_expr , spliceGenerated :: MsgDoc spliceGenerated = res -> MsgDoc ppr_res res result }) ; (res, [ForeignRef (Q ())]) -> TcRn (res, [ForeignRef (Q ())]) forall (m :: * -> *) a. Monad m => a -> m a return (res result, [ForeignRef (Q ())] mod_finalizers) } where meta_ty_name :: Name meta_ty_name = case UntypedSpliceFlavour flavour of UntypedSpliceFlavour UntypedExpSplice -> Name expQTyConName UntypedSpliceFlavour UntypedPatSplice -> Name patQTyConName UntypedSpliceFlavour UntypedTypeSplice -> Name typeQTyConName UntypedSpliceFlavour UntypedDeclSplice -> Name decsQTyConName what :: String what = case UntypedSpliceFlavour flavour of UntypedSpliceFlavour UntypedExpSplice -> String "expression" UntypedSpliceFlavour UntypedPatSplice -> String "pattern" UntypedSpliceFlavour UntypedTypeSplice -> String "type" UntypedSpliceFlavour UntypedDeclSplice -> String "declarations" is_decl :: Bool is_decl = case UntypedSpliceFlavour flavour of UntypedSpliceFlavour UntypedDeclSplice -> Bool True UntypedSpliceFlavour _ -> Bool False ------------------ makePending :: UntypedSpliceFlavour -> HsSplice GhcRn -> PendingRnSplice makePending :: UntypedSpliceFlavour -> HsSplice (GhcPass 'Renamed) -> PendingRnSplice makePending UntypedSpliceFlavour flavour (HsUntypedSplice XUntypedSplice (GhcPass 'Renamed) _ SpliceDecoration _ IdP (GhcPass 'Renamed) n LHsExpr (GhcPass 'Renamed) e) = UntypedSpliceFlavour -> Name -> LHsExpr (GhcPass 'Renamed) -> PendingRnSplice PendingRnSplice UntypedSpliceFlavour flavour Name IdP (GhcPass 'Renamed) n LHsExpr (GhcPass 'Renamed) e makePending UntypedSpliceFlavour flavour (HsQuasiQuote XQuasiQuote (GhcPass 'Renamed) _ IdP (GhcPass 'Renamed) n IdP (GhcPass 'Renamed) quoter SrcSpan q_span FastString quote) = UntypedSpliceFlavour -> Name -> LHsExpr (GhcPass 'Renamed) -> PendingRnSplice PendingRnSplice UntypedSpliceFlavour flavour Name IdP (GhcPass 'Renamed) n (UntypedSpliceFlavour -> Name -> SrcSpan -> FastString -> LHsExpr (GhcPass 'Renamed) mkQuasiQuoteExpr UntypedSpliceFlavour flavour Name IdP (GhcPass 'Renamed) quoter SrcSpan q_span FastString quote) makePending UntypedSpliceFlavour _ splice :: HsSplice (GhcPass 'Renamed) splice@(HsTypedSplice {}) = String -> MsgDoc -> PendingRnSplice forall a. HasCallStack => String -> MsgDoc -> a pprPanic String "makePending" (HsSplice (GhcPass 'Renamed) -> MsgDoc forall a. Outputable a => a -> MsgDoc ppr HsSplice (GhcPass 'Renamed) splice) makePending UntypedSpliceFlavour _ splice :: HsSplice (GhcPass 'Renamed) splice@(HsSpliced {}) = String -> MsgDoc -> PendingRnSplice forall a. HasCallStack => String -> MsgDoc -> a pprPanic String "makePending" (HsSplice (GhcPass 'Renamed) -> MsgDoc forall a. Outputable a => a -> MsgDoc ppr HsSplice (GhcPass 'Renamed) splice) ------------------ mkQuasiQuoteExpr :: UntypedSpliceFlavour -> Name -> SrcSpan -> FastString -> LHsExpr GhcRn -- Return the expression (quoter "...quote...") -- which is what we must run in a quasi-quote mkQuasiQuoteExpr :: UntypedSpliceFlavour -> Name -> SrcSpan -> FastString -> LHsExpr (GhcPass 'Renamed) mkQuasiQuoteExpr UntypedSpliceFlavour flavour Name quoter SrcSpan q_span FastString quote = SrcSpan -> HsExpr (GhcPass 'Renamed) -> LHsExpr (GhcPass 'Renamed) forall l e. l -> e -> GenLocated l e L SrcSpan q_span (HsExpr (GhcPass 'Renamed) -> LHsExpr (GhcPass 'Renamed)) -> HsExpr (GhcPass 'Renamed) -> LHsExpr (GhcPass 'Renamed) forall a b. (a -> b) -> a -> b $ XApp (GhcPass 'Renamed) -> LHsExpr (GhcPass 'Renamed) -> LHsExpr (GhcPass 'Renamed) -> HsExpr (GhcPass 'Renamed) forall p. XApp p -> LHsExpr p -> LHsExpr p -> HsExpr p HsApp NoExtField XApp (GhcPass 'Renamed) noExtField (SrcSpan -> HsExpr (GhcPass 'Renamed) -> LHsExpr (GhcPass 'Renamed) forall l e. l -> e -> GenLocated l e L SrcSpan q_span (HsExpr (GhcPass 'Renamed) -> LHsExpr (GhcPass 'Renamed)) -> HsExpr (GhcPass 'Renamed) -> LHsExpr (GhcPass 'Renamed) forall a b. (a -> b) -> a -> b $ XApp (GhcPass 'Renamed) -> LHsExpr (GhcPass 'Renamed) -> LHsExpr (GhcPass 'Renamed) -> HsExpr (GhcPass 'Renamed) forall p. XApp p -> LHsExpr p -> LHsExpr p -> HsExpr p HsApp NoExtField XApp (GhcPass 'Renamed) noExtField (SrcSpan -> HsExpr (GhcPass 'Renamed) -> LHsExpr (GhcPass 'Renamed) forall l e. l -> e -> GenLocated l e L SrcSpan q_span (XVar (GhcPass 'Renamed) -> Located (IdP (GhcPass 'Renamed)) -> HsExpr (GhcPass 'Renamed) forall p. XVar p -> Located (IdP p) -> HsExpr p HsVar NoExtField XVar (GhcPass 'Renamed) noExtField (SrcSpan -> Name -> GenLocated SrcSpan Name forall l e. l -> e -> GenLocated l e L SrcSpan q_span Name quote_selector))) LHsExpr (GhcPass 'Renamed) quoterExpr) LHsExpr (GhcPass 'Renamed) quoteExpr where quoterExpr :: LHsExpr (GhcPass 'Renamed) quoterExpr = SrcSpan -> HsExpr (GhcPass 'Renamed) -> LHsExpr (GhcPass 'Renamed) forall l e. l -> e -> GenLocated l e L SrcSpan q_span (HsExpr (GhcPass 'Renamed) -> LHsExpr (GhcPass 'Renamed)) -> HsExpr (GhcPass 'Renamed) -> LHsExpr (GhcPass 'Renamed) forall a b. (a -> b) -> a -> b $! XVar (GhcPass 'Renamed) -> Located (IdP (GhcPass 'Renamed)) -> HsExpr (GhcPass 'Renamed) forall p. XVar p -> Located (IdP p) -> HsExpr p HsVar NoExtField XVar (GhcPass 'Renamed) noExtField (GenLocated SrcSpan Name -> HsExpr (GhcPass 'Renamed)) -> GenLocated SrcSpan Name -> HsExpr (GhcPass 'Renamed) forall a b. (a -> b) -> a -> b $! (SrcSpan -> Name -> GenLocated SrcSpan Name forall l e. l -> e -> GenLocated l e L SrcSpan q_span Name quoter) quoteExpr :: LHsExpr (GhcPass 'Renamed) quoteExpr = SrcSpan -> HsExpr (GhcPass 'Renamed) -> LHsExpr (GhcPass 'Renamed) forall l e. l -> e -> GenLocated l e L SrcSpan q_span (HsExpr (GhcPass 'Renamed) -> LHsExpr (GhcPass 'Renamed)) -> HsExpr (GhcPass 'Renamed) -> LHsExpr (GhcPass 'Renamed) forall a b. (a -> b) -> a -> b $! XLitE (GhcPass 'Renamed) -> HsLit (GhcPass 'Renamed) -> HsExpr (GhcPass 'Renamed) forall p. XLitE p -> HsLit p -> HsExpr p HsLit NoExtField XLitE (GhcPass 'Renamed) noExtField (HsLit (GhcPass 'Renamed) -> HsExpr (GhcPass 'Renamed)) -> HsLit (GhcPass 'Renamed) -> HsExpr (GhcPass 'Renamed) forall a b. (a -> b) -> a -> b $! XHsString (GhcPass 'Renamed) -> FastString -> HsLit (GhcPass 'Renamed) forall x. XHsString x -> FastString -> HsLit x HsString SourceText XHsString (GhcPass 'Renamed) NoSourceText FastString quote quote_selector :: Name quote_selector = case UntypedSpliceFlavour flavour of UntypedSpliceFlavour UntypedExpSplice -> Name quoteExpName UntypedSpliceFlavour UntypedPatSplice -> Name quotePatName UntypedSpliceFlavour UntypedTypeSplice -> Name quoteTypeName UntypedSpliceFlavour UntypedDeclSplice -> Name quoteDecName --------------------- rnSplice :: HsSplice GhcPs -> RnM (HsSplice GhcRn, FreeVars) -- Not exported...used for all rnSplice :: HsSplice GhcPs -> TcM (HsSplice (GhcPass 'Renamed), Uses) rnSplice (HsTypedSplice XTypedSplice GhcPs x SpliceDecoration hasParen IdP GhcPs splice_name LHsExpr GhcPs expr) = do { SrcSpan loc <- TcRn SrcSpan getSrcSpanM ; Name n' <- Located RdrName -> RnM Name newLocalBndrRn (SrcSpan -> RdrName -> Located RdrName forall l e. l -> e -> GenLocated l e L SrcSpan loc RdrName IdP GhcPs splice_name) ; (LHsExpr (GhcPass 'Renamed) expr', Uses fvs) <- LHsExpr GhcPs -> RnM (LHsExpr (GhcPass 'Renamed), Uses) rnLExpr LHsExpr GhcPs expr ; (HsSplice (GhcPass 'Renamed), Uses) -> TcM (HsSplice (GhcPass 'Renamed), Uses) forall (m :: * -> *) a. Monad m => a -> m a return (XTypedSplice (GhcPass 'Renamed) -> SpliceDecoration -> IdP (GhcPass 'Renamed) -> LHsExpr (GhcPass 'Renamed) -> HsSplice (GhcPass 'Renamed) forall id. XTypedSplice id -> SpliceDecoration -> IdP id -> LHsExpr id -> HsSplice id HsTypedSplice XTypedSplice GhcPs XTypedSplice (GhcPass 'Renamed) x SpliceDecoration hasParen Name IdP (GhcPass 'Renamed) n' LHsExpr (GhcPass 'Renamed) expr', Uses fvs) } rnSplice (HsUntypedSplice XUntypedSplice GhcPs x SpliceDecoration hasParen IdP GhcPs splice_name LHsExpr GhcPs expr) = do { SrcSpan loc <- TcRn SrcSpan getSrcSpanM ; Name n' <- Located RdrName -> RnM Name newLocalBndrRn (SrcSpan -> RdrName -> Located RdrName forall l e. l -> e -> GenLocated l e L SrcSpan loc RdrName IdP GhcPs splice_name) ; (LHsExpr (GhcPass 'Renamed) expr', Uses fvs) <- LHsExpr GhcPs -> RnM (LHsExpr (GhcPass 'Renamed), Uses) rnLExpr LHsExpr GhcPs expr ; (HsSplice (GhcPass 'Renamed), Uses) -> TcM (HsSplice (GhcPass 'Renamed), Uses) forall (m :: * -> *) a. Monad m => a -> m a return (XUntypedSplice (GhcPass 'Renamed) -> SpliceDecoration -> IdP (GhcPass 'Renamed) -> LHsExpr (GhcPass 'Renamed) -> HsSplice (GhcPass 'Renamed) forall id. XUntypedSplice id -> SpliceDecoration -> IdP id -> LHsExpr id -> HsSplice id HsUntypedSplice XUntypedSplice GhcPs XUntypedSplice (GhcPass 'Renamed) x SpliceDecoration hasParen Name IdP (GhcPass 'Renamed) n' LHsExpr (GhcPass 'Renamed) expr', Uses fvs) } rnSplice (HsQuasiQuote XQuasiQuote GhcPs x IdP GhcPs splice_name IdP GhcPs quoter SrcSpan q_loc FastString quote) = do { SrcSpan loc <- TcRn SrcSpan getSrcSpanM ; Name splice_name' <- Located RdrName -> RnM Name newLocalBndrRn (SrcSpan -> RdrName -> Located RdrName forall l e. l -> e -> GenLocated l e L SrcSpan loc RdrName IdP GhcPs splice_name) -- Rename the quoter; akin to the HsVar case of rnExpr ; Name quoter' <- RdrName -> RnM Name lookupOccRn RdrName IdP GhcPs quoter ; Module this_mod <- IOEnv (Env TcGblEnv TcLclEnv) Module forall (m :: * -> *). HasModule m => m Module getModule ; Bool -> IOEnv (Env TcGblEnv TcLclEnv) () -> IOEnv (Env TcGblEnv TcLclEnv) () forall (f :: * -> *). Applicative f => Bool -> f () -> f () when (Module -> Name -> Bool nameIsLocalOrFrom Module this_mod Name quoter') (IOEnv (Env TcGblEnv TcLclEnv) () -> IOEnv (Env TcGblEnv TcLclEnv) ()) -> IOEnv (Env TcGblEnv TcLclEnv) () -> IOEnv (Env TcGblEnv TcLclEnv) () forall a b. (a -> b) -> a -> b $ Name -> IOEnv (Env TcGblEnv TcLclEnv) () checkThLocalName Name quoter' ; (HsSplice (GhcPass 'Renamed), Uses) -> TcM (HsSplice (GhcPass 'Renamed), Uses) forall (m :: * -> *) a. Monad m => a -> m a return (XQuasiQuote (GhcPass 'Renamed) -> IdP (GhcPass 'Renamed) -> IdP (GhcPass 'Renamed) -> SrcSpan -> FastString -> HsSplice (GhcPass 'Renamed) forall id. XQuasiQuote id -> IdP id -> IdP id -> SrcSpan -> FastString -> HsSplice id HsQuasiQuote XQuasiQuote GhcPs XQuasiQuote (GhcPass 'Renamed) x Name IdP (GhcPass 'Renamed) splice_name' Name IdP (GhcPass 'Renamed) quoter' SrcSpan q_loc FastString quote , Name -> Uses unitFV Name quoter') } rnSplice splice :: HsSplice GhcPs splice@(HsSpliced {}) = String -> MsgDoc -> TcM (HsSplice (GhcPass 'Renamed), Uses) forall a. HasCallStack => String -> MsgDoc -> a pprPanic String "rnSplice" (HsSplice GhcPs -> MsgDoc forall a. Outputable a => a -> MsgDoc ppr HsSplice GhcPs splice) --------------------- rnSpliceExpr :: HsSplice GhcPs -> RnM (HsExpr GhcRn, FreeVars) rnSpliceExpr :: HsSplice GhcPs -> RnM (HsExpr (GhcPass 'Renamed), Uses) rnSpliceExpr HsSplice GhcPs splice = (HsSplice (GhcPass 'Renamed) -> RnM (HsExpr (GhcPass 'Renamed), Uses)) -> (HsSplice (GhcPass 'Renamed) -> (PendingRnSplice, HsExpr (GhcPass 'Renamed))) -> HsSplice GhcPs -> RnM (HsExpr (GhcPass 'Renamed), Uses) forall a. (HsSplice (GhcPass 'Renamed) -> RnM (a, Uses)) -> (HsSplice (GhcPass 'Renamed) -> (PendingRnSplice, a)) -> HsSplice GhcPs -> RnM (a, Uses) rnSpliceGen HsSplice (GhcPass 'Renamed) -> RnM (HsExpr (GhcPass 'Renamed), Uses) run_expr_splice HsSplice (GhcPass 'Renamed) -> (PendingRnSplice, HsExpr (GhcPass 'Renamed)) pend_expr_splice HsSplice GhcPs splice where pend_expr_splice :: HsSplice GhcRn -> (PendingRnSplice, HsExpr GhcRn) pend_expr_splice :: HsSplice (GhcPass 'Renamed) -> (PendingRnSplice, HsExpr (GhcPass 'Renamed)) pend_expr_splice HsSplice (GhcPass 'Renamed) rn_splice = (UntypedSpliceFlavour -> HsSplice (GhcPass 'Renamed) -> PendingRnSplice makePending UntypedSpliceFlavour UntypedExpSplice HsSplice (GhcPass 'Renamed) rn_splice, XSpliceE (GhcPass 'Renamed) -> HsSplice (GhcPass 'Renamed) -> HsExpr (GhcPass 'Renamed) forall p. XSpliceE p -> HsSplice p -> HsExpr p HsSpliceE NoExtField XSpliceE (GhcPass 'Renamed) noExtField HsSplice (GhcPass 'Renamed) rn_splice) run_expr_splice :: HsSplice GhcRn -> RnM (HsExpr GhcRn, FreeVars) run_expr_splice :: HsSplice (GhcPass 'Renamed) -> RnM (HsExpr (GhcPass 'Renamed), Uses) run_expr_splice HsSplice (GhcPass 'Renamed) rn_splice | HsSplice (GhcPass 'Renamed) -> Bool forall id. HsSplice id -> Bool isTypedSplice HsSplice (GhcPass 'Renamed) rn_splice -- Run it later, in the type checker = do { -- Ugh! See Note [Splices] above String -> MsgDoc -> IOEnv (Env TcGblEnv TcLclEnv) () traceRn String "rnSpliceExpr: typed expression splice" MsgDoc empty ; LocalRdrEnv lcl_rdr <- RnM LocalRdrEnv getLocalRdrEnv ; GlobalRdrEnv gbl_rdr <- TcRn GlobalRdrEnv getGlobalRdrEnv ; let gbl_names :: Uses gbl_names = [Name] -> Uses mkNameSet [GlobalRdrElt -> Name gre_name GlobalRdrElt gre | GlobalRdrElt gre <- GlobalRdrEnv -> [GlobalRdrElt] globalRdrEnvElts GlobalRdrEnv gbl_rdr , GlobalRdrElt -> Bool isLocalGRE GlobalRdrElt gre] lcl_names :: Uses lcl_names = [Name] -> Uses mkNameSet (LocalRdrEnv -> [Name] localRdrEnvElts LocalRdrEnv lcl_rdr) ; (HsExpr (GhcPass 'Renamed), Uses) -> RnM (HsExpr (GhcPass 'Renamed), Uses) forall (m :: * -> *) a. Monad m => a -> m a return (XSpliceE (GhcPass 'Renamed) -> HsSplice (GhcPass 'Renamed) -> HsExpr (GhcPass 'Renamed) forall p. XSpliceE p -> HsSplice p -> HsExpr p HsSpliceE NoExtField XSpliceE (GhcPass 'Renamed) noExtField HsSplice (GhcPass 'Renamed) rn_splice, Uses lcl_names Uses -> Uses -> Uses `plusFV` Uses gbl_names) } | Bool otherwise -- Run it here, see Note [Running splices in the Renamer] = do { String -> MsgDoc -> IOEnv (Env TcGblEnv TcLclEnv) () traceRn String "rnSpliceExpr: untyped expression splice" MsgDoc empty ; (LHsExpr GhcPs rn_expr, [ForeignRef (Q ())] mod_finalizers) <- UntypedSpliceFlavour -> (LHsExpr GhcTc -> TcRn (LHsExpr GhcPs)) -> (LHsExpr GhcPs -> MsgDoc) -> HsSplice (GhcPass 'Renamed) -> TcRn (LHsExpr GhcPs, [ForeignRef (Q ())]) forall res. UntypedSpliceFlavour -> (LHsExpr GhcTc -> TcRn res) -> (res -> MsgDoc) -> HsSplice (GhcPass 'Renamed) -> TcRn (res, [ForeignRef (Q ())]) runRnSplice UntypedSpliceFlavour UntypedExpSplice LHsExpr GhcTc -> TcRn (LHsExpr GhcPs) runMetaE LHsExpr GhcPs -> MsgDoc forall a. Outputable a => a -> MsgDoc ppr HsSplice (GhcPass 'Renamed) rn_splice ; (LHsExpr (GhcPass 'Renamed) lexpr3, Uses fvs) <- RnM (LHsExpr (GhcPass 'Renamed), Uses) -> RnM (LHsExpr (GhcPass 'Renamed), Uses) forall r. TcM r -> TcM r checkNoErrs (LHsExpr GhcPs -> RnM (LHsExpr (GhcPass 'Renamed), Uses) rnLExpr LHsExpr GhcPs rn_expr) -- See Note [Delaying modFinalizers in untyped splices]. ; (HsExpr (GhcPass 'Renamed), Uses) -> RnM (HsExpr (GhcPass 'Renamed), Uses) forall (m :: * -> *) a. Monad m => a -> m a return ( XPar (GhcPass 'Renamed) -> LHsExpr (GhcPass 'Renamed) -> HsExpr (GhcPass 'Renamed) forall p. XPar p -> LHsExpr p -> HsExpr p HsPar NoExtField XPar (GhcPass 'Renamed) noExtField (LHsExpr (GhcPass 'Renamed) -> HsExpr (GhcPass 'Renamed)) -> LHsExpr (GhcPass 'Renamed) -> HsExpr (GhcPass 'Renamed) forall a b. (a -> b) -> a -> b $ XSpliceE (GhcPass 'Renamed) -> HsSplice (GhcPass 'Renamed) -> HsExpr (GhcPass 'Renamed) forall p. XSpliceE p -> HsSplice p -> HsExpr p HsSpliceE NoExtField XSpliceE (GhcPass 'Renamed) noExtField (HsSplice (GhcPass 'Renamed) -> HsExpr (GhcPass 'Renamed)) -> (HsExpr (GhcPass 'Renamed) -> HsSplice (GhcPass 'Renamed)) -> HsExpr (GhcPass 'Renamed) -> HsExpr (GhcPass 'Renamed) forall b c a. (b -> c) -> (a -> b) -> a -> c . XSpliced (GhcPass 'Renamed) -> ThModFinalizers -> HsSplicedThing (GhcPass 'Renamed) -> HsSplice (GhcPass 'Renamed) forall id. XSpliced id -> ThModFinalizers -> HsSplicedThing id -> HsSplice id HsSpliced NoExtField XSpliced (GhcPass 'Renamed) noExtField ([ForeignRef (Q ())] -> ThModFinalizers ThModFinalizers [ForeignRef (Q ())] mod_finalizers) (HsSplicedThing (GhcPass 'Renamed) -> HsSplice (GhcPass 'Renamed)) -> (HsExpr (GhcPass 'Renamed) -> HsSplicedThing (GhcPass 'Renamed)) -> HsExpr (GhcPass 'Renamed) -> HsSplice (GhcPass 'Renamed) forall b c a. (b -> c) -> (a -> b) -> a -> c . HsExpr (GhcPass 'Renamed) -> HsSplicedThing (GhcPass 'Renamed) forall id. HsExpr id -> HsSplicedThing id HsSplicedExpr (HsExpr (GhcPass 'Renamed) -> HsExpr (GhcPass 'Renamed)) -> LHsExpr (GhcPass 'Renamed) -> LHsExpr (GhcPass 'Renamed) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> LHsExpr (GhcPass 'Renamed) lexpr3 , Uses fvs) } {- Note [Running splices in the Renamer] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Splices used to be run in the typechecker, which led to (#4364). Since the renamer must decide which expressions depend on which others, and it cannot reliably do this for arbitrary splices, we used to conservatively say that splices depend on all other expressions in scope. Unfortunately, this led to the problem of cyclic type declarations seen in (#4364). Instead, by running splices in the renamer, we side-step the problem of determining dependencies: by the time the dependency analysis happens, any splices have already been run, and expression dependencies can be determined as usual. However, see (#9813), for an example where we would like to run splices *after* performing dependency analysis (that is, after renaming). It would be desirable to typecheck "non-splicy" expressions (those expressions that do not contain splices directly or via dependence on an expression that does) before "splicy" expressions, such that types/expressions within the same declaration group would be available to `reify` calls, for example consider the following: > module M where > data D = C > f = 1 > g = $(mapM reify ['f, 'D, ''C] ...) Compilation of this example fails since D/C/f are not in the type environment and thus cannot be reified as they have not been typechecked by the time the splice is renamed and thus run. These requirements are at odds: we do not want to run splices in the renamer as we wish to first determine dependencies and typecheck certain expressions, making them available to reify, but cannot accurately determine dependencies without running splices in the renamer! Indeed, the conclusion of (#9813) was that it is not worth the complexity to try and a) implement and maintain the code for renaming/typechecking non-splicy expressions before splicy expressions, b) explain to TH users which expressions are/not available to reify at any given point. -} {- Note [Rebindable syntax and Template Haskell] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When processing Template Haskell quotes with Rebindable Syntax (RS) enabled, there are two possibilities: apply the RS rules to the quotes or don't. One might expect that with {-# LANGUAGE RebindableSyntax #-} at the top of a module, any 'if' expression would end up being turned into a call to whatever 'ifThenElse' function is in scope, regardless of whether the said if expression appears in "normal" Haskell code or in a TH quote. This however comes with its problems. Consider the following code: {-# LANGUAGE TemplateHaskell, RebindableSyntax #-} module X where import Prelude ( Monad(..), Bool(..), print, ($) ) import Language.Haskell.TH.Syntax $( do stuff <- [| if True then 10 else 15 |] runIO $ print stuff return [] ) If we apply the RS rules, then GHC would complain about not having suitable fromInteger/ifThenElse functions in scope. But this quote is just a bit of Haskell syntax that has yet to be used, or, to put it differently, placed (spliced) in some context where the said functions might be available. More generally, untyped TH quotes are meant to work with yet-unbound identifiers. This tends to show that untyped TH and Rebindable Syntax overall don't play well together. Users still have the option to splice "normal" if expressions into modules where RS is enabled, to turn them into applications of an 'ifThenElse' function of their choice. Typed TH (TTH) quotes, on the other hand, come with different constraints. They don't quite have this "delayed" nature: we typecheck them while processing them, and TTH users expect RS to Just Work in their quotes, exactly like it does outside of the quotes. There, we do not have to accept unbound identifiers and we can apply the RS rules both in the typechecking and desugaring of the quotes without triggering surprising/bad behaviour for users. For instance, the following code is expected to be rejected (because of the lack of suitable 'fromInteger'/'ifThenElse' functions in scope): {-# LANGUAGE TemplateHaskell, RebindableSyntax #-} module X where import Prelude ( Monad(..), Bool(..), print, ($) ) import Language.Haskell.TH.Syntax $$( do stuff <- [|| if True then 10 else 15 ||] runIO $ print stuff return [] ) The conclusion is that even if RS is enabled for a given module, GHC disables it when processing untyped TH quotes from that module, to avoid the aforementioned problems, but keeps it on while processing typed TH quotes. This note and approach originated in #18102. -} {- Note [Delaying modFinalizers in untyped splices] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When splices run in the renamer, 'reify' does not have access to the local type environment (#11832, [1]). For instance, in > let x = e in $(reify (mkName "x") >>= runIO . print >> [| return () |]) 'reify' cannot find @x@, because the local type environment is not yet populated. To address this, we allow 'reify' execution to be deferred with 'addModFinalizer'. > let x = e in $(do addModFinalizer (reify (mkName "x") >>= runIO . print) [| return () |] ) The finalizer is run with the local type environment when type checking is complete. Since the local type environment is not available in the renamer, we annotate the tree at the splice point [2] with @HsSpliceE (HsSpliced finalizers e)@ where @e@ is the result of splicing and @finalizers@ are the finalizers that have been collected during evaluation of the splice [3]. In our example, > HsLet > (x = e) > (HsSpliceE $ HsSpliced [reify (mkName "x") >>= runIO . print] > (HsSplicedExpr $ return ()) > ) When the typechecker finds the annotation, it inserts the finalizers in the global environment and exposes the current local environment to them [4, 5, 6]. > addModFinalizersWithLclEnv [reify (mkName "x") >>= runIO . print] References: [1] https://gitlab.haskell.org/ghc/ghc/wikis/template-haskell/reify [2] 'rnSpliceExpr' [3] 'GHC.Tc.Gen.Splice.qAddModFinalizer' [4] 'GHC.Tc.Gen.Expr.tcExpr' ('HsSpliceE' ('HsSpliced' ...)) [5] 'GHC.Tc.Gen.HsType.tc_hs_type' ('HsSpliceTy' ('HsSpliced' ...)) [6] 'GHC.Tc.Gen.Pat.tc_pat' ('SplicePat' ('HsSpliced' ...)) -} ---------------------- rnSpliceType :: HsSplice GhcPs -> RnM (HsType GhcRn, FreeVars) rnSpliceType :: HsSplice GhcPs -> RnM (HsType (GhcPass 'Renamed), Uses) rnSpliceType HsSplice GhcPs splice = (HsSplice (GhcPass 'Renamed) -> RnM (HsType (GhcPass 'Renamed), Uses)) -> (HsSplice (GhcPass 'Renamed) -> (PendingRnSplice, HsType (GhcPass 'Renamed))) -> HsSplice GhcPs -> RnM (HsType (GhcPass 'Renamed), Uses) forall a. (HsSplice (GhcPass 'Renamed) -> RnM (a, Uses)) -> (HsSplice (GhcPass 'Renamed) -> (PendingRnSplice, a)) -> HsSplice GhcPs -> RnM (a, Uses) rnSpliceGen HsSplice (GhcPass 'Renamed) -> RnM (HsType (GhcPass 'Renamed), Uses) run_type_splice HsSplice (GhcPass 'Renamed) -> (PendingRnSplice, HsType (GhcPass 'Renamed)) pend_type_splice HsSplice GhcPs splice where pend_type_splice :: HsSplice (GhcPass 'Renamed) -> (PendingRnSplice, HsType (GhcPass 'Renamed)) pend_type_splice HsSplice (GhcPass 'Renamed) rn_splice = ( UntypedSpliceFlavour -> HsSplice (GhcPass 'Renamed) -> PendingRnSplice makePending UntypedSpliceFlavour UntypedTypeSplice HsSplice (GhcPass 'Renamed) rn_splice , XSpliceTy (GhcPass 'Renamed) -> HsSplice (GhcPass 'Renamed) -> HsType (GhcPass 'Renamed) forall pass. XSpliceTy pass -> HsSplice pass -> HsType pass HsSpliceTy NoExtField XSpliceTy (GhcPass 'Renamed) noExtField HsSplice (GhcPass 'Renamed) rn_splice) run_type_splice :: HsSplice (GhcPass 'Renamed) -> RnM (HsType (GhcPass 'Renamed), Uses) run_type_splice HsSplice (GhcPass 'Renamed) rn_splice = do { String -> MsgDoc -> IOEnv (Env TcGblEnv TcLclEnv) () traceRn String "rnSpliceType: untyped type splice" MsgDoc empty ; (LHsType GhcPs hs_ty2, [ForeignRef (Q ())] mod_finalizers) <- UntypedSpliceFlavour -> (LHsExpr GhcTc -> TcRn (LHsType GhcPs)) -> (LHsType GhcPs -> MsgDoc) -> HsSplice (GhcPass 'Renamed) -> TcRn (LHsType GhcPs, [ForeignRef (Q ())]) forall res. UntypedSpliceFlavour -> (LHsExpr GhcTc -> TcRn res) -> (res -> MsgDoc) -> HsSplice (GhcPass 'Renamed) -> TcRn (res, [ForeignRef (Q ())]) runRnSplice UntypedSpliceFlavour UntypedTypeSplice LHsExpr GhcTc -> TcRn (LHsType GhcPs) runMetaT LHsType GhcPs -> MsgDoc forall a. Outputable a => a -> MsgDoc ppr HsSplice (GhcPass 'Renamed) rn_splice ; (LHsType (GhcPass 'Renamed) hs_ty3, Uses fvs) <- do { let doc :: HsDocContext doc = LHsType GhcPs -> HsDocContext SpliceTypeCtx LHsType GhcPs hs_ty2 ; RnM (LHsType (GhcPass 'Renamed), Uses) -> RnM (LHsType (GhcPass 'Renamed), Uses) forall r. TcM r -> TcM r checkNoErrs (RnM (LHsType (GhcPass 'Renamed), Uses) -> RnM (LHsType (GhcPass 'Renamed), Uses)) -> RnM (LHsType (GhcPass 'Renamed), Uses) -> RnM (LHsType (GhcPass 'Renamed), Uses) forall a b. (a -> b) -> a -> b $ HsDocContext -> LHsType GhcPs -> RnM (LHsType (GhcPass 'Renamed), Uses) rnLHsType HsDocContext doc LHsType GhcPs hs_ty2 } -- checkNoErrs: see Note [Renamer errors] -- See Note [Delaying modFinalizers in untyped splices]. ; (HsType (GhcPass 'Renamed), Uses) -> RnM (HsType (GhcPass 'Renamed), Uses) forall (m :: * -> *) a. Monad m => a -> m a return ( XParTy (GhcPass 'Renamed) -> LHsType (GhcPass 'Renamed) -> HsType (GhcPass 'Renamed) forall pass. XParTy pass -> LHsType pass -> HsType pass HsParTy NoExtField XParTy (GhcPass 'Renamed) noExtField (LHsType (GhcPass 'Renamed) -> HsType (GhcPass 'Renamed)) -> LHsType (GhcPass 'Renamed) -> HsType (GhcPass 'Renamed) forall a b. (a -> b) -> a -> b $ XSpliceTy (GhcPass 'Renamed) -> HsSplice (GhcPass 'Renamed) -> HsType (GhcPass 'Renamed) forall pass. XSpliceTy pass -> HsSplice pass -> HsType pass HsSpliceTy NoExtField XSpliceTy (GhcPass 'Renamed) noExtField (HsSplice (GhcPass 'Renamed) -> HsType (GhcPass 'Renamed)) -> (HsType (GhcPass 'Renamed) -> HsSplice (GhcPass 'Renamed)) -> HsType (GhcPass 'Renamed) -> HsType (GhcPass 'Renamed) forall b c a. (b -> c) -> (a -> b) -> a -> c . XSpliced (GhcPass 'Renamed) -> ThModFinalizers -> HsSplicedThing (GhcPass 'Renamed) -> HsSplice (GhcPass 'Renamed) forall id. XSpliced id -> ThModFinalizers -> HsSplicedThing id -> HsSplice id HsSpliced NoExtField XSpliced (GhcPass 'Renamed) noExtField ([ForeignRef (Q ())] -> ThModFinalizers ThModFinalizers [ForeignRef (Q ())] mod_finalizers) (HsSplicedThing (GhcPass 'Renamed) -> HsSplice (GhcPass 'Renamed)) -> (HsType (GhcPass 'Renamed) -> HsSplicedThing (GhcPass 'Renamed)) -> HsType (GhcPass 'Renamed) -> HsSplice (GhcPass 'Renamed) forall b c a. (b -> c) -> (a -> b) -> a -> c . HsType (GhcPass 'Renamed) -> HsSplicedThing (GhcPass 'Renamed) forall id. HsType id -> HsSplicedThing id HsSplicedTy (HsType (GhcPass 'Renamed) -> HsType (GhcPass 'Renamed)) -> LHsType (GhcPass 'Renamed) -> LHsType (GhcPass 'Renamed) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> LHsType (GhcPass 'Renamed) hs_ty3 , Uses fvs ) } -- Wrap the result of the splice in parens so that we don't -- lose the outermost location set by runQuasiQuote (#7918) {- Note [Partial Type Splices] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Partial Type Signatures are partially supported in TH type splices: only anonymous wild cards are allowed. -- ToDo: SLPJ says: I don't understand all this Normally, named wild cards are collected before renaming a (partial) type signature. However, TH type splices are run during renaming, i.e. after the initial traversal, leading to out of scope errors for named wild cards. We can't just extend the initial traversal to collect the named wild cards in TH type splices, as we'd need to expand them, which is supposed to happen only once, during renaming. Similarly, the extra-constraints wild card is handled right before renaming too, and is therefore also not supported in a TH type splice. Another reason to forbid extra-constraints wild cards in TH type splices is that a single signature can contain many TH type splices, whereas it mustn't contain more than one extra-constraints wild card. Enforcing would this be hard the way things are currently organised. Anonymous wild cards pose no problem, because they start out without names and are given names during renaming. These names are collected right after renaming. The names generated for anonymous wild cards in TH type splices will thus be collected as well. For more details about renaming wild cards, see GHC.Rename.HsType.rnHsSigWcType Note that partial type signatures are fully supported in TH declaration splices, e.g.: [d| foo :: _ => _ foo x y = x == y |] This is because in this case, the partial type signature can be treated as a whole signature, instead of as an arbitrary type. -} ---------------------- -- | Rename a splice pattern. See Note [rnSplicePat] rnSplicePat :: HsSplice GhcPs -> RnM ( Either (Pat GhcPs) (Pat GhcRn) , FreeVars) rnSplicePat :: HsSplice GhcPs -> RnM (Either (Pat GhcPs) (Pat (GhcPass 'Renamed)), Uses) rnSplicePat HsSplice GhcPs splice = (HsSplice (GhcPass 'Renamed) -> RnM (Either (Pat GhcPs) (Pat (GhcPass 'Renamed)), Uses)) -> (HsSplice (GhcPass 'Renamed) -> (PendingRnSplice, Either (Pat GhcPs) (Pat (GhcPass 'Renamed)))) -> HsSplice GhcPs -> RnM (Either (Pat GhcPs) (Pat (GhcPass 'Renamed)), Uses) forall a. (HsSplice (GhcPass 'Renamed) -> RnM (a, Uses)) -> (HsSplice (GhcPass 'Renamed) -> (PendingRnSplice, a)) -> HsSplice GhcPs -> RnM (a, Uses) rnSpliceGen HsSplice (GhcPass 'Renamed) -> RnM (Either (Pat GhcPs) (Pat (GhcPass 'Renamed)), Uses) run_pat_splice HsSplice (GhcPass 'Renamed) -> (PendingRnSplice, Either (Pat GhcPs) (Pat (GhcPass 'Renamed))) forall b. HsSplice (GhcPass 'Renamed) -> (PendingRnSplice, Either b (Pat (GhcPass 'Renamed))) pend_pat_splice HsSplice GhcPs splice where pend_pat_splice :: HsSplice GhcRn -> (PendingRnSplice, Either b (Pat GhcRn)) pend_pat_splice :: forall b. HsSplice (GhcPass 'Renamed) -> (PendingRnSplice, Either b (Pat (GhcPass 'Renamed))) pend_pat_splice HsSplice (GhcPass 'Renamed) rn_splice = (UntypedSpliceFlavour -> HsSplice (GhcPass 'Renamed) -> PendingRnSplice makePending UntypedSpliceFlavour UntypedPatSplice HsSplice (GhcPass 'Renamed) rn_splice , Pat (GhcPass 'Renamed) -> Either b (Pat (GhcPass 'Renamed)) forall a b. b -> Either a b Right (XSplicePat (GhcPass 'Renamed) -> HsSplice (GhcPass 'Renamed) -> Pat (GhcPass 'Renamed) forall p. XSplicePat p -> HsSplice p -> Pat p SplicePat NoExtField XSplicePat (GhcPass 'Renamed) noExtField HsSplice (GhcPass 'Renamed) rn_splice)) run_pat_splice :: HsSplice GhcRn -> RnM (Either (Pat GhcPs) (Pat GhcRn), FreeVars) run_pat_splice :: HsSplice (GhcPass 'Renamed) -> RnM (Either (Pat GhcPs) (Pat (GhcPass 'Renamed)), Uses) run_pat_splice HsSplice (GhcPass 'Renamed) rn_splice = do { String -> MsgDoc -> IOEnv (Env TcGblEnv TcLclEnv) () traceRn String "rnSplicePat: untyped pattern splice" MsgDoc empty ; (GenLocated SrcSpan (Pat GhcPs) pat, [ForeignRef (Q ())] mod_finalizers) <- UntypedSpliceFlavour -> (LHsExpr GhcTc -> TcRn (GenLocated SrcSpan (Pat GhcPs))) -> (GenLocated SrcSpan (Pat GhcPs) -> MsgDoc) -> HsSplice (GhcPass 'Renamed) -> TcRn (GenLocated SrcSpan (Pat GhcPs), [ForeignRef (Q ())]) forall res. UntypedSpliceFlavour -> (LHsExpr GhcTc -> TcRn res) -> (res -> MsgDoc) -> HsSplice (GhcPass 'Renamed) -> TcRn (res, [ForeignRef (Q ())]) runRnSplice UntypedSpliceFlavour UntypedPatSplice LHsExpr GhcTc -> TcRn (GenLocated SrcSpan (Pat GhcPs)) LHsExpr GhcTc -> TcM (LPat GhcPs) runMetaP GenLocated SrcSpan (Pat GhcPs) -> MsgDoc forall a. Outputable a => a -> MsgDoc ppr HsSplice (GhcPass 'Renamed) rn_splice -- See Note [Delaying modFinalizers in untyped splices]. ; (Either (Pat GhcPs) (Pat (GhcPass 'Renamed)), Uses) -> RnM (Either (Pat GhcPs) (Pat (GhcPass 'Renamed)), Uses) forall (m :: * -> *) a. Monad m => a -> m a return ( Pat GhcPs -> Either (Pat GhcPs) (Pat (GhcPass 'Renamed)) forall a b. a -> Either a b Left (Pat GhcPs -> Either (Pat GhcPs) (Pat (GhcPass 'Renamed))) -> Pat GhcPs -> Either (Pat GhcPs) (Pat (GhcPass 'Renamed)) forall a b. (a -> b) -> a -> b $ XParPat GhcPs -> LPat GhcPs -> Pat GhcPs forall p. XParPat p -> LPat p -> Pat p ParPat NoExtField XParPat GhcPs noExtField (LPat GhcPs -> Pat GhcPs) -> LPat GhcPs -> Pat GhcPs forall a b. (a -> b) -> a -> b $ ((XSplicePat GhcPs -> HsSplice GhcPs -> Pat GhcPs forall p. XSplicePat p -> HsSplice p -> Pat p SplicePat NoExtField XSplicePat GhcPs noExtField) (HsSplice GhcPs -> Pat GhcPs) -> (Pat GhcPs -> HsSplice GhcPs) -> Pat GhcPs -> Pat GhcPs forall b c a. (b -> c) -> (a -> b) -> a -> c . XSpliced GhcPs -> ThModFinalizers -> HsSplicedThing GhcPs -> HsSplice GhcPs forall id. XSpliced id -> ThModFinalizers -> HsSplicedThing id -> HsSplice id HsSpliced NoExtField XSpliced GhcPs noExtField ([ForeignRef (Q ())] -> ThModFinalizers ThModFinalizers [ForeignRef (Q ())] mod_finalizers) (HsSplicedThing GhcPs -> HsSplice GhcPs) -> (Pat GhcPs -> HsSplicedThing GhcPs) -> Pat GhcPs -> HsSplice GhcPs forall b c a. (b -> c) -> (a -> b) -> a -> c . Pat GhcPs -> HsSplicedThing GhcPs forall id. Pat id -> HsSplicedThing id HsSplicedPat) (Pat GhcPs -> Pat GhcPs) -> GenLocated SrcSpan (Pat GhcPs) -> GenLocated SrcSpan (Pat GhcPs) forall a b l. (a -> b) -> GenLocated l a -> GenLocated l b `mapLoc` GenLocated SrcSpan (Pat GhcPs) pat , Uses emptyFVs ) } -- Wrap the result of the quasi-quoter in parens so that we don't -- lose the outermost location set by runQuasiQuote (#7918) ---------------------- rnSpliceDecl :: SpliceDecl GhcPs -> RnM (SpliceDecl GhcRn, FreeVars) rnSpliceDecl :: SpliceDecl GhcPs -> RnM (SpliceDecl (GhcPass 'Renamed), Uses) rnSpliceDecl (SpliceDecl XSpliceDecl GhcPs _ (L SrcSpan loc HsSplice GhcPs splice) SpliceExplicitFlag flg) = (HsSplice (GhcPass 'Renamed) -> RnM (SpliceDecl (GhcPass 'Renamed), Uses)) -> (HsSplice (GhcPass 'Renamed) -> (PendingRnSplice, SpliceDecl (GhcPass 'Renamed))) -> HsSplice GhcPs -> RnM (SpliceDecl (GhcPass 'Renamed), Uses) forall a. (HsSplice (GhcPass 'Renamed) -> RnM (a, Uses)) -> (HsSplice (GhcPass 'Renamed) -> (PendingRnSplice, a)) -> HsSplice GhcPs -> RnM (a, Uses) rnSpliceGen HsSplice (GhcPass 'Renamed) -> RnM (SpliceDecl (GhcPass 'Renamed), Uses) forall {a} {a}. Outputable a => a -> a run_decl_splice HsSplice (GhcPass 'Renamed) -> (PendingRnSplice, SpliceDecl (GhcPass 'Renamed)) pend_decl_splice HsSplice GhcPs splice where pend_decl_splice :: HsSplice (GhcPass 'Renamed) -> (PendingRnSplice, SpliceDecl (GhcPass 'Renamed)) pend_decl_splice HsSplice (GhcPass 'Renamed) rn_splice = ( UntypedSpliceFlavour -> HsSplice (GhcPass 'Renamed) -> PendingRnSplice makePending UntypedSpliceFlavour UntypedDeclSplice HsSplice (GhcPass 'Renamed) rn_splice , XSpliceDecl (GhcPass 'Renamed) -> Located (HsSplice (GhcPass 'Renamed)) -> SpliceExplicitFlag -> SpliceDecl (GhcPass 'Renamed) forall p. XSpliceDecl p -> Located (HsSplice p) -> SpliceExplicitFlag -> SpliceDecl p SpliceDecl NoExtField XSpliceDecl (GhcPass 'Renamed) noExtField (SrcSpan -> HsSplice (GhcPass 'Renamed) -> Located (HsSplice (GhcPass 'Renamed)) forall l e. l -> e -> GenLocated l e L SrcSpan loc HsSplice (GhcPass 'Renamed) rn_splice) SpliceExplicitFlag flg) run_decl_splice :: a -> a run_decl_splice a rn_splice = String -> MsgDoc -> a forall a. HasCallStack => String -> MsgDoc -> a pprPanic String "rnSpliceDecl" (a -> MsgDoc forall a. Outputable a => a -> MsgDoc ppr a rn_splice) rnTopSpliceDecls :: HsSplice GhcPs -> RnM ([LHsDecl GhcPs], FreeVars) -- Declaration splice at the very top level of the module rnTopSpliceDecls :: HsSplice GhcPs -> RnM ([LHsDecl GhcPs], Uses) rnTopSpliceDecls HsSplice GhcPs splice = do { HsSplice GhcPs -> IOEnv (Env TcGblEnv TcLclEnv) () checkTopSpliceAllowed HsSplice GhcPs splice ; (HsSplice (GhcPass 'Renamed) rn_splice, Uses fvs) <- TcM (HsSplice (GhcPass 'Renamed), Uses) -> TcM (HsSplice (GhcPass 'Renamed), Uses) forall r. TcM r -> TcM r checkNoErrs (TcM (HsSplice (GhcPass 'Renamed), Uses) -> TcM (HsSplice (GhcPass 'Renamed), Uses)) -> TcM (HsSplice (GhcPass 'Renamed), Uses) -> TcM (HsSplice (GhcPass 'Renamed), Uses) forall a b. (a -> b) -> a -> b $ ThStage -> TcM (HsSplice (GhcPass 'Renamed), Uses) -> TcM (HsSplice (GhcPass 'Renamed), Uses) forall a. ThStage -> TcM a -> TcM a setStage (SpliceType -> ThStage Splice SpliceType Untyped) (TcM (HsSplice (GhcPass 'Renamed), Uses) -> TcM (HsSplice (GhcPass 'Renamed), Uses)) -> TcM (HsSplice (GhcPass 'Renamed), Uses) -> TcM (HsSplice (GhcPass 'Renamed), Uses) forall a b. (a -> b) -> a -> b $ HsSplice GhcPs -> TcM (HsSplice (GhcPass 'Renamed), Uses) rnSplice HsSplice GhcPs splice -- As always, be sure to checkNoErrs above lest we end up with -- holes making it to typechecking, hence #12584. -- -- Note that we cannot call checkNoErrs for the whole duration -- of rnTopSpliceDecls. The reason is that checkNoErrs changes -- the local environment to temporarily contain a new -- reference to store errors, and add_mod_finalizers would -- cause this reference to be stored after checkNoErrs finishes. -- This is checked by test TH_finalizer. ; String -> MsgDoc -> IOEnv (Env TcGblEnv TcLclEnv) () traceRn String "rnTopSpliceDecls: untyped declaration splice" MsgDoc empty ; ([LHsDecl GhcPs] decls, [ForeignRef (Q ())] mod_finalizers) <- TcM ([LHsDecl GhcPs], [ForeignRef (Q ())]) -> TcM ([LHsDecl GhcPs], [ForeignRef (Q ())]) forall r. TcM r -> TcM r checkNoErrs (TcM ([LHsDecl GhcPs], [ForeignRef (Q ())]) -> TcM ([LHsDecl GhcPs], [ForeignRef (Q ())])) -> TcM ([LHsDecl GhcPs], [ForeignRef (Q ())]) -> TcM ([LHsDecl GhcPs], [ForeignRef (Q ())]) forall a b. (a -> b) -> a -> b $ UntypedSpliceFlavour -> (LHsExpr GhcTc -> TcRn [LHsDecl GhcPs]) -> ([LHsDecl GhcPs] -> MsgDoc) -> HsSplice (GhcPass 'Renamed) -> TcM ([LHsDecl GhcPs], [ForeignRef (Q ())]) forall res. UntypedSpliceFlavour -> (LHsExpr GhcTc -> TcRn res) -> (res -> MsgDoc) -> HsSplice (GhcPass 'Renamed) -> TcRn (res, [ForeignRef (Q ())]) runRnSplice UntypedSpliceFlavour UntypedDeclSplice LHsExpr GhcTc -> TcRn [LHsDecl GhcPs] runMetaD [LHsDecl GhcPs] -> MsgDoc ppr_decls HsSplice (GhcPass 'Renamed) rn_splice ; [ForeignRef (Q ())] -> IOEnv (Env TcGblEnv TcLclEnv) () add_mod_finalizers_now [ForeignRef (Q ())] mod_finalizers ; ([LHsDecl GhcPs], Uses) -> RnM ([LHsDecl GhcPs], Uses) forall (m :: * -> *) a. Monad m => a -> m a return ([LHsDecl GhcPs] decls,Uses fvs) } where ppr_decls :: [LHsDecl GhcPs] -> SDoc ppr_decls :: [LHsDecl GhcPs] -> MsgDoc ppr_decls [LHsDecl GhcPs] ds = [MsgDoc] -> MsgDoc vcat ((LHsDecl GhcPs -> MsgDoc) -> [LHsDecl GhcPs] -> [MsgDoc] forall a b. (a -> b) -> [a] -> [b] map LHsDecl GhcPs -> MsgDoc forall a. Outputable a => a -> MsgDoc ppr [LHsDecl GhcPs] ds) -- Adds finalizers to the global environment instead of delaying them -- to the type checker. -- -- Declaration splices do not have an interesting local environment so -- there is no point in delaying them. -- -- See Note [Delaying modFinalizers in untyped splices]. add_mod_finalizers_now :: [ForeignRef (TH.Q ())] -> TcRn () add_mod_finalizers_now :: [ForeignRef (Q ())] -> IOEnv (Env TcGblEnv TcLclEnv) () add_mod_finalizers_now [] = () -> IOEnv (Env TcGblEnv TcLclEnv) () forall (m :: * -> *) a. Monad m => a -> m a return () add_mod_finalizers_now [ForeignRef (Q ())] mod_finalizers = do TcRef [(TcLclEnv, ThModFinalizers)] th_modfinalizers_var <- (TcGblEnv -> TcRef [(TcLclEnv, ThModFinalizers)]) -> TcRnIf TcGblEnv TcLclEnv TcGblEnv -> IOEnv (Env TcGblEnv TcLclEnv) (TcRef [(TcLclEnv, ThModFinalizers)]) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap TcGblEnv -> TcRef [(TcLclEnv, ThModFinalizers)] tcg_th_modfinalizers TcRnIf TcGblEnv TcLclEnv TcGblEnv forall gbl lcl. TcRnIf gbl lcl gbl getGblEnv TcLclEnv env <- TcRnIf TcGblEnv TcLclEnv TcLclEnv forall gbl lcl. TcRnIf gbl lcl lcl getLclEnv TcRef [(TcLclEnv, ThModFinalizers)] -> ([(TcLclEnv, ThModFinalizers)] -> [(TcLclEnv, ThModFinalizers)]) -> IOEnv (Env TcGblEnv TcLclEnv) () forall a gbl lcl. TcRef a -> (a -> a) -> TcRnIf gbl lcl () updTcRef TcRef [(TcLclEnv, ThModFinalizers)] th_modfinalizers_var (([(TcLclEnv, ThModFinalizers)] -> [(TcLclEnv, ThModFinalizers)]) -> IOEnv (Env TcGblEnv TcLclEnv) ()) -> ([(TcLclEnv, ThModFinalizers)] -> [(TcLclEnv, ThModFinalizers)]) -> IOEnv (Env TcGblEnv TcLclEnv) () forall a b. (a -> b) -> a -> b $ \[(TcLclEnv, ThModFinalizers)] fins -> (TcLclEnv env, [ForeignRef (Q ())] -> ThModFinalizers ThModFinalizers [ForeignRef (Q ())] mod_finalizers) (TcLclEnv, ThModFinalizers) -> [(TcLclEnv, ThModFinalizers)] -> [(TcLclEnv, ThModFinalizers)] forall a. a -> [a] -> [a] : [(TcLclEnv, ThModFinalizers)] fins {- Note [rnSplicePat] ~~~~~~~~~~~~~~~~~~ Renaming a pattern splice is a bit tricky, because we need the variables bound in the pattern to be in scope in the RHS of the pattern. This scope management is effectively done by using continuation-passing style in GHC.Rename.Pat, through the CpsRn monad. We don't wish to be in that monad here (it would create import cycles and generally conflict with renaming other splices), so we really want to return a (Pat RdrName) -- the result of running the splice -- which can then be further renamed in GHC.Rename.Pat, in the CpsRn monad. The problem is that if we're renaming a splice within a bracket, we *don't* want to run the splice now. We really do just want to rename it to an HsSplice Name. Of course, then we can't know what variables are bound within the splice. So we accept any unbound variables and rename them again when the bracket is spliced in. If a variable is brought into scope by a pattern splice all is fine. If it is not then an error is reported. In any case, when we're done in rnSplicePat, we'll either have a Pat RdrName (the result of running a top-level splice) or a Pat Name (the renamed nested splice). Thus, the awkward return type of rnSplicePat. -} spliceCtxt :: HsSplice GhcPs -> SDoc spliceCtxt :: HsSplice GhcPs -> MsgDoc spliceCtxt HsSplice GhcPs splice = MsgDoc -> ThLevel -> MsgDoc -> MsgDoc hang (String -> MsgDoc text String "In the" MsgDoc -> MsgDoc -> MsgDoc <+> MsgDoc what) ThLevel 2 (HsSplice GhcPs -> MsgDoc forall a. Outputable a => a -> MsgDoc ppr HsSplice GhcPs splice) where what :: MsgDoc what = case HsSplice GhcPs splice of HsUntypedSplice {} -> String -> MsgDoc text String "untyped splice:" HsTypedSplice {} -> String -> MsgDoc text String "typed splice:" HsQuasiQuote {} -> String -> MsgDoc text String "quasi-quotation:" HsSpliced {} -> String -> MsgDoc text String "spliced expression:" -- | The splice data to be logged data SpliceInfo = SpliceInfo { SpliceInfo -> String spliceDescription :: String , SpliceInfo -> Maybe (LHsExpr (GhcPass 'Renamed)) spliceSource :: Maybe (LHsExpr GhcRn) -- Nothing <=> top-level decls -- added by addTopDecls , SpliceInfo -> Bool spliceIsDecl :: Bool -- True <=> put the generate code in a file -- when -dth-dec-file is on , SpliceInfo -> MsgDoc spliceGenerated :: SDoc } -- Note that 'spliceSource' is *renamed* but not *typechecked* -- Reason (a) less typechecking crap -- (b) data constructors after type checking have been -- changed to their *wrappers*, and that makes them -- print always fully qualified -- | outputs splice information for 2 flags which have different output formats: -- `-ddump-splices` and `-dth-dec-file` traceSplice :: SpliceInfo -> TcM () traceSplice :: SpliceInfo -> IOEnv (Env TcGblEnv TcLclEnv) () traceSplice (SpliceInfo { spliceDescription :: SpliceInfo -> String spliceDescription = String sd, spliceSource :: SpliceInfo -> Maybe (LHsExpr (GhcPass 'Renamed)) spliceSource = Maybe (LHsExpr (GhcPass 'Renamed)) mb_src , spliceGenerated :: SpliceInfo -> MsgDoc spliceGenerated = MsgDoc gen, spliceIsDecl :: SpliceInfo -> Bool spliceIsDecl = Bool is_decl }) = do { SrcSpan loc <- case Maybe (LHsExpr (GhcPass 'Renamed)) mb_src of Maybe (LHsExpr (GhcPass 'Renamed)) Nothing -> TcRn SrcSpan getSrcSpanM Just (L SrcSpan loc HsExpr (GhcPass 'Renamed) _) -> SrcSpan -> TcRn SrcSpan forall (m :: * -> *) a. Monad m => a -> m a return SrcSpan loc ; DumpFlag -> MsgDoc -> IOEnv (Env TcGblEnv TcLclEnv) () traceOptTcRn DumpFlag Opt_D_dump_splices (SrcSpan -> MsgDoc spliceDebugDoc SrcSpan loc) ; Bool -> IOEnv (Env TcGblEnv TcLclEnv) () -> IOEnv (Env TcGblEnv TcLclEnv) () forall (f :: * -> *). Applicative f => Bool -> f () -> f () when Bool is_decl (IOEnv (Env TcGblEnv TcLclEnv) () -> IOEnv (Env TcGblEnv TcLclEnv) ()) -> IOEnv (Env TcGblEnv TcLclEnv) () -> IOEnv (Env TcGblEnv TcLclEnv) () forall a b. (a -> b) -> a -> b $ -- Raw material for -dth-dec-file do { DynFlags dflags <- IOEnv (Env TcGblEnv TcLclEnv) DynFlags forall (m :: * -> *). HasDynFlags m => m DynFlags getDynFlags ; IO () -> IOEnv (Env TcGblEnv TcLclEnv) () forall (m :: * -> *) a. MonadIO m => IO a -> m a liftIO (IO () -> IOEnv (Env TcGblEnv TcLclEnv) ()) -> IO () -> IOEnv (Env TcGblEnv TcLclEnv) () forall a b. (a -> b) -> a -> b $ PrintUnqualified -> DynFlags -> DumpFlag -> String -> DumpFormat -> MsgDoc -> IO () dumpIfSet_dyn_printer PrintUnqualified alwaysQualify DynFlags dflags DumpFlag Opt_D_th_dec_file String "" DumpFormat FormatHaskell (SrcSpan -> MsgDoc spliceCodeDoc SrcSpan loc) } } where -- `-ddump-splices` spliceDebugDoc :: SrcSpan -> SDoc spliceDebugDoc :: SrcSpan -> MsgDoc spliceDebugDoc SrcSpan loc = let code :: [MsgDoc] code = case Maybe (LHsExpr (GhcPass 'Renamed)) mb_src of Maybe (LHsExpr (GhcPass 'Renamed)) Nothing -> [MsgDoc] ending Just LHsExpr (GhcPass 'Renamed) e -> ThLevel -> MsgDoc -> MsgDoc nest ThLevel 2 (LHsExpr (GhcPass 'Renamed) -> MsgDoc forall a. Outputable a => a -> MsgDoc ppr (LHsExpr (GhcPass 'Renamed) -> LHsExpr (GhcPass 'Renamed) forall (p :: Pass). LHsExpr (GhcPass p) -> LHsExpr (GhcPass p) stripParensLHsExpr LHsExpr (GhcPass 'Renamed) e)) MsgDoc -> [MsgDoc] -> [MsgDoc] forall a. a -> [a] -> [a] : [MsgDoc] ending ending :: [MsgDoc] ending = [ String -> MsgDoc text String "======>", ThLevel -> MsgDoc -> MsgDoc nest ThLevel 2 MsgDoc gen ] in MsgDoc -> ThLevel -> MsgDoc -> MsgDoc hang (SrcSpan -> MsgDoc forall a. Outputable a => a -> MsgDoc ppr SrcSpan loc MsgDoc -> MsgDoc -> MsgDoc <> MsgDoc colon MsgDoc -> MsgDoc -> MsgDoc <+> String -> MsgDoc text String "Splicing" MsgDoc -> MsgDoc -> MsgDoc <+> String -> MsgDoc text String sd) ThLevel 2 ([MsgDoc] -> MsgDoc sep [MsgDoc] code) -- `-dth-dec-file` spliceCodeDoc :: SrcSpan -> SDoc spliceCodeDoc :: SrcSpan -> MsgDoc spliceCodeDoc SrcSpan loc = [MsgDoc] -> MsgDoc vcat [ String -> MsgDoc text String "--" MsgDoc -> MsgDoc -> MsgDoc <+> SrcSpan -> MsgDoc forall a. Outputable a => a -> MsgDoc ppr SrcSpan loc MsgDoc -> MsgDoc -> MsgDoc <> MsgDoc colon MsgDoc -> MsgDoc -> MsgDoc <+> String -> MsgDoc text String "Splicing" MsgDoc -> MsgDoc -> MsgDoc <+> String -> MsgDoc text String sd , MsgDoc gen ] illegalTypedSplice :: SDoc illegalTypedSplice :: MsgDoc illegalTypedSplice = String -> MsgDoc text String "Typed splices may not appear in untyped brackets" illegalUntypedSplice :: SDoc illegalUntypedSplice :: MsgDoc illegalUntypedSplice = String -> MsgDoc text String "Untyped splices may not appear in typed brackets" checkThLocalName :: Name -> RnM () checkThLocalName :: Name -> IOEnv (Env TcGblEnv TcLclEnv) () checkThLocalName Name name | Name -> Bool isUnboundName Name name -- Do not report two errors for = () -> IOEnv (Env TcGblEnv TcLclEnv) () forall (m :: * -> *) a. Monad m => a -> m a return () -- $(not_in_scope args) | Bool otherwise = do { String -> MsgDoc -> IOEnv (Env TcGblEnv TcLclEnv) () traceRn String "checkThLocalName" (Name -> MsgDoc forall a. Outputable a => a -> MsgDoc ppr Name name) ; Maybe (TopLevelFlag, ThLevel, ThStage) mb_local_use <- Name -> TcRn (Maybe (TopLevelFlag, ThLevel, ThStage)) getStageAndBindLevel Name name ; case Maybe (TopLevelFlag, ThLevel, ThStage) mb_local_use of { Maybe (TopLevelFlag, ThLevel, ThStage) Nothing -> () -> IOEnv (Env TcGblEnv TcLclEnv) () forall (m :: * -> *) a. Monad m => a -> m a return () ; -- Not a locally-bound thing Just (TopLevelFlag top_lvl, ThLevel bind_lvl, ThStage use_stage) -> do { let use_lvl :: ThLevel use_lvl = ThStage -> ThLevel thLevel ThStage use_stage ; MsgDoc -> ThLevel -> ThLevel -> IOEnv (Env TcGblEnv TcLclEnv) () checkWellStaged (MsgDoc -> MsgDoc quotes (Name -> MsgDoc forall a. Outputable a => a -> MsgDoc ppr Name name)) ThLevel bind_lvl ThLevel use_lvl ; String -> MsgDoc -> IOEnv (Env TcGblEnv TcLclEnv) () traceRn String "checkThLocalName" (Name -> MsgDoc forall a. Outputable a => a -> MsgDoc ppr Name name MsgDoc -> MsgDoc -> MsgDoc <+> ThLevel -> MsgDoc forall a. Outputable a => a -> MsgDoc ppr ThLevel bind_lvl MsgDoc -> MsgDoc -> MsgDoc <+> ThStage -> MsgDoc forall a. Outputable a => a -> MsgDoc ppr ThStage use_stage MsgDoc -> MsgDoc -> MsgDoc <+> ThLevel -> MsgDoc forall a. Outputable a => a -> MsgDoc ppr ThLevel use_lvl) ; TopLevelFlag -> ThLevel -> ThStage -> ThLevel -> Name -> IOEnv (Env TcGblEnv TcLclEnv) () checkCrossStageLifting TopLevelFlag top_lvl ThLevel bind_lvl ThStage use_stage ThLevel use_lvl Name name } } } -------------------------------------- checkCrossStageLifting :: TopLevelFlag -> ThLevel -> ThStage -> ThLevel -> Name -> TcM () -- We are inside brackets, and (use_lvl > bind_lvl) -- Now we must check whether there's a cross-stage lift to do -- Examples \x -> [| x |] -- [| map |] -- -- This code is similar to checkCrossStageLifting in GHC.Tc.Gen.Expr, but -- this is only run on *untyped* brackets. checkCrossStageLifting :: TopLevelFlag -> ThLevel -> ThStage -> ThLevel -> Name -> IOEnv (Env TcGblEnv TcLclEnv) () checkCrossStageLifting TopLevelFlag top_lvl ThLevel bind_lvl ThStage use_stage ThLevel use_lvl Name name | Brack ThStage _ (RnPendingUntyped IORef [PendingRnSplice] ps_var) <- ThStage use_stage -- Only for untyped brackets , ThLevel use_lvl ThLevel -> ThLevel -> Bool forall a. Ord a => a -> a -> Bool > ThLevel bind_lvl -- Cross-stage condition = TopLevelFlag -> Name -> IORef [PendingRnSplice] -> IOEnv (Env TcGblEnv TcLclEnv) () check_cross_stage_lifting TopLevelFlag top_lvl Name name IORef [PendingRnSplice] ps_var | Bool otherwise = () -> IOEnv (Env TcGblEnv TcLclEnv) () forall (m :: * -> *) a. Monad m => a -> m a return () check_cross_stage_lifting :: TopLevelFlag -> Name -> TcRef [PendingRnSplice] -> TcM () check_cross_stage_lifting :: TopLevelFlag -> Name -> IORef [PendingRnSplice] -> IOEnv (Env TcGblEnv TcLclEnv) () check_cross_stage_lifting TopLevelFlag top_lvl Name name IORef [PendingRnSplice] ps_var | TopLevelFlag -> Bool isTopLevel TopLevelFlag top_lvl -- Top-level identifiers in this module, -- (which have External Names) -- are just like the imported case: -- no need for the 'lifting' treatment -- E.g. this is fine: -- f x = x -- g y = [| f 3 |] = Bool -> IOEnv (Env TcGblEnv TcLclEnv) () -> IOEnv (Env TcGblEnv TcLclEnv) () forall (f :: * -> *). Applicative f => Bool -> f () -> f () when (Name -> Bool isExternalName Name name) (Name -> IOEnv (Env TcGblEnv TcLclEnv) () keepAlive Name name) -- See Note [Keeping things alive for Template Haskell] | Bool otherwise = -- Nested identifiers, such as 'x' in -- E.g. \x -> [| h x |] -- We must behave as if the reference to x was -- h $(lift x) -- We use 'x' itself as the SplicePointName, used by -- the desugarer to stitch it all back together. -- If 'x' occurs many times we may get many identical -- bindings of the same SplicePointName, but that doesn't -- matter, although it's a mite untidy. do { String -> MsgDoc -> IOEnv (Env TcGblEnv TcLclEnv) () traceRn String "checkCrossStageLifting" (Name -> MsgDoc forall a. Outputable a => a -> MsgDoc ppr Name name) -- Construct the (lift x) expression ; let lift_expr :: LHsExpr (GhcPass 'Renamed) lift_expr = LHsExpr (GhcPass 'Renamed) -> LHsExpr (GhcPass 'Renamed) -> LHsExpr (GhcPass 'Renamed) forall (id :: Pass). IsPass id => LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) nlHsApp (IdP (GhcPass 'Renamed) -> LHsExpr (GhcPass 'Renamed) forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id) nlHsVar Name IdP (GhcPass 'Renamed) liftName) (IdP (GhcPass 'Renamed) -> LHsExpr (GhcPass 'Renamed) forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id) nlHsVar Name IdP (GhcPass 'Renamed) name) pend_splice :: PendingRnSplice pend_splice = UntypedSpliceFlavour -> Name -> LHsExpr (GhcPass 'Renamed) -> PendingRnSplice PendingRnSplice UntypedSpliceFlavour UntypedExpSplice Name name LHsExpr (GhcPass 'Renamed) lift_expr -- Update the pending splices ; [PendingRnSplice] ps <- IORef [PendingRnSplice] -> IOEnv (Env TcGblEnv TcLclEnv) [PendingRnSplice] forall a env. IORef a -> IOEnv env a readMutVar IORef [PendingRnSplice] ps_var ; IORef [PendingRnSplice] -> [PendingRnSplice] -> IOEnv (Env TcGblEnv TcLclEnv) () forall a env. IORef a -> a -> IOEnv env () writeMutVar IORef [PendingRnSplice] ps_var (PendingRnSplice pend_splice PendingRnSplice -> [PendingRnSplice] -> [PendingRnSplice] forall a. a -> [a] -> [a] : [PendingRnSplice] ps) } {- Note [Keeping things alive for Template Haskell] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider f x = x+1 g y = [| f 3 |] Here 'f' is referred to from inside the bracket, which turns into data and mentions only f's *name*, not 'f' itself. So we need some other way to keep 'f' alive, lest it get dropped as dead code. That's what keepAlive does. It puts it in the keep-alive set, which subsequently ensures that 'f' stays as a top level binding. This must be done by the renamer, not the type checker (as of old), because the type checker doesn't typecheck the body of untyped brackets (#8540). A thing can have a bind_lvl of outerLevel, but have an internal name: foo = [d| op = 3 bop = op + 1 |] Here the bind_lvl of 'op' is (bogusly) outerLevel, even though it is bound inside a bracket. That is because we don't even record binding levels for top-level things; the binding levels are in the LocalRdrEnv. So the occurrence of 'op' in the rhs of 'bop' looks a bit like a cross-stage thing, but it isn't really. And in fact we never need to do anything here for top-level bound things, so all is fine, if a bit hacky. For these chaps (which have Internal Names) we don't want to put them in the keep-alive set. Note [Quoting names] ~~~~~~~~~~~~~~~~~~~~ A quoted name 'n is a bit like a quoted expression [| n |], except that we have no cross-stage lifting (c.f. GHC.Tc.Gen.Expr.thBrackId). So, after incrementing the use-level to account for the brackets, the cases are: bind > use Error bind = use+1 OK bind < use Imported things OK Top-level things OK Non-top-level Error where 'use' is the binding level of the 'n quote. (So inside the implied bracket the level would be use+1.) Examples: f 'map -- OK; also for top-level defns of this module \x. f 'x -- Not ok (bind = 1, use = 1) -- (whereas \x. f [| x |] might have been ok, by -- cross-stage lifting \y. [| \x. $(f 'y) |] -- Not ok (bind =1, use = 1) [| \x. $(f 'x) |] -- OK (bind = 2, use = 1) -}