Commit 567dbd9b authored by Facundo Domínguez's avatar Facundo Domínguez

Have addModFinalizer expose the local type environment.

Summary:
This annotates the splice point with 'HsSpliced ref e' where 'e' is the
result of the splice. 'ref' is a reference that the typechecker will fill with
the local type environment.

The finalizer then reads the ref and uses the local type environment, which
causes 'reify' to find local variables when run in the finalizer.

Test Plan: ./validate

Reviewers: simonpj, simonmar, bgamari, austin, goldfire

Reviewed By: goldfire

Subscribers: simonmar, thomie, mboes

Differential Revision: https://phabricator.haskell.org/D2286

GHC Trac Issues: #11832
parent f560a03c
...@@ -1071,6 +1071,7 @@ repSplice :: HsSplice Name -> DsM (Core a) ...@@ -1071,6 +1071,7 @@ repSplice :: HsSplice Name -> DsM (Core a)
repSplice (HsTypedSplice n _) = rep_splice n repSplice (HsTypedSplice n _) = rep_splice n
repSplice (HsUntypedSplice n _) = rep_splice n repSplice (HsUntypedSplice n _) = rep_splice n
repSplice (HsQuasiQuote 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 :: Name -> DsM (Core a)
rep_splice splice_name rep_splice splice_name
......
...@@ -45,8 +45,14 @@ import Type ...@@ -45,8 +45,14 @@ import Type
-- libraries: -- libraries:
import Data.Data hiding (Fixity(..)) import Data.Data hiding (Fixity(..))
import qualified Data.Data as Data (Fixity(..))
import Data.Maybe (isNothing) 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 ...@@ -1926,12 +1932,55 @@ data HsSplice id
SrcSpan -- The span of the enclosed string SrcSpan -- The span of the enclosed string
FastString -- 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) deriving instance (DataId id) => Data (HsSplice id)
isTypedSplice :: HsSplice id -> Bool isTypedSplice :: HsSplice id -> Bool
isTypedSplice (HsTypedSplice {}) = True isTypedSplice (HsTypedSplice {}) = True
isTypedSplice _ = False -- Quasi-quotes are untyped splices 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] -- See Note [Pending Splices]
type SplicePointName = Name type SplicePointName = Name
...@@ -2015,6 +2064,11 @@ splices. In contrast, when pretty printing the output of the type checker, we ...@@ -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. 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 instance (OutputableBndrId id) => Outputable (HsSplice id) where
ppr s = pprSplice s ppr s = pprSplice s
...@@ -2026,6 +2080,7 @@ pprSplice :: (OutputableBndrId id) => HsSplice id -> SDoc ...@@ -2026,6 +2080,7 @@ pprSplice :: (OutputableBndrId id) => HsSplice id -> SDoc
pprSplice (HsTypedSplice n e) = ppr_splice (text "$$") n e pprSplice (HsTypedSplice n e) = ppr_splice (text "$$") n e
pprSplice (HsUntypedSplice 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 (HsQuasiQuote n q _ s) = ppr_quasi n q s
pprSplice (HsSpliced _ thing) = ppr thing
ppr_quasi :: OutputableBndr id => id -> id -> FastString -> SDoc ppr_quasi :: OutputableBndr id => id -> id -> FastString -> SDoc
ppr_quasi n quoter quote = ifPprDebug (brackets (ppr n)) <> ppr_quasi n quoter quote = ifPprDebug (brackets (ppr n)) <>
......
...@@ -446,6 +446,10 @@ rnPatAndThen mk (TuplePat pats boxed _) ...@@ -446,6 +446,10 @@ rnPatAndThen mk (TuplePat pats boxed _)
; pats' <- rnLPatsAndThen mk pats ; pats' <- rnLPatsAndThen mk pats
; return (TuplePat pats' boxed []) } ; 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) rnPatAndThen mk (SplicePat splice)
= do { eith <- liftCpsFV $ rnSplicePat splice = do { eith <- liftCpsFV $ rnSplicePat splice
; case eith of -- See Note [rnSplicePat] in RnSplice ; case eith of -- See Note [rnSplicePat] in RnSplice
......
...@@ -46,7 +46,17 @@ import THNames ( quoteExpName, quotePatName, quoteDecName, quoteTypeNam ...@@ -46,7 +46,17 @@ import THNames ( quoteExpName, quotePatName, quoteDecName, quoteTypeNam
, decsQTyConName, expQTyConName, patQTyConName, typeQTyConName, ) , decsQTyConName, expQTyConName, patQTyConName, typeQTyConName, )
import {-# SOURCE #-} TcExpr ( tcPolyExpr ) 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 #endif
import qualified GHC.LanguageExtensions as LangExt import qualified GHC.LanguageExtensions as LangExt
...@@ -77,6 +87,10 @@ rnBracket e br_body ...@@ -77,6 +87,10 @@ rnBracket e br_body
illegalUntypedBracket illegalUntypedBracket
; Splice Untyped -> checkTc (not (isTypedBracket br_body)) ; Splice Untyped -> checkTc (not (isTypedBracket br_body))
illegalTypedBracket illegalTypedBracket
; RunSplice _ ->
-- See Note [RunSplice ThLevel] in "TcRnTypes".
pprPanic "rnBracket: Renaming bracket when running a splice"
(ppr e)
; Comp -> return () ; Comp -> return ()
; Brack {} -> failWithTc illegalBracket ; Brack {} -> failWithTc illegalBracket
} }
...@@ -278,12 +292,17 @@ rnSpliceGen run_splice pend_splice splice ...@@ -278,12 +292,17 @@ rnSpliceGen run_splice pend_splice splice
else Untyped 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 runRnSplice :: UntypedSpliceFlavour
-> (LHsExpr Id -> TcRn res) -> (LHsExpr Id -> TcRn res)
-> (res -> SDoc) -- How to pretty-print res -> (res -> SDoc) -- How to pretty-print res
-- Usually just ppr, but not for [Decl] -- Usually just ppr, but not for [Decl]
-> HsSplice Name -- Always untyped -> HsSplice Name -- Always untyped
-> TcRn res -> TcRn (res, [ForeignRef (TH.Q ())])
runRnSplice flavour run_meta ppr_res splice runRnSplice flavour run_meta ppr_res splice
= do { splice' <- getHooked runRnSpliceHook return >>= ($ splice) = do { splice' <- getHooked runRnSpliceHook return >>= ($ splice)
...@@ -291,6 +310,7 @@ runRnSplice flavour run_meta ppr_res splice ...@@ -291,6 +310,7 @@ runRnSplice flavour run_meta ppr_res splice
HsUntypedSplice _ e -> e HsUntypedSplice _ e -> e
HsQuasiQuote _ q qs str -> mkQuasiQuoteExpr flavour q qs str HsQuasiQuote _ q qs str -> mkQuasiQuoteExpr flavour q qs str
HsTypedSplice {} -> pprPanic "runRnSplice" (ppr splice) HsTypedSplice {} -> pprPanic "runRnSplice" (ppr splice)
HsSpliced {} -> pprPanic "runRnSplice" (ppr splice)
-- Typecheck the expression -- Typecheck the expression
; meta_exp_ty <- tcMetaTy meta_ty_name ; meta_exp_ty <- tcMetaTy meta_ty_name
...@@ -298,13 +318,16 @@ runRnSplice flavour run_meta ppr_res splice ...@@ -298,13 +318,16 @@ runRnSplice flavour run_meta ppr_res splice
tcPolyExpr the_expr meta_exp_ty tcPolyExpr the_expr meta_exp_ty
-- Run the expression -- 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 ; traceSplice (SpliceInfo { spliceDescription = what
, spliceIsDecl = is_decl , spliceIsDecl = is_decl
, spliceSource = Just the_expr , spliceSource = Just the_expr
, spliceGenerated = ppr_res result }) , spliceGenerated = ppr_res result })
; return result } ; return (result, mod_finalizers) }
where where
meta_ty_name = case flavour of meta_ty_name = case flavour of
...@@ -331,6 +354,8 @@ makePending flavour (HsQuasiQuote n quoter q_span quote) ...@@ -331,6 +354,8 @@ makePending flavour (HsQuasiQuote n quoter q_span quote)
= PendingRnSplice flavour n (mkQuasiQuoteExpr flavour quoter q_span quote) = PendingRnSplice flavour n (mkQuasiQuoteExpr flavour quoter q_span quote)
makePending _ splice@(HsTypedSplice {}) makePending _ splice@(HsTypedSplice {})
= pprPanic "makePending" (ppr splice) = pprPanic "makePending" (ppr splice)
makePending _ splice@(HsSpliced {})
= pprPanic "makePending" (ppr splice)
------------------ ------------------
mkQuasiQuoteExpr :: UntypedSpliceFlavour -> Name -> SrcSpan -> FastString -> LHsExpr Name mkQuasiQuoteExpr :: UntypedSpliceFlavour -> Name -> SrcSpan -> FastString -> LHsExpr Name
...@@ -380,6 +405,8 @@ rnSplice (HsQuasiQuote splice_name quoter q_loc quote) ...@@ -380,6 +405,8 @@ rnSplice (HsQuasiQuote splice_name quoter q_loc quote)
; return (HsQuasiQuote splice_name' quoter' q_loc quote, unitFV quoter') } ; 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 :: HsSplice RdrName -> RnM (HsExpr Name, FreeVars)
rnSpliceExpr splice rnSpliceExpr splice
...@@ -404,9 +431,16 @@ rnSpliceExpr splice ...@@ -404,9 +431,16 @@ rnSpliceExpr splice
| otherwise -- Run it here, see Note [Running splices in the Renamer] | otherwise -- Run it here, see Note [Running splices in the Renamer]
= do { traceRn (text "rnSpliceExpr: untyped expression splice") = 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) ; (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] {- Note [Running splices in the Renamer]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
...@@ -450,6 +484,54 @@ to try and ...@@ -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 rnSpliceType :: HsSplice RdrName -> PostTc Name Kind
-> RnM (HsType Name, FreeVars) -> RnM (HsType Name, FreeVars)
...@@ -461,11 +543,18 @@ rnSpliceType splice k ...@@ -461,11 +543,18 @@ rnSpliceType splice k
run_type_splice rn_splice run_type_splice rn_splice
= do { traceRn (text "rnSpliceType: untyped type 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 ; (hs_ty3, fvs) <- do { let doc = SpliceTypeCtx hs_ty2
; checkNoErrs $ rnLHsType doc hs_ty2 } ; checkNoErrs $ rnLHsType doc hs_ty2 }
-- checkNoErrs: see Note [Renamer errors] -- 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 -- Wrap the result of the splice in parens so that we don't
-- lose the outermost location set by runQuasiQuote (#7918) -- lose the outermost location set by runQuasiQuote (#7918)
...@@ -521,8 +610,15 @@ rnSplicePat splice ...@@ -521,8 +610,15 @@ rnSplicePat splice
run_pat_splice rn_splice run_pat_splice rn_splice
= do { traceRn (text "rnSplicePat: untyped pattern splice") = do { traceRn (text "rnSplicePat: untyped pattern splice")
; pat <- runRnSplice UntypedPatSplice runMetaP ppr rn_splice ; (pat, mod_finalizers) <-
; return (Left (ParPat pat), emptyFVs) } 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 -- Wrap the result of the quasi-quoter in parens so that we don't
-- lose the outermost location set by runQuasiQuote (#7918) -- lose the outermost location set by runQuasiQuote (#7918)
...@@ -542,12 +638,28 @@ rnTopSpliceDecls splice ...@@ -542,12 +638,28 @@ rnTopSpliceDecls splice
= do { (rn_splice, fvs) <- setStage (Splice Untyped) $ = do { (rn_splice, fvs) <- setStage (Splice Untyped) $
rnSplice splice rnSplice splice
; traceRn (text "rnTopSpliceDecls: untyped declaration 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) } ; return (decls,fvs) }
where where
ppr_decls :: [LHsDecl RdrName] -> SDoc ppr_decls :: [LHsDecl RdrName] -> SDoc
ppr_decls ds = vcat (map ppr ds) 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] Note [rnSplicePat]
~~~~~~~~~~~~~~~~~~ ~~~~~~~~~~~~~~~~~~
...@@ -582,6 +694,7 @@ spliceCtxt splice ...@@ -582,6 +694,7 @@ spliceCtxt splice
HsUntypedSplice {} -> text "untyped splice:" HsUntypedSplice {} -> text "untyped splice:"
HsTypedSplice {} -> text "typed splice:" HsTypedSplice {} -> text "typed splice:"
HsQuasiQuote {} -> text "quasi-quotation:" HsQuasiQuote {} -> text "quasi-quotation:"
HsSpliced {} -> text "spliced expression:"
-- | The splice data to be logged -- | The splice data to be logged
data SpliceInfo data SpliceInfo
......
...@@ -1031,6 +1031,7 @@ collectAnonWildCards lty = go lty ...@@ -1031,6 +1031,7 @@ collectAnonWildCards lty = go lty
`mappend` go ty `mappend` go ty
HsQualTy { hst_ctxt = L _ ctxt HsQualTy { hst_ctxt = L _ ctxt
, hst_body = ty } -> gos ctxt `mappend` go ty , hst_body = ty } -> gos ctxt `mappend` go ty
HsSpliceTy (HsSpliced _ (HsSplicedTy ty)) _ -> go $ L noSrcSpan ty
-- HsQuasiQuoteTy, HsSpliceTy, HsCoreTy, HsTyLit -- HsQuasiQuoteTy, HsSpliceTy, HsCoreTy, HsTyLit
_ -> mempty _ -> mempty
......
...@@ -981,6 +981,14 @@ tcExpr (PArrSeq _ _) _ ...@@ -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 tcExpr (HsSpliceE splice) res_ty
= tcSpliceExpr splice res_ty = tcSpliceExpr splice res_ty
tcExpr (HsBracket brack) res_ty tcExpr (HsBracket brack) res_ty
......
...@@ -501,6 +501,18 @@ tc_hs_type _ ty@(HsRecTy _) _ ...@@ -501,6 +501,18 @@ tc_hs_type _ ty@(HsRecTy _) _
-- signatures) should have been removed by now -- signatures) should have been removed by now
= failWithTc (text "Record syntax is illegal here:" <+> ppr ty) = 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 -- This should never happen; type splices are expanded by the renamer
tc_hs_type _ ty@(HsSpliceTy {}) _exp_kind tc_hs_type _ ty@(HsSpliceTy {}) _exp_kind
= failWithTc (text "Unexpected type splice:" <+> ppr ty) = failWithTc (text "Unexpected type splice:" <+> ppr ty)
......
...@@ -583,6 +583,15 @@ tc_pat penv (NPlusKPat (L nm_loc name) (L loc lit) _ ge minus _) pat_ty thing_in ...@@ -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 ge' minus'' pat_ty
; return (pat', res) } ; 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 tc_pat _ _other_pat _ _ = panic "tc_pat" -- ConPatOut, SigPatOut
---------------- ----------------
......
...@@ -106,6 +106,7 @@ module TcRnMonad( ...@@ -106,6 +106,7 @@ module TcRnMonad(
-- * Template Haskell context -- * Template Haskell context
recordThUse, recordThSpliceUse, recordTopLevelSpliceLoc, recordThUse, recordThSpliceUse, recordTopLevelSpliceLoc,
getTopLevelSpliceLocs, keepAlive, getStage, getStageAndBindLevel, setStage, getTopLevelSpliceLocs, keepAlive, getStage, getStageAndBindLevel, setStage,
addModFinalizersWithLclEnv,
-- * Safe Haskell context -- * Safe Haskell context
recordUnsafeInfer, finalSafeMode, fixSafeInstances, recordUnsafeInfer, finalSafeMode, fixSafeInstances,
...@@ -174,6 +175,7 @@ import Data.Set ( Set ) ...@@ -174,6 +175,7 @@ import Data.Set ( Set )
import qualified Data.Set as Set import qualified Data.Set as Set
#ifdef GHCI #ifdef GHCI
import {-# SOURCE #-} TcSplice ( runRemoteModFinalizers )
import qualified Data.Map as Map import qualified Data.Map as Map
#endif #endif
...@@ -1529,6 +1531,21 @@ getStageAndBindLevel name ...@@ -1529,6 +1531,21 @@ getStageAndBindLevel name
setStage :: ThStage -> TcM a -> TcRn a setStage :: ThStage -> TcM a -> TcRn a
setStage s = updLclEnv (\ env -> env { tcl_th_ctxt = s }) 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
{- {-
************************************************************************ ************************************************************************
* * * *
......
...@@ -502,8 +502,11 @@ data TcGblEnv ...@@ -502,8 +502,11 @@ data TcGblEnv
tcg_th_topnames :: TcRef NameSet, tcg_th_topnames :: TcRef NameSet,
-- ^ Exact names bound in top-level declarations in tcg_th_topdecls -- ^ Exact names bound in top-level declarations in tcg_th_topdecls
tcg_th_modfinalizers :: TcRef [TH.Q ()], tcg_th_modfinalizers :: TcRef [TcM ()],
-- ^ Template Haskell module finalizers -- ^ Template Haskell module finalizers.
--
-- They are computations in the @TcM@ monad rather than @Q@ because we
-- set them to use particular local environments.