Several TH/quasiquote changes

a) Added quasi-quote forms for
      declarations
      types
   e.g.   f :: [$qq| ... |]

b) Allow Template Haskell pattern quotes (but not splices)
   e.g.  f x = [p| Int -> $x |]

c) Improve pretty-printing for HsPat to remove superfluous
   parens.  (This isn't TH related really, but it affects
   some of the same code.)


A consequence of (a) is that when gathering and grouping declarations
in RnSource.findSplice, we must expand quasiquotes as we do so.
Otherwise it's all fairly straightforward.  I did a little bit of
refactoring in TcSplice.

User-manual changes still to come.

5 files changed, 123 insertions, 40 deletions

diff --git a/compiler/rename/RnExpr.lhs b/compiler/rename/RnExpr.lhs
index a269dd5098..6dc6801e16 100644
--- a/compiler/rename/RnExpr.lhs
+++ b/compiler/rename/RnExpr.lhs
@@ -20,7 +20,7 @@ module RnExpr (
 import {-# SOURCE #-} TcSplice( runQuasiQuoteExpr )
 #endif 	/* GHCI */
 
-import RnSource  ( rnSrcDecls )
+import RnSource  ( rnSrcDecls, findSplice )
 import RnBinds   ( rnLocalBindsAndThen, rnValBindsLHS, rnValBindsRHS,
                    rnMatchGroup, makeMiniFixityEnv) 
 import HsSyn
@@ -171,10 +171,8 @@ rnExpr (HsSpliceE splice)
 rnExpr e@(HsQuasiQuoteE _) = pprPanic "Cant do quasiquotation without GHCi" (ppr e)
 #else
 rnExpr (HsQuasiQuoteE qq)
-  = rnQuasiQuote qq 		`thenM` \ (qq', fvs_qq) ->
-    runQuasiQuoteExpr qq'	`thenM` \ (L _ expr') ->
-    rnExpr expr'		`thenM` \ (expr'', fvs_expr) ->
-    return (expr'', fvs_qq `plusFV` fvs_expr)
+  = runQuasiQuoteExpr qq	`thenM` \ (L _ expr') ->
+    rnExpr expr'
 #endif 	/* GHCI */
 
 ---------------------------------------------
@@ -306,7 +304,7 @@ rnExpr e@(ELazyPat {}) = patSynErr e
 \begin{code}
 rnExpr (HsProc pat body)
   = newArrowScope $
-    rnPats ProcExpr [pat] $ \ [pat'] ->
+    rnPat ProcExpr pat $ \ pat' ->
     rnCmdTop body	         `thenM` \ (body',fvBody) ->
     return (HsProc pat' body', fvBody)
 
@@ -597,15 +595,24 @@ rnBracket (VarBr n) = do { name <- lookupOccRn n
 rnBracket (ExpBr e) = do { (e', fvs) <- rnLExpr e
 			 ; return (ExpBr e', fvs) }
 
-rnBracket (PatBr _) = failWith (ptext (sLit "Tempate Haskell pattern brackets are not supported yet"))
+rnBracket (PatBr p) = rnPat ThPatQuote p $ \ p' -> return (PatBr p', emptyFVs)
+
 rnBracket (TypBr t) = do { (t', fvs) <- rnHsTypeFVs doc t
 			 ; return (TypBr t', fvs) }
 		    where
 		      doc = ptext (sLit "In a Template-Haskell quoted type")
-rnBracket (DecBr group) 
-  = do { gbl_env  <- getGblEnv
 
-	; let new_gbl_env = gbl_env { tcg_dus = emptyDUs }
+rnBracket (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.  
+
+       ; gbl_env  <- getGblEnv
+       ; let new_gbl_env = gbl_env { tcg_dus = emptyDUs }
 	      		  -- The emptyDUs is so that we just collect uses for this
                           -- group alone in the call to rnSrcDecls below
        ; (tcg_env, group') <- setGblEnv new_gbl_env $ 
@@ -613,7 +620,9 @@ rnBracket (DecBr group)
 			      rnSrcDecls group      
 
        -- Discard the tcg_env; it contains only extra info about fixity
-	; return (DecBr group', allUses (tcg_dus tcg_env)) }
+	; return (DecBrG group', allUses (tcg_dus tcg_env)) }
+
+rnBracket (DecBrG _) = panic "rnBracket: unexpected DecBrG"
 \end{code}
 
 %************************************************************************
@@ -661,7 +670,7 @@ rnStmt ctxt (L loc (BindStmt pat expr _ _)) thing_inside
 		-- The binders do not scope over the expression
 	; (bind_op, fvs1) <- lookupSyntaxName bindMName
 	; (fail_op, fvs2) <- lookupSyntaxName failMName
-	; rnPats (StmtCtxt ctxt) [pat] $ \ [pat'] -> do
+	; rnPat (StmtCtxt ctxt) pat $ \ pat' -> do
 	{ (thing, fvs3) <- thing_inside
 	; return (([L loc (BindStmt pat' expr' bind_op fail_op)], thing),
 		  fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) }}
diff --git a/compiler/rename/RnHsSyn.lhs b/compiler/rename/RnHsSyn.lhs
index 5fbe7f7eed..cb0727b7cc 100644
--- a/compiler/rename/RnHsSyn.lhs
+++ b/compiler/rename/RnHsSyn.lhs
@@ -70,6 +70,7 @@ extractHsTyNames ty
     get (HsTyVar tv)           = unitNameSet tv
     get (HsSpliceTy {})        = emptyNameSet   -- Type splices mention no type variables
     get (HsSpliceTyOut {})     = emptyNameSet   -- Ditto
+    get (HsQuasiQuoteTy {})    = emptyNameSet   -- Ditto
     get (HsKindSig ty _)       = getl ty
     get (HsForAllTy _ tvs
                     ctxt ty)   = (extractHsCtxtTyNames ctxt
diff --git a/compiler/rename/RnPat.lhs b/compiler/rename/RnPat.lhs
index c06aa38e06..bc17495478 100644
--- a/compiler/rename/RnPat.lhs
+++ b/compiler/rename/RnPat.lhs
@@ -11,7 +11,7 @@ free variables.
 
 \begin{code}
 module RnPat (-- main entry points
-              rnPats, rnBindPat,
+              rnPat, rnPats, rnBindPat,
 
               NameMaker, applyNameMaker,     -- a utility for making names:
               localRecNameMaker, topRecNameMaker,  --   sometimes we want to make local names,
@@ -22,9 +22,6 @@ module RnPat (-- main entry points
 	      -- Literals
 	      rnLit, rnOverLit,     
 
-	      -- Quasiquotation
-	      rnQuasiQuote,
-
              -- Pattern Error messages that are also used elsewhere
              checkTupSize, patSigErr
              ) where
@@ -233,6 +230,12 @@ rnPats ctxt pats thing_inside
   where
     doc_pat = ptext (sLit "In") <+> pprMatchContext ctxt
 
+rnPat :: HsMatchContext Name -- for error messages
+      -> LPat RdrName 
+      -> (LPat Name -> RnM (a, FreeVars))
+      -> RnM (a, FreeVars)
+rnPat ctxt pat thing_inside 
+  = rnPats ctxt [pat] (\[pat'] -> thing_inside pat')
 
 applyNameMaker :: NameMaker -> Located RdrName -> RnM Name
 applyNameMaker mk rdr = do { (n, _fvs) <- runCps (newName mk rdr); return n }
@@ -363,8 +366,7 @@ rnPatAndThen _ p@(QuasiQuotePat {})
   = pprPanic "Can't do QuasiQuotePat without GHCi" (ppr p)
 #else
 rnPatAndThen mk (QuasiQuotePat qq)
-  = do { qq' <- liftCpsFV $ rnQuasiQuote qq
-       ; pat <- liftCps $ runQuasiQuotePat qq'
+  = do { pat <- liftCps $ runQuasiQuotePat qq
        ; L _ pat' <- rnLPatAndThen mk pat
        ; return pat' }
 #endif 	/* GHCI */
@@ -565,27 +567,6 @@ rnOverLit lit@(OverLit {ol_val=val})
 
 %************************************************************************
 %*									*
-\subsubsection{Quasiquotation}
-%*									*
-%************************************************************************
-
-See Note [Quasi-quote overview] in TcSplice.
-
-\begin{code}
-rnQuasiQuote :: HsQuasiQuote RdrName -> RnM (HsQuasiQuote Name, FreeVars)
-rnQuasiQuote (HsQuasiQuote n quoter quoteSpan quote)
-  = do	{ loc  <- getSrcSpanM
-   	; n' <- newLocalBndrRn (L loc n)
-   	; quoter' <- lookupOccRn quoter
-		-- If 'quoter' is not in scope, proceed no further
-		-- Otherwise lookupOcc adds an error messsage and returns 
-		-- an "unubound name", which makes the subsequent attempt to
-		-- run the quote fail
-   	; return (HsQuasiQuote n' quoter' quoteSpan quote, unitFV quoter') }
-\end{code}
-
-%************************************************************************
-%*									*
 \subsubsection{Errors}
 %*									*
 %************************************************************************
diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs
index 6984a4b66a..c01afec63a 100644
--- a/compiler/rename/RnSource.lhs
+++ b/compiler/rename/RnSource.lhs
@@ -5,12 +5,15 @@
 
 \begin{code}
 module RnSource ( 
-	rnSrcDecls, addTcgDUs, rnTyClDecls 
+	rnSrcDecls, addTcgDUs, rnTyClDecls, findSplice
     ) where
 
 #include "HsVersions.h"
 
 import {-# SOURCE #-} RnExpr( rnLExpr )
+#ifdef GHCI
+import {-# SOURCE #-} TcSplice ( runQuasiQuoteDecl )
+#endif 	/* GHCI */
 
 import HsSyn
 import RdrName		( RdrName, isRdrDataCon, elemLocalRdrEnv, rdrNameOcc )
@@ -1096,3 +1099,83 @@ rnHsTyVar _doc tyvar = lookupOccRn tyvar
 \end{code}
 
 
+%*********************************************************
+%*							*
+	findSplice
+%*							*
+%*********************************************************
+
+This code marches down the declarations, looking for the first
+Template Haskell splice.  As it does so it
+	a) groups the declarations into a HsGroup
+	b) runs any top-level quasi-quotes
+
+\begin{code}
+findSplice :: [LHsDecl RdrName] -> RnM (HsGroup RdrName, Maybe (SpliceDecl RdrName, [LHsDecl RdrName]))
+findSplice ds = addl emptyRdrGroup ds
+
+addl :: HsGroup RdrName -> [LHsDecl RdrName]
+     -> RnM (HsGroup RdrName, Maybe (SpliceDecl RdrName, [LHsDecl RdrName]))
+-- This stuff reverses the declarations (again) but it doesn't matter
+addl gp []	     = return (gp, Nothing)
+addl gp (L l d : ds) = add gp l d ds
+
+
+add :: HsGroup RdrName -> SrcSpan -> HsDecl RdrName -> [LHsDecl RdrName]
+    -> RnM (HsGroup RdrName, Maybe (SpliceDecl RdrName, [LHsDecl RdrName]))
+
+add gp _ (SpliceD e) ds = return (gp, Just (e, ds))
+
+#ifndef GHCI
+add _ _ (QuasiQuoteD qq) _
+  = pprPanic "Can't do QuasiQuote declarations without GHCi" (ppr qq)
+#else
+add gp _ (QuasiQuoteD qq) ds		-- Expand quasiquotes
+  = do { ds' <- runQuasiQuoteDecl qq
+       ; addl gp (ds' ++ ds) }
+#endif
+
+-- Class declarations: pull out the fixity signatures to the top
+add gp@(HsGroup {hs_tyclds = ts, hs_fixds = fs}) l (TyClD d) ds
+  | isClassDecl d
+  = let fsigs = [ L l f | L l (FixSig f) <- tcdSigs d ] in
+    addl (gp { hs_tyclds = L l d : ts, hs_fixds = fsigs ++ fs}) ds
+  | otherwise
+  = addl (gp { hs_tyclds = L l d : ts }) ds
+
+-- Signatures: fixity sigs go a different place than all others
+add gp@(HsGroup {hs_fixds = ts}) l (SigD (FixSig f)) ds
+  = addl (gp {hs_fixds = L l f : ts}) ds
+add gp@(HsGroup {hs_valds = ts}) l (SigD d) ds
+  = addl (gp {hs_valds = add_sig (L l d) ts}) ds
+
+-- Value declarations: use add_bind
+add gp@(HsGroup {hs_valds  = ts}) l (ValD d) ds
+  = addl (gp { hs_valds = add_bind (L l d) ts }) ds
+
+-- The rest are routine
+add gp@(HsGroup {hs_instds = ts})  l (InstD d) ds
+  = addl (gp { hs_instds = L l d : ts }) ds
+add gp@(HsGroup {hs_derivds = ts})  l (DerivD d) ds
+  = addl (gp { hs_derivds = L l d : ts }) ds
+add gp@(HsGroup {hs_defds  = ts})  l (DefD d) ds
+  = addl (gp { hs_defds = L l d : ts }) ds
+add gp@(HsGroup {hs_fords  = ts}) l (ForD d) ds
+  = addl (gp { hs_fords = L l d : ts }) ds
+add gp@(HsGroup {hs_warnds  = ts})  l (WarningD d) ds
+  = addl (gp { hs_warnds = L l d : ts }) ds
+add gp@(HsGroup {hs_annds  = ts}) l (AnnD d) ds
+  = addl (gp { hs_annds = L l d : ts }) ds
+add gp@(HsGroup {hs_ruleds  = ts}) l (RuleD d) ds
+  = addl (gp { hs_ruleds = L l d : ts }) ds
+add gp l (DocD d) ds
+  = addl (gp { hs_docs = (L l d) : (hs_docs gp) })  ds
+
+add_bind :: LHsBind a -> HsValBinds a -> HsValBinds a
+add_bind b (ValBindsIn bs sigs) = ValBindsIn (bs `snocBag` b) sigs
+add_bind _ (ValBindsOut {})     = panic "RdrHsSyn:add_bind"
+
+add_sig :: LSig a -> HsValBinds a -> HsValBinds a
+add_sig s (ValBindsIn bs sigs) = ValBindsIn bs (s:sigs) 
+add_sig _ (ValBindsOut {})     = panic "RdrHsSyn:add_sig"
+\end{code}
\ No newline at end of file
diff --git a/compiler/rename/RnTypes.lhs b/compiler/rename/RnTypes.lhs
index cb60b934d2..ed3e6d0d7c 100644
--- a/compiler/rename/RnTypes.lhs
+++ b/compiler/rename/RnTypes.lhs
@@ -18,6 +18,9 @@ module RnTypes (
   ) where
 
 import {-# SOURCE #-} RnExpr( rnLExpr )
+#ifdef GHCI
+import {-# SOURCE #-} TcSplice( runQuasiQuoteType )
+#endif 	/* GHCI */
 
 import DynFlags
 import HsSyn
@@ -191,6 +194,12 @@ rnHsType doc (HsDocTy ty haddock_doc) = do
     haddock_doc' <- rnLHsDoc haddock_doc
     return (HsDocTy ty' haddock_doc')
 
+#ifndef GHCI
+rnHsType _ ty@(HsQuasiQuoteTy _) = pprPanic "Can't do quasiquotation without GHCi" (ppr ty)
+#else
+rnHsType doc (HsQuasiQuoteTy qq) = do { ty <- runQuasiQuoteType qq
+                                      ; rnHsType doc (unLoc ty) }
+#endif
 rnHsType _ (HsSpliceTyOut {}) = panic "rnHsType"
 
 rnLHsTypes :: SDoc -> [LHsType RdrName]