X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FhsSyn%2FHsPat.lhs;h=a524ab8732a6f0c0e0f10e80521e2d903f63c69c;hp=d4b0e1b37d8ce5d343a4c29adc4e52f2f3a33aa5;hb=6a05ec5ef5373f61b7f9f5bdc344483417fa801b;hpb=7fc749a43b4b6b85d234fa95d4928648259584f4

diff --git a/compiler/hsSyn/HsPat.lhs b/compiler/hsSyn/HsPat.lhs
index d4b0e1b..a524ab8 100644
--- a/compiler/hsSyn/HsPat.lhs
+++ b/compiler/hsSyn/HsPat.lhs
@@ -19,7 +19,7 @@ module HsPat (
 	HsConPatDetails, hsConPatArgs, 
 	HsRecFields(..), HsRecField(..), hsRecFields,
 
-	mkPrefixConPat, mkCharLitPat, mkNilPat, mkCoPat,
+	mkPrefixConPat, mkCharLitPat, mkNilPat, mkCoPat, mkCoPatCoI,
 
 	isBangHsBind,	
 	patsAreAllCons, isConPat, isSigPat, isWildPat,
@@ -28,15 +28,16 @@ module HsPat (
 
 #include "HsVersions.h"
 
-
-import {-# SOURCE #-} HsExpr		( SyntaxExpr )
+import {-# SOURCE #-} HsExpr		(SyntaxExpr, LHsExpr, pprLExpr)
 
 -- friends:
 import HsBinds
 import HsLit
 import HsTypes
+import HsDoc
 import BasicTypes
 -- others:
+import Coercion
 import PprCore		( {- instance OutputableBndr TyVar -} )
 import TysWiredIn
 import Var
@@ -66,7 +67,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
+  | BangPat	(LPat id)		-- Bang pattern
 
 	------------ Lists, tuples, arrays ---------------
   | ListPat	[LPat id]		-- Syntactic list
@@ -104,6 +105,13 @@ data Pat id
 	pat_ty	  :: Type   		-- The type of the pattern
     }
 
+	------------ View patterns ---------------
+  | ViewPat       (LHsExpr id)      
+                  (LPat id)
+                  PostTcType        -- The overall type of the pattern
+                                    -- (= the argument type of the view function)
+                                    -- for hsPatType.
+
 	------------ Literal and n+k patterns ---------------
   | LitPat	    HsLit		-- Used for *non-overloaded* literal patterns:
 					-- Int#, Char#, Int, Char, String, etc.
@@ -112,7 +120,6 @@ data Pat id
 		    (Maybe (SyntaxExpr id))	-- Just (Name of 'negate') for negative
 						-- patterns, Nothing otherwise
 		    (SyntaxExpr id)		-- Equality checker, of type t->t->Bool
-		    PostTcType			-- Type of the pattern
 
   | NPlusKPat	    (Located id)	-- n+k pattern
 		    (HsOverLit id)	-- It'll always be an HsIntegral
@@ -219,6 +226,7 @@ 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 (ListPat pats _)     = brackets (interpp'SP pats)
 pprPat (PArrPat pats _)     = pabrackets (interpp'SP pats)
@@ -235,8 +243,8 @@ pprPat (ConPatOut { pat_con = con, pat_tvs = tvs, pat_dicts = dicts,
     else pprUserCon con details
 
 pprPat (LitPat s)	      = ppr s
-pprPat (NPat l Nothing  _ _)  = ppr l
-pprPat (NPat l (Just _) _ _)  = char '-' <> 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 (CoPat co pat _)	      = parens (pprHsWrapper (ppr pat) co)
@@ -292,10 +300,14 @@ mkNilPat ty = mkPrefixConPat nilDataCon [] ty
 mkCharLitPat :: Char -> OutPat id
 mkCharLitPat c = mkPrefixConPat charDataCon [noLoc $ LitPat (HsCharPrim c)] charTy
 
-mkCoPat :: HsWrapper -> OutPat id -> Type -> OutPat id
-mkCoPat co lpat@(L loc pat) ty
-  | isIdHsWrapper co = lpat
-  | otherwise = L loc (CoPat co pat ty)
+mkCoPat :: HsWrapper -> Pat id -> Type -> Pat id
+mkCoPat co pat ty
+  | isIdHsWrapper co = pat
+  | 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
 \end{code}
 
 
@@ -352,7 +364,7 @@ patsAreAllLits pat_list = all isLitPat pat_list
 
 isLitPat (AsPat _ pat)	        = isLitPat (unLoc pat)
 isLitPat (LitPat _)	        = True
-isLitPat (NPat _ _ _ _)	        = True
+isLitPat (NPat _ _ _)	        = True
 isLitPat (NPlusKPat _ _ _ _)    = True
 isLitPat other		        = False
 
@@ -362,7 +374,12 @@ 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
+-- (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
+--	in 3.17.2 of the Haskell 98 report.)
+-- 
+-- isIrrefutableHsPat returns False if it's in doubt; specifically
 -- 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
@@ -378,6 +395,7 @@ isIrrefutableHsPat pat
     go1 (CoPat _ pat _)     = go1 pat
     go1 (ParPat pat)        = go pat
     go1 (AsPat _ pat)       = go pat
+    go1 (ViewPat _ pat _)   = go pat
     go1 (SigPatIn pat _)    = go pat
     go1 (SigPatOut pat _)   = go pat
     go1 (TuplePat pats _ _) = all go pats
@@ -390,7 +408,7 @@ isIrrefutableHsPat pat
 	&& all go (hsConPatArgs details)
 
     go1 (LitPat _) 	   = False
-    go1 (NPat _ _ _ _)	   = False
+    go1 (NPat _ _ _)	   = False
     go1 (NPlusKPat _ _ _ _) = False
 
     go1 (TypePat _)   = panic "isIrrefutableHsPat: type pattern"