module RnSplice (
rnTopSpliceDecls,
rnSpliceType, rnSpliceExpr, rnSplicePat, rnSpliceDecl,
rnBracket,
checkThLocalName
) where
import Name
import NameSet
import HsSyn
import RdrName
import TcRnMonad
import Kind
#ifdef GHCI
import ErrUtils ( dumpIfSet_dyn_printer )
import Control.Monad ( unless, when )
import DynFlags
import DsMeta ( decsQTyConName, expQTyConName, patQTyConName, typeQTyConName )
import LoadIface ( loadInterfaceForName )
import Module
import RnEnv
import RnPat ( rnPat )
import RnSource ( rnSrcDecls, findSplice )
import RnTypes ( rnLHsType )
import SrcLoc
import TcEnv ( checkWellStaged, tcMetaTy )
import Outputable
import BasicTypes ( TopLevelFlag, isTopLevel )
import FastString
import Hooks
import RnExpr ( rnLExpr )
import TcExpr ( tcMonoExpr )
import TcSplice ( runMetaD, runMetaE, runMetaP, runMetaT, tcTopSpliceExpr )
#endif
#ifndef GHCI
rnBracket :: HsExpr RdrName -> HsBracket RdrName -> RnM (HsExpr Name, FreeVars)
rnBracket e _ = failTH e "Template Haskell bracket"
rnTopSpliceDecls :: HsSplice RdrName -> RnM ([LHsDecl RdrName], FreeVars)
rnTopSpliceDecls e = failTH e "Template Haskell top splice"
rnSpliceType :: HsSplice RdrName -> PostTc Name Kind
-> RnM (HsType Name, FreeVars)
rnSpliceType e _ = failTH e "Template Haskell type splice"
rnSpliceExpr :: Bool -> HsSplice RdrName -> RnM (HsExpr Name, FreeVars)
rnSpliceExpr _ e = failTH e "Template Haskell splice"
rnSplicePat :: HsSplice RdrName -> RnM (Either (Pat RdrName) (Pat Name), FreeVars)
rnSplicePat e = failTH e "Template Haskell pattern splice"
rnSpliceDecl :: SpliceDecl RdrName -> RnM (SpliceDecl Name, FreeVars)
rnSpliceDecl e = failTH e "Template Haskell declaration splice"
#else
rnSpliceGen :: Bool
-> (HsSplice Name -> RnM (a, FreeVars))
-> (HsSplice Name -> (PendingRnSplice, a))
-> HsSplice RdrName
-> RnM (a, FreeVars)
rnSpliceGen is_typed_splice run_splice pend_splice splice@(HsSplice _ expr)
= addErrCtxt (spliceCtxt (HsSpliceE is_typed_splice splice)) $
setSrcSpan (getLoc expr) $ 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) <- setStage (Splice is_typed_splice) $
rnSplice splice
; (result, fvs2) <- run_splice splice'
; return (result, fvs1 `plusFV` fvs2) } }
rnSplice :: HsSplice RdrName -> RnM (HsSplice Name, FreeVars)
rnSplice (HsSplice splice_name expr)
= do { checkTH expr "Template Haskell splice"
; loc <- getSrcSpanM
; n' <- newLocalBndrRn (L loc splice_name)
; (expr', fvs) <- rnLExpr expr
; return (HsSplice n' expr', fvs) }
rnSpliceExpr :: Bool -> HsSplice RdrName -> RnM (HsExpr Name, FreeVars)
rnSpliceExpr is_typed splice
= rnSpliceGen is_typed run_expr_splice pend_expr_splice splice
where
pend_expr_splice :: HsSplice Name -> (PendingRnSplice, HsExpr Name)
pend_expr_splice rn_splice@(HsSplice n e)
= (PendingRnExpSplice (PendSplice n e), HsSpliceE is_typed rn_splice)
run_expr_splice :: HsSplice Name -> RnM (HsExpr Name, FreeVars)
run_expr_splice rn_splice@(HsSplice _ expr')
| is_typed
= do {
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 is_typed rn_splice, lcl_names `plusFV` gbl_names) }
| otherwise
= do { expr <- getHooked runRnSpliceHook return >>= ($ expr')
; meta_exp_ty <- tcMetaTy expQTyConName
; zonked_q_expr <- tcTopSpliceExpr False $
tcMonoExpr expr meta_exp_ty
; expr2 <- runMetaE zonked_q_expr
; showSplice "expression" expr (ppr expr2)
; (lexpr3, fvs) <- checkNoErrs $
rnLExpr expr2
; return (unLoc lexpr3, fvs) }
rnSpliceType :: HsSplice RdrName -> PostTc Name Kind
-> RnM (HsType Name, FreeVars)
rnSpliceType splice k
= rnSpliceGen False run_type_splice pend_type_splice splice
where
pend_type_splice rn_splice@(HsSplice n e)
= (PendingRnTypeSplice (PendSplice n e), HsSpliceTy rn_splice k)
run_type_splice (HsSplice _ expr')
= do { expr <- getHooked runRnSpliceHook return >>= ($ expr')
; meta_exp_ty <- tcMetaTy typeQTyConName
; zonked_q_expr <- tcTopSpliceExpr False $
tcMonoExpr expr meta_exp_ty
; hs_ty2 <- runMetaT zonked_q_expr
; showSplice "type" expr (ppr hs_ty2)
; (hs_ty3, fvs) <- do { let doc = SpliceTypeCtx hs_ty2
; checkNoErrs $ rnLHsType doc hs_ty2
}
; return (unLoc hs_ty3, fvs) }
rnSplicePat :: HsSplice RdrName -> RnM ( Either (Pat RdrName) (Pat Name)
, FreeVars)
rnSplicePat splice
= rnSpliceGen False run_pat_splice pend_pat_splice splice
where
pend_pat_splice rn_splice@(HsSplice n e)
= (PendingRnPatSplice (PendSplice n e), Right $ SplicePat rn_splice)
run_pat_splice (HsSplice _ expr')
= do { expr <- getHooked runRnSpliceHook return >>= ($ expr')
; meta_exp_ty <- tcMetaTy patQTyConName
; zonked_q_expr <- tcTopSpliceExpr False $
tcMonoExpr expr meta_exp_ty
; pat <- runMetaP zonked_q_expr
; showSplice "pattern" expr (ppr pat)
; return (Left $ unLoc pat, emptyFVs) }
rnSpliceDecl :: SpliceDecl RdrName -> RnM (SpliceDecl Name, FreeVars)
rnSpliceDecl (SpliceDecl (L loc splice) flg)
= rnSpliceGen False run_decl_splice pend_decl_splice splice
where
pend_decl_splice rn_splice@(HsSplice n e)
= (PendingRnDeclSplice (PendSplice n e), SpliceDecl(L loc rn_splice) flg)
run_decl_splice rn_splice = pprPanic "rnSpliceDecl" (ppr rn_splice)
rnTopSpliceDecls :: HsSplice RdrName -> RnM ([LHsDecl RdrName], FreeVars)
rnTopSpliceDecls (HsSplice _ expr'')
= do { (expr, fvs) <- setStage (Splice False) $
rnLExpr expr''
; expr' <- getHooked runRnSpliceHook return >>= ($ expr)
; list_q <- tcMetaTy decsQTyConName
; zonked_q_expr <- tcTopSpliceExpr False (tcMonoExpr expr' list_q)
; decls <- runMetaD zonked_q_expr
; traceSplice $ SpliceInfo True
"declarations"
(Just (getLoc expr))
(Just $ ppr expr')
(vcat (map ppr decls))
; return (decls,fvs) }
rnBracket :: HsExpr RdrName -> HsBracket RdrName -> RnM (HsExpr Name, FreeVars)
rnBracket e br_body
= addErrCtxt (quotationCtxtDoc br_body) $
do {
thEnabled <- xoptM Opt_TemplateHaskell
; unless thEnabled $
failWith ( vcat [ ptext (sLit "Syntax error on") <+> ppr e
, ptext (sLit "Perhaps you intended to use TemplateHaskell") ] )
; checkTH e "Template Haskell bracket"
; cur_stage <- getStage
; case cur_stage of
{ Splice True -> checkTc (isTypedBracket br_body) illegalUntypedBracket
; Splice False -> checkTc (not (isTypedBracket br_body)) illegalTypedBracket
; Comp -> return ()
; Brack {} -> failWithTc illegalBracket
}
; recordThUse
; case isTypedBracket br_body of
True -> do { (body', fvs_e) <- setStage (Brack cur_stage RnPendingTyped) $
rn_bracket cur_stage br_body
; return (HsBracket body', fvs_e) }
False -> do { 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 body' pendings, fvs_e) }
}
rn_bracket :: ThStage -> HsBracket RdrName -> RnM (HsBracket Name, FreeVars)
rn_bracket outer_stage br@(VarBr flg rdr_name)
= do { name <- lookupOccRn rdr_name
; this_mod <- getModule
; case flg of
{
False -> return ()
; True | 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 (text "rn_bracket VarBr" <+> ppr name <+> ppr bind_lvl <+> ppr outer_stage)
; checkTc (thLevel outer_stage + 1 == bind_lvl)
(quotedNameStageErr br) }
}
}
; True | otherwise ->
discardResult (loadInterfaceForName msg name)
}
; return (VarBr flg name, unitFV name) }
where
msg = ptext (sLit "Need interface for Template Haskell quoted Name")
rn_bracket _ (ExpBr e) = do { (e', fvs) <- rnLExpr e
; return (ExpBr e', fvs) }
rn_bracket _ (PatBr p) = rnPat ThPatQuote p $ \ p' -> return (PatBr p', emptyFVs)
rn_bracket _ (TypBr t) = do { (t', fvs) <- rnLHsType TypBrCtx t
; return (TypBr t', fvs) }
rn_bracket _ (DecBrL 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 (text "rn_bracket dec" <+> (ppr (tcg_dus tcg_env) $$
ppr (duUses (tcg_dus tcg_env))))
; return (DecBrG group', duUses (tcg_dus tcg_env)) }
where
groupDecls :: [LHsDecl RdrName] -> RnM (HsGroup RdrName)
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 e) = do { (e', fvs) <- rnLExpr e
; return (TExpBr e', fvs) }
spliceCtxt :: HsExpr RdrName -> SDoc
spliceCtxt expr= hang (ptext (sLit "In the splice:")) 2 (ppr expr)
showSplice :: String -> LHsExpr Name -> SDoc -> TcM ()
showSplice what before after =
traceSplice $ SpliceInfo False what Nothing (Just $ ppr before) after
data SpliceInfo
= SpliceInfo
{ spliceIsDeclaration :: Bool
, spliceDescription :: String
, spliceLocation :: Maybe SrcSpan
, spliceSource :: Maybe SDoc
, spliceGenerated :: SDoc
}
traceSplice :: SpliceInfo -> TcM ()
traceSplice sd = do
loc <- case sd of
SpliceInfo { spliceLocation = Nothing } -> getSrcSpanM
SpliceInfo { spliceLocation = Just loc } -> return loc
traceOptTcRn Opt_D_dump_splices (spliceDebugDoc loc sd)
when (spliceIsDeclaration sd) $ do
dflags <- getDynFlags
liftIO $ dumpIfSet_dyn_printer alwaysQualify dflags Opt_D_th_dec_file
(spliceCodeDoc loc sd)
where
spliceDebugDoc :: SrcSpan -> SpliceInfo -> SDoc
spliceDebugDoc loc sd
= let code = case spliceSource sd of
Nothing -> ending
Just b -> nest 2 b : ending
ending = [ text "======>", nest 2 (spliceGenerated sd) ]
in (vcat [ ppr loc <> colon
<+> text "Splicing" <+> text (spliceDescription sd)
, nest 2 (sep code)
])
spliceCodeDoc :: SrcSpan -> SpliceInfo -> SDoc
spliceCodeDoc loc sd
= (vcat [ text "--" <+> ppr loc <> colon
<+> text "Splicing" <+> text (spliceDescription sd)
, sep [spliceGenerated sd]
])
illegalBracket :: SDoc
illegalBracket = ptext (sLit "Template Haskell brackets cannot be nested (without intervening splices)")
illegalTypedBracket :: SDoc
illegalTypedBracket = ptext (sLit "Typed brackets may only appear in typed slices.")
illegalUntypedBracket :: SDoc
illegalUntypedBracket = ptext (sLit "Untyped brackets may only appear in untyped slices.")
illegalTypedSplice :: SDoc
illegalTypedSplice = ptext (sLit "Typed splices may not appear in untyped brackets")
illegalUntypedSplice :: SDoc
illegalUntypedSplice = ptext (sLit "Untyped splices may not appear in typed brackets")
quotedNameStageErr :: HsBracket RdrName -> SDoc
quotedNameStageErr br
= sep [ ptext (sLit "Stage error: the non-top-level quoted name") <+> ppr br
, ptext (sLit "must be used at the same stage at which is is bound")]
quotationCtxtDoc :: HsBracket RdrName -> SDoc
quotationCtxtDoc br_body
= hang (ptext (sLit "In the Template Haskell quotation"))
2 (ppr br_body)
#endif
checkThLocalName :: Name -> RnM ()
#ifndef GHCI /* GHCI and TH is off */
checkThLocalName _name
= return ()
#else /* GHCI and TH is on */
checkThLocalName name
= do { traceRn (text "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 (text "checkThLocalName" <+> ppr name <+> ppr bind_lvl <+> ppr use_stage <+> ppr use_lvl)
; when (use_lvl > bind_lvl) $
checkCrossStageLifting top_lvl name use_stage } } }
checkCrossStageLifting :: TopLevelFlag -> Name -> ThStage -> TcM ()
checkCrossStageLifting top_lvl name (Brack _ (RnPendingUntyped ps_var))
| isTopLevel top_lvl
= when (isExternalName name) (keepAlive name)
| otherwise
=
do { traceRn (text "checkCrossStageLifting" <+> ppr name)
;
; ps <- readMutVar ps_var
; writeMutVar ps_var (PendingRnCrossStageSplice name : ps) }
checkCrossStageLifting _ _ _ = return ()
#endif /* GHCI */