Add full support for declaration splices.

Since declaration splices are now untyped, they can be used anywhere a
declaration is valid, including in declaration brackets.

compiler/hsSyn/HsDecls.lhs

@@ -40,8 +40,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,
@@ -62,7 +62,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
@@ -136,6 +136,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
@@ -171,12 +172,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,
@@ -190,6 +193,7 @@ appendGroups
   hs_docs   = docs1 }
     HsGroup { 
         hs_valds  = val_groups2,
+        hs_splcds = spliceds2,
         hs_tyclds = tyclds2, 
         hs_instds = instds2,
         hs_derivds = derivds2,
@@ -204,6 +208,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,
@@ -269,15 +274,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}
 
 

compiler/hsSyn/HsExpr.lhs

@@ -339,6 +339,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)
@@ -1420,6 +1421,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}

compiler/parser/Parser.y.pp

@@ -612,13 +612,13 @@
                                                     VectD (HsVectTypeIn True $3 (Just $5)) }
         | '{-# VECTORISE' 'class' gtycon '#-}'  { unitOL $ LL $ VectD (HsVectClassIn $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
 --
@@ -1355,7 +1355,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) };
@@ -1371,6 +1371,14 @@
                                         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)) }
         : '=' exp wherebinds    { sL (comb3 $1 $2 $3) $ GRHSs (unguardedRHS $2) (unLoc $3) }
         | gdrhs wherebinds      { LL $ GRHSs (reverse (unLoc $1)) (unLoc $2) }
@@ -1537,15 +1545,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)) }
@@ -1562,6 +1562,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 -}                   { [] }

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, mkTyFamInstEqn, mkTyFamInstGroup,
@@ -212,16 +212,18 @@ mkFamDecl loc flavour lhs ksig
        ; tyvars <- checkTyVars lhs tparams
        ; return (L loc (FamilyDecl 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)

compiler/rename/RnSource.lhs

@@ -11,6 +11,7 @@ module RnSource (
 #include "HsVersions.h"
 
 import {-# SOURCE #-} RnExpr( rnLExpr )
+import {-# SOURCE #-} RnSplice ( rnSpliceDecl )
 #ifdef GHCI
 import {-# SOURCE #-} TcSplice ( runQuasiQuoteDecl )
 #endif /* GHCI */
@@ -70,6 +71,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,
@@ -157,12 +159,14 @@ 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_splcds  = rn_splice_decls,
                              hs_tyclds  = rn_tycl_decls,
                              hs_instds  = rn_inst_decls,
                              hs_derivds = rn_deriv_decls,
@@ -180,7 +184,8 @@ rnSrcDecls extra_deps group@(HsGroup { hs_valds   = val_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] ;
+                              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 ;

compiler/rename/RnSplice.lhs

@@ -1,6 +1,6 @@
 \begin{code}
 module RnSplice (
-        rnSpliceType, rnSpliceExpr, rnSplicePat,
+        rnSplice, rnSpliceType, rnSpliceExpr, rnSplicePat, rnSpliceDecl,
         rnBracket, checkTH,
         checkThLocalName
   ) where
@@ -37,6 +37,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"
 
@@ -46,6 +49,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 <+>
@@ -259,6 +265,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
@@ -352,14 +385,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
@@ -373,6 +399,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"
 

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}

compiler/typecheck/TcHsSyn.lhs

@@ -572,6 +572,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')

compiler/typecheck/TcRnDriver.lhs

@@ -23,6 +23,7 @@ module TcRnDriver (
 
 #ifdef GHCI
 import {-# SOURCE #-} TcSplice ( tcSpliceDecls )
+import RnSplice ( rnSplice )
 #endif
 
 import DynFlags
@@ -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) $