diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index 8dd8b484881ce76413f995b52cc2459ceddb6354..01c4903c548e867f744a7b74b67be91b2b96d3f9 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -1071,6 +1071,7 @@ repSplice :: HsSplice Name -> DsM (Core a) repSplice (HsTypedSplice n _) = rep_splice n repSplice (HsUntypedSplice n _) = rep_splice n repSplice (HsQuasiQuote n _ _ _) = rep_splice n +repSplice e@(HsSpliced _ _) = pprPanic "repSplice" (ppr e) rep_splice :: Name -> DsM (Core a) rep_splice splice_name diff --git a/compiler/hsSyn/HsExpr.hs b/compiler/hsSyn/HsExpr.hs index 79cf0798821d353d082304f8fc9aadbf371bac13..ffba782dfd5a048e37f7640ed09afc77d961442a 100644 --- a/compiler/hsSyn/HsExpr.hs +++ b/compiler/hsSyn/HsExpr.hs @@ -45,8 +45,14 @@ import Type -- libraries: import Data.Data hiding (Fixity(..)) +import qualified Data.Data as Data (Fixity(..)) import Data.Maybe (isNothing) +#ifdef GHCI +import GHCi.RemoteTypes ( ForeignRef ) +import qualified Language.Haskell.TH as TH (Q) +#endif + {- ************************************************************************ * * @@ -1926,12 +1932,55 @@ data HsSplice id SrcSpan -- The span of the enclosed string FastString -- The enclosed string + | HsSpliced -- See Note [Delaying modFinalizers in untyped splices] in + -- RnSplice. + -- This is the result of splicing a splice. It is produced by + -- the renamer and consumed by the typechecker. It lives only + -- between the two. + ThModFinalizers -- TH finalizers produced by the splice. + (HsSplicedThing id) -- The result of splicing + deriving Typeable + deriving instance (DataId id) => Data (HsSplice id) isTypedSplice :: HsSplice id -> Bool isTypedSplice (HsTypedSplice {}) = True isTypedSplice _ = False -- Quasi-quotes are untyped splices +-- | Finalizers produced by a splice with +-- 'Language.Haskell.TH.Syntax.addModFinalizer' +-- +-- See Note [Delaying modFinalizers in untyped splices] in RnSplice. For how +-- this is used. +-- +#ifdef GHCI +newtype ThModFinalizers = ThModFinalizers [ForeignRef (TH.Q ())] +#else +data ThModFinalizers = ThModFinalizers +#endif + +-- A Data instance which ignores the argument of 'ThModFinalizers'. +#ifdef GHCI +instance Data ThModFinalizers where + gunfold _ z _ = z $ ThModFinalizers [] + toConstr a = mkConstr (dataTypeOf a) "ThModFinalizers" [] Data.Prefix + dataTypeOf a = mkDataType "HsExpr.ThModFinalizers" [toConstr a] +#else +instance Data ThModFinalizers where + gunfold _ z _ = z ThModFinalizers + toConstr a = mkConstr (dataTypeOf a) "ThModFinalizers" [] Data.Prefix + dataTypeOf a = mkDataType "HsExpr.ThModFinalizers" [toConstr a] +#endif + +-- | Values that can result from running a splice. +data HsSplicedThing id + = HsSplicedExpr (HsExpr id) + | HsSplicedTy (HsType id) + | HsSplicedPat (Pat id) + deriving Typeable + +deriving instance (DataId id) => Data (HsSplicedThing id) + -- See Note [Pending Splices] type SplicePointName = Name @@ -2015,6 +2064,11 @@ splices. In contrast, when pretty printing the output of the type checker, we sense, although I hate to add another constructor to HsExpr. -} +instance OutputableBndrId id => Outputable (HsSplicedThing id) where + ppr (HsSplicedExpr e) = ppr_expr e + ppr (HsSplicedTy t) = ppr t + ppr (HsSplicedPat p) = ppr p + instance (OutputableBndrId id) => Outputable (HsSplice id) where ppr s = pprSplice s @@ -2026,6 +2080,7 @@ pprSplice :: (OutputableBndrId id) => HsSplice id -> SDoc pprSplice (HsTypedSplice n e) = ppr_splice (text "$$") n e pprSplice (HsUntypedSplice n e) = ppr_splice (text "$") n e pprSplice (HsQuasiQuote n q _ s) = ppr_quasi n q s +pprSplice (HsSpliced _ thing) = ppr thing ppr_quasi :: OutputableBndr id => id -> id -> FastString -> SDoc ppr_quasi n quoter quote = ifPprDebug (brackets (ppr n)) <> diff --git a/compiler/rename/RnPat.hs b/compiler/rename/RnPat.hs index f44d492fe05916586e7d411894c38e185acd9538..0ec15a969f9bcda7dc8c7582ee6681a491ea5e67 100644 --- a/compiler/rename/RnPat.hs +++ b/compiler/rename/RnPat.hs @@ -446,6 +446,10 @@ rnPatAndThen mk (TuplePat pats boxed _) ; pats' <- rnLPatsAndThen mk pats ; return (TuplePat pats' boxed []) } +-- If a splice has been run already, just rename the result. +rnPatAndThen mk (SplicePat (HsSpliced mfs (HsSplicedPat pat))) + = SplicePat . HsSpliced mfs . HsSplicedPat <$> rnPatAndThen mk pat + rnPatAndThen mk (SplicePat splice) = do { eith <- liftCpsFV $ rnSplicePat splice ; case eith of -- See Note [rnSplicePat] in RnSplice diff --git a/compiler/rename/RnSplice.hs b/compiler/rename/RnSplice.hs index b23621d1bdd30b3a41c3279ad79a2662967c110f..1b99376a515c6931bc26a9953e64bfb6a0324ab9 100644 --- a/compiler/rename/RnSplice.hs +++ b/compiler/rename/RnSplice.hs @@ -46,7 +46,17 @@ import THNames ( quoteExpName, quotePatName, quoteDecName, quoteTypeNam , decsQTyConName, expQTyConName, patQTyConName, typeQTyConName, ) import {-# SOURCE #-} TcExpr ( tcPolyExpr ) -import {-# SOURCE #-} TcSplice ( runMetaD, runMetaE, runMetaP, runMetaT, tcTopSpliceExpr ) +import {-# SOURCE #-} TcSplice + ( runMetaD + , runMetaE + , runMetaP + , runMetaT + , runRemoteModFinalizers + , tcTopSpliceExpr + ) + +import GHCi.RemoteTypes ( ForeignRef ) +import qualified Language.Haskell.TH as TH (Q) #endif import qualified GHC.LanguageExtensions as LangExt @@ -77,6 +87,10 @@ rnBracket e br_body illegalUntypedBracket ; Splice Untyped -> checkTc (not (isTypedBracket br_body)) illegalTypedBracket + ; RunSplice _ -> + -- See Note [RunSplice ThLevel] in "TcRnTypes". + pprPanic "rnBracket: Renaming bracket when running a splice" + (ppr e) ; Comp -> return () ; Brack {} -> failWithTc illegalBracket } @@ -278,12 +292,17 @@ rnSpliceGen run_splice pend_splice splice else Untyped ------------------ + +-- | Returns the result of running a splice and the modFinalizers collected +-- during the execution. +-- +-- See Note [Delaying modFinalizers in untyped splices]. runRnSplice :: UntypedSpliceFlavour -> (LHsExpr Id -> TcRn res) -> (res -> SDoc) -- How to pretty-print res -- Usually just ppr, but not for [Decl] -> HsSplice Name -- Always untyped - -> TcRn res + -> TcRn (res, [ForeignRef (TH.Q ())]) runRnSplice flavour run_meta ppr_res splice = do { splice' <- getHooked runRnSpliceHook return >>= ($ splice) @@ -291,6 +310,7 @@ runRnSplice flavour run_meta ppr_res splice HsUntypedSplice _ e -> e HsQuasiQuote _ q qs str -> mkQuasiQuoteExpr flavour q qs str HsTypedSplice {} -> pprPanic "runRnSplice" (ppr splice) + HsSpliced {} -> pprPanic "runRnSplice" (ppr splice) -- Typecheck the expression ; meta_exp_ty <- tcMetaTy meta_ty_name @@ -298,13 +318,16 @@ runRnSplice flavour run_meta ppr_res splice tcPolyExpr the_expr meta_exp_ty -- Run the expression - ; result <- run_meta zonked_q_expr + ; mod_finalizers_ref <- newTcRef [] + ; result <- setStage (RunSplice mod_finalizers_ref) $ + run_meta zonked_q_expr + ; mod_finalizers <- readTcRef mod_finalizers_ref ; traceSplice (SpliceInfo { spliceDescription = what , spliceIsDecl = is_decl , spliceSource = Just the_expr , spliceGenerated = ppr_res result }) - ; return result } + ; return (result, mod_finalizers) } where meta_ty_name = case flavour of @@ -331,6 +354,8 @@ makePending flavour (HsQuasiQuote n quoter q_span quote) = PendingRnSplice flavour n (mkQuasiQuoteExpr flavour quoter q_span quote) makePending _ splice@(HsTypedSplice {}) = pprPanic "makePending" (ppr splice) +makePending _ splice@(HsSpliced {}) + = pprPanic "makePending" (ppr splice) ------------------ mkQuasiQuoteExpr :: UntypedSpliceFlavour -> Name -> SrcSpan -> FastString -> LHsExpr Name @@ -380,6 +405,8 @@ rnSplice (HsQuasiQuote splice_name quoter q_loc quote) ; return (HsQuasiQuote splice_name' quoter' q_loc quote, unitFV quoter') } +rnSplice splice@(HsSpliced {}) = pprPanic "rnSplice" (ppr splice) + --------------------- rnSpliceExpr :: HsSplice RdrName -> RnM (HsExpr Name, FreeVars) rnSpliceExpr splice @@ -404,9 +431,16 @@ rnSpliceExpr splice | otherwise -- Run it here, see Note [Running splices in the Renamer] = do { traceRn (text "rnSpliceExpr: untyped expression splice") - ; rn_expr <- runRnSplice UntypedExpSplice runMetaE ppr rn_splice + ; (rn_expr, mod_finalizers) <- + runRnSplice UntypedExpSplice runMetaE ppr rn_splice ; (lexpr3, fvs) <- checkNoErrs (rnLExpr rn_expr) - ; return (HsPar lexpr3, fvs) } + -- See Note [Delaying modFinalizers in untyped splices]. + ; return ( HsPar $ HsSpliceE + . HsSpliced (ThModFinalizers mod_finalizers) + . HsSplicedExpr <$> + lexpr3 + , fvs) + } {- Note [Running splices in the Renamer] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -450,6 +484,54 @@ to try and -} +{- Note [Delaying modFinalizers in untyped splices] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +When splices run in the renamer, 'reify' does not have access to the local +type environment (Trac #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://ghc.haskell.org/trac/ghc/wiki/TemplateHaskell/Reify +[2] 'rnSpliceExpr' +[3] 'TcSplice.qAddModFinalizer' +[4] 'TcExpr.tcExpr' ('HsSpliceE' ('HsSpliced' ...)) +[5] 'TcHsType.tc_hs_type' ('HsSpliceTy' ('HsSpliced' ...)) +[6] 'TcPat.tc_pat' ('SplicePat' ('HsSpliced' ...)) + +-} + ---------------------- rnSpliceType :: HsSplice RdrName -> PostTc Name Kind -> RnM (HsType Name, FreeVars) @@ -461,11 +543,18 @@ rnSpliceType splice k run_type_splice rn_splice = do { traceRn (text "rnSpliceType: untyped type splice") - ; hs_ty2 <- runRnSplice UntypedTypeSplice runMetaT ppr rn_splice + ; (hs_ty2, mod_finalizers) <- + runRnSplice UntypedTypeSplice runMetaT ppr rn_splice ; (hs_ty3, fvs) <- do { let doc = SpliceTypeCtx hs_ty2 ; checkNoErrs $ rnLHsType doc hs_ty2 } -- checkNoErrs: see Note [Renamer errors] - ; return (HsParTy hs_ty3, fvs) } + -- See Note [Delaying modFinalizers in untyped splices]. + ; return ( HsParTy $ flip HsSpliceTy k + . HsSpliced (ThModFinalizers mod_finalizers) + . HsSplicedTy <$> + hs_ty3 + , fvs + ) } -- Wrap the result of the splice in parens so that we don't -- lose the outermost location set by runQuasiQuote (#7918) @@ -521,8 +610,15 @@ rnSplicePat splice run_pat_splice rn_splice = do { traceRn (text "rnSplicePat: untyped pattern splice") - ; pat <- runRnSplice UntypedPatSplice runMetaP ppr rn_splice - ; return (Left (ParPat pat), emptyFVs) } + ; (pat, mod_finalizers) <- + runRnSplice UntypedPatSplice runMetaP ppr rn_splice + -- See Note [Delaying modFinalizers in untyped splices]. + ; return ( Left $ ParPat $ SplicePat + . HsSpliced (ThModFinalizers mod_finalizers) + . HsSplicedPat <$> + pat + , emptyFVs + ) } -- Wrap the result of the quasi-quoter in parens so that we don't -- lose the outermost location set by runQuasiQuote (#7918) @@ -542,12 +638,28 @@ rnTopSpliceDecls splice = do { (rn_splice, fvs) <- setStage (Splice Untyped) $ rnSplice splice ; traceRn (text "rnTopSpliceDecls: untyped declaration splice") - ; decls <- runRnSplice UntypedDeclSplice runMetaD ppr_decls rn_splice + ; (decls, mod_finalizers) <- + runRnSplice UntypedDeclSplice runMetaD ppr_decls rn_splice + ; add_mod_finalizers_now mod_finalizers ; return (decls,fvs) } where ppr_decls :: [LHsDecl RdrName] -> SDoc ppr_decls ds = vcat (map ppr 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 mod_finalizers = do + th_modfinalizers_var <- fmap tcg_th_modfinalizers getGblEnv + updTcRef th_modfinalizers_var $ \fins -> + runRemoteModFinalizers (ThModFinalizers mod_finalizers) : fins + + {- Note [rnSplicePat] ~~~~~~~~~~~~~~~~~~ @@ -582,6 +694,7 @@ spliceCtxt splice HsUntypedSplice {} -> text "untyped splice:" HsTypedSplice {} -> text "typed splice:" HsQuasiQuote {} -> text "quasi-quotation:" + HsSpliced {} -> text "spliced expression:" -- | The splice data to be logged data SpliceInfo diff --git a/compiler/rename/RnTypes.hs b/compiler/rename/RnTypes.hs index d8a58777f9979a684b0a25fb427de9578b2df99a..36264310f96859cd6e44b98fd6a8ea0ccfcecd13 100644 --- a/compiler/rename/RnTypes.hs +++ b/compiler/rename/RnTypes.hs @@ -1031,6 +1031,7 @@ collectAnonWildCards lty = go lty `mappend` go ty HsQualTy { hst_ctxt = L _ ctxt , hst_body = ty } -> gos ctxt `mappend` go ty + HsSpliceTy (HsSpliced _ (HsSplicedTy ty)) _ -> go $ L noSrcSpan ty -- HsQuasiQuoteTy, HsSpliceTy, HsCoreTy, HsTyLit _ -> mempty diff --git a/compiler/typecheck/TcExpr.hs b/compiler/typecheck/TcExpr.hs index 643b037cb6e3af09763bb78cbc930dcb98de9b04..a6918b6cf844eabf7e369afbd64c65de65a439f8 100644 --- a/compiler/typecheck/TcExpr.hs +++ b/compiler/typecheck/TcExpr.hs @@ -981,6 +981,14 @@ tcExpr (PArrSeq _ _) _ ************************************************************************ -} +-- HsSpliced is an annotation produced by 'RnSplice.rnSpliceExpr'. +-- Here we get rid of it and add the finalizers to the global environment. +-- +-- See Note [Delaying modFinalizers in untyped splices] in RnSplice. +tcExpr (HsSpliceE (HsSpliced mod_finalizers (HsSplicedExpr expr))) + res_ty + = do addModFinalizersWithLclEnv mod_finalizers + tcExpr expr res_ty tcExpr (HsSpliceE splice) res_ty = tcSpliceExpr splice res_ty tcExpr (HsBracket brack) res_ty diff --git a/compiler/typecheck/TcHsType.hs b/compiler/typecheck/TcHsType.hs index 2d029b2fdc096b7b77ed771267a192424c4cf2dd..ea65a736435ca33d76b4d6f5deb0e0c67d5c4a96 100644 --- a/compiler/typecheck/TcHsType.hs +++ b/compiler/typecheck/TcHsType.hs @@ -501,6 +501,18 @@ tc_hs_type _ ty@(HsRecTy _) _ -- signatures) should have been removed by now = failWithTc (text "Record syntax is illegal here:" <+> ppr ty) +-- HsSpliced is an annotation produced by 'RnSplice.rnSpliceType'. +-- Here we get rid of it and add the finalizers to the global environment +-- while capturing the local environment. +-- +-- See Note [Delaying modFinalizers in untyped splices]. +tc_hs_type mode (HsSpliceTy (HsSpliced mod_finalizers (HsSplicedTy ty)) + _ + ) + exp_kind + = do addModFinalizersWithLclEnv mod_finalizers + tc_hs_type mode ty exp_kind + -- This should never happen; type splices are expanded by the renamer tc_hs_type _ ty@(HsSpliceTy {}) _exp_kind = failWithTc (text "Unexpected type splice:" <+> ppr ty) diff --git a/compiler/typecheck/TcPat.hs b/compiler/typecheck/TcPat.hs index a46136efca72f0864008638b9e523a7b02ca4a0b..e62b30030da67e660ee0be84c031ad15c912fb9f 100644 --- a/compiler/typecheck/TcPat.hs +++ b/compiler/typecheck/TcPat.hs @@ -583,6 +583,15 @@ tc_pat penv (NPlusKPat (L nm_loc name) (L loc lit) _ ge minus _) pat_ty thing_in ge' minus'' pat_ty ; return (pat', res) } +-- HsSpliced is an annotation produced by 'RnSplice.rnSplicePat'. +-- Here we get rid of it and add the finalizers to the global environment. +-- +-- See Note [Delaying modFinalizers in untyped splices] in RnSplice. +tc_pat penv (SplicePat (HsSpliced mod_finalizers (HsSplicedPat pat))) + pat_ty thing_inside + = do addModFinalizersWithLclEnv mod_finalizers + tc_pat penv pat pat_ty thing_inside + tc_pat _ _other_pat _ _ = panic "tc_pat" -- ConPatOut, SigPatOut ---------------- diff --git a/compiler/typecheck/TcRnMonad.hs b/compiler/typecheck/TcRnMonad.hs index a411e18c62b075241ecfdff7342757fba6738a31..e8513d39b02999703ee808cae3400060563ecd2e 100644 --- a/compiler/typecheck/TcRnMonad.hs +++ b/compiler/typecheck/TcRnMonad.hs @@ -106,6 +106,7 @@ module TcRnMonad( -- * Template Haskell context recordThUse, recordThSpliceUse, recordTopLevelSpliceLoc, getTopLevelSpliceLocs, keepAlive, getStage, getStageAndBindLevel, setStage, + addModFinalizersWithLclEnv, -- * Safe Haskell context recordUnsafeInfer, finalSafeMode, fixSafeInstances, @@ -174,6 +175,7 @@ import Data.Set ( Set ) import qualified Data.Set as Set #ifdef GHCI +import {-# SOURCE #-} TcSplice ( runRemoteModFinalizers ) import qualified Data.Map as Map #endif @@ -1529,6 +1531,21 @@ getStageAndBindLevel name setStage :: ThStage -> TcM a -> TcRn a setStage s = updLclEnv (\ env -> env { tcl_th_ctxt = s }) +#ifdef GHCI +-- | Adds the given modFinalizers to the global environment and set them to use +-- the current local environment. +addModFinalizersWithLclEnv :: ThModFinalizers -> TcM () +addModFinalizersWithLclEnv mod_finalizers + = do lcl_env <- getLclEnv + th_modfinalizers_var <- fmap tcg_th_modfinalizers getGblEnv + updTcRef th_modfinalizers_var $ \fins -> + setLclEnv lcl_env (runRemoteModFinalizers mod_finalizers) + : fins +#else +addModFinalizersWithLclEnv :: ThModFinalizers -> TcM () +addModFinalizersWithLclEnv ThModFinalizers = return () +#endif + {- ************************************************************************ * * diff --git a/compiler/typecheck/TcRnTypes.hs b/compiler/typecheck/TcRnTypes.hs index 67fd77e81dc0113c69d38c3f55b8afe0dc2a1920..d952d2309e31e3ab5f4d3272bbbc45bfb3a346bc 100644 --- a/compiler/typecheck/TcRnTypes.hs +++ b/compiler/typecheck/TcRnTypes.hs @@ -502,8 +502,11 @@ data TcGblEnv tcg_th_topnames :: TcRef NameSet, -- ^ Exact names bound in top-level declarations in tcg_th_topdecls - tcg_th_modfinalizers :: TcRef [TH.Q ()], - -- ^ Template Haskell module finalizers + tcg_th_modfinalizers :: TcRef [TcM ()], + -- ^ Template Haskell module finalizers. + -- + -- They are computations in the @TcM@ monad rather than @Q@ because we + -- set them to use particular local environments. tcg_th_state :: TcRef (Map TypeRep Dynamic), tcg_th_remote_state :: TcRef (Maybe (ForeignRef (IORef QState))), @@ -788,6 +791,25 @@ data ThStage -- See Note [Template Haskell state diagram] in TcSplice -- the result replaces the splice -- Binding level = 0 +#ifdef GHCI + | RunSplice (TcRef [ForeignRef (TH.Q ())]) + -- Set when running a splice, i.e. NOT when renaming or typechecking the + -- Haskell code for the splice. See Note [RunSplice ThLevel]. + -- + -- Contains a list of mod finalizers collected while executing the splice. + -- + -- 'addModFinalizer' inserts finalizers here, and from here they are taken + -- to construct an @HsSpliced@ annotation for untyped splices. See Note + -- [Delaying modFinalizers in untyped splices] in "RnSplice". + -- + -- For typed splices, the typechecker takes finalizers from here and + -- inserts them in the list of finalizers in the global environment. + -- + -- See Note [Collecting modFinalizers in typed splices] in "TcSplice". +#else + | RunSplice () +#endif + | Comp -- Ordinary Haskell code -- Binding level = 1 @@ -811,9 +833,10 @@ topAnnStage = Splice Untyped topSpliceStage = Splice Untyped instance Outputable ThStage where - ppr (Splice _) = text "Splice" - ppr Comp = text "Comp" - ppr (Brack s _) = text "Brack" <> parens (ppr s) + ppr (Splice _) = text "Splice" + ppr (RunSplice _) = text "RunSplice" + ppr Comp = text "Comp" + ppr (Brack s _) = text "Brack" <> parens (ppr s) type ThLevel = Int -- NB: see Note [Template Haskell levels] in TcSplice @@ -827,9 +850,25 @@ impLevel = 0 -- Imported things; they can be used inside a top level splice outerLevel = 1 -- Things defined outside brackets thLevel :: ThStage -> ThLevel -thLevel (Splice _) = 0 -thLevel Comp = 1 -thLevel (Brack s _) = thLevel s + 1 +thLevel (Splice _) = 0 +thLevel (RunSplice _) = + -- See Note [RunSplice ThLevel]. + panic "thLevel: called when running a splice" +thLevel Comp = 1 +thLevel (Brack s _) = thLevel s + 1 + +{- Node [RunSplice ThLevel] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The 'RunSplice' stage is set when executing a splice, and only when running a +splice. In particular it is not set when the splice is renamed or typechecked. + +'RunSplice' is needed to provide a reference where 'addModFinalizer' can insert +the finalizer (see Note [Delaying modFinalizers in untyped splices]), and +'addModFinalizer' runs when doing Q things. Therefore, It doesn't make sense to +set 'RunSplice' when renaming or typechecking the splice, where 'Splice', 'Brak' +or 'Comp' are used instead. + +-} --------------------------- -- Arrow-notation context diff --git a/compiler/typecheck/TcSplice.hs b/compiler/typecheck/TcSplice.hs index 44bc2994874a504444ea37eb4a92c7fa949cc70f..fa68d2e98bf386cf573789ef9a6b483e81d5ed3c 100644 --- a/compiler/typecheck/TcSplice.hs +++ b/compiler/typecheck/TcSplice.hs @@ -29,7 +29,7 @@ module TcSplice( -- called only in stage2 (ie GHCI is on) runMetaE, runMetaP, runMetaT, runMetaD, runQuasi, tcTopSpliceExpr, lookupThName_maybe, - defaultRunMeta, runMeta', + defaultRunMeta, runMeta', runRemoteModFinalizers, finishTH #endif ) where @@ -446,12 +446,28 @@ tcSpliceExpr splice@(HsTypedSplice name expr) res_ty setSrcSpan (getLoc expr) $ do { stage <- getStage ; case stage of - Splice {} -> tcTopSplice expr res_ty - Comp -> tcTopSplice expr res_ty - Brack pop_stage pend -> tcNestedSplice pop_stage pend name expr res_ty } + Splice {} -> tcTopSplice expr res_ty + Brack pop_stage pend -> tcNestedSplice pop_stage pend name expr res_ty + RunSplice _ -> + -- See Note [RunSplice ThLevel] in "TcRnTypes". + pprPanic ("tcSpliceExpr: attempted to typecheck a splice when " ++ + "running another splice") (ppr splice) + Comp -> tcTopSplice expr res_ty + } tcSpliceExpr splice _ = pprPanic "tcSpliceExpr" (ppr splice) +{- Note [Collecting modFinalizers in typed splices] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +'qAddModFinalizer' of the @Quasi TcM@ instance adds finalizers in the local +environment (see Note [Delaying modFinalizers in untyped splices] in +"RnSplice"). Thus after executing the splice, we move the finalizers to the +finalizer list in the global environment and set them to use the current local +environment (with 'addModFinalizersWithLclEnv'). + +-} + tcNestedSplice :: ThStage -> PendingStuff -> Name -> LHsExpr Name -> ExpRhoType -> TcM (HsExpr Id) -- See Note [How brackets and nested splices are handled] @@ -482,8 +498,13 @@ tcTopSplice expr res_ty ; zonked_q_expr <- tcTopSpliceExpr Typed $ tcMonoExpr expr (mkCheckExpType meta_exp_ty) + -- See Note [Collecting modFinalizers in typed splices]. + ; modfinalizers_ref <- newTcRef [] -- Run the expression - ; expr2 <- runMetaE zonked_q_expr + ; expr2 <- setStage (RunSplice modfinalizers_ref) $ + runMetaE zonked_q_expr + ; mod_finalizers <- readTcRef modfinalizers_ref + ; addModFinalizersWithLclEnv $ ThModFinalizers mod_finalizers ; traceSplice (SpliceInfo { spliceDescription = "expression" , spliceIsDecl = False , spliceSource = Just expr @@ -618,6 +639,29 @@ seqSerialized (Serialized the_type bytes) = the_type `seq` bytes `seqList` () runQuasi :: TH.Q a -> TcM a runQuasi act = TH.runQ act +runRemoteModFinalizers :: ThModFinalizers -> TcM () +runRemoteModFinalizers (ThModFinalizers finRefs) = do + dflags <- getDynFlags + let withForeignRefs [] f = f [] + withForeignRefs (x : xs) f = withForeignRef x $ \r -> + withForeignRefs xs $ \rs -> f (r : rs) + if gopt Opt_ExternalInterpreter dflags then do + hsc_env <- env_top <$> getEnv + withIServ hsc_env $ \i -> do + tcg <- getGblEnv + th_state <- readTcRef (tcg_th_remote_state tcg) + case th_state of + Nothing -> return () -- TH was not started, nothing to do + Just fhv -> do + liftIO $ withForeignRef fhv $ \st -> + withForeignRefs finRefs $ \qrefs -> + writeIServ i (putMessage (RunModFinalizers st qrefs)) + () <- runRemoteTH i [] + readQResult i + else do + qs <- liftIO (withForeignRefs finRefs $ mapM localRef) + runQuasi $ sequence_ qs + runQResult :: (a -> String) -> (SrcSpan -> a -> b) @@ -884,8 +928,9 @@ instance TH.Quasi TcM where 2 (text "Probable cause: you used mkName instead of newName to generate a binding.") qAddModFinalizer fin = do - th_modfinalizers_var <- fmap tcg_th_modfinalizers getGblEnv - updTcRef th_modfinalizers_var (\fins -> fin:fins) + r <- liftIO $ mkRemoteRef fin + fref <- liftIO $ mkForeignRef r (freeRemoteRef r) + addModFinalizerRef fref qGetQ :: forall a. Typeable a => TcM (Maybe a) qGetQ = do @@ -904,30 +949,30 @@ instance TH.Quasi TcM where dflags <- hsc_dflags <$> getTopEnv return $ map toEnum $ IntSet.elems $ extensionFlags dflags +-- | Adds a mod finalizer reference to the local environment. +addModFinalizerRef :: ForeignRef (TH.Q ()) -> TcM () +addModFinalizerRef finRef = do + th_stage <- getStage + case th_stage of + RunSplice th_modfinalizers_var -> updTcRef th_modfinalizers_var (finRef :) + -- This case happens only if a splice is executed and the caller does + -- not set the 'ThStage' to 'RunSplice' to collect finalizers. + -- See Note [Delaying modFinalizers in untyped splices] in RnSplice. + _ -> + pprPanic "addModFinalizer was called when no finalizers were collected" + (ppr th_stage) -- | Run all module finalizers finishTH :: TcM () finishTH = do - hsc_env <- env_top <$> getEnv + tcg <- getGblEnv + let th_modfinalizers_var = tcg_th_modfinalizers tcg + modfinalizers <- readTcRef th_modfinalizers_var + writeTcRef th_modfinalizers_var [] + sequence_ modfinalizers dflags <- getDynFlags - if not (gopt Opt_ExternalInterpreter dflags) - then do - tcg <- getGblEnv - let th_modfinalizers_var = tcg_th_modfinalizers tcg - modfinalizers <- readTcRef th_modfinalizers_var - writeTcRef th_modfinalizers_var [] - mapM_ runQuasi modfinalizers - else withIServ hsc_env $ \i -> do - tcg <- getGblEnv - th_state <- readTcRef (tcg_th_remote_state tcg) - case th_state of - Nothing -> return () -- TH was not started, nothing to do - Just fhv -> do - liftIO $ withForeignRef fhv $ \rhv -> - writeIServ i (putMessage (FinishTH rhv)) - () <- runRemoteTH i [] - () <- readQResult i - writeTcRef (tcg_th_remote_state tcg) Nothing + when (gopt Opt_ExternalInterpreter dflags) $ + writeTcRef (tcg_th_remote_state tcg) Nothing runTHExp :: ForeignHValue -> TcM TH.Exp runTHExp = runTH THExp @@ -1073,6 +1118,9 @@ handleTHMessage msg = case msg of ReifyModule m -> wrapTHResult $ TH.qReifyModule m ReifyConStrictness nm -> wrapTHResult $ TH.qReifyConStrictness nm AddDependentFile f -> wrapTHResult $ TH.qAddDependentFile f + AddModFinalizer r -> do + hsc_env <- env_top <$> getEnv + wrapTHResult $ liftIO (mkFinalizedHValue hsc_env r) >>= addModFinalizerRef AddTopDecls decs -> wrapTHResult $ TH.qAddTopDecls decs IsExtEnabled ext -> wrapTHResult $ TH.qIsExtEnabled ext ExtsEnabled -> wrapTHResult $ TH.qExtsEnabled diff --git a/compiler/typecheck/TcSplice.hs-boot b/compiler/typecheck/TcSplice.hs-boot index db4884e35472655c6e615175128fef3ec2f7da55..14e479a04e3762724ad9679b3a6a4fbb2f928eb5 100644 --- a/compiler/typecheck/TcSplice.hs-boot +++ b/compiler/typecheck/TcSplice.hs-boot @@ -9,7 +9,7 @@ import TcType ( ExpRhoType ) import Annotations ( Annotation, CoreAnnTarget ) #ifdef GHCI -import HsSyn ( LHsType, LPat, LHsDecl ) +import HsSyn ( LHsType, LPat, LHsDecl, ThModFinalizers ) import RdrName ( RdrName ) import TcRnTypes ( SpliceType ) import qualified Language.Haskell.TH as TH @@ -39,5 +39,6 @@ runMetaD :: LHsExpr TcId -> TcM [LHsDecl RdrName] lookupThName_maybe :: TH.Name -> TcM (Maybe Name) runQuasi :: TH.Q a -> TcM a +runRemoteModFinalizers :: ThModFinalizers -> TcM () finishTH :: TcM () #endif diff --git a/iserv/src/Main.hs b/iserv/src/Main.hs index 3fcd49f5c791a162d27795520bca46d17141dfc3..66e15c9785e57f949bbcbe550cd3dd4c21cde700 100644 --- a/iserv/src/Main.hs +++ b/iserv/src/Main.hs @@ -53,7 +53,7 @@ serv verbose pipe@Pipe{..} restore = loop case msg of Shutdown -> return () RunTH st q ty loc -> wrapRunTH $ runTH pipe st q ty loc - FinishTH st -> wrapRunTH $ finishTH pipe st + RunModFinalizers st qrefs -> wrapRunTH $ runModFinalizerRefs pipe st qrefs _other -> run msg >>= reply reply :: forall a. (Binary a, Show a) => a -> IO () diff --git a/libraries/ghci/GHCi/Message.hs b/libraries/ghci/GHCi/Message.hs index b14fca4f2dc69a1eaccedb4731cf188b64e947a6..01fd7f0e3cb13a77c516a7b71cdaf1994b6e41f8 100644 --- a/libraries/ghci/GHCi/Message.hs +++ b/libraries/ghci/GHCi/Message.hs @@ -172,9 +172,6 @@ data Message a where -- | Start a new TH module, return a state token that should be StartTH :: Message (RemoteRef (IORef QState)) - -- | Run TH module finalizers, and free the HValueRef - FinishTH :: RemoteRef (IORef QState) -> Message (QResult ()) - -- | Evaluate a TH computation. -- -- Returns a ByteString, because we have to force the result @@ -189,6 +186,10 @@ data Message a where -> Maybe TH.Loc -> Message (QResult ByteString) + -- | Run the given mod finalizers. + RunModFinalizers :: RemoteRef (IORef QState) + -> [RemoteRef (TH.Q ())] + -> Message (QResult ()) deriving instance Show (Message a) @@ -223,6 +224,7 @@ data THMessage a where ReifyConStrictness :: TH.Name -> THMessage (THResult [TH.DecidedStrictness]) AddDependentFile :: FilePath -> THMessage (THResult ()) + AddModFinalizer :: RemoteRef (TH.Q ()) -> THMessage (THResult ()) AddTopDecls :: [TH.Dec] -> THMessage (THResult ()) IsExtEnabled :: Extension -> THMessage (THResult Bool) ExtsEnabled :: THMessage (THResult [Extension]) @@ -258,7 +260,8 @@ getTHMessage = do 13 -> THMsg <$> return ExtsEnabled 14 -> THMsg <$> return StartRecover 15 -> THMsg <$> EndRecover <$> get - _ -> return (THMsg RunTHDone) + 16 -> return (THMsg RunTHDone) + _ -> THMsg <$> AddModFinalizer <$> get putTHMessage :: THMessage a -> Put putTHMessage m = case m of @@ -279,6 +282,7 @@ putTHMessage m = case m of StartRecover -> putWord8 14 EndRecover a -> putWord8 15 >> put a RunTHDone -> putWord8 16 + AddModFinalizer a -> putWord8 17 >> put a data EvalOpts = EvalOpts @@ -368,8 +372,6 @@ instance Binary THResultType data QState = QState { qsMap :: Map TypeRep Dynamic -- ^ persistent data between splices in a module - , qsFinalizers :: [TH.Q ()] - -- ^ registered finalizers (in reverse order) , qsLocation :: Maybe TH.Loc -- ^ location for current splice, if any , qsPipe :: Pipe @@ -415,7 +417,7 @@ getMessage = do 29 -> Msg <$> (BreakpointStatus <$> get <*> get) 30 -> Msg <$> (GetBreakpointVar <$> get <*> get) 31 -> Msg <$> return StartTH - 32 -> Msg <$> FinishTH <$> get + 32 -> Msg <$> (RunModFinalizers <$> get <*> get) _ -> Msg <$> (RunTH <$> get <*> get <*> get <*> get) putMessage :: Message a -> Put @@ -452,7 +454,7 @@ putMessage m = case m of BreakpointStatus arr ix -> putWord8 29 >> put arr >> put ix GetBreakpointVar a b -> putWord8 30 >> put a >> put b StartTH -> putWord8 31 - FinishTH val -> putWord8 32 >> put val + RunModFinalizers a b -> putWord8 32 >> put a >> put b RunTH st q loc ty -> putWord8 33 >> put st >> put q >> put loc >> put ty -- ----------------------------------------------------------------------------- diff --git a/libraries/ghci/GHCi/TH.hs b/libraries/ghci/GHCi/TH.hs index 3495162a12a5d354193b85de2424cb43f4e3e7e9..def6aee33e7dcb4499a4aea735ce4cbc2de7e769 100644 --- a/libraries/ghci/GHCi/TH.hs +++ b/libraries/ghci/GHCi/TH.hs @@ -5,7 +5,12 @@ -- | -- Running TH splices -- -module GHCi.TH (startTH, finishTH, runTH, GHCiQException(..)) where +module GHCi.TH + ( startTH + , runModFinalizerRefs + , runTH + , GHCiQException(..) + ) where {- Note [Remote Template Haskell] @@ -110,14 +115,7 @@ import Unsafe.Coerce -- | Create a new instance of 'QState' initQState :: Pipe -> QState -initQState p = QState M.empty [] Nothing p - -runModFinalizers :: GHCiQ () -runModFinalizers = go =<< getState - where - go s | (f:ff) <- qsFinalizers s = do - putState (s { qsFinalizers = ff}) >> TH.runQ f >> getState >>= go - go _ = return () +initQState p = QState M.empty Nothing p -- | The monad in which we run TH computations on the server newtype GHCiQ a = GHCiQ { runGHCiQ :: QState -> IO (a, QState) } @@ -151,9 +149,6 @@ instance Fail.MonadFail GHCiQ where getState :: GHCiQ QState getState = GHCiQ $ \s -> return (s,s) -putState :: QState -> GHCiQ () -putState s = GHCiQ $ \_ -> return ((),s) - noLoc :: TH.Loc noLoc = TH.Loc "" "" "" (0,0) (0,0) @@ -198,8 +193,8 @@ instance TH.Quasi GHCiQ where qRunIO m = GHCiQ $ \s -> fmap (,s) m qAddDependentFile file = ghcCmd (AddDependentFile file) qAddTopDecls decls = ghcCmd (AddTopDecls decls) - qAddModFinalizer fin = GHCiQ $ \s -> - return ((), s { qsFinalizers = fin : qsFinalizers s }) + qAddModFinalizer fin = GHCiQ (\s -> mkRemoteRef fin >>= return . (, s)) >>= + ghcCmd . AddModFinalizer qGetQ = GHCiQ $ \s -> let lookup :: forall a. Typeable a => Map TypeRep Dynamic -> Maybe a lookup m = fromDynamic =<< M.lookup (typeOf (undefined::a)) m @@ -216,12 +211,17 @@ startTH = do r <- newIORef (initQState (error "startTH: no pipe")) mkRemoteRef r --- | The implementation of the 'FinishTH' message. -finishTH :: Pipe -> RemoteRef (IORef QState) -> IO () -finishTH pipe rstate = do +-- | Runs the mod finalizers. +-- +-- The references must be created on the caller process. +runModFinalizerRefs :: Pipe -> RemoteRef (IORef QState) + -> [RemoteRef (TH.Q ())] + -> IO () +runModFinalizerRefs pipe rstate qrefs = do + qs <- mapM localRef qrefs qstateref <- localRef rstate qstate <- readIORef qstateref - _ <- runGHCiQ runModFinalizers qstate { qsPipe = pipe } + _ <- runGHCiQ (TH.runQ $ sequence_ qs) qstate { qsPipe = pipe } return () -- | The implementation of the 'RunTH' message diff --git a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs index dfcf471f1dabfc99da0dc447313f9497eae2b8bf..62bdd10aacb4688a24912562e1a91fdb743cdd63 100644 --- a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs +++ b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs @@ -458,6 +458,10 @@ addTopDecls ds = Q (qAddTopDecls ds) -- | Add a finalizer that will run in the Q monad after the current module has -- been type checked. This only makes sense when run within a top-level splice. +-- +-- The finalizer is given the local type environment at the splice point. Thus +-- 'reify' is able to find the local definitions when executed inside the +-- finalizer. addModFinalizer :: Q () -> Q () addModFinalizer act = Q (qAddModFinalizer (unQ act)) diff --git a/testsuite/tests/th/TH_reifyLocalDefs.hs b/testsuite/tests/th/TH_reifyLocalDefs.hs new file mode 100644 index 0000000000000000000000000000000000000000..0bfc90fe1a9a49f02ac48a2926793a7731769c48 --- /dev/null +++ b/testsuite/tests/th/TH_reifyLocalDefs.hs @@ -0,0 +1,36 @@ +-- test reification of local definitions +{-# LANGUAGE CPP #-} +{-# LANGUAGE TemplateHaskell #-} +import Language.Haskell.TH.Syntax +import System.IO + +-- Sidestep the staging restriction +-- printTypeOf :: String -> Q () +#define printTypeOf(n) (addModFinalizer $ do \ + { VarI _ t _ <- reify (mkName (n)) \ + ; runIO $ hPutStrLn stderr (n ++ " :: " ++ show t) \ + }) + +main :: IO () +main = print (f 1 "", g 'a' 2, h True 3) + where + f xf yf = ( xf :: Int + , let ff $(do printTypeOf("yf") + [p| z |] + ) = z :: $(do printTypeOf("z") + [t| () |] + ) + in $(do printTypeOf("xf") + [| yf :: String |] + ) + ) + g xg y = ( $(do printTypeOf("xg") + [| y :: Int |] + ) + , xg :: Char + ) + h xh y = ( $$(do printTypeOf("xh") + [|| y :: Int ||] + ) + , xh :: Bool + ) diff --git a/testsuite/tests/th/TH_reifyLocalDefs.stderr b/testsuite/tests/th/TH_reifyLocalDefs.stderr new file mode 100644 index 0000000000000000000000000000000000000000..6b654f2986173217c6a936c9ca618dfce0afd9dd --- /dev/null +++ b/testsuite/tests/th/TH_reifyLocalDefs.stderr @@ -0,0 +1,5 @@ +xh :: ConT GHC.Types.Bool +xf :: ConT GHC.Types.Int +z :: TupleT 0 +yf :: ConT GHC.Base.String +xg :: ConT GHC.Types.Char diff --git a/testsuite/tests/th/all.T b/testsuite/tests/th/all.T index 10da6f0e3cb5adfddbe43db13dfc1187b09c2c3d..ff2d6d465f692330bc35c5e5e29475a2d9ea5589 100644 --- a/testsuite/tests/th/all.T +++ b/testsuite/tests/th/all.T @@ -77,6 +77,7 @@ test('TH_spliceD2', test('TH_reifyDecl1', normal, compile, ['-v0']) test('TH_reifyDecl2', normal, compile, ['-v0']) +test('TH_reifyLocalDefs', normal, compile, ['-v0']) test('TH_reifyMkName', normal, compile, ['-v0'])