module RnSplice (
rnTopSpliceDecls,
rnSpliceType, rnSpliceExpr, rnSplicePat, rnSpliceDecl,
rnBracket,
checkThLocalName
, traceSplice, SpliceInfo(..)
) where
#include "HsVersions.h"
import GhcPrelude
import Name
import NameSet
import HsSyn
import RdrName
import TcRnMonad
import RnEnv
import RnUtils ( HsDocContext(..), newLocalBndrRn )
import RnUnbound ( isUnboundName )
import RnSource ( rnSrcDecls, findSplice )
import RnPat ( rnPat )
import BasicTypes ( TopLevelFlag, isTopLevel, SourceText(..) )
import Outputable
import Module
import SrcLoc
import RnTypes ( rnLHsType )
import Control.Monad ( unless, when )
import RnExpr ( rnLExpr )
import TcEnv ( checkWellStaged )
import THNames ( liftName )
import DynFlags
import FastString
import ErrUtils ( dumpIfSet_dyn_printer )
import TcEnv ( tcMetaTy )
import Hooks
import THNames ( quoteExpName, quotePatName, quoteDecName, quoteTypeName
, decsQTyConName, expQTyConName, patQTyConName, typeQTyConName, )
import TcExpr ( tcPolyExpr )
import TcSplice
( runMetaD
, runMetaE
, runMetaP
, runMetaT
, runRemoteModFinalizers
, tcTopSpliceExpr
)
import GHCi.RemoteTypes ( ForeignRef )
import qualified Language.Haskell.TH as TH (Q)
import qualified GHC.LanguageExtensions as LangExt
rnBracket :: HsExpr GhcPs -> HsBracket GhcPs -> RnM (HsExpr GhcRn, FreeVars)
rnBracket e br_body
= addErrCtxt (quotationCtxtDoc br_body) $
do {
thQuotesEnabled <- xoptM LangExt.TemplateHaskellQuotes
; unless thQuotesEnabled $
failWith ( vcat
[ text "Syntax error on" <+> ppr e
, text ("Perhaps you intended to use TemplateHaskell"
++ " or TemplateHaskellQuotes") ] )
; cur_stage <- getStage
; case cur_stage of
{ Splice Typed -> checkTc (isTypedBracket br_body)
illegalUntypedBracket
; Splice Untyped -> checkTc (not (isTypedBracket br_body))
illegalTypedBracket
; RunSplice _ ->
pprPanic "rnBracket: Renaming bracket when running a splice"
(ppr e)
; Comp -> return ()
; Brack {} -> failWithTc illegalBracket
}
; 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 noExt 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 noExt 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) $
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_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 }
; (tcg_env, group') <- setGblEnv new_gbl_env $
rnSrcDecls group
; 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 {}) = panic "rn_bracket: unexpected XBracket"
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" ]
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 { (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
runRnSplice :: UntypedSpliceFlavour
-> (LHsExpr GhcTc -> TcRn res)
-> (res -> SDoc)
-> HsSplice GhcRn
-> 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)
XSplice {} -> pprPanic "runRnSplice" (ppr splice)
; meta_exp_ty <- tcMetaTy meta_ty_name
; zonked_q_expr <- tcTopSpliceExpr Untyped $
tcPolyExpr 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)
makePending _ splice@(XSplice {})
= pprPanic "makePending" (ppr splice)
mkQuasiQuoteExpr :: UntypedSpliceFlavour -> Name -> SrcSpan -> FastString
-> LHsExpr GhcRn
mkQuasiQuoteExpr flavour quoter q_span quote
= L q_span $ HsApp noExt (L q_span $
HsApp noExt (L q_span (HsVar noExt (L q_span quote_selector)))
quoterExpr)
quoteExpr
where
quoterExpr = L q_span $! HsVar noExt $! (L q_span quoter)
quoteExpr = L q_span $! HsLit noExt $! 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 { checkTH expr "Template Haskell typed splice"
; 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 { checkTH expr "Template Haskell untyped splice"
; 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 { checkTH quoter "Template Haskell quasi-quote"
; loc <- getSrcSpanM
; splice_name' <- newLocalBndrRn (L 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)
rnSplice splice@(XSplice {}) = 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 noExt 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 [gre_name gre | gre <- globalRdrEnvElts gbl_rdr
, isLocalGRE gre]
lcl_names = mkNameSet (localRdrEnvElts lcl_rdr)
; return (HsSpliceE noExt 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)
; return ( HsPar noExt $ HsSpliceE noExt
. HsSpliced noExt (ThModFinalizers mod_finalizers)
. HsSplicedExpr <$>
lexpr3
, 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 noExt 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 noExt $ HsSpliceTy noExt
. HsSpliced noExt (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 rn_splice
= (makePending UntypedPatSplice rn_splice
, Right (SplicePat noExt rn_splice))
run_pat_splice rn_splice
= do { traceRn "rnSplicePat: untyped pattern splice" empty
; (pat, mod_finalizers) <-
runRnSplice UntypedPatSplice runMetaP ppr rn_splice
; return ( Left $ ParPat noExt $ (SplicePat noExt)
. HsSpliced noExt (ThModFinalizers mod_finalizers)
. HsSplicedPat <$>
pat
, 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 noExt (L loc rn_splice) flg)
run_decl_splice rn_splice = pprPanic "rnSpliceDecl" (ppr rn_splice)
rnSpliceDecl (XSpliceDecl _) = panic "rnSpliceDecl"
rnTopSpliceDecls :: HsSplice GhcPs -> RnM ([LHsDecl GhcPs], FreeVars)
rnTopSpliceDecls splice
= do { (rn_splice, fvs) <- checkNoErrs $
setStage (Splice Untyped) $
rnSplice splice
; traceRn "rnTopSpliceDecls: untyped declaration splice" empty
; (decls, mod_finalizers) <-
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
updTcRef th_modfinalizers_var $ \fins ->
runRemoteModFinalizers (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:"
XSplice {} -> 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 loc
; traceOptTcRn Opt_D_dump_splices (spliceDebugDoc loc)
; when is_decl $
do { dflags <- getDynFlags
; liftIO $ dumpIfSet_dyn_printer alwaysQualify dflags Opt_D_th_dec_file
(spliceCodeDoc loc) } }
where
spliceDebugDoc :: SrcSpan -> SDoc
spliceDebugDoc loc
= let code = case mb_src of
Nothing -> ending
Just e -> nest 2 (ppr 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 :: 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
= 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
; ps <- readMutVar ps_var
; writeMutVar ps_var (pend_splice : ps) }