X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=ghc%2Fcompiler%2FdeSugar%2FMatch.lhs;h=d72d6adf173a55e47c5e9db12720bbfac13a96da;hp=bbc37b33b8012cdea7f06cc32e463c95f68e1569;hb=3c245de9199f522f75ace92219256badbd928bd6;hpb=febd6d9a765b22b982ec229f1f2426d1b5958232

diff --git a/ghc/compiler/deSugar/Match.lhs b/ghc/compiler/deSugar/Match.lhs
index bbc37b3..d72d6ad 100644
--- a/ghc/compiler/deSugar/Match.lhs
+++ b/ghc/compiler/deSugar/Match.lhs
@@ -4,7 +4,7 @@
 \section[Main_match]{The @match@ function}
 
 \begin{code}
-module Match ( match, matchWrapper, matchSimply, matchSinglePat ) where
+module Match ( match, matchEquations, matchWrapper, matchSimply, matchSinglePat ) where
 
 #include "HsVersions.h"
 
@@ -69,7 +69,7 @@ matchCheck_really dflags ctx vars ty qs
   where (pats, eqns_shadow) = check qs
         incomplete    = want_incomplete && (notNull pats)
         want_incomplete = case ctx of
-                              DsMatchContext RecUpd _ _ ->
+                              DsMatchContext RecUpd _ ->
                                   dopt Opt_WarnIncompletePatternsRecUpd dflags
                               _ ->
                                   dopt Opt_WarnIncompletePatterns       dflags
@@ -90,7 +90,7 @@ The next two functions create the warning message.
 
 \begin{code}
 dsShadowWarn :: DsMatchContext -> [EquationInfo] -> DsM ()
-dsShadowWarn ctx@(DsMatchContext kind _ loc) qs
+dsShadowWarn ctx@(DsMatchContext kind loc) qs
   = putSrcSpanDs loc (dsWarn warn)
   where
     warn | qs `lengthExceeds` maximum_output
@@ -103,7 +103,7 @@ dsShadowWarn ctx@(DsMatchContext kind _ loc) qs
 
 
 dsIncompleteWarn :: DsMatchContext -> [ExhaustivePat] -> DsM ()
-dsIncompleteWarn ctx@(DsMatchContext kind _ loc) pats 
+dsIncompleteWarn ctx@(DsMatchContext kind loc) pats 
   = putSrcSpanDs loc (dsWarn warn)
 	where
 	  warn = pp_context ctx (ptext SLIT("are non-exhaustive"))
@@ -115,7 +115,7 @@ dsIncompleteWarn ctx@(DsMatchContext kind _ loc) pats
 	  dots | pats `lengthExceeds` maximum_output = ptext SLIT("...")
 	       | otherwise                           = empty
 
-pp_context (DsMatchContext kind pats _loc) msg rest_of_msg_fun
+pp_context (DsMatchContext kind _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
@@ -650,19 +650,11 @@ JJQC 30-Nov-1997
 
 \begin{code}
 matchWrapper ctxt (MatchGroup matches match_ty)
-  = do	{ eqns_info <- mapM mk_eqn_info matches
-	; dflags <- getDOptsDs
-	; locn <- getSrcSpanDs
-	; let   ds_ctxt      = DsMatchContext ctxt arg_pats locn
-		error_string = matchContextErrString ctxt
-
-	; new_vars     <- selectMatchVars arg_pats pat_tys
-	; match_result <- match_fun dflags ds_ctxt new_vars rhs_ty eqns_info
-
-	; fail_expr <- mkErrorAppDs pAT_ERROR_ID rhs_ty error_string
-	; result_expr <- extractMatchResult match_result fail_expr
+  = do	{ eqns_info   <- mapM mk_eqn_info matches
+	; new_vars    <- selectMatchVars arg_pats pat_tys
+	; result_expr <- matchEquations ctxt new_vars eqns_info rhs_ty
 	; return (new_vars, result_expr) }
-  where 
+  where
     arg_pats          = map unLoc (hsLMatchPats (head matches))
     n_pats	      = length arg_pats
     (pat_tys, rhs_ty) = splitFunTysN n_pats match_ty
@@ -672,8 +664,23 @@ matchWrapper ctxt (MatchGroup matches match_ty)
 	   ; match_result <- dsGRHSs ctxt upats grhss rhs_ty
 	   ; return (EqnInfo { eqn_wrap = idWrapper,
 			       eqn_pats = upats, 
-			       eqn_rhs = match_result}) }
+			       eqn_rhs  = match_result}) }
 
+
+matchEquations  :: HsMatchContext Name
+		-> [Id]	-> [EquationInfo] -> Type
+		-> DsM CoreExpr
+matchEquations ctxt vars eqns_info rhs_ty
+  = do	{ dflags <- getDOptsDs
+	; locn   <- getSrcSpanDs
+	; let   ds_ctxt      = DsMatchContext ctxt locn
+		error_string = matchContextErrString ctxt
+
+	; match_result <- match_fun dflags ds_ctxt vars rhs_ty eqns_info
+
+	; fail_expr <- mkErrorAppDs pAT_ERROR_ID rhs_ty error_string
+	; extractMatchResult match_result fail_expr }
+  where 
     match_fun dflags ds_ctxt
        = case ctxt of 
            LambdaExpr | dopt Opt_WarnSimplePatterns dflags -> matchCheck ds_ctxt
@@ -719,7 +726,7 @@ matchSinglePat (Var var) hs_ctx (L _ pat) ty match_result
            | dopt Opt_WarnSimplePatterns dflags = matchCheck ds_ctx
   	   | otherwise	       		        = match
 	   where
-	     ds_ctx = DsMatchContext hs_ctx [pat] locn
+	     ds_ctx = DsMatchContext hs_ctx locn
     in
     match_fn dflags [var] ty [EqnInfo { eqn_wrap = idWrapper,
 					eqn_pats = [pat],