Commit 5246e123 authored by gmainland's avatar gmainland
Browse files

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.
parent db6cb113
......@@ -42,8 +42,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,
......@@ -67,7 +67,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
......@@ -142,6 +142,7 @@ data HsDecl id
data HsGroup id
= HsGroup {
hs_valds :: HsValBinds id,
hs_splcds :: [LSpliceDecl id],
hs_tyclds :: [TyClGroup id],
-- A list of mutually-recursive groups
......@@ -177,12 +178,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,
......@@ -196,6 +199,7 @@ appendGroups
hs_docs = docs1 }
HsGroup {
hs_valds = val_groups2,
hs_splcds = spliceds2,
hs_tyclds = tyclds2,
hs_instds = instds2,
hs_derivds = derivds2,
......@@ -210,6 +214,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,
......@@ -276,15 +281,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}
......@@ -1436,4 +1442,4 @@ instance OutputableBndr name => Outputable (RoleAnnotDecl name) where
roleAnnotDeclName :: RoleAnnotDecl name -> name
roleAnnotDeclName (RoleAnnotDecl (L _ name) _) = name
\end{code}
\ No newline at end of file
\end{code}
......@@ -350,6 +350,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)
......@@ -1431,6 +1432,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}
......
......@@ -599,13 +599,13 @@ topdecl :: { OrdList (LHsDecl RdrName) }
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
--
......@@ -1367,7 +1367,7 @@ docdecld :: { LDocDecl }
| 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) };
......@@ -1383,6 +1383,14 @@ decl :: { Located (OrdList (LHsDecl RdrName)) }
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) }
......@@ -1552,15 +1560,7 @@ aexp2 :: { LHsExpr RdrName }
| '_' { 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)) }
......@@ -1577,6 +1577,16 @@ aexp2 :: { LHsExpr RdrName }
-- 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 -} { [] }
......
......@@ -7,7 +7,7 @@ Functions over HsSyn specialised to RdrName.
module RdrHsSyn (
mkHsOpApp,
mkHsIntegral, mkHsFractional, mkHsIsString,
mkHsDo, mkTopSpliceDecl,
mkHsDo, mkSpliceDecl,
mkRoleAnnotDecl,
mkClassDecl,
mkTyData, mkFamInstData,
......@@ -215,16 +215,18 @@ reLocate :: SrcSpan -> Located a -> Located a
-- a whole, rather than just the binding site
reLocate loc (L _ x) = L loc x
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
-- Ensure a type literal is used correctly; notably, we need the proper extension enabled,
-- and if it's an integer literal, the literal must be >= 0. This can occur with
......
......@@ -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 */
......@@ -72,6 +73,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,
......@@ -159,12 +161,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,
......@@ -182,7 +186,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 ;
......
\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"
......
......@@ -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}
......@@ -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')
......
......@@ -23,6 +23,7 @@ module TcRnDriver (
#ifdef GHCI
import {-# SOURCE #-} TcSplice ( tcSpliceDecls )
import RnSplice ( rnSplice )
#endif
import DynFlags
......@@ -508,15 +509,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) $
......
......@@ -286,7 +286,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)
......@@ -413,6 +413,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)
......@@ -655,7 +660,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)
......
......@@ -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]
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment