diff --git a/compiler/hsSyn/HsDecls.lhs b/compiler/hsSyn/HsDecls.lhs index bac9ec63480f..c35de3b9b154 100644 --- a/compiler/hsSyn/HsDecls.lhs +++ b/compiler/hsSyn/HsDecls.lhs @@ -33,8 +33,8 @@ module HsDecls ( lvectDeclName, lvectInstDecl, -- ** @default@ declarations DefaultDecl(..), LDefaultDecl, - -- ** Top-level template haskell splice - SpliceDecl(..), + -- ** Template haskell declaration splice + SpliceDecl(..), LSpliceDecl, -- ** Foreign function interface declarations ForeignDecl(..), LForeignDecl, ForeignImport(..), ForeignExport(..), noForeignImportCoercionYet, noForeignExportCoercionYet, @@ -55,7 +55,7 @@ module HsDecls ( ) where -- friends: -import {-# SOURCE #-} HsExpr( LHsExpr, HsExpr, pprExpr ) +import {-# SOURCE #-} HsExpr( LHsExpr, HsExpr, HsSplice, pprExpr ) -- Because Expr imports Decls via HsBracket import HsBinds @@ -128,6 +128,7 @@ data HsDecl id data HsGroup id = HsGroup { hs_valds :: HsValBinds id, + hs_splcds :: [LSpliceDecl id], hs_tyclds :: [[LTyClDecl id]], -- A list of mutually-recursive groups @@ -163,12 +164,14 @@ emptyGroup = HsGroup { hs_tyclds = [], hs_instds = [], hs_fixds = [], hs_defds = [], hs_annds = [], hs_fords = [], hs_warnds = [], hs_ruleds = [], hs_vects = [], hs_valds = error "emptyGroup hs_valds: Can't happen", + hs_splcds = [], hs_docs = [] } appendGroups :: HsGroup a -> HsGroup a -> HsGroup a appendGroups HsGroup { hs_valds = val_groups1, + hs_splcds = spliceds1, hs_tyclds = tyclds1, hs_instds = instds1, hs_derivds = derivds1, @@ -182,6 +185,7 @@ appendGroups hs_docs = docs1 } HsGroup { hs_valds = val_groups2, + hs_splcds = spliceds2, hs_tyclds = tyclds2, hs_instds = instds2, hs_derivds = derivds2, @@ -196,6 +200,7 @@ appendGroups = HsGroup { hs_valds = val_groups1 `plusHsValBinds` val_groups2, + hs_splcds = spliceds1 ++ spliceds2, hs_tyclds = tyclds1 ++ tyclds2, hs_instds = instds1 ++ instds2, hs_derivds = derivds1 ++ derivds2, @@ -261,15 +266,16 @@ instance OutputableBndr name => Outputable (HsGroup name) where vcat_mb gap (Nothing : ds) = vcat_mb gap ds vcat_mb gap (Just d : ds) = gap $$ d $$ vcat_mb blankLine ds +type LSpliceDecl name = Located (SpliceDecl name) data SpliceDecl id = SpliceDecl -- Top level splice - (Located (HsExpr id)) + (Located (HsSplice id)) HsExplicitFlag -- Explicit <=> $(f x y) -- Implicit <=> f x y, i.e. a naked top level expression deriving (Data, Typeable) instance OutputableBndr name => Outputable (SpliceDecl name) where - ppr (SpliceDecl e _) = ptext (sLit "$") <> parens (pprExpr (unLoc e)) + ppr (SpliceDecl e _) = ppr e \end{code} diff --git a/compiler/hsSyn/HsExpr.lhs b/compiler/hsSyn/HsExpr.lhs index 294fea79e099..ab50c4124d1f 100644 --- a/compiler/hsSyn/HsExpr.lhs +++ b/compiler/hsSyn/HsExpr.lhs @@ -320,6 +320,7 @@ data PendingSplice = PendingRnExpSplice Name (LHsExpr Name) | PendingRnPatSplice Name (LHsExpr Name) | PendingRnTypeSplice Name (LHsExpr Name) + | PendingRnDeclSplice Name (LHsExpr Name) | PendingRnCrossStageSplice Name | PendingTcSplice Name (LHsExpr Id) deriving (Data, Typeable) @@ -1295,6 +1296,7 @@ instance Outputable PendingSplice where ppr (PendingRnExpSplice name expr) = ppr (name, expr) ppr (PendingRnPatSplice name expr) = ppr (name, expr) ppr (PendingRnTypeSplice name expr) = ppr (name, expr) + ppr (PendingRnDeclSplice name expr) = ppr (name, expr) ppr (PendingRnCrossStageSplice name) = ppr name ppr (PendingTcSplice name expr) = ppr (name, expr) \end{code} diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp index 4b22e0a28840..29930dfb3f33 100644 --- a/compiler/parser/Parser.y.pp +++ b/compiler/parser/Parser.y.pp @@ -600,13 +600,13 @@ | '{-# VECTORISE_SCALAR' 'instance' type '#-}' { unitOL $ LL $ VectD (HsVectInstIn $3) } | annotation { unitOL $1 } - | decl { unLoc $1 } + | decl_no_th { unLoc $1 } -- Template Haskell Extension -- The $(..) form is one possible form of infixexp -- but we treat an arbitrary expression just as if -- it had a $(..) wrapped around it - | infixexp { unitOL (LL $ mkTopSpliceDecl $1) } + | infixexp { unitOL (LL $ mkSpliceDecl $1) } -- Type classes -- @@ -1313,7 +1313,7 @@ | docnamed { L1 (case (unLoc $1) of (n, doc) -> DocCommentNamed n doc) } | docsection { L1 (case (unLoc $1) of (n, doc) -> DocGroup n doc) } -decl :: { Located (OrdList (LHsDecl RdrName)) } +decl_no_th :: { Located (OrdList (LHsDecl RdrName)) } : sigdecl { $1 } | '!' aexp rhs {% do { let { e = LL (SectionR (LL (HsVar bang_RDR)) $2) }; @@ -1329,6 +1329,15 @@ return $! (sL l (unitOL $! (sL l $ ValD r))) } } | docdecl { LL $ unitOL $1 } +decl :: { Located (OrdList (LHsDecl RdrName)) } + : decl_no_th { $1 } + + -- Why do we only allow naked declaration splices in top-level + -- declarations and not here? Short answer: because readFail009 + -- fails terribly with a panic in cvBindsAndSigs otherwise. + | splice_exp { LL $ unitOL (LL $ mkSpliceDecl $1) } + +-- rhs :: { Located (GRHSs RdrName (LHsExpr RdrName)) } rhs :: { Located (GRHSs RdrName) } : '=' exp wherebinds { sL (comb3 $1 $2 $3) $ GRHSs (unguardedRHS $2) (unLoc $3) } | gdrhs wherebinds { LL $ GRHSs (reverse (unLoc $1)) (unLoc $2) } @@ -1484,15 +1493,7 @@ | '_' { L1 EWildPat } -- Template Haskell Extension - | TH_ID_SPLICE { L1 $ mkHsSpliceE - (L1 $ HsVar (mkUnqual varName - (getTH_ID_SPLICE $1))) } - | '$(' exp ')' { LL $ mkHsSpliceE $2 } - | TH_ID_TY_SPLICE { L1 $ mkHsSpliceTE - (L1 $ HsVar (mkUnqual varName - (getTH_ID_TY_SPLICE $1))) } - | '$$(' exp ')' { LL $ mkHsSpliceTE $2 } - + | splice_exp { $1 } | SIMPLEQUOTE qvar { LL $ HsBracket (VarBr True (unLoc $2)) } | SIMPLEQUOTE qcon { LL $ HsBracket (VarBr True (unLoc $2)) } @@ -1509,6 +1510,16 @@ -- arrow notation extension | '(|' aexp2 cmdargs '|)' { LL $ HsArrForm $2 Nothing (reverse $3) } +splice_exp :: { LHsExpr RdrName } + : TH_ID_SPLICE { L1 $ mkHsSpliceE + (L1 $ HsVar (mkUnqual varName + (getTH_ID_SPLICE $1))) } + | '$(' exp ')' { LL $ mkHsSpliceE $2 } + | TH_ID_TY_SPLICE { L1 $ mkHsSpliceTE + (L1 $ HsVar (mkUnqual varName + (getTH_ID_TY_SPLICE $1))) } + | '$$(' exp ')' { LL $ mkHsSpliceTE $2 } + cmdargs :: { [LHsCmdTop RdrName] } : cmdargs acmd { $2 : $1 } | {- empty -} { [] } diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs index 7576b06867b0..1d6569407658 100644 --- a/compiler/parser/RdrHsSyn.lhs +++ b/compiler/parser/RdrHsSyn.lhs @@ -7,7 +7,7 @@ Functions over HsSyn specialised to RdrName. module RdrHsSyn ( mkHsOpApp, mkHsIntegral, mkHsFractional, mkHsIsString, - mkHsDo, mkHsSpliceE, mkTopSpliceDecl, + mkHsDo, mkHsSpliceE, mkSpliceDecl, mkClassDecl, mkTyData, mkFamInstData, mkTySynonym, mkFamInstSynonym, @@ -197,16 +197,18 @@ mkTyFamily loc flavour lhs ksig ; tyvars <- checkTyVars lhs tparams ; return (L loc (TyFamily flavour tc tyvars ksig)) } -mkTopSpliceDecl :: LHsExpr RdrName -> HsDecl RdrName +mkSpliceDecl :: LHsExpr RdrName -> HsDecl RdrName -- If the user wrote -- [pads| ... ] then return a QuasiQuoteD -- $(e) then return a SpliceD -- but if she wrote, say, -- f x then behave as if she'd written $(f x) -- ie a SpliceD -mkTopSpliceDecl (L _ (HsQuasiQuoteE qq)) = QuasiQuoteD qq -mkTopSpliceDecl (L _ (HsSpliceE (HsSplice _ _ expr))) = SpliceD (SpliceDecl expr Explicit) -mkTopSpliceDecl other_expr = SpliceD (SpliceDecl other_expr Implicit) +mkSpliceDecl (L _ (HsQuasiQuoteE qq)) = QuasiQuoteD qq +mkSpliceDecl (L loc (HsSpliceE splice)) = SpliceD (SpliceDecl (L loc splice) Explicit) +mkSpliceDecl other_expr = SpliceD (SpliceDecl (L (getLoc other_expr) splice) Implicit) + where + HsSpliceE splice = mkHsSpliceE other_expr mkTyLit :: Located (HsTyLit) -> P (LHsType RdrName) diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs index 595f4653d392..d4f905fb7ba4 100644 --- a/compiler/rename/RnSource.lhs +++ b/compiler/rename/RnSource.lhs @@ -18,6 +18,7 @@ module RnSource ( #include "HsVersions.h" import {-# SOURCE #-} RnExpr( rnLExpr ) +import {-# SOURCE #-} RnSplice ( rnSpliceDecl ) #ifdef GHCI import {-# SOURCE #-} TcSplice ( runQuasiQuoteDecl ) #endif /* GHCI */ @@ -76,6 +77,7 @@ Checks the @(..)@ etc constraints in the export list. rnSrcDecls :: [Name] -> HsGroup RdrName -> RnM (TcGblEnv, HsGroup Name) -- Rename a HsGroup; used for normal source files *and* hs-boot files rnSrcDecls extra_deps group@(HsGroup { hs_valds = val_decls, + hs_splcds = splice_decls, hs_tyclds = tycl_decls, hs_instds = inst_decls, hs_derivds = deriv_decls, @@ -163,14 +165,16 @@ rnSrcDecls extra_deps group@(HsGroup { hs_valds = val_decls, (rn_ann_decls, src_fvs6) <- rnList rnAnnDecl ann_decls ; (rn_default_decls, src_fvs7) <- rnList rnDefaultDecl default_decls ; (rn_deriv_decls, src_fvs8) <- rnList rnSrcDerivDecl deriv_decls ; + (rn_splice_decls, src_fvs9) <- rnList rnSpliceDecl splice_decls ; -- Haddock docs; no free vars rn_docs <- mapM (wrapLocM rnDocDecl) docs ; last_tcg_env <- getGblEnv ; -- (I) Compute the results and return - let {rn_group = HsGroup { hs_valds = rn_val_decls, - hs_tyclds = rn_tycl_decls, - hs_instds = rn_inst_decls, + let {rn_group = HsGroup { hs_valds = rn_val_decls, + hs_splcds = rn_splice_decls, + hs_tyclds = rn_tycl_decls, + hs_instds = rn_inst_decls, hs_derivds = rn_deriv_decls, hs_fixds = rn_fix_decls, hs_warnds = [], -- warns are returned in the tcg_env @@ -184,10 +188,11 @@ rnSrcDecls extra_deps group@(HsGroup { hs_valds = val_decls, tycl_bndrs = hsTyClDeclsBinders rn_tycl_decls rn_inst_decls ; ford_bndrs = hsForeignDeclsBinders rn_foreign_decls ; - other_def = (Just (mkNameSet tycl_bndrs `unionNameSets` mkNameSet ford_bndrs), emptyNameSet) ; - other_fvs = plusFVs [src_fvs1, src_fvs2, src_fvs3, src_fvs4, - src_fvs5, src_fvs6, src_fvs7, src_fvs8] ; - -- It is tiresome to gather the binders from type and class decls + other_def = (Just (mkNameSet tycl_bndrs `unionNameSets` mkNameSet ford_bndrs), emptyNameSet) ; + other_fvs = plusFVs [src_fvs1, src_fvs2, src_fvs3, src_fvs4, + src_fvs5, src_fvs6, src_fvs7, src_fvs8, + src_fvs9] ; + -- It is tiresome to gather the binders from type and class decls src_dus = [other_def] `plusDU` bind_dus `plusDU` usesOnly other_fvs ; -- Instance decls may have occurrences of things bound in bind_dus diff --git a/compiler/rename/RnSplice.lhs b/compiler/rename/RnSplice.lhs index 1d31d8ff5eab..a52f95ea93df 100644 --- a/compiler/rename/RnSplice.lhs +++ b/compiler/rename/RnSplice.lhs @@ -1,6 +1,6 @@ \begin{code} module RnSplice ( - rnSpliceType, rnSpliceExpr, rnSplicePat, + rnSplice, rnSpliceType, rnSpliceExpr, rnSplicePat, rnSpliceDecl, rnBracket, checkTH, checkThLocalName ) where @@ -36,6 +36,9 @@ import {-# SOURCE #-} TcSplice ( runMetaE, runMetaP, runMetaT, tcTopSpliceExpr ) rnBracket :: HsExpr RdrName -> HsBracket RdrName -> RnM (HsExpr Name, FreeVars) rnBracket e _ = failTH e "bracket" +rnSplice :: HsSplice RdrName -> RnM (HsSplice Name, FreeVars) +rnSplice e = failTH e "splice" + rnSpliceType :: HsSplice RdrName -> PostTcKind -> RnM (HsType Name, FreeVars) rnSpliceType e _ = failTH e "splice" @@ -45,6 +48,9 @@ rnSpliceExpr e = failTH e "splice" rnSplicePat :: HsSplice RdrName -> RnM (Pat Name, FreeVars) rnSplicePat e = failTH e "splice" +rnSpliceDecl :: SpliceDecl RdrName -> RnM (SpliceDecl Name, FreeVars) +rnSpliceDecl e = failTH e "splice" + failTH :: Outputable a => a -> String -> RnM b failTH e what -- Raise an error in a stage-1 compiler = failWithTc (vcat [ptext (sLit "Template Haskell") <+> text what <+> @@ -258,6 +264,33 @@ rnSplicePat splice@(HsSplice False _ expr) } \end{code} +\begin{code} +rnSpliceDecl :: SpliceDecl RdrName -> RnM (SpliceDecl Name, FreeVars) +rnSpliceDecl (SpliceDecl (L _ (HsSplice True _ _)) _) + = panic "rnSpliceDecls: encountered typed declaration splice" + +rnSpliceDecl (SpliceDecl (L loc splice@(HsSplice False _ expr)) flg) + = addErrCtxt (exprCtxt (HsSpliceE splice)) $ + setSrcSpan (getLoc expr) $ do + { stage <- getStage + ; case stage of + { Brack isTypedBrack pop_stage ps_var _ -> + do { checkTc (not isTypedBrack) illegalUntypedSplice + + ; (splice'@(HsSplice _ name expr'), fvs) <- setStage pop_stage $ + rnSplice splice + + ; ps <- readMutVar ps_var + ; writeMutVar ps_var (PendingRnDeclSplice name expr' : ps) + + ; return (SpliceDecl (L loc splice') flg, fvs) + } + ; _ -> + pprPanic "rnSpliceDecls: should not have been called on top-level splice" (ppr expr) + } + } +\end{code} + %************************************************************************ %* * Template Haskell brackets @@ -351,14 +384,7 @@ rn_bracket _ (TypBr t) = do { (t', fvs) <- rnLHsType TypBrCtx t ; return (TypBr t', fvs) } rn_bracket _ (DecBrL decls) - = do { (group, mb_splice) <- findSplice decls - ; case mb_splice of - Nothing -> return () - Just (SpliceDecl (L loc _) _, _) - -> setSrcSpan loc $ - addErr (ptext (sLit "Declaration splices are not permitted inside declaration brackets")) - -- Why not? See Section 7.3 of the TH paper. - + = 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 @@ -372,6 +398,18 @@ rn_bracket _ (DecBrL decls) ; 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" diff --git a/compiler/rename/RnSplice.lhs-boot b/compiler/rename/RnSplice.lhs-boot index 40700bd3ca6d..2e9990f207db 100644 --- a/compiler/rename/RnSplice.lhs-boot +++ b/compiler/rename/RnSplice.lhs-boot @@ -11,9 +11,11 @@ import Outputable rnBracket :: HsExpr RdrName -> HsBracket RdrName -> RnM (HsExpr Name, FreeVars) +rnSplice :: HsSplice RdrName -> RnM (HsSplice Name, FreeVars) rnSpliceType :: HsSplice RdrName -> PostTcKind -> RnM (HsType Name, FreeVars) rnSpliceExpr :: HsSplice RdrName -> RnM (HsExpr Name, FreeVars) rnSplicePat :: HsSplice RdrName -> RnM (Pat Name, FreeVars) +rnSpliceDecl :: SpliceDecl RdrName -> RnM (SpliceDecl Name, FreeVars) checkTH :: Outputable a => a -> String -> RnM () \end{code} diff --git a/compiler/typecheck/TcHsSyn.lhs b/compiler/typecheck/TcHsSyn.lhs index a85d438c0c76..87db29255a96 100644 --- a/compiler/typecheck/TcHsSyn.lhs +++ b/compiler/typecheck/TcHsSyn.lhs @@ -586,6 +586,9 @@ zonkExpr env (HsBracketOut body bs) zonk_b (PendingRnTypeSplice _ e) = pprPanic "zonkExpr: PendingRnTypeSplice" (ppr e) + zonk_b (PendingRnDeclSplice _ e) + = pprPanic "zonkExpr: PendingRnDeclSplice" (ppr e) + zonk_b (PendingTcSplice n e) = do e' <- zonkLExpr env e return (PendingTcSplice n e') diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index 530530a16c77..a558aa43c0db 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/compiler/typecheck/TcRnDriver.lhs @@ -23,6 +23,7 @@ module TcRnDriver ( #ifdef GHCI import {-# SOURCE #-} TcSplice ( tcSpliceDecls ) +import RnSplice ( rnSplice ) #endif import TypeRep @@ -497,15 +498,15 @@ tc_rn_src_decls boot_details ds failWithTc (text "Can't do a top-level splice; need a bootstrapped compiler") #else -- If there's a splice, we must carry on - Just (SpliceDecl splice_expr _, rest_ds) -> do { + Just (SpliceDecl (L _ splice) _, rest_ds) -> do { -- Rename the splice expression, and get its supporting decls - (rn_splice_expr, splice_fvs) <- checkNoErrs (rnLExpr splice_expr) ; + (rn_splice, splice_fvs) <- checkNoErrs (rnSplice splice) ; -- checkNoErrs: don't typecheck if renaming failed - rnDump (ppr rn_splice_expr) ; + rnDump (ppr rn_splice) ; -- Execute the splice - spliced_decls <- tcSpliceDecls rn_splice_expr ; + spliced_decls <- tcSpliceDecls rn_splice ; -- Glue them on the front of the remaining decls and loop setGblEnv (tcg_env `addTcgDUs` usesOnly splice_fvs) $ diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs index 15bc02e89626..589fdd176b0b 100644 --- a/compiler/typecheck/TcSplice.lhs +++ b/compiler/typecheck/TcSplice.lhs @@ -284,7 +284,7 @@ The predicate we use is TcEnv.thTopLevelId. \begin{code} tcBracket :: HsBracket Name -> [PendingSplice] -> TcRhoType -> TcM (HsExpr TcId) -tcSpliceDecls :: LHsExpr Name -> TcM [LHsDecl RdrName] +tcSpliceDecls :: HsSplice Name -> TcM [LHsDecl RdrName] tcSpliceExpr :: HsSplice Name -> TcRhoType -> TcM (HsExpr TcId) tcSplicePat :: HsSplice Name -> TcRhoType -> TcM (HsExpr TcId) tcSpliceType :: HsSplice Name -> FreeVars -> TcM (TcType, TcKind) @@ -411,6 +411,11 @@ tcPendingSplice (PendingRnTypeSplice n expr) ; return () } +tcPendingSplice (PendingRnDeclSplice n expr) + = do { _ <- tcSpliceDecls (HsSplice False n expr) + ; return () + } + tcPendingSplice (PendingTcSplice _ expr) = pprPanic "tcPendingSplice: PendingTcSplice" (ppr expr) @@ -653,7 +658,10 @@ tcSpliceType splice@(HsSplice False name expr) _ -- Always at top level -- Type sig at top of file: -- tcSpliceDecls :: LHsExpr Name -> TcM [LHsDecl RdrName] -tcSpliceDecls expr +tcSpliceDecls splice@(HsSplice True _ _) + = pprPanic "tcSpliceDecls: encountered a typed type splice" (ppr splice) + +tcSpliceDecls (HsSplice False _ expr) = do { list_q <- tcMetaTy decsQTyConName -- Q [Dec] ; zonked_q_expr <- tcTopSpliceExpr False (tcMonoExpr expr list_q) diff --git a/compiler/typecheck/TcSplice.lhs-boot b/compiler/typecheck/TcSplice.lhs-boot index 1b871256977f..d33641ff6889 100644 --- a/compiler/typecheck/TcSplice.lhs-boot +++ b/compiler/typecheck/TcSplice.lhs-boot @@ -18,7 +18,7 @@ tcSpliceExpr :: HsSplice Name tcSpliceType :: HsSplice Name -> FreeVars -> TcM (TcType, TcKind) -tcSpliceDecls :: LHsExpr Name -> TcM [LHsDecl RdrName] +tcSpliceDecls :: HsSplice Name -> TcM [LHsDecl RdrName] tcBracket :: HsBracket Name -> [PendingSplice]