X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FdeSugar%2FMatch.lhs;h=bbc37b33b8012cdea7f06cc32e463c95f68e1569;hb=5d3051c66796dcf884b052f9e4afc3ed19b9f514;hp=fe5b95b94adfac099e37bdc1670e586ab5129bea;hpb=da5cbb6395529a8605ad317c4ca605ec02d35128;p=ghc-hetmet.git

diff --git a/ghc/compiler/deSugar/Match.lhs b/ghc/compiler/deSugar/Match.lhs
index fe5b95b..bbc37b3 100644
--- a/ghc/compiler/deSugar/Match.lhs
+++ b/ghc/compiler/deSugar/Match.lhs
@@ -10,12 +10,12 @@ module Match ( match, matchWrapper, matchSimply, matchSinglePat ) where
 
 import DynFlags	( DynFlag(..), dopt )
 import HsSyn		
-import TcHsSyn		( hsPatType )
+import TcHsSyn		( mkVanillaTuplePat )
 import Check            ( check, ExhaustivePat )
 import CoreSyn
 import CoreUtils	( bindNonRec, exprType )
 import DsMonad
-import DsBinds		( dsHsNestedBinds )
+import DsBinds		( dsLHsBinds )
 import DsGRHSs		( dsGRHSs )
 import DsUtils
 import Id		( idName, idType, Id )
@@ -24,12 +24,12 @@ import MatchCon		( matchConFamily )
 import MatchLit		( matchLiterals, matchNPlusKPats, matchNPats, tidyLitPat, tidyNPat )
 import PrelInfo		( pAT_ERROR_ID )
 import TcType		( Type, tcTyConAppArgs )
-import Type		( splitFunTysN )
-import TysWiredIn	( consDataCon, mkTupleTy, mkListTy,
+import Type		( splitFunTysN, mkTyVarTys )
+import TysWiredIn	( consDataCon, mkListTy, unitTy,
 			  tupleCon, parrFakeCon, mkPArrTy )
 import BasicTypes	( Boxity(..) )
 import ListSetOps	( runs )
-import SrcLoc		( noSrcSpan, noLoc, unLoc, Located(..) )
+import SrcLoc		( noLoc, unLoc, Located(..) )
 import Util             ( lengthExceeds, notNull )
 import Name		( Name )
 import Outputable
@@ -90,19 +90,21 @@ The next two functions create the warning message.
 
 \begin{code}
 dsShadowWarn :: DsMatchContext -> [EquationInfo] -> DsM ()
-dsShadowWarn ctx@(DsMatchContext kind _ _) qs = dsWarn warn 
-	where
-	  warn | qs `lengthExceeds` maximum_output
-               = pp_context ctx (ptext SLIT("are overlapped"))
-		            (\ f -> vcat (map (ppr_eqn f kind) (take maximum_output qs)) $$
-			    ptext SLIT("..."))
-	       | otherwise
-               = pp_context ctx (ptext SLIT("are overlapped"))
-	                    (\ f -> vcat $ map (ppr_eqn f kind) qs)
+dsShadowWarn ctx@(DsMatchContext kind _ loc) qs
+  = putSrcSpanDs loc (dsWarn warn)
+  where
+    warn | qs `lengthExceeds` maximum_output
+         = pp_context ctx (ptext SLIT("are overlapped"))
+		      (\ f -> vcat (map (ppr_eqn f kind) (take maximum_output qs)) $$
+		      ptext SLIT("..."))
+	 | otherwise
+         = pp_context ctx (ptext SLIT("are overlapped"))
+	              (\ f -> vcat $ map (ppr_eqn f kind) qs)
 
 
 dsIncompleteWarn :: DsMatchContext -> [ExhaustivePat] -> DsM ()
-dsIncompleteWarn ctx@(DsMatchContext kind _ _) pats = dsWarn warn 
+dsIncompleteWarn ctx@(DsMatchContext kind _ loc) pats 
+  = putSrcSpanDs loc (dsWarn warn)
 	where
 	  warn = pp_context ctx (ptext SLIT("are non-exhaustive"))
                     	    (\f -> hang (ptext SLIT("Patterns not matched:"))
@@ -113,9 +115,9 @@ dsIncompleteWarn ctx@(DsMatchContext kind _ _) pats = dsWarn warn
 	  dots | pats `lengthExceeds` maximum_output = ptext SLIT("...")
 	       | otherwise                           = empty
 
-pp_context (DsMatchContext kind pats loc) msg rest_of_msg_fun
-  = (loc, vcat [ptext SLIT("Pattern match(es)") <+> msg,
-	        sep [ptext SLIT("In") <+> ppr_match <> char ':', nest 4 (rest_of_msg_fun pref)]])
+pp_context (DsMatchContext kind pats _loc) msg rest_of_msg_fun
+  = vcat [ptext SLIT("Pattern match(es)") <+> msg,
+	  sep [ptext SLIT("In") <+> ppr_match <> char ':', nest 4 (rest_of_msg_fun pref)]]
   where
     (ppr_match, pref)
 	= case kind of
@@ -341,7 +343,7 @@ Float, 	Double, at least) are converted to unboxed form; e.g.,
 
 \begin{code}
 tidyEqnInfo :: Id -> EquationInfo -> DsM EquationInfo
-	-- DsM'd because of internal call to dsHsNestedBinds
+	-- DsM'd because of internal call to dsLHsBinds
 	-- 	and mkSelectorBinds.
 	-- "tidy1" does the interesting stuff, looking at
 	-- one pattern and fiddling the list of bindings.
@@ -399,7 +401,7 @@ tidy1 v wrap (VarPat var)
   = returnDs (wrap . wrapBind var v, WildPat (idType var)) 
 
 tidy1 v wrap (VarPatOut var binds)
-  = do	{ prs <- dsHsNestedBinds binds
+  = do	{ prs <- dsLHsBinds binds
 	; return (wrap . wrapBind var v . mkDsLet (Rec prs),
 		  WildPat (idType var)) }
 
@@ -408,6 +410,8 @@ tidy1 v wrap (VarPatOut var binds)
 tidy1 v wrap (AsPat (L _ var) pat)
   = tidy1 v (wrap . wrapBind var v) (unLoc pat)
 
+tidy1 v wrap (BangPat pat)
+  = tidy1 v (wrap . seqVar v) (unLoc pat)
 
 {- now, here we handle lazy patterns:
     tidy1 v ~p bs = (v, v1 = case v of p -> v1 :
@@ -432,7 +436,7 @@ tidy1 v wrap (LazyPat pat)
 tidy1 v wrap (ConPatOut (L loc con) ex_tvs dicts binds ps pat_ty)
   = returnDs (wrap, ConPatOut (L loc con) ex_tvs dicts binds tidy_ps pat_ty)
   where
-    tidy_ps = PrefixCon (tidy_con con pat_ty ps)
+    tidy_ps = PrefixCon (tidy_con con ex_tvs pat_ty ps)
 
 tidy1 v wrap (ListPat pats ty)
   = returnDs (wrap, unLoc list_ConPat)
@@ -450,18 +454,17 @@ tidy1 v wrap (PArrPat pats ty)
     arity      = length pats
     parrConPat = mkPrefixConPat (parrFakeCon arity) pats (mkPArrTy ty)
 
-tidy1 v wrap (TuplePat pats boxity)
+tidy1 v wrap (TuplePat pats boxity ty)
   = returnDs (wrap, unLoc tuple_ConPat)
   where
     arity = length pats
-    tuple_ConPat = mkPrefixConPat (tupleCon boxity arity) pats
-				  (mkTupleTy boxity arity (map hsPatType pats))
+    tuple_ConPat = mkPrefixConPat (tupleCon boxity arity) pats ty
 
 tidy1 v wrap (DictPat dicts methods)
   = case num_of_d_and_ms of
-	0 -> tidy1 v wrap (TuplePat [] Boxed) 
+	0 -> tidy1 v wrap (TuplePat [] Boxed unitTy) 
 	1 -> tidy1 v wrap (unLoc (head dict_and_method_pats))
-	_ -> tidy1 v wrap (TuplePat dict_and_method_pats Boxed)
+	_ -> tidy1 v wrap (mkVanillaTuplePat dict_and_method_pats Boxed)
   where
     num_of_d_and_ms	 = length dicts + length methods
     dict_and_method_pats = map nlVarPat (dicts ++ methods)
@@ -480,9 +483,9 @@ tidy1 v wrap non_interesting_pat
   = returnDs (wrap, non_interesting_pat)
 
 
-tidy_con data_con pat_ty (PrefixCon ps)   = ps
-tidy_con data_con pat_ty (InfixCon p1 p2) = [p1,p2]
-tidy_con data_con pat_ty (RecCon rpats)
+tidy_con data_con ex_tvs pat_ty (PrefixCon ps)   = ps
+tidy_con data_con ex_tvs pat_ty (InfixCon p1 p2) = [p1,p2]
+tidy_con data_con ex_tvs pat_ty (RecCon rpats)
   | null rpats
   =	-- Special case for C {}, which can be used for 
 	-- a constructor that isn't declared to have
@@ -490,14 +493,13 @@ tidy_con data_con pat_ty (RecCon rpats)
     map (noLoc . WildPat) con_arg_tys'
 
   | otherwise
-  = ASSERT( isVanillaDataCon data_con )
-	-- We're in a record case, so the data con must be vanilla
-	-- and hence no existentials to worry about
-    map mk_pat tagged_arg_tys
+  = map mk_pat tagged_arg_tys
   where
 	-- Boring stuff to find the arg-tys of the constructor
 	
-    inst_tys         = tcTyConAppArgs pat_ty	-- Newtypes must be opaque
+    inst_tys | isVanillaDataCon data_con = tcTyConAppArgs pat_ty	-- Newtypes must be opaque
+	     | otherwise		 = mkTyVarTys ex_tvs
+
     con_arg_tys'     = dataConInstOrigArgTys data_con inst_tys
     tagged_arg_tys   = con_arg_tys' `zip` dataConFieldLabels data_con