module GHC.Rename.Splice (
rnTopSpliceDecls,
rnSpliceType, rnSpliceExpr, rnSplicePat, rnSpliceDecl,
rnTypedBracket, rnUntypedBracket,
checkThLocalName
, traceSplice, SpliceInfo(..)
) where
import GHC.Prelude
import GHC.Types.Name
import GHC.Types.Name.Set
import GHC.Hs
import GHC.Types.Name.Reader
import GHC.Tc.Errors.Types
import GHC.Tc.Utils.Monad
import GHC.Driver.Env.Types
import GHC.Rename.Env
import GHC.Rename.Utils ( newLocalBndrRn )
import GHC.Rename.Unbound ( isUnboundName )
import GHC.Rename.Module ( rnSrcDecls, findSplice )
import GHC.Rename.Pat ( rnPat )
import GHC.Types.Error
import GHC.Types.Basic ( TopLevelFlag, isTopLevel )
import GHC.Types.SourceText ( SourceText(..) )
import GHC.Utils.Outputable
import GHC.Unit.Module
import GHC.Types.SrcLoc
import GHC.Rename.HsType ( rnLHsType )
import Control.Monad ( unless, when )
import GHC.Rename.Expr ( rnLExpr )
import GHC.Tc.Utils.Env ( checkWellStaged, tcMetaTy )
import GHC.Driver.Session
import GHC.Data.FastString
import GHC.Utils.Logger
import GHC.Utils.Panic
import GHC.Driver.Hooks
import GHC.Builtin.Names.TH ( decsQTyConName, expQTyConName, liftName
, patQTyConName, quoteDecName, quoteExpName
, quotePatName, quoteTypeName, typeQTyConName)
import GHC.Tc.Gen.Expr ( tcCheckPolyExpr )
import GHC.Tc.Gen.Splice
( runMetaD
, runMetaE
, runMetaP
, runMetaT
, tcTopSpliceExpr
)
import GHC.Tc.Utils.Zonk
import GHCi.RemoteTypes ( ForeignRef )
import qualified Language.Haskell.TH as TH (Q)
import qualified GHC.LanguageExtensions as LangExt
checkForTemplateHaskellQuotes :: HsExpr GhcPs -> RnM ()
checkForTemplateHaskellQuotes e =
do { thQuotesEnabled <- xoptM LangExt.TemplateHaskellQuotes
; unless thQuotesEnabled $
failWith ( TcRnUnknownMessage $ mkPlainError noHints $ vcat
[ text "Syntax error on" <+> ppr e
, text ("Perhaps you intended to use TemplateHaskell"
++ " or TemplateHaskellQuotes") ] )
}
rnTypedBracket :: HsExpr GhcPs -> LHsExpr GhcPs -> RnM (HsExpr GhcRn, FreeVars)
rnTypedBracket e br_body
= addErrCtxt (typedQuotationCtxtDoc br_body) $
do { checkForTemplateHaskellQuotes e
; cur_stage <- getStage
; case cur_stage of
{ Splice Typed -> return ()
; Splice Untyped -> failWithTc illegalTypedBracket
; RunSplice _ ->
pprPanic "rnTypedBracket: Renaming typed bracket when running a splice"
(ppr e)
; Comp -> return ()
; Brack {} -> failWithTc illegalBracket
}
; recordThUse
; traceRn "Renaming typed TH bracket" empty
; (body', fvs_e) <- setStage (Brack cur_stage RnPendingTyped) $ rnLExpr br_body
; return (HsTypedBracket noExtField body', fvs_e)
}
rnUntypedBracket :: HsExpr GhcPs -> HsQuote GhcPs -> RnM (HsExpr GhcRn, FreeVars)
rnUntypedBracket e br_body
= addErrCtxt (untypedQuotationCtxtDoc br_body) $
do { checkForTemplateHaskellQuotes e
; cur_stage <- getStage
; case cur_stage of
{ Splice Typed -> failWithTc illegalUntypedBracket
; Splice Untyped -> return ()
; RunSplice _ ->
pprPanic "rnUntypedBracket: Renaming untyped bracket when running a splice"
(ppr e)
; Comp -> return ()
; Brack {} -> failWithTc illegalBracket
}
; recordThUse
; traceRn "Renaming untyped TH bracket" empty
; ps_var <- newMutVar []
; (body', fvs_e) <-
unsetXOptM LangExt.RebindableSyntax $
setStage (Brack cur_stage (RnPendingUntyped ps_var)) $
rn_utbracket cur_stage br_body
; pendings <- readMutVar ps_var
; return (HsUntypedBracket pendings body', fvs_e)
}
rn_utbracket :: ThStage -> HsQuote GhcPs -> RnM (HsQuote GhcRn, FreeVars)
rn_utbracket outer_stage br@(VarBr x flg rdr_name)
= do { name <- lookupOccRn (unLoc rdr_name)
; check_namespace flg name
; this_mod <- getModule
; when (flg && nameIsLocalOrFrom this_mod name) $
do { mb_bind_lvl <- lookupLocalOccThLvl_maybe name
; case mb_bind_lvl of
{ Nothing -> return ()
; Just (top_lvl, bind_lvl)
| isTopLevel top_lvl
-> when (isExternalName name) (keepAlive name)
| otherwise
-> do { traceRn "rn_utbracket VarBr"
(ppr name <+> ppr bind_lvl
<+> ppr outer_stage)
; checkTc (thLevel outer_stage + 1 == bind_lvl)
(quotedNameStageErr br) }
}
}
; return (VarBr x flg (noLocA name), unitFV name) }
rn_utbracket _ (ExpBr x e) = do { (e', fvs) <- rnLExpr e
; return (ExpBr x e', fvs) }
rn_utbracket _ (PatBr x p)
= rnPat ThPatQuote p $ \ p' -> return (PatBr x p', emptyFVs)
rn_utbracket _ (TypBr x t) = do { (t', fvs) <- rnLHsType TypBrCtx t
; return (TypBr x t', fvs) }
rn_utbracket _ (DecBrL x decls)
= do { group <- groupDecls decls
; gbl_env <- getGblEnv
; let new_gbl_env = gbl_env { tcg_dus = emptyDUs }
; (tcg_env, group') <- setGblEnv new_gbl_env $
rnSrcDecls group
; traceRn "rn_utbracket 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 = noLocA splice : hs_splcds group' }
}
}}
rn_utbracket _ (DecBrG {}) = panic "rn_ut_bracket: unexpected DecBrG"
check_namespace :: Bool -> Name -> RnM ()
check_namespace is_single_tick nm
= unless (isValNameSpace ns == is_single_tick) $
failWithTc $ (TcRnIncorrectNameSpace nm True)
where
ns = nameNameSpace nm
typedQuotationCtxtDoc :: LHsExpr GhcPs -> SDoc
typedQuotationCtxtDoc br_body
= hang (text "In the Template Haskell typed quotation")
2 (thTyBrackets . ppr $ br_body)
untypedQuotationCtxtDoc :: HsQuote GhcPs -> SDoc
untypedQuotationCtxtDoc br_body
= hang (text "In the Template Haskell quotation")
2 (ppr br_body)
illegalBracket :: TcRnMessage
illegalBracket = TcRnUnknownMessage $ mkPlainError noHints $
text "Template Haskell brackets cannot be nested" <+>
text "(without intervening splices)"
illegalTypedBracket :: TcRnMessage
illegalTypedBracket = TcRnUnknownMessage $ mkPlainError noHints $
text "Typed brackets may only appear in typed splices."
illegalUntypedBracket :: TcRnMessage
illegalUntypedBracket = TcRnUnknownMessage $ mkPlainError noHints $
text "Untyped brackets may only appear in untyped splices."
quotedNameStageErr :: HsQuote GhcPs -> TcRnMessage
quotedNameStageErr br
= TcRnUnknownMessage $ mkPlainError noHints $
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" ]
rnSpliceGen :: (HsSplice GhcRn -> RnM (a, FreeVars))
-> (HsSplice GhcRn -> (PendingRnSplice, a))
-> 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 { checkTopSpliceAllowed splice
; (splice', fvs1) <- checkNoErrs $
setStage (Splice splice_type) $
rnSplice splice
; (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
checkTopSpliceAllowed :: HsSplice GhcPs -> RnM ()
checkTopSpliceAllowed splice = do
let (herald, ext) = spliceExtension splice
extEnabled <- xoptM ext
unless extEnabled
(failWith $ TcRnUnknownMessage $ mkPlainError noHints $
text herald <+> text "are not permitted without" <+> ppr ext)
where
spliceExtension :: HsSplice GhcPs -> (String, LangExt.Extension)
spliceExtension (HsQuasiQuote {}) = ("Quasi-quotes", LangExt.QuasiQuotes)
spliceExtension (HsTypedSplice {}) = ("Top-level splices", LangExt.TemplateHaskell)
spliceExtension (HsUntypedSplice {}) = ("Top-level splices", LangExt.TemplateHaskell)
spliceExtension s@(HsSpliced {}) = pprPanic "spliceExtension" (ppr s)
runRnSplice :: UntypedSpliceFlavour
-> (LHsExpr GhcTc -> TcRn res)
-> (res -> SDoc)
-> HsSplice GhcRn
-> TcRn (res, [ForeignRef (TH.Q ())])
runRnSplice flavour run_meta ppr_res splice
= do { hooks <- hsc_hooks <$> getTopEnv
; splice' <- case runRnSpliceHook hooks of
Nothing -> return splice
Just h -> h 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)
; meta_exp_ty <- tcMetaTy meta_ty_name
; zonked_q_expr <- zonkTopLExpr =<<
tcTopSpliceExpr Untyped
(tcCheckPolyExpr the_expr meta_exp_ty)
; 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)
mkQuasiQuoteExpr :: UntypedSpliceFlavour -> Name -> SrcSpan -> FastString
-> LHsExpr GhcRn
mkQuasiQuoteExpr flavour quoter q_span' quote
= L q_span $ HsApp noComments (L q_span
$ HsApp noComments (L q_span
(HsVar noExtField (L (la2na q_span) quote_selector)))
quoterExpr)
quoteExpr
where
q_span = noAnnSrcSpan q_span'
quoterExpr = L q_span $! HsVar noExtField $! (L (la2na q_span) quoter)
quoteExpr = L q_span $! HsLit noComments $! HsString NoSourceText quote
quote_selector = case flavour of
UntypedExpSplice -> quoteExpName
UntypedPatSplice -> quotePatName
UntypedTypeSplice -> quoteTypeName
UntypedDeclSplice -> quoteDecName
rnSplice :: HsSplice GhcPs -> RnM (HsSplice GhcRn, FreeVars)
rnSplice (HsTypedSplice x hasParen splice_name expr)
= do { loc <- getSrcSpanM
; n' <- newLocalBndrRn (L (noAnnSrcSpan 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 (noAnnSrcSpan 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 (noAnnSrcSpan loc) splice_name)
; 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)
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 noAnn rn_splice)
run_expr_splice :: HsSplice GhcRn -> RnM (HsExpr GhcRn, FreeVars)
run_expr_splice rn_splice
| isTypedSplice rn_splice
= do {
traceRn "rnSpliceExpr: typed expression splice" empty
; lcl_rdr <- getLocalRdrEnv
; gbl_rdr <- getGlobalRdrEnv
; let gbl_names = mkNameSet [greMangledName gre | gre <- globalRdrEnvElts gbl_rdr
, isLocalGRE gre]
lcl_names = mkNameSet (localRdrEnvElts lcl_rdr)
; return (HsSpliceE noAnn rn_splice, lcl_names `plusFV` gbl_names) }
| otherwise
= do { traceRn "rnSpliceExpr: untyped expression splice" empty
; (rn_expr, mod_finalizers) <-
runRnSplice UntypedExpSplice runMetaE ppr rn_splice
; (lexpr3, fvs) <- checkNoErrs (rnLExpr rn_expr)
; let e = HsSpliceE noAnn
. HsSpliced noExtField (ThModFinalizers mod_finalizers)
. HsSplicedExpr
<$> lexpr3
; return (gHsPar e, fvs)
}
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 }
; return ( HsParTy noAnn
$ HsSpliceTy noExtField
. HsSpliced noExtField (ThModFinalizers mod_finalizers)
. HsSplicedTy <$>
hs_ty3
, fvs
) }
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
; let p = SplicePat noExtField
. HsSpliced noExtField (ThModFinalizers mod_finalizers)
. HsSplicedPat
<$> pat
; return (Left $ gParPat p, emptyFVs) }
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)
rnTopSpliceDecls :: HsSplice GhcPs -> RnM ([LHsDecl GhcPs], FreeVars)
rnTopSpliceDecls splice
= do { checkTopSpliceAllowed splice
; (rn_splice, fvs) <- checkNoErrs $
setStage (Splice Untyped) $
rnSplice splice
; 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)
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
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:"
data SpliceInfo
= SpliceInfo
{ spliceDescription :: String
, spliceSource :: Maybe (LHsExpr GhcRn)
, spliceIsDecl :: Bool
, spliceGenerated :: SDoc
}
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 (locA loc)
traceOptTcRn Opt_D_dump_splices (spliceDebugDoc loc)
when is_decl $ do
logger <- getLogger
liftIO $ putDumpFileMaybe logger Opt_D_th_dec_file "" FormatHaskell (spliceCodeDoc loc)
where
spliceDebugDoc :: SrcSpan -> SDoc
spliceDebugDoc loc
= let code = case mb_src of
Nothing -> ending
Just e -> nest 2 (ppr (stripParensLHsExpr e)) : ending
ending = [ text "======>", nest 2 gen ]
in hang (ppr loc <> colon <+> text "Splicing" <+> text sd)
2 (sep code)
spliceCodeDoc :: SrcSpan -> SDoc
spliceCodeDoc loc
= vcat [ text "--" <+> ppr loc <> colon <+> text "Splicing" <+> text sd
, gen ]
illegalTypedSplice :: TcRnMessage
illegalTypedSplice = TcRnUnknownMessage $ mkPlainError noHints $
text "Typed splices may not appear in untyped brackets"
illegalUntypedSplice :: TcRnMessage
illegalUntypedSplice = TcRnUnknownMessage $ mkPlainError noHints $
text "Untyped splices may not appear in typed brackets"
checkThLocalName :: Name -> RnM ()
checkThLocalName name
| isUnboundName name
= return ()
| otherwise
= do { traceRn "checkThLocalName" (ppr name)
; mb_local_use <- getStageAndBindLevel name
; case mb_local_use of {
Nothing -> return () ;
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 ()
checkCrossStageLifting top_lvl bind_lvl use_stage use_lvl name
| Brack _ (RnPendingUntyped ps_var) <- use_stage
, use_lvl > bind_lvl
= 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
= when (isExternalName name) (keepAlive name)
| otherwise
=
do { traceRn "checkCrossStageLifting" (ppr name)
; let lift_expr = nlHsApp (nlHsVar liftName) (nlHsVar name)
pend_splice = PendingRnSplice UntypedExpSplice name lift_expr
; addDetailedDiagnostic (TcRnImplicitLift name)
; ps <- readMutVar ps_var
; writeMutVar ps_var (pend_splice : ps) }