X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FdeSugar%2FMatch.lhs;h=c7d0b5d860b9207592ae7160b73be87ffcf92755;hb=7d61cb61daa5e433a0cb85b34b7f0c58b2f961ff;hp=f657e967a3938b55d329ce1a36e6207e9ee604a8;hpb=6c381e873e222417d9a67aeec77b9555eca7b7a8;p=ghc-hetmet.git

diff --git a/ghc/compiler/deSugar/Match.lhs b/ghc/compiler/deSugar/Match.lhs
index f657e96..c7d0b5d 100644
--- a/ghc/compiler/deSugar/Match.lhs
+++ b/ghc/compiler/deSugar/Match.lhs
@@ -25,9 +25,13 @@ import MatchCon		( matchConFamily )
 import MatchLit		( matchLiterals )
 
 import CoreUtils	( escErrorMsg, mkErrorApp )
-import Id		( idType, mkTupleCon, GenId{-instance-} )
+import FieldLabel	( allFieldLabelTags, fieldLabelTag )
+import Id		( idType, mkTupleCon, dataConSig,
+			  recordSelectorFieldLabel,
+			  GenId{-instance-}
+			)
 import PprStyle		( PprStyle(..) )
-import PprType		( GenTyVar{-instance-}, GenType{-instance-} )
+import PprType		( GenType{-instance-}, GenTyVar{-ditto-} )
 import PrelInfo		( nilDataCon, consDataCon, mkTupleTy, mkListTy,
 			  charTy, charDataCon, intTy, intDataCon,
 			  floatTy, floatDataCon, doubleTy, doubleDataCon,
@@ -35,10 +39,12 @@ import PrelInfo		( nilDataCon, consDataCon, mkTupleTy, mkListTy,
 			  floatPrimTy, doublePrimTy, stringTy,
 			  addrTy, addrPrimTy, addrDataCon,
 			  wordTy, wordPrimTy, wordDataCon )
-import Type		( isPrimType, eqTy )
-import TyVar		( GenTyVar )
-import Unique		( Unique )
-import Util		( panic, pprPanic )
+import Type		( isPrimType, eqTy, getAppDataTyCon,
+			  instantiateTauTy
+			)
+import TyVar		( GenTyVar{-instance Eq-} )
+import Unique		( Unique{-instance Eq-} )
+import Util		( panic, pprPanic, assertPanic )
 \end{code}
 
 The function @match@ is basically the same as in the Wadler chapter,
@@ -320,6 +326,27 @@ tidy1 v (LazyPat pat) match_result
 tidy1 v (ConOpPat pat1 id pat2 ty) match_result
   = returnDs (ConPat id ty [pat1, pat2], match_result)
 
+tidy1 v (RecPat con_id pat_ty rpats) match_result
+  = returnDs (ConPat con_id pat_ty pats, match_result)
+  where
+    pats 		    = map mk_pat tagged_arg_tys
+
+	-- Boring stuff to find the arg-tys of the constructor
+    (tyvars, _, arg_tys, _) = dataConSig con_id
+    (_, inst_tys, _) 	    = getAppDataTyCon pat_ty
+    tenv 		    = tyvars `zip` inst_tys
+    con_arg_tys'	    = map (instantiateTauTy tenv) arg_tys
+    tagged_arg_tys	    = con_arg_tys' `zip` allFieldLabelTags
+
+	-- mk_pat picks a WildPat of the appropriate type for absent fields,
+	-- and the specified pattern for present fields
+    mk_pat (arg_ty, tag) = case [pat | (sel_id,pat,_) <- rpats,
+					fieldLabelTag (recordSelectorFieldLabel sel_id) == tag 
+				] of
+				(pat:pats) -> ASSERT( null pats )
+					      pat
+				[]	   -> WildPat arg_ty
+
 tidy1 v (ListPat ty pats) match_result
   = returnDs (list_ConPat, match_result)
   where