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.

6 files changed, 89 insertions, 60 deletions

diff --git a/compiler/hsSyn/HsDecls.lhs b/compiler/hsSyn/HsDecls.lhs
index 607b319dd2..000ed193f2 100644
--- a/compiler/hsSyn/HsDecls.lhs
+++ b/compiler/hsSyn/HsDecls.lhs
@@ -102,6 +102,7 @@ data HsDecl id
   | RuleD	(RuleDecl id)
   | SpliceD	(SpliceDecl id)
   | DocD	(DocDecl)
+  | QuasiQuoteD	(HsQuasiQuote id)
 
 
 -- NB: all top-level fixity decls are contained EITHER
@@ -204,6 +205,7 @@ instance OutputableBndr name => Outputable (HsDecl name) where
     ppr (AnnD ad)               = ppr ad
     ppr (SpliceD dd)            = ppr dd
     ppr (DocD doc)              = ppr doc
+    ppr (QuasiQuoteD qq)        = ppr qq
 
 instance OutputableBndr name => Outputable (HsGroup name) where
     ppr (HsGroup { hs_valds  = val_decls,
diff --git a/compiler/hsSyn/HsExpr.lhs b/compiler/hsSyn/HsExpr.lhs
index 10c106d3e5..fd4f6db8eb 100644
--- a/compiler/hsSyn/HsExpr.lhs
+++ b/compiler/hsSyn/HsExpr.lhs
@@ -744,7 +744,7 @@ pprPatBind pat ty@(grhss)
 
 pprMatch :: (OutputableBndr idL, OutputableBndr idR) => HsMatchContext idL -> Match idR -> SDoc
 pprMatch ctxt (Match pats maybe_ty grhss)
-  = herald <+> sep [sep (map ppr other_pats),
+  = herald <+> sep [sep (map pprParendLPat other_pats),
                     ppr_maybe_ty,
                     nest 2 (pprGRHSs ctxt grhss)]
   where
@@ -756,18 +756,21 @@ pprMatch ctxt (Match pats maybe_ty grhss)
                         -- Not pprBndr; the AbsBinds will
                         -- have printed the signature
 
-                | null pats3 -> (pp_infix, [])
+                | null pats2 -> (pp_infix, [])
                         -- x &&& y = e
 
-                | otherwise -> (parens pp_infix, pats3)
+                | otherwise -> (parens pp_infix, pats2)
                         -- (x &&& y) z = e
                 where
-                  (pat1:pat2:pats3) = pats
-                  pp_infix = ppr pat1 <+> ppr fun <+> ppr pat2
+                  pp_infix = pprParendLPat pat1 <+> ppr fun <+> pprParendLPat pat2
 
             LambdaExpr -> (char '\\', pats)
-            _          -> (empty,     pats)
+	    
+            _  -> ASSERT( null pats1 )
+                  (ppr pat1, [])	-- No parens around the single pat
 
+    (pat1:pats1) = pats
+    (pat2:pats2) = pats1
     ppr_maybe_ty = case maybe_ty of
                         Just ty -> dcolon <+> ppr ty
                         Nothing -> empty
@@ -975,10 +978,11 @@ pprGroupByClause (GroupBySomething eitherUsingExpr byExpr) = hsep [ptext (sLit "
 
 pprDo :: OutputableBndr id => HsStmtContext any -> [LStmt id] -> LHsExpr id -> SDoc
 pprDo DoExpr      stmts body = ptext (sLit "do")  <+> ppr_do_stmts stmts body
+pprDo GhciStmt    stmts body = ptext (sLit "do")  <+> ppr_do_stmts stmts body
 pprDo (MDoExpr _) stmts body = ptext (sLit "mdo") <+> ppr_do_stmts stmts body
 pprDo ListComp    stmts body = pprComp brackets    stmts body
 pprDo PArrComp    stmts body = pprComp pa_brackets stmts body
-pprDo _           _     _    = panic "pprDo" -- PatGuard, ParStmtCxt, GhciStmt
+pprDo _           _     _    = panic "pprDo" -- PatGuard, ParStmtCxt
 
 ppr_do_stmts :: OutputableBndr id => [LStmt id] -> LHsExpr id -> SDoc
 -- Print a bunch of do stmts, with explicit braces and semicolons,
@@ -1013,22 +1017,24 @@ pprSplice (HsSplice n e)
     = char '$' <> ifPprDebug (brackets (ppr n)) <> pprParendExpr e
 
 
-data HsBracket id = ExpBr (LHsExpr id)          -- [|  expr  |]
-                  | PatBr (LPat id)             -- [p| pat   |]
-                  | DecBr (HsGroup id)          -- [d| decls |]
-                  | TypBr (LHsType id)          -- [t| type  |]
-                  | VarBr id                    -- 'x, ''T
+data HsBracket id = ExpBr (LHsExpr id)   -- [|  expr  |]
+                  | PatBr (LPat id)      -- [p| pat   |]
+                  | DecBrL [LHsDecl id]	 -- [d| decls |]; result of parser
+                  | DecBrG (HsGroup id)  -- [d| decls |]; result of renamer
+                  | TypBr (LHsType id)   -- [t| type  |]
+                  | VarBr id             -- 'x, ''T
 
 instance OutputableBndr id => Outputable (HsBracket id) where
   ppr = pprHsBracket
 
 
 pprHsBracket :: OutputableBndr id => HsBracket id -> SDoc
-pprHsBracket (ExpBr e) = thBrackets empty (ppr e)
-pprHsBracket (PatBr p) = thBrackets (char 'p') (ppr p)
-pprHsBracket (DecBr d) = thBrackets (char 'd') (ppr d)
-pprHsBracket (TypBr t) = thBrackets (char 't') (ppr t)
-pprHsBracket (VarBr n) = char '\'' <> ppr n
+pprHsBracket (ExpBr e) 	 = thBrackets empty (ppr e)
+pprHsBracket (PatBr p) 	 = thBrackets (char 'p') (ppr p)
+pprHsBracket (DecBrG gp) = thBrackets (char 'd') (ppr gp)
+pprHsBracket (DecBrL ds) = thBrackets (char 'd') (vcat (map ppr ds))
+pprHsBracket (TypBr t) 	 = thBrackets (char 't') (ppr t)
+pprHsBracket (VarBr n) 	 = char '\'' <> ppr n
 -- Infelicity: can't show ' vs '', because
 -- we can't ask n what its OccName is, because the
 -- pretty-printer for HsExpr doesn't ask for NamedThings
@@ -1087,6 +1093,7 @@ data HsMatchContext id  -- Context of a Match
                                 --    tell matchWrapper what sort of
                                 --    runtime error message to generate]
   | StmtCtxt (HsStmtContext id) -- Pattern of a do-stmt or list comprehension
+  | ThPatQuote			-- A Template Haskell pattern quotation [p| (a,b) |]
   deriving ()
 
 data HsStmtContext id
@@ -1123,6 +1130,7 @@ matchSeparator ProcExpr     = ptext (sLit "->")
 matchSeparator PatBindRhs   = ptext (sLit "=")
 matchSeparator (StmtCtxt _) = ptext (sLit "<-")
 matchSeparator RecUpd       = panic "unused"
+matchSeparator ThPatQuote   = panic "unused"
 \end{code}
 
 \begin{code}
@@ -1131,6 +1139,7 @@ pprMatchContext (FunRhs fun _)    = ptext (sLit "the definition of")
                                     <+> quotes (ppr fun)
 pprMatchContext CaseAlt           = ptext (sLit "a case alternative")
 pprMatchContext RecUpd            = ptext (sLit "a record-update construct")
+pprMatchContext ThPatQuote        = ptext (sLit "a Template Haskell pattern quotation")
 pprMatchContext PatBindRhs        = ptext (sLit "a pattern binding")
 pprMatchContext LambdaExpr        = ptext (sLit "a lambda abstraction")
 pprMatchContext ProcExpr          = ptext (sLit "an arrow abstraction")
@@ -1173,6 +1182,7 @@ matchContextErrString PatBindRhs                 = ptext (sLit "pattern binding"
 matchContextErrString RecUpd                     = ptext (sLit "record update")
 matchContextErrString LambdaExpr                 = ptext (sLit "lambda")
 matchContextErrString ProcExpr                   = ptext (sLit "proc")
+matchContextErrString ThPatQuote                 = panic "matchContextErrString"  -- Not used at runtime
 matchContextErrString (StmtCtxt (ParStmtCtxt c)) = matchContextErrString (StmtCtxt c)
 matchContextErrString (StmtCtxt (TransformStmtCtxt c)) = matchContextErrString (StmtCtxt c)
 matchContextErrString (StmtCtxt (PatGuard _))    = ptext (sLit "pattern guard")
diff --git a/compiler/hsSyn/HsPat.lhs b/compiler/hsSyn/HsPat.lhs
index af921de689..506537517d 100644
--- a/compiler/hsSyn/HsPat.lhs
+++ b/compiler/hsSyn/HsPat.lhs
@@ -19,13 +19,13 @@ module HsPat (
 	HsConPatDetails, hsConPatArgs, 
 	HsRecFields(..), HsRecField(..), hsRecFields,
 
-	HsQuasiQuote(..),
-
 	mkPrefixConPat, mkCharLitPat, mkNilPat, mkCoPat, mkCoPatCoI,
 
 	isBangHsBind, hsPatNeedsParens,
 	patsAreAllCons, isConPat, isSigPat, isWildPat,
-	patsAreAllLits,	isLitPat, isIrrefutableHsPat
+	patsAreAllLits,	isLitPat, isIrrefutableHsPat,
+
+	pprParendLPat
     ) where
 
 import {-# SOURCE #-} HsExpr		(SyntaxExpr, LHsExpr, pprLExpr)
@@ -215,24 +215,6 @@ hsRecFields :: HsRecFields id arg -> [id]
 hsRecFields rbinds = map (unLoc . hsRecFieldId) (rec_flds rbinds)
 \end{code}
 
-\begin{code}
-data HsQuasiQuote id = HsQuasiQuote 
-		       id
-		       id
-		       SrcSpan
-		       FastString
-
-instance OutputableBndr id => Outputable (HsQuasiQuote id) where
-    ppr = ppr_qq
-
-ppr_qq :: OutputableBndr id => HsQuasiQuote id -> SDoc
-ppr_qq (HsQuasiQuote name quoter _ quote) =
-    char '$' <> brackets (ppr name) <>
-    ptext (sLit "[:") <> ppr quoter <> ptext (sLit "|") <>
-    ppr quote <> ptext (sLit "|]")
-\end{code}
-
-
 %************************************************************************
 %*									*
 %* 		Printing patterns
@@ -252,14 +234,30 @@ pprPatBndr var		  	-- Print with type info if -dppr-debug is on
     else
 	ppr var
 
+pprParendLPat :: (OutputableBndr name) => LPat name -> SDoc
+pprParendLPat (L _ p) = pprParendPat p
+
+pprParendPat :: (OutputableBndr name) => Pat name -> SDoc
+pprParendPat p | patNeedsParens p = parens (pprPat p)
+               | otherwise        = pprPat p
+
+patNeedsParens :: Pat name -> Bool
+patNeedsParens (ConPatIn _ d)               = not (null (hsConPatArgs d))
+patNeedsParens (ConPatOut { pat_args = d }) = not (null (hsConPatArgs d))
+patNeedsParens (SigPatIn {})  = True
+patNeedsParens (SigPatOut {}) = True
+patNeedsParens (ViewPat {})   = True
+patNeedsParens (CoPat {})     = True
+patNeedsParens _              = False
+
 pprPat :: (OutputableBndr name) => Pat name -> SDoc
 pprPat (VarPat var)  	  = pprPatBndr var
-pprPat (VarPatOut var bs) = parens (pprPatBndr var <+> braces (ppr bs))
+pprPat (VarPatOut var bs) = pprPatBndr var <+> braces (ppr bs)
 pprPat (WildPat _)	  = char '_'
-pprPat (LazyPat pat)      = char '~' <> ppr pat
-pprPat (BangPat pat)      = char '!' <> ppr pat
-pprPat (AsPat name pat)   = parens (hcat [ppr name, char '@', ppr pat])
-pprPat (ViewPat expr pat _) = parens (hcat [pprLExpr expr, text " -> ", ppr pat])
+pprPat (LazyPat pat)      = char '~' <> pprParendLPat pat
+pprPat (BangPat pat)      = char '!' <> pprParendLPat pat
+pprPat (AsPat name pat)   = hcat [ppr name, char '@', pprParendLPat pat]
+pprPat (ViewPat expr pat _) = hcat [pprLExpr expr, text " -> ", ppr pat]
 pprPat (ParPat pat)	    = parens (ppr pat)
 pprPat (ListPat pats _)     = brackets (interpp'SP pats)
 pprPat (PArrPat pats _)     = pabrackets (interpp'SP pats)
@@ -275,26 +273,23 @@ pprPat (ConPatOut { pat_con = con, pat_tvs = tvs, pat_dicts = dicts,
 		   	  pprLHsBinds binds, pprConArgs details]
     else pprUserCon con details
 
-pprPat (LitPat s)	      = ppr s
+pprPat (LitPat s)	    = ppr s
 pprPat (NPat l Nothing  _)  = ppr l
 pprPat (NPat l (Just _) _)  = char '-' <> ppr l
-pprPat (NPlusKPat n k _ _)    = hcat [ppr n, char '+', ppr k]
-pprPat (QuasiQuotePat (HsQuasiQuote name quoter _ quote)) 
-    = char '$' <> brackets (ppr name) <>
-      ptext (sLit "[:") <> ppr quoter <> ptext (sLit "|") <>
-      ppr quote <> ptext (sLit "|]")
-pprPat (TypePat ty)	      = ptext (sLit "{|") <> ppr ty <> ptext (sLit "|}")
-pprPat (CoPat co pat _)	      = parens (pprHsWrapper (ppr pat) co)
-pprPat (SigPatIn pat ty)      = ppr pat <+> dcolon <+> ppr ty
-pprPat (SigPatOut pat ty)     = ppr pat <+> dcolon <+> ppr ty
+pprPat (NPlusKPat n k _ _)  = hcat [ppr n, char '+', ppr k]
+pprPat (QuasiQuotePat qq)   = ppr qq
+pprPat (TypePat ty)	    = ptext (sLit "{|") <> ppr ty <> ptext (sLit "|}")
+pprPat (CoPat co pat _)	    = pprHsWrapper (ppr pat) co
+pprPat (SigPatIn pat ty)    = ppr pat <+> dcolon <+> ppr ty
+pprPat (SigPatOut pat ty)   = ppr pat <+> dcolon <+> ppr ty
 
 pprUserCon :: (Outputable con, OutputableBndr id) => con -> HsConPatDetails id -> SDoc
 pprUserCon c (InfixCon p1 p2) = ppr p1 <+> ppr c <+> ppr p2
 pprUserCon c details          = ppr c <+> pprConArgs details
 
 pprConArgs ::  OutputableBndr id => HsConPatDetails id -> SDoc
-pprConArgs (PrefixCon pats) = interppSP pats
-pprConArgs (InfixCon p1 p2) = interppSP [p1,p2]
+pprConArgs (PrefixCon pats) = sep (map pprParendLPat pats)
+pprConArgs (InfixCon p1 p2) = sep [pprParendLPat p1, pprParendLPat p2]
 pprConArgs (RecCon rpats)   = ppr rpats
 
 instance (OutputableBndr id, Outputable arg)
diff --git a/compiler/hsSyn/HsPat.lhs-boot b/compiler/hsSyn/HsPat.lhs-boot
index f5d250eb97..d5b685c1f1 100644
--- a/compiler/hsSyn/HsPat.lhs-boot
+++ b/compiler/hsSyn/HsPat.lhs-boot
@@ -1,9 +1,6 @@
 \begin{code}
 module HsPat where
-import SrcLoc( Located, SrcSpan )
-import FastString ( FastString )
-
-data HsQuasiQuote i = HsQuasiQuote i i SrcSpan FastString
+import SrcLoc( Located )
 
 data Pat i
 type LPat i = Located (Pat i)
diff --git a/compiler/hsSyn/HsTypes.lhs b/compiler/hsSyn/HsTypes.lhs
index 4e6e5ab908..4417751335 100644
--- a/compiler/hsSyn/HsTypes.lhs
+++ b/compiler/hsSyn/HsTypes.lhs
@@ -12,6 +12,7 @@ module HsTypes (
 	HsExplicitForAll(..),
 	HsContext, LHsContext,
 	HsPred(..), LHsPred,
+	HsQuasiQuote(..),
 
 	LBangType, BangType, HsBang(..), 
         getBangType, getBangStrictness, 
@@ -61,6 +62,28 @@ placeHolderType  = panic "Evaluated the place holder for a PostTcType"
 
 %************************************************************************
 %*									*
+	Quasi quotes; used in types and elsewhere
+%*									*
+%************************************************************************
+
+\begin{code}
+data HsQuasiQuote id = HsQuasiQuote 
+		       	   id		-- The quasi-quoter
+		       	   SrcSpan	-- The span of the enclosed string
+		       	   FastString	-- The enclosed string
+
+instance OutputableBndr id => Outputable (HsQuasiQuote id) where
+    ppr = ppr_qq
+
+ppr_qq :: OutputableBndr id => HsQuasiQuote id -> SDoc
+ppr_qq (HsQuasiQuote quoter _ quote) =
+    char '[' <> ppr quoter <> ptext (sLit "|") <>
+    ppr quote <> ptext (sLit "|]")
+\end{code}
+
+
+%************************************************************************
+%*									*
 \subsection{Bang annotations}
 %*									*
 %************************************************************************
@@ -157,6 +180,7 @@ data HsType name
 			Kind		-- A type with a kind signature
 
   | HsSpliceTy		(HsSplice name)
+  | HsQuasiQuoteTy	(HsQuasiQuote name)
 
   | HsDocTy             (LHsType name) LHsDocString -- A documented type
 
@@ -374,6 +398,7 @@ ppr_mono_ty ctxt_prec (HsForAllTy exp tvs ctxt ty)
     sep [pprHsForAll exp tvs ctxt, ppr_mono_lty pREC_TOP ty]
 
 ppr_mono_ty _    (HsBangTy b ty)     = ppr b <> ppr ty
+ppr_mono_ty _    (HsQuasiQuoteTy qq) = ppr qq
 ppr_mono_ty _    (HsRecTy flds)      = pprConDeclFields flds
 ppr_mono_ty _    (HsTyVar name)      = ppr name
 ppr_mono_ty prec (HsFunTy ty1 ty2)   = ppr_fun_ty prec ty1 ty2
diff --git a/compiler/hsSyn/HsUtils.lhs b/compiler/hsSyn/HsUtils.lhs
index d629bae6ba..37a72050c5 100644
--- a/compiler/hsSyn/HsUtils.lhs
+++ b/compiler/hsSyn/HsUtils.lhs
@@ -189,7 +189,7 @@ unqualSplice = mkRdrUnqual (mkVarOccFS (fsLit "splice"))
 		-- identify the splice
 
 mkHsQuasiQuote :: RdrName -> SrcSpan -> FastString -> HsQuasiQuote RdrName
-mkHsQuasiQuote quoter span quote = HsQuasiQuote unqualQuasiQuote quoter span quote
+mkHsQuasiQuote quoter span quote = HsQuasiQuote quoter span quote
 
 unqualQuasiQuote :: RdrName
 unqualQuasiQuote = mkRdrUnqual (mkVarOccFS (fsLit "quasiquote"))