X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FhsSyn%2FHsPat.lhs;h=af921de689221cfa825a35f55b3946a744ca204f;hb=fb6d198f498d4e325a540f28aaa6e1d1530839c3;hp=266cff2aa02f6c29307fd7d9ff864792491b3869;hpb=f3399c446c7507d46d6cc550aa2fe7027dbc1b5b;p=ghc-hetmet.git

diff --git a/compiler/hsSyn/HsPat.lhs b/compiler/hsSyn/HsPat.lhs
index 266cff2..af921de 100644
--- a/compiler/hsSyn/HsPat.lhs
+++ b/compiler/hsSyn/HsPat.lhs
@@ -5,7 +5,7 @@
 \section[PatSyntax]{Abstract Haskell syntax---patterns}
 
 \begin{code}
-{-# OPTIONS -w #-}
+{-# OPTIONS -fno-warn-incomplete-patterns #-}
 -- The above warning supression flag is a temporary kludge.
 -- While working on this module you are encouraged to remove it and fix
 -- any warnings in the module. See
@@ -23,20 +23,17 @@ module HsPat (
 
 	mkPrefixConPat, mkCharLitPat, mkNilPat, mkCoPat, mkCoPatCoI,
 
-	isBangHsBind,	
+	isBangHsBind, hsPatNeedsParens,
 	patsAreAllCons, isConPat, isSigPat, isWildPat,
 	patsAreAllLits,	isLitPat, isIrrefutableHsPat
     ) where
 
-#include "HsVersions.h"
-
 import {-# SOURCE #-} HsExpr		(SyntaxExpr, LHsExpr, pprLExpr)
 
 -- friends:
 import HsBinds
 import HsLit
 import HsTypes
-import HsDoc
 import BasicTypes
 -- others:
 import Coercion
@@ -178,15 +175,23 @@ 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
-	-- Just n  => the group uses ".." notation, 
-	--		and the first n elts of rec_flds
-	--		were the user-written ones
-	-- (In the latter case, the remaining elts of
-	--  rec_flds are the non-user-written ones)
+		  rec_dotdot :: Maybe Int }  -- Note [DotDot fields]
+
+-- Note [DotDot fields]
+-- ~~~~~~~~~~~~~~~~~~~~
+-- The rec_dotdot field means this:
+--   Nothing => the normal case
+--   Just n  => the group uses ".." notation, 
+--
+-- In the latter case: 
+--
+--   *before* renamer: rec_flds are exactly the n user-written fields
+--
+--   *after* renamer:  rec_flds includes *all* fields, with 
+--   	     	       the first 'n' being the user-written ones
+--		       and the remainder being 'filled in' implicitly
 
 data HsRecField id arg = HsRecField {
 	hsRecFieldId  :: Located id,
@@ -199,9 +204,12 @@ data HsRecField id arg = HsRecField {
 -- If you write T { x, y = v+1 }, the HsRecFields will be
 --	HsRecField x x True ...
 --	HsRecField y (v+1) False ...
--- That is, for "punned" field x is immediately expanded to x=x
--- but with a punning flag so we can detect it later
+-- That is, for "punned" field x is expanded (in the renamer) 
+-- to x=x; but with a punning flag so we can detect it later
 -- (e.g. when pretty printing)
+--
+-- If the original field was qualified, we un-qualify it, thus
+--    T { A.x } means T { A.x = x }
 
 hsRecFields :: HsRecFields id arg -> [id]
 hsRecFields rbinds = map (unLoc . hsRecFieldId) (rec_flds rbinds)
@@ -213,6 +221,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}
 
 
@@ -242,8 +259,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)
@@ -264,16 +281,18 @@ 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("|}")
+      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
 
+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 (RecCon rpats)   = ppr rpats
@@ -285,18 +304,18 @@ instance (OutputableBndr id, Outputable arg)
   ppr (HsRecFields { rec_flds = flds, rec_dotdot = Just n })
 	= braces (fsep (punctuate comma (map ppr (take n flds) ++ [dotdot])))
 	where
-	  dotdot = ptext SLIT("..") <+> ifPprDebug (ppr (drop n flds))
+	  dotdot = ptext (sLit "..") <+> ifPprDebug (ppr (drop n flds))
 
 instance (OutputableBndr id, Outputable arg)
       => Outputable (HsRecField id arg) where
   ppr (HsRecField { hsRecFieldId = f, hsRecFieldArg = arg, 
 		    hsRecPun = pun })
-    = ppr f <+> (if pun then empty else equals <+> ppr arg)
+    = ppr f <+> (ppUnless pun $ equals <+> ppr arg)
 
 -- add parallel array brackets around a document
 --
 pabrackets   :: SDoc -> SDoc
-pabrackets p  = ptext SLIT("[:") <> p <> ptext SLIT(":]")
+pabrackets p  = ptext (sLit "[:") <> p <> ptext (sLit ":]")
 \end{code}
 
 
@@ -326,8 +345,8 @@ mkCoPat co pat ty
   | otherwise        = CoPat co pat ty
 
 mkCoPatCoI :: CoercionI -> Pat id -> Type -> Pat id
-mkCoPatCoI IdCo     pat ty = pat
-mkCoPatCoI (ACo co) pat ty = mkCoPat (WpCo co) pat ty
+mkCoPatCoI IdCo     pat _  = pat
+mkCoPatCoI (ACo co) pat ty = mkCoPat (WpCast co) pat ty
 \end{code}
 
 
@@ -361,39 +380,43 @@ patterns are treated specially, of course.
 
 The 1.3 report defines what ``irrefutable'' and ``failure-free'' patterns are.
 \begin{code}
+isWildPat :: Pat id -> Bool
 isWildPat (WildPat _) = True
-isWildPat other	      = False
+isWildPat _           = False
 
 patsAreAllCons :: [Pat id] -> Bool
 patsAreAllCons pat_list = all isConPat pat_list
 
+isConPat :: Pat id -> Bool
 isConPat (AsPat _ pat)	 = isConPat (unLoc pat)
 isConPat (ConPatIn {})	 = True
 isConPat (ConPatOut {})  = True
 isConPat (ListPat {})	 = True
 isConPat (PArrPat {})	 = True
 isConPat (TuplePat {})	 = True
-isConPat other		 = False
+isConPat _               = False
 
+isSigPat :: Pat id -> Bool
 isSigPat (SigPatIn _ _)  = True
 isSigPat (SigPatOut _ _) = True
-isSigPat other		 = False
+isSigPat _               = False
 
 patsAreAllLits :: [Pat id] -> Bool
 patsAreAllLits pat_list = all isLitPat pat_list
 
+isLitPat :: Pat id -> Bool
 isLitPat (AsPat _ pat)	        = isLitPat (unLoc pat)
 isLitPat (LitPat _)	        = True
 isLitPat (NPat _ _ _)	        = True
 isLitPat (NPlusKPat _ _ _ _)    = True
-isLitPat other		        = False
+isLitPat _                      = False
 
 isBangHsBind :: HsBind id -> Bool
 -- In this module because HsPat is above HsBinds in the import graph
-isBangHsBind (PatBind { pat_lhs = L _ (BangPat p) }) = True
-isBangHsBind bind				     = False
+isBangHsBind (PatBind { pat_lhs = L _ (BangPat _) }) = True
+isBangHsBind _                                       = False
 
-isIrrefutableHsPat :: LPat id -> Bool
+isIrrefutableHsPat :: OutputableBndr id => LPat id -> Bool
 -- (isIrrefutableHsPat p) is true if matching against p cannot fail,
 -- in the sense of falling through to the next pattern.
 --	(NB: this is not quite the same as the (silly) defn
@@ -405,12 +428,12 @@ isIrrefutableHsPat :: 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 pat)       = 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
@@ -419,18 +442,50 @@ isIrrefutableHsPat pat
     go1 (SigPatIn pat _)    = go pat
     go1 (SigPatOut pat _)   = go pat
     go1 (TuplePat pats _ _) = all go pats
-    go1 (ListPat pats _)    = False
-    go1 (PArrPat pats _)    = 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 (TypePat _)   = panic "isIrrefutableHsPat: type pattern"
+    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}