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

diff --git a/ghc/compiler/deSugar/Match.lhs b/ghc/compiler/deSugar/Match.lhs
index c7d0b5d..5437929 100644
--- a/ghc/compiler/deSugar/Match.lhs
+++ b/ghc/compiler/deSugar/Match.lhs
@@ -12,22 +12,22 @@ import Ubiq
 import DsLoop		-- here for paranoia-checking reasons
 			-- and to break dsExpr/dsBinds-ish loop
 
-import HsSyn
+import HsSyn		hiding ( collectBinders{-also from CoreSyn-} )
 import TcHsSyn		( TypecheckedPat(..), TypecheckedMatch(..),
 			  TypecheckedHsBinds(..), TypecheckedHsExpr(..)	)
 import DsHsSyn		( outPatType, collectTypedPatBinders )
 import CoreSyn
 
+import CoreUtils	( coreExprType )
 import DsMonad
 import DsGRHSs		( dsGRHSs )
 import DsUtils
 import MatchCon		( matchConFamily )
 import MatchLit		( matchLiterals )
 
-import CoreUtils	( escErrorMsg, mkErrorApp )
 import FieldLabel	( allFieldLabelTags, fieldLabelTag )
 import Id		( idType, mkTupleCon, dataConSig,
-			  recordSelectorFieldLabel,
+			  dataConArgTys, recordSelectorFieldLabel,
 			  GenId{-instance-}
 			)
 import PprStyle		( PprStyle(..) )
@@ -38,7 +38,9 @@ import PrelInfo		( nilDataCon, consDataCon, mkTupleTy, mkListTy,
 			  integerTy, intPrimTy, charPrimTy,
 			  floatPrimTy, doublePrimTy, stringTy,
 			  addrTy, addrPrimTy, addrDataCon,
-			  wordTy, wordPrimTy, wordDataCon )
+			  wordTy, wordPrimTy, wordDataCon,
+			  pAT_ERROR_ID
+			)
 import Type		( isPrimType, eqTy, getAppDataTyCon,
 			  instantiateTauTy
 			)
@@ -329,14 +331,12 @@ tidy1 v (ConOpPat pat1 id pat2 ty) 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
+    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
+    (_, inst_tys, _) = {-_trace "getAppDataTyCon.Match" $-} getAppDataTyCon pat_ty
+    con_arg_tys'     = dataConArgTys con_id inst_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
@@ -513,21 +513,24 @@ matchUnmixedEqns :: [Id]
 matchUnmixedEqns [] _ _ = panic "matchUnmixedEqns: no names"
 
 matchUnmixedEqns all_vars@(var:vars) eqns_info shadows
-  | unfailablePats column_1_pats	-- Could check just one; we know they've been tidied, unmixed;
-					-- this way is (arguably) a sanity-check
-  =	-- Real true variables, just like in matchVar, SLPJ p 94
+  | unfailablePat first_pat
+  = ASSERT( unfailablePats column_1_pats )	-- Sanity check
+  	-- Real true variables, just like in matchVar, SLPJ p 94
     match vars remaining_eqns_info remaining_shadows
 
-  | patsAreAllCons column_1_pats	-- ToDo: maybe check just one...
-  = matchConFamily all_vars eqns_info shadows
+  | isConPat first_pat
+  = ASSERT( patsAreAllCons column_1_pats )
+    matchConFamily all_vars eqns_info shadows
 
-  | patsAreAllLits column_1_pats	-- ToDo: maybe check just one...
-  =	-- see notes in MatchLiteral
+  | isLitPat first_pat
+  = ASSERT( patsAreAllLits column_1_pats )
+  	-- see notes in MatchLiteral
 	-- not worried about the same literal more than once in a column
 	-- (ToDo: sort this out later)
     matchLiterals all_vars eqns_info shadows
 
   where
+    first_pat		= head column_1_pats
     column_1_pats 	= [pat                       | EqnInfo (pat:_)  _            <- eqns_info]
     remaining_eqns_info = [EqnInfo pats match_result | EqnInfo (_:pats) match_result <- eqns_info]
     remaining_shadows   = [EqnInfo pats match_result | EqnInfo (pat:pats) match_result <- shadows,
@@ -613,16 +616,12 @@ matchWrapper kind [(GRHSMatch
 matchWrapper kind matches error_string
   = flattenMatches kind matches	`thenDs` \ eqns_info@(EqnInfo arg_pats (MatchResult _ result_ty _ _) : _) ->
 
-    selectMatchVars arg_pats	`thenDs` \ new_vars ->
-    match new_vars eqns_info []	`thenDs` \ match_result ->
+    selectMatchVars arg_pats				`thenDs` \ new_vars ->
+    match new_vars eqns_info []				`thenDs` \ match_result ->
+
+    mkErrorAppDs pAT_ERROR_ID result_ty error_string	`thenDs` \ fail_expr ->
+    extractMatchResult match_result fail_expr		`thenDs` \ result_expr ->
 
-    getSrcLocDs			`thenDs` \ (src_file, src_line) ->
-    newSysLocalDs stringTy	`thenDs` \ str_var -> -- to hold the String
-    let
-	src_loc_str = escErrorMsg ('"' : src_file) ++ "%l" ++ src_line
-	fail_expr   = mkErrorApp result_ty str_var (src_loc_str++": "++error_string)
-    in
-    extractMatchResult match_result fail_expr	`thenDs` \ result_expr ->
     returnDs (new_vars, result_expr)
 \end{code}
 
@@ -703,4 +702,15 @@ flattenMatches kind (match : matches)
 	returnDs (EqnInfo pats (mkCoLetsMatchResult core_binds match_result))
       where
 	pats = reverse pats_so_far	-- They've accumulated in reverse order
+
+    flatten_match pats_so_far (SimpleMatch expr) 
+      = dsExpr expr		`thenDs` \ core_expr ->
+	returnDs (EqnInfo pats
+		    (MatchResult CantFail (coreExprType core_expr) 
+			      (\ ignore -> core_expr)
+			      NoMatchContext))
+	-- The NoMatchContext is just a place holder.  In a simple match,
+	-- the matching can't fail, so we won't generate an error message.
+      where
+	pats = reverse pats_so_far	-- They've accumulated in reverse order
 \end{code}