diff options
Diffstat (limited to 'compiler/GHC/Rename/Splice.hs')
| -rw-r--r-- | compiler/GHC/Rename/Splice.hs | 902 |
1 files changed, 902 insertions, 0 deletions
diff --git a/compiler/GHC/Rename/Splice.hs b/compiler/GHC/Rename/Splice.hs new file mode 100644 index 0000000000..5211834c0e --- /dev/null +++ b/compiler/GHC/Rename/Splice.hs @@ -0,0 +1,902 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} + +module GHC.Rename.Splice ( + rnTopSpliceDecls, + rnSpliceType, rnSpliceExpr, rnSplicePat, rnSpliceDecl, + rnBracket, + checkThLocalName + , traceSplice, SpliceInfo(..) + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import Name +import NameSet +import GHC.Hs +import RdrName +import TcRnMonad + +import GHC.Rename.Env +import GHC.Rename.Utils ( HsDocContext(..), newLocalBndrRn ) +import GHC.Rename.Unbound ( isUnboundName ) +import GHC.Rename.Source ( rnSrcDecls, findSplice ) +import GHC.Rename.Pat ( rnPat ) +import BasicTypes ( TopLevelFlag, isTopLevel, SourceText(..) ) +import Outputable +import Module +import SrcLoc +import GHC.Rename.Types ( rnLHsType ) + +import Control.Monad ( unless, when ) + +import {-# SOURCE #-} GHC.Rename.Expr ( rnLExpr ) + +import TcEnv ( checkWellStaged ) +import THNames ( liftName ) + +import DynFlags +import FastString +import ErrUtils ( dumpIfSet_dyn_printer, DumpFormat (..) ) +import TcEnv ( tcMetaTy ) +import Hooks +import THNames ( quoteExpName, quotePatName, quoteDecName, quoteTypeName + , decsQTyConName, expQTyConName, patQTyConName, typeQTyConName, ) + +import {-# SOURCE #-} TcExpr ( tcPolyExpr ) +import {-# SOURCE #-} TcSplice + ( runMetaD + , runMetaE + , runMetaP + , runMetaT + , tcTopSpliceExpr + ) + +import TcHsSyn + +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 e br_body + = addErrCtxt (quotationCtxtDoc br_body) $ + do { -- Check that -XTemplateHaskellQuotes is enabled and available + thQuotesEnabled <- xoptM LangExt.TemplateHaskellQuotes + ; unless thQuotesEnabled $ + failWith ( vcat + [ text "Syntax error on" <+> ppr e + , text ("Perhaps you intended to use TemplateHaskell" + ++ " or TemplateHaskellQuotes") ] ) + + -- Check for nested brackets + ; cur_stage <- getStage + ; case cur_stage of + { Splice Typed -> checkTc (isTypedBracket 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 + } + + -- Brackets are desugared to code that mentions the TH package + ; recordThUse + + ; case isTypedBracket br_body of + True -> do { traceRn "Renaming typed TH bracket" empty + ; (body', fvs_e) <- + setStage (Brack cur_stage RnPendingTyped) $ + rn_bracket cur_stage br_body + ; return (HsBracket noExtField body', fvs_e) } + + False -> do { traceRn "Renaming untyped TH bracket" empty + ; ps_var <- newMutVar [] + ; (body', fvs_e) <- + setStage (Brack cur_stage (RnPendingUntyped ps_var)) $ + rn_bracket cur_stage br_body + ; pendings <- readMutVar ps_var + ; return (HsRnBracketOut noExtField body' pendings, fvs_e) } + } + +rn_bracket :: ThStage -> HsBracket GhcPs -> RnM (HsBracket GhcRn, FreeVars) +rn_bracket outer_stage br@(VarBr x flg rdr_name) + = do { name <- lookupOccRn rdr_name + ; this_mod <- getModule + + ; when (flg && nameIsLocalOrFrom this_mod name) $ + -- Type variables can be quoted in TH. See #5721. + do { mb_bind_lvl <- lookupLocalOccThLvl_maybe name + ; case mb_bind_lvl of + { Nothing -> return () -- Can happen for data constructors, + -- but nothing needs to be done for them + + ; Just (top_lvl, bind_lvl) -- See Note [Quoting names] + | isTopLevel top_lvl + -> when (isExternalName name) (keepAlive name) + | otherwise + -> do { traceRn "rn_bracket VarBr" + (ppr name <+> ppr bind_lvl + <+> ppr outer_stage) + ; checkTc (thLevel outer_stage + 1 == bind_lvl) + (quotedNameStageErr br) } + } + } + ; return (VarBr x flg name, unitFV name) } + +rn_bracket _ (ExpBr x e) = do { (e', fvs) <- rnLExpr e + ; return (ExpBr x e', fvs) } + +rn_bracket _ (PatBr x p) + = rnPat ThPatQuote p $ \ p' -> return (PatBr x p', emptyFVs) + +rn_bracket _ (TypBr x t) = do { (t', fvs) <- rnLHsType TypBrCtx t + ; return (TypBr x t', fvs) } + +rn_bracket _ (DecBrL x decls) + = do { group <- groupDecls decls + ; gbl_env <- getGblEnv + ; let new_gbl_env = gbl_env { tcg_dus = emptyDUs } + -- The emptyDUs is so that we just collect uses for this + -- group alone in the call to rnSrcDecls below + ; (tcg_env, group') <- setGblEnv new_gbl_env $ + rnSrcDecls group + + -- Discard the tcg_env; it contains only extra info about fixity + ; traceRn "rn_bracket dec" (ppr (tcg_dus tcg_env) $$ + ppr (duUses (tcg_dus tcg_env))) + ; return (DecBrG x group', duUses (tcg_dus tcg_env)) } + where + groupDecls :: [LHsDecl GhcPs] -> RnM (HsGroup GhcPs) + groupDecls decls + = do { (group, mb_splice) <- findSplice decls + ; case mb_splice of + { Nothing -> return group + ; Just (splice, rest) -> + do { group' <- groupDecls rest + ; let group'' = appendGroups group group' + ; return group'' { hs_splcds = noLoc splice : hs_splcds group' } + } + }} + +rn_bracket _ (DecBrG {}) = panic "rn_bracket: unexpected DecBrG" + +rn_bracket _ (TExpBr x e) = do { (e', fvs) <- rnLExpr e + ; return (TExpBr x e', fvs) } + +rn_bracket _ (XBracket nec) = noExtCon nec + +quotationCtxtDoc :: HsBracket GhcPs -> SDoc +quotationCtxtDoc br_body + = hang (text "In the Template Haskell quotation") + 2 (ppr br_body) + +illegalBracket :: SDoc +illegalBracket = + text "Template Haskell brackets cannot be nested" <+> + text "(without intervening splices)" + +illegalTypedBracket :: SDoc +illegalTypedBracket = + text "Typed brackets may only appear in typed splices." + +illegalUntypedBracket :: SDoc +illegalUntypedBracket = + text "Untyped brackets may only appear in untyped splices." + +quotedNameStageErr :: HsBracket GhcPs -> SDoc +quotedNameStageErr br + = sep [ text "Stage error: the non-top-level quoted name" <+> ppr br + , text "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 run_splice pend_splice splice + = addErrCtxt (spliceCtxt splice) $ do + { stage <- getStage + ; case stage of + Brack pop_stage RnPendingTyped + -> do { checkTc is_typed_splice illegalUntypedSplice + ; (splice', fvs) <- setStage pop_stage $ + rnSplice splice + ; let (_pending_splice, result) = pend_splice splice' + ; return (result, fvs) } + + Brack pop_stage (RnPendingUntyped ps_var) + -> do { checkTc (not is_typed_splice) illegalTypedSplice + ; (splice', fvs) <- setStage pop_stage $ + rnSplice splice + ; let (pending_splice, result) = pend_splice splice' + ; ps <- readMutVar ps_var + ; writeMutVar ps_var (pending_splice : ps) + ; return (result, fvs) } + + _ -> do { (splice', fvs1) <- checkNoErrs $ + setStage (Splice splice_type) $ + rnSplice 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 + ; (result, fvs2) <- run_splice splice' + ; return (result, fvs1 `plusFV` fvs2) } } + where + is_typed_splice = isTypedSplice splice + splice_type = if is_typed_splice + then Typed + 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 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 flavour run_meta ppr_res splice + = do { splice' <- getHooked runRnSpliceHook return >>= ($ splice) + + ; let the_expr = case splice' of + HsUntypedSplice _ _ _ e -> e + HsQuasiQuote _ _ q qs str -> mkQuasiQuoteExpr flavour q qs str + HsTypedSplice {} -> pprPanic "runRnSplice" (ppr splice) + HsSpliced {} -> pprPanic "runRnSplice" (ppr splice) + HsSplicedT {} -> pprPanic "runRnSplice" (ppr splice) + XSplice nec -> noExtCon nec + + -- Typecheck the expression + ; meta_exp_ty <- tcMetaTy meta_ty_name + ; zonked_q_expr <- zonkTopLExpr =<< + tcTopSpliceExpr Untyped + (tcPolyExpr the_expr meta_exp_ty) + + -- Run the expression + ; 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, mod_finalizers) } + + where + meta_ty_name = case flavour of + UntypedExpSplice -> expQTyConName + UntypedPatSplice -> patQTyConName + UntypedTypeSplice -> typeQTyConName + UntypedDeclSplice -> decsQTyConName + what = case flavour of + UntypedExpSplice -> "expression" + UntypedPatSplice -> "pattern" + UntypedTypeSplice -> "type" + UntypedDeclSplice -> "declarations" + is_decl = case flavour of + UntypedDeclSplice -> True + _ -> False + +------------------ +makePending :: UntypedSpliceFlavour + -> HsSplice GhcRn + -> PendingRnSplice +makePending flavour (HsUntypedSplice _ _ n e) + = PendingRnSplice flavour n e +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) +makePending _ splice@(HsSplicedT {}) + = pprPanic "makePending" (ppr splice) +makePending _ (XSplice nec) + = noExtCon nec + +------------------ +mkQuasiQuoteExpr :: UntypedSpliceFlavour -> Name -> SrcSpan -> FastString + -> LHsExpr GhcRn +-- Return the expression (quoter "...quote...") +-- which is what we must run in a quasi-quote +mkQuasiQuoteExpr flavour quoter q_span quote + = L q_span $ HsApp noExtField (L q_span + $ HsApp noExtField (L q_span (HsVar noExtField (L q_span quote_selector))) + quoterExpr) + quoteExpr + where + quoterExpr = L q_span $! HsVar noExtField $! (L q_span quoter) + quoteExpr = L q_span $! HsLit noExtField $! HsString NoSourceText quote + quote_selector = case flavour of + UntypedExpSplice -> quoteExpName + UntypedPatSplice -> quotePatName + UntypedTypeSplice -> quoteTypeName + UntypedDeclSplice -> quoteDecName + +--------------------- +rnSplice :: HsSplice GhcPs -> RnM (HsSplice GhcRn, FreeVars) +-- Not exported...used for all +rnSplice (HsTypedSplice x hasParen splice_name expr) + = do { loc <- getSrcSpanM + ; n' <- newLocalBndrRn (L loc splice_name) + ; (expr', fvs) <- rnLExpr expr + ; return (HsTypedSplice x hasParen n' expr', fvs) } + +rnSplice (HsUntypedSplice x hasParen splice_name expr) + = do { loc <- getSrcSpanM + ; n' <- newLocalBndrRn (L loc splice_name) + ; (expr', fvs) <- rnLExpr expr + ; return (HsUntypedSplice x hasParen n' expr', fvs) } + +rnSplice (HsQuasiQuote x splice_name quoter q_loc quote) + = do { loc <- getSrcSpanM + ; splice_name' <- newLocalBndrRn (L loc splice_name) + + -- Rename the quoter; akin to the HsVar case of rnExpr + ; quoter' <- lookupOccRn quoter + ; this_mod <- getModule + ; when (nameIsLocalOrFrom this_mod quoter') $ + checkThLocalName quoter' + + ; return (HsQuasiQuote x splice_name' quoter' q_loc quote + , unitFV quoter') } + +rnSplice splice@(HsSpliced {}) = pprPanic "rnSplice" (ppr splice) +rnSplice splice@(HsSplicedT {}) = pprPanic "rnSplice" (ppr splice) +rnSplice (XSplice nec) = noExtCon nec + +--------------------- +rnSpliceExpr :: HsSplice GhcPs -> RnM (HsExpr GhcRn, FreeVars) +rnSpliceExpr splice + = rnSpliceGen run_expr_splice pend_expr_splice splice + where + pend_expr_splice :: HsSplice GhcRn -> (PendingRnSplice, HsExpr GhcRn) + pend_expr_splice rn_splice + = (makePending UntypedExpSplice rn_splice, HsSpliceE noExtField rn_splice) + + run_expr_splice :: HsSplice GhcRn -> RnM (HsExpr GhcRn, FreeVars) + run_expr_splice rn_splice + | isTypedSplice rn_splice -- Run it later, in the type checker + = do { -- Ugh! See Note [Splices] above + traceRn "rnSpliceExpr: typed expression splice" empty + ; lcl_rdr <- getLocalRdrEnv + ; gbl_rdr <- getGlobalRdrEnv + ; let gbl_names = mkNameSet [gre_name gre | gre <- globalRdrEnvElts gbl_rdr + , isLocalGRE gre] + lcl_names = mkNameSet (localRdrEnvElts lcl_rdr) + + ; return (HsSpliceE noExtField rn_splice, lcl_names `plusFV` gbl_names) } + + | otherwise -- Run it here, see Note [Running splices in the Renamer] + = do { traceRn "rnSpliceExpr: untyped expression splice" empty + ; (rn_expr, mod_finalizers) <- + runRnSplice UntypedExpSplice runMetaE ppr rn_splice + ; (lexpr3, fvs) <- checkNoErrs (rnLExpr rn_expr) + -- See Note [Delaying modFinalizers in untyped splices]. + ; return ( HsPar noExtField $ HsSpliceE noExtField + . HsSpliced noExtField (ThModFinalizers mod_finalizers) + . HsSplicedExpr <$> + lexpr3 + , 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 [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] 'TcSplice.qAddModFinalizer' +[4] 'TcExpr.tcExpr' ('HsSpliceE' ('HsSpliced' ...)) +[5] 'TcHsType.tc_hs_type' ('HsSpliceTy' ('HsSpliced' ...)) +[6] 'TcPat.tc_pat' ('SplicePat' ('HsSpliced' ...)) + +-} + +---------------------- +rnSpliceType :: HsSplice GhcPs -> RnM (HsType GhcRn, FreeVars) +rnSpliceType splice + = rnSpliceGen run_type_splice pend_type_splice splice + where + pend_type_splice rn_splice + = ( makePending UntypedTypeSplice rn_splice + , HsSpliceTy noExtField rn_splice) + + run_type_splice rn_splice + = do { traceRn "rnSpliceType: untyped type splice" empty + ; (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] + -- See Note [Delaying modFinalizers in untyped splices]. + ; return ( HsParTy noExtField + $ HsSpliceTy noExtField + . HsSpliced noExtField (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) + +{- 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.Types.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 splice + = rnSpliceGen run_pat_splice pend_pat_splice splice + where + pend_pat_splice :: HsSplice GhcRn -> + (PendingRnSplice, Either b (Pat GhcRn)) + pend_pat_splice rn_splice + = (makePending UntypedPatSplice rn_splice + , Right (SplicePat noExtField rn_splice)) + + run_pat_splice :: HsSplice GhcRn -> + RnM (Either (Pat GhcPs) (Pat GhcRn), FreeVars) + run_pat_splice rn_splice + = do { traceRn "rnSplicePat: untyped pattern splice" empty + ; (pat, mod_finalizers) <- + runRnSplice UntypedPatSplice runMetaP ppr rn_splice + -- See Note [Delaying modFinalizers in untyped splices]. + ; return ( Left $ ParPat noExtField $ ((SplicePat noExtField) + . HsSpliced noExtField (ThModFinalizers mod_finalizers) + . HsSplicedPat) `mapLoc` + pat + , 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 _ (L loc splice) flg) + = rnSpliceGen run_decl_splice pend_decl_splice splice + where + pend_decl_splice rn_splice + = ( makePending UntypedDeclSplice rn_splice + , SpliceDecl noExtField (L loc rn_splice) flg) + + run_decl_splice rn_splice = pprPanic "rnSpliceDecl" (ppr rn_splice) +rnSpliceDecl (XSpliceDecl nec) = noExtCon nec + +rnTopSpliceDecls :: HsSplice GhcPs -> RnM ([LHsDecl GhcPs], FreeVars) +-- Declaration splice at the very top level of the module +rnTopSpliceDecls splice + = do { (rn_splice, fvs) <- checkNoErrs $ + setStage (Splice Untyped) $ + rnSplice 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. + ; traceRn "rnTopSpliceDecls: untyped declaration splice" empty + ; (decls, mod_finalizers) <- checkNoErrs $ + runRnSplice UntypedDeclSplice runMetaD ppr_decls rn_splice + ; add_mod_finalizers_now mod_finalizers + ; return (decls,fvs) } + where + ppr_decls :: [LHsDecl GhcPs] -> 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 [] = return () + add_mod_finalizers_now mod_finalizers = do + th_modfinalizers_var <- fmap tcg_th_modfinalizers getGblEnv + env <- getLclEnv + updTcRef th_modfinalizers_var $ \fins -> + (env, ThModFinalizers mod_finalizers) : 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 splice + = hang (text "In the" <+> what) 2 (ppr splice) + where + what = case splice of + HsUntypedSplice {} -> text "untyped splice:" + HsTypedSplice {} -> text "typed splice:" + HsQuasiQuote {} -> text "quasi-quotation:" + HsSpliced {} -> text "spliced expression:" + HsSplicedT {} -> text "spliced expression:" + XSplice {} -> text "spliced expression:" + +-- | The splice data to be logged +data SpliceInfo + = SpliceInfo + { spliceDescription :: String + , spliceSource :: Maybe (LHsExpr GhcRn) -- Nothing <=> top-level decls + -- added by addTopDecls + , spliceIsDecl :: Bool -- True <=> put the generate code in a file + -- when -dth-dec-file is on + , 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 { spliceDescription = sd, spliceSource = mb_src + , spliceGenerated = gen, spliceIsDecl = is_decl }) + = do { loc <- case mb_src of + Nothing -> getSrcSpanM + Just (L loc _) -> return loc + ; traceOptTcRn Opt_D_dump_splices (spliceDebugDoc loc) + + ; when is_decl $ -- Raw material for -dth-dec-file + do { dflags <- getDynFlags + ; liftIO $ dumpIfSet_dyn_printer alwaysQualify dflags Opt_D_th_dec_file + "" FormatHaskell (spliceCodeDoc loc) } } + where + -- `-ddump-splices` + spliceDebugDoc :: SrcSpan -> SDoc + spliceDebugDoc loc + = let code = case mb_src of + Nothing -> ending + Just e -> nest 2 (ppr (stripParensHsExpr e)) : ending + ending = [ text "======>", nest 2 gen ] + in hang (ppr loc <> colon <+> text "Splicing" <+> text sd) + 2 (sep code) + + -- `-dth-dec-file` + spliceCodeDoc :: SrcSpan -> SDoc + spliceCodeDoc loc + = vcat [ text "--" <+> ppr loc <> colon <+> text "Splicing" <+> text sd + , gen ] + +illegalTypedSplice :: SDoc +illegalTypedSplice = text "Typed splices may not appear in untyped brackets" + +illegalUntypedSplice :: SDoc +illegalUntypedSplice = text "Untyped splices may not appear in typed brackets" + +checkThLocalName :: Name -> RnM () +checkThLocalName name + | isUnboundName name -- Do not report two errors for + = return () -- $(not_in_scope args) + + | otherwise + = do { traceRn "checkThLocalName" (ppr name) + ; mb_local_use <- getStageAndBindLevel name + ; case mb_local_use of { + Nothing -> return () ; -- Not a locally-bound thing + Just (top_lvl, bind_lvl, use_stage) -> + do { let use_lvl = thLevel use_stage + ; checkWellStaged (quotes (ppr name)) bind_lvl use_lvl + ; traceRn "checkThLocalName" (ppr name <+> ppr bind_lvl + <+> ppr use_stage + <+> ppr use_lvl) + ; checkCrossStageLifting top_lvl bind_lvl use_stage use_lvl 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 TcExpr, but +-- this is only run on *untyped* brackets. + +checkCrossStageLifting top_lvl bind_lvl use_stage use_lvl name + | Brack _ (RnPendingUntyped ps_var) <- use_stage -- Only for untyped brackets + , use_lvl > bind_lvl -- Cross-stage condition + = check_cross_stage_lifting top_lvl name ps_var + | otherwise + = return () + +check_cross_stage_lifting :: TopLevelFlag -> Name -> TcRef [PendingRnSplice] -> TcM () +check_cross_stage_lifting top_lvl name ps_var + | isTopLevel 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 |] + = when (isExternalName name) (keepAlive name) + -- See Note [Keeping things alive for Template Haskell] + + | 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 { traceRn "checkCrossStageLifting" (ppr name) + + -- Construct the (lift x) expression + ; let lift_expr = nlHsApp (nlHsVar liftName) (nlHsVar name) + pend_splice = PendingRnSplice UntypedExpSplice name lift_expr + + -- Update the pending splices + ; ps <- readMutVar ps_var + ; writeMutVar ps_var (pend_splice : 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 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. TcExpr.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) +-} |