X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FhsSyn%2FHsPat.lhs;h=79b906207b54629de873bd8e107bb02318af71d8;hp=953d228942a0c85da06b8035a72c430609819740;hb=9da4639011348fb6c318e3cba4b08622f811d9c4;hpb=0065d5ab628975892cea1ec7303f968c3338cbe1

diff --git a/compiler/hsSyn/HsPat.lhs b/compiler/hsSyn/HsPat.lhs
index 953d228..79b9062 100644
--- a/compiler/hsSyn/HsPat.lhs
+++ b/compiler/hsSyn/HsPat.lhs
@@ -5,11 +5,11 @@
 
 \begin{code}
 module HsPat (
-	Pat(..), InPat, OutPat, LPat,
+	Pat(..), InPat, OutPat, LPat, 
 	
 	HsConDetails(..), hsConArgs,
 
-	mkPrefixConPat, mkCharLitPat, mkNilPat, 
+	mkPrefixConPat, mkCharLitPat, mkNilPat, mkCoPat,
 
 	isBangHsBind,	
 	patsAreAllCons, isConPat, isSigPat, isWildPat,
@@ -22,7 +22,8 @@ module HsPat (
 import {-# SOURCE #-} HsExpr		( SyntaxExpr )
 
 -- friends:
-import HsBinds		( DictBinds, HsBind(..), emptyLHsBinds, pprLHsBinds )
+import HsBinds		( DictBinds, HsBind(..), HsWrapper, isIdHsWrapper, pprHsWrapper,
+			  emptyLHsBinds, pprLHsBinds )
 import HsLit		( HsLit(HsCharPrim), HsOverLit )
 import HsTypes		( LHsType, PostTcType )
 import BasicTypes	( Boxity, tupleParens )
@@ -81,12 +82,15 @@ data Pat id
   | ConPatIn	(Located id)
 		(HsConDetails id (LPat id))
 
-  | ConPatOut	(Located DataCon)
-		[TyVar]			-- Existentially bound type variables
-		[id]			-- Ditto dictionaries
-		(DictBinds id)		-- Bindings involving those dictionaries
-		(HsConDetails id (LPat id))
-		Type    		-- The type of the pattern
+  | ConPatOut {
+	pat_con   :: Located DataCon,
+	pat_tvs   :: [TyVar],		-- Existentially bound type variables
+					--   including any bound coercion variables
+	pat_dicts :: [id],		-- Ditto dictionaries
+	pat_binds :: DictBinds id,	-- Bindings involving those dictionaries
+	pat_args  :: HsConDetails id (LPat id),
+	pat_ty	  :: Type   		-- The type of the pattern
+    }
 
 	------------ Literal and n+k patterns ---------------
   | LitPat	    HsLit		-- Used for *non-overloaded* literal patterns:
@@ -118,8 +122,16 @@ data Pat id
 
 	------------ Dictionary patterns (translation only) ---------------
   | DictPat	    -- Used when destructing Dictionaries with an explicit case
-		    [id]			-- superclass dicts
-		    [id]			-- methods
+		    [id]		-- Superclass dicts
+		    [id]		-- Methods
+
+	------------ Pattern coercions (translation only) ---------------
+  | CoPat 	HsWrapper		-- If co::t1 -> t2, p::t2, 
+					-- then (CoPat co p) :: t1
+		(Pat id)		-- Why not LPat?  Ans: existing locn will do
+	    	Type
+	-- During desugaring a (CoPat co pat) turns into a cast with 'co' on 
+	-- the scrutinee, followed by a match on 'pat'
 \end{code}
 
 HsConDetails is use both for patterns and for data type declarations
@@ -169,7 +181,8 @@ 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 _) 
+pprPat (ConPatOut { pat_con = con, pat_tvs = tvs, pat_dicts = dicts, 
+		    pat_binds = binds, pat_args = details })
   = getPprStyle $ \ sty ->	-- Tiresome; in TcBinds.tcRhs we print out a 
     if debugStyle sty then 	-- typechecked Pat in an error message, 
 				-- and we want to make sure it prints nicely
@@ -182,6 +195,7 @@ 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)
 pprPat (SigPatIn pat ty)      = ppr pat <+> dcolon <+> ppr ty
 pprPat (SigPatOut pat ty)     = ppr pat <+> dcolon <+> ppr ty
 pprPat (DictPat ds ms)	      = parens (sep [ptext SLIT("{-dict-}"),
@@ -214,13 +228,21 @@ pabrackets p  = ptext SLIT("[:") <> p <> ptext SLIT(":]")
 \begin{code}
 mkPrefixConPat :: DataCon -> [OutPat id] -> Type -> OutPat id
 -- Make a vanilla Prefix constructor pattern
-mkPrefixConPat dc pats ty = noLoc $ ConPatOut (noLoc dc) [] [] emptyLHsBinds (PrefixCon pats) ty
+mkPrefixConPat dc pats ty 
+  = noLoc $ ConPatOut { pat_con = noLoc dc, pat_tvs = [], pat_dicts = [],
+			pat_binds = emptyLHsBinds, pat_args = PrefixCon pats, 
+			pat_ty = ty }
 
 mkNilPat :: Type -> OutPat id
 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)
 \end{code}
 
 
@@ -260,14 +282,14 @@ isWildPat other	      = False
 patsAreAllCons :: [Pat id] -> Bool
 patsAreAllCons pat_list = all isConPat pat_list
 
-isConPat (AsPat _ pat)		 = isConPat (unLoc pat)
-isConPat (ConPatIn _ _)		 = True
-isConPat (ConPatOut _ _ _ _ _ _) = True
-isConPat (ListPat _ _)		 = True
-isConPat (PArrPat _ _)		 = True
-isConPat (TuplePat _ _ _)	 = True
-isConPat (DictPat ds ms)	 = (length ds + length ms) > 1
-isConPat other			 = False
+isConPat (AsPat _ pat)	 = isConPat (unLoc pat)
+isConPat (ConPatIn {})	 = True
+isConPat (ConPatOut {})  = True
+isConPat (ListPat {})	 = True
+isConPat (PArrPat {})	 = True
+isConPat (TuplePat {})	 = True
+isConPat (DictPat ds ms) = (length ds + length ms) > 1
+isConPat other		 = False
 
 isSigPat (SigPatIn _ _)  = True
 isSigPat (SigPatOut _ _) = True
@@ -301,6 +323,7 @@ isIrrefutableHsPat pat
     go1 (VarPatOut _ _)     = True
     go1 (LazyPat pat)       = True
     go1 (BangPat pat)       = go pat
+    go1 (CoPat _ pat _)     = go1 pat
     go1 (ParPat pat)        = go pat
     go1 (AsPat _ pat)       = go pat
     go1 (SigPatIn pat _)    = go pat
@@ -310,7 +333,7 @@ isIrrefutableHsPat pat
     go1 (PArrPat pats _)    = False	-- ?
 
     go1 (ConPatIn _ _) = False	-- Conservative
-    go1 (ConPatOut (L _ con) _ _ _ details _) 
+    go1 (ConPatOut{ pat_con = L _ con, pat_args = details }) 
 	=  isProductTyCon (dataConTyCon con)
 	&& all go (hsConArgs details)