X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FhsSyn%2FHsPat.lhs;h=953d228942a0c85da06b8035a72c430609819740;hb=5d3051c66796dcf884b052f9e4afc3ed19b9f514;hp=4d64a466a549c3b3b753a073bc1d828246dbf317;hpb=d551dbfef0b710f5ede21ee0c54ee7e80dd53b64;p=ghc-hetmet.git

diff --git a/ghc/compiler/hsSyn/HsPat.lhs b/ghc/compiler/hsSyn/HsPat.lhs
index 4d64a46..953d228 100644
--- a/ghc/compiler/hsSyn/HsPat.lhs
+++ b/ghc/compiler/hsSyn/HsPat.lhs
@@ -11,8 +11,8 @@ module HsPat (
 
 	mkPrefixConPat, mkCharLitPat, mkNilPat, 
 
-	isWildPat, 
-	patsAreAllCons, isConPat, isSigPat,
+	isBangHsBind,	
+	patsAreAllCons, isConPat, isSigPat, isWildPat,
 	patsAreAllLits,	isLitPat, isIrrefutableHsPat
     ) where
 
@@ -22,7 +22,7 @@ module HsPat (
 import {-# SOURCE #-} HsExpr		( SyntaxExpr )
 
 -- friends:
-import HsBinds		( DictBinds, emptyLHsBinds, pprLHsBinds )
+import HsBinds		( DictBinds, HsBind(..), emptyLHsBinds, pprLHsBinds )
 import HsLit		( HsLit(HsCharPrim), HsOverLit )
 import HsTypes		( LHsType, PostTcType )
 import BasicTypes	( Boxity, tupleParens )
@@ -53,6 +53,7 @@ data Pat id
   | LazyPat	(LPat id)		-- Lazy pattern
   | AsPat	(Located id) (LPat id)  -- As pattern
   | ParPat      (LPat id)		-- Parenthesised pattern
+  | BangPat	(LPat id)		-- Bang patterng
 
 	------------ Lists, tuples, arrays ---------------
   | ListPat	[LPat id]		-- Syntactic list
@@ -60,6 +61,18 @@ data Pat id
    	    	    
   | TuplePat	[LPat id]		-- Tuple
 		Boxity			-- UnitPat is TuplePat []
+		PostTcType
+	-- You might think that the PostTcType was redundant, but it's essential
+	--	data T a where
+	--	  T1 :: Int -> T Int
+	--	f :: (T a, a) -> Int
+	--	f (T1 x, z) = z
+	-- When desugaring, we must generate
+	--	f = /\a. \v::a.  case v of (t::T a, w::a) ->
+	--			 case t of (T1 (x::Int)) -> 
+	-- Note the (w::a), NOT (w::Int), because we have not yet
+	-- refined 'a' to Int.  So we must know that the second component
+	-- of the tuple is of type 'a' not Int.  See selectMatchVar
 
   | PArrPat	[LPat id]		-- Syntactic parallel array
 		PostTcType		-- The type of the elements
@@ -79,7 +92,7 @@ data Pat id
   | LitPat	    HsLit		-- Used for *non-overloaded* literal patterns:
 					-- Int#, Char#, Int, Char, String, etc.
 
-  | NPat	    (HsOverLit id)		-- *Always* positive
+  | NPat	    (HsOverLit id)		-- ALWAYS positive
 		    (Maybe (SyntaxExpr id))	-- Just (Name of 'negate') for negative
 						-- patterns, Nothing otherwise
 		    (SyntaxExpr id)		-- Equality checker, of type t->t->Bool
@@ -144,17 +157,16 @@ pprPatBndr var		  	-- Print with type info if -dppr-debug is on
 	ppr var
 
 pprPat :: (OutputableBndr name) => Pat name -> SDoc
-
 pprPat (VarPat var)  	  = pprPatBndr var
 pprPat (VarPatOut var bs) = parens (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 (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)
+pprPat (ListPat pats _)     = brackets (interpp'SP pats)
+pprPat (PArrPat pats _)     = pabrackets (interpp'SP pats)
+pprPat (TuplePat pats bx _) = tupleParens bx (interpp'SP pats)
 
 pprPat (ConPatIn con details) = pprUserCon con details
 pprPat (ConPatOut con tvs dicts binds details _) 
@@ -166,7 +178,8 @@ pprPat (ConPatOut con tvs dicts binds details _)
     else pprUserCon con details
 
 pprPat (LitPat s)	      = ppr s
-pprPat (NPat l _ _ _)	      = ppr l
+pprPat (NPat l Nothing  _ _)  = ppr l
+pprPat (NPat l (Just _) _ _)  = char '-' <> ppr l
 pprPat (NPlusKPat n k _ _)    = hcat [ppr n, char '+', ppr k]
 pprPat (TypePat ty)	      = ptext SLIT("{|") <> ppr ty <> ptext SLIT("|}")
 pprPat (SigPatIn pat ty)      = ppr pat <+> dcolon <+> ppr ty
@@ -252,7 +265,7 @@ isConPat (ConPatIn _ _)		 = True
 isConPat (ConPatOut _ _ _ _ _ _) = True
 isConPat (ListPat _ _)		 = True
 isConPat (PArrPat _ _)		 = True
-isConPat (TuplePat _ _)		 = True
+isConPat (TuplePat _ _ _)	 = True
 isConPat (DictPat ds ms)	 = (length ds + length ms) > 1
 isConPat other			 = False
 
@@ -269,26 +282,32 @@ isLitPat (NPat _ _ _ _)	        = True
 isLitPat (NPlusKPat _ _ _ _)    = True
 isLitPat other		        = 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
+
 isIrrefutableHsPat :: LPat id -> Bool
 -- This function returns False if it's in doubt; specifically
--- on a ConPatIn it doesn't know th size of the constructor family
+-- on a ConPatIn it doesn't know the size of the constructor family
 -- But if it returns True, the pattern is definitely irrefutable
 isIrrefutableHsPat pat
   = go pat
   where
     go (L _ pat)	 = go1 pat
 
-    go1 (WildPat _)       = True
-    go1 (VarPat _)        = True
-    go1 (VarPatOut _ _)   = True
-    go1 (LazyPat _)       = True
-    go1 (ParPat pat)      = go pat
-    go1 (AsPat _ pat)     = go pat
-    go1 (SigPatIn pat _)  = go pat
-    go1 (SigPatOut pat _) = go pat
-    go1 (ListPat pats _)  = all go pats
-    go1 (TuplePat pats _) = all go pats
-    go1 (PArrPat pats _)  = all go pats
+    go1 (WildPat _)         = True
+    go1 (VarPat _)          = True
+    go1 (VarPatOut _ _)     = True
+    go1 (LazyPat pat)       = True
+    go1 (BangPat pat)       = go pat
+    go1 (ParPat pat)        = go pat
+    go1 (AsPat _ pat)       = go 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 (ConPatIn _ _) = False	-- Conservative
     go1 (ConPatOut (L _ con) _ _ _ details _)