Add quasi-quotation, courtesy of Geoffrey Mainland

[ghc-hetmet.git] / compiler / hsSyn / HsExpr.lhs

diff --git a/compiler/hsSyn/HsExpr.lhs b/compiler/hsSyn/HsExpr.lhs
index c8ce17e..68dcda8 100644 (file)
--- a/compiler/hsSyn/HsExpr.lhs
+++ b/compiler/hsSyn/HsExpr.lhs
@@ -203,6 +203,9 @@ data HsExpr id
 
   | HsSpliceE (HsSplice id)
 
+  | HsQuasiQuoteE (HsQuasiQuote id)
+       -- See Note [Quasi-quote overview] in TcSplice
+
   -----------------------------------------------------------
   -- Arrow notation extension
 
@@ -370,12 +373,15 @@ ppr_expr (SectionR op expr)
     pp_infixly v
       = (sep [pprInfix v, pp_expr])
 
-ppr_expr (HsLam matches :: HsExpr id)
-  = pprMatches (LambdaExpr :: HsMatchContext id) matches
+--avoid using PatternSignatures for stage1 code portability
+ppr_expr exprType@(HsLam matches)
+  = pprMatches (LambdaExpr `asTypeOf` idType exprType) matches
+ where idType :: HsExpr id -> HsMatchContext id; idType = undefined
 
-ppr_expr (HsCase expr matches :: HsExpr id)
+ppr_expr exprType@(HsCase expr matches)
   = sep [ sep [ptext SLIT("case"), nest 4 (ppr expr), ptext SLIT("of")],
-          nest 2 (pprMatches (CaseAlt :: HsMatchContext id) matches) ]
+          nest 2 (pprMatches (CaseAlt `asTypeOf` idType exprType) matches) ]
+ where idType :: HsExpr id -> HsMatchContext id; idType = undefined
 
 ppr_expr (HsIf e1 e2 e3)
   = sep [hsep [ptext SLIT("if"), nest 2 (ppr e1), ptext SLIT("then")],
@@ -435,6 +441,10 @@ ppr_expr (HsSpliceE s)       = pprSplice s
 ppr_expr (HsBracket b)       = pprHsBracket b
 ppr_expr (HsBracketOut e []) = ppr e
 ppr_expr (HsBracketOut e ps) = ppr e $$ ptext SLIT("pending") <+> ppr ps
+ppr_expr (HsQuasiQuoteE (HsQuasiQuote name quoter _ quote)) 
+    = char '$' <> brackets (ppr name) <>
+      ptext SLIT("[:") <> ppr quoter <> ptext SLIT("|") <>
+      ppr quote <> ptext SLIT("|]")
 
 ppr_expr (HsProc pat (L _ (HsCmdTop cmd _ _ _)))
   = hsep [ptext SLIT("proc"), ppr pat, ptext SLIT("->"), ppr cmd]
@@ -699,8 +709,10 @@ pprFunBind fun inf matches = pprMatches (FunRhs fun inf) matches
 -- Exported to HsBinds, which can't see the defn of HsMatchContext
 pprPatBind :: (OutputableBndr bndr, OutputableBndr id)
            => LPat bndr -> GRHSs id -> SDoc
-pprPatBind pat (grhss :: GRHSs id)
- = sep [ppr pat, nest 4 (pprGRHSs (PatBindRhs :: HsMatchContext id) grhss)]
+pprPatBind pat ty@(grhss)
+ = sep [ppr pat, nest 4 (pprGRHSs (PatBindRhs `asTypeOf` idType ty) grhss)]
+--avoid using PatternSignatures for stage1 code portability
+ where idType :: GRHSs id -> HsMatchContext id; idType = undefined
 
 
 pprMatch :: (OutputableBndr idL, OutputableBndr idR) => HsMatchContext idL -> Match idR -> SDoc