X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FhsSyn%2FHsPat.lhs;h=e87a6a27b446ba774fc223b3923dcb6fceffb5d8;hb=a1895147d4d0480f65535c99488ba25873e97bff;hp=032070698e838a915554d78feaf68b7fc98875bd;hpb=ce0ff544eec55a39aa279f2641032e95320089b2;p=ghc-hetmet.git

diff --git a/compiler/hsSyn/HsPat.lhs b/compiler/hsSyn/HsPat.lhs
index 0320706..e87a6a2 100644
--- a/compiler/hsSyn/HsPat.lhs
+++ b/compiler/hsSyn/HsPat.lhs
@@ -23,9 +23,9 @@ module HsPat (
 
 	mkPrefixConPat, mkCharLitPat, mkNilPat, mkCoPat, mkCoPatCoI,
 
-	isBangHsBind,	
+	isBangHsBind, hsPatNeedsParens,
 	patsAreAllCons, isConPat, isSigPat, isWildPat,
-	patsAreAllLits,	isLitPat, isIrrefutableHsPat
+	patsAreAllLits,	isLitPat, isIrrefutableHsPat, hasViewPat
     ) where
 
 import {-# SOURCE #-} HsExpr		(SyntaxExpr, LHsExpr, pprLExpr)
@@ -175,7 +175,7 @@ However HsRecFields is used only for patterns and expressions
 \begin{code}
 data HsRecFields id arg 	-- A bunch of record fields
 				--	{ x = 3, y = True }
-	-- Used for both expressiona and patterns
+	-- Used for both expressions and patterns
   = HsRecFields { rec_flds   :: [HsRecField id arg],
 		  rec_dotdot :: Maybe Int }
 	-- Nothing => the normal case
@@ -210,6 +210,15 @@ data HsQuasiQuote id = HsQuasiQuote
 		       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}
 
 
@@ -239,8 +248,8 @@ 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 (ParPat pat)	  = parens (ppr pat)
+pprPat (ViewPat expr pat _) = parens (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)
 pprPat (TuplePat pats bx _) = tupleParens bx (interpp'SP pats)
@@ -360,6 +369,34 @@ patterns are treated specially, of course.
 
 The 1.3 report defines what ``irrefutable'' and ``failure-free'' patterns are.
 \begin{code}
+hasViewPat :: LPat id -> Bool
+hasViewPat (L _ p) = go p where
+  go (WildPat _)             = False
+  go (VarPat _)              = False
+  go (VarPatOut _ _)         = False
+  go (LazyPat p)             = hasViewPat p
+  go (AsPat _ p)             = hasViewPat p
+  go (ParPat p)              = hasViewPat p
+  go (BangPat p)             = hasViewPat p
+  go (ListPat p _)           = any hasViewPat p
+  go (TuplePat p _ _)        = any hasViewPat p
+  go (PArrPat p _)           = any hasViewPat p
+  go (ConPatIn _ p)          = go' p
+  go (ConPatOut _ _ _ _ p _) = go' p
+  go (ViewPat _ _ _)         = True
+  go (QuasiQuotePat _)       = False
+  go (LitPat _)              = False
+  go (NPat _ _ _)            = False
+  go (NPlusKPat _ _ _ _)     = False
+  go (TypePat _)             = False
+  go (SigPatIn p _)          = hasViewPat p
+  go (SigPatOut p _)         = hasViewPat p
+  go (CoPat _ _ _)           = False
+  go' p = case p of
+    PrefixCon ps              -> any hasViewPat ps
+    RecCon (HsRecFields fs _) -> any (hasViewPat . hsRecFieldArg) fs
+    InfixCon p1 p2            -> hasViewPat p1 || hasViewPat p2
+
 isWildPat :: Pat id -> Bool
 isWildPat (WildPat _) = True
 isWildPat _           = False
@@ -408,12 +445,12 @@ isIrrefutableHsPat :: OutputableBndr id => LPat id -> Bool
 isIrrefutableHsPat pat
   = go pat
   where
-    go (L _ pat)	 = go1 pat
+    go (L _ pat) = go1 pat
 
-    go1 (WildPat _)         = True
-    go1 (VarPat _)          = True
-    go1 (VarPatOut _ _)     = True
-    go1 (LazyPat _)         = True
+    go1 (WildPat {})        = True
+    go1 (VarPat {})         = True
+    go1 (VarPatOut {})      = True
+    go1 (LazyPat {})        = True
     go1 (BangPat pat)       = go pat
     go1 (CoPat _ pat _)     = go1 pat
     go1 (ParPat pat)        = go pat
@@ -422,22 +459,50 @@ isIrrefutableHsPat pat
     go1 (SigPatIn pat _)    = go pat
     go1 (SigPatOut pat _)   = go pat
     go1 (TuplePat pats _ _) = all go pats
-    go1 (ListPat _ _)       = False
-    go1 (PArrPat _ _)       = False	-- ?
+    go1 (ListPat {})        = False
+    go1 (PArrPat {})        = False	-- ?
 
-    go1 (ConPatIn _ _) = False	-- Conservative
+    go1 (ConPatIn {})       = False	-- Conservative
     go1 (ConPatOut{ pat_con = L _ con, pat_args = details }) 
 	=  isProductTyCon (dataConTyCon con)
 	&& all go (hsConPatArgs details)
 
-    go1 (LitPat _) 	   = False
-    go1 (NPat _ _ _)	   = False
-    go1 (NPlusKPat _ _ _ _) = False
+    go1 (LitPat {})    = False
+    go1 (NPat {})      = False
+    go1 (NPlusKPat {}) = False
 
     go1 (QuasiQuotePat {}) = urk pat	-- Gotten rid of by renamer, before
 					-- isIrrefutablePat is called
     go1 (TypePat {})       = urk pat
 
     urk pat = pprPanic "isIrrefutableHsPat:" (ppr pat)
+
+hsPatNeedsParens :: Pat a -> Bool
+hsPatNeedsParens (WildPat {})        = False
+hsPatNeedsParens (VarPat {})         = False
+hsPatNeedsParens (VarPatOut {})      = True
+hsPatNeedsParens (LazyPat {})        = False
+hsPatNeedsParens (BangPat {})        = False
+hsPatNeedsParens (CoPat {})          = True
+hsPatNeedsParens (ParPat {})         = False
+hsPatNeedsParens (AsPat {})          = False
+hsPatNeedsParens (ViewPat {})        = True
+hsPatNeedsParens (SigPatIn {})       = True
+hsPatNeedsParens (SigPatOut {})      = True
+hsPatNeedsParens (TuplePat {})       = False
+hsPatNeedsParens (ListPat {})        = False
+hsPatNeedsParens (PArrPat {})        = False	
+hsPatNeedsParens (ConPatIn _ ds)     = conPatNeedsParens ds
+hsPatNeedsParens (ConPatOut {})      = True
+hsPatNeedsParens (LitPat {})   	     = False
+hsPatNeedsParens (NPat {})	     = False
+hsPatNeedsParens (NPlusKPat {})      = True
+hsPatNeedsParens (QuasiQuotePat {})  = True
+hsPatNeedsParens (TypePat {})        = False
+
+conPatNeedsParens :: HsConDetails a b -> Bool
+conPatNeedsParens (PrefixCon args) = not (null args)
+conPatNeedsParens (InfixCon {})    = False
+conPatNeedsParens (RecCon {})      = False
 \end{code}