X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FdeSugar%2FMatch.lhs;fp=compiler%2FdeSugar%2FMatch.lhs;h=4bc0c4b7925468b97ec08514014b57dac3772006;hb=a7554688338b04ec362bc475b0992ef8799c8bd0;hp=2c9aa0bfd876b922cd703623f471f7e7151398a3;hpb=e9b68a09e815946e9d6b6606f80e43d582cf098d;p=ghc-hetmet.git

diff --git a/compiler/deSugar/Match.lhs b/compiler/deSugar/Match.lhs
index 2c9aa0b..4bc0c4b 100644
--- a/compiler/deSugar/Match.lhs
+++ b/compiler/deSugar/Match.lhs
@@ -700,21 +700,14 @@ 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
+  = do	{ locn <- getSrcSpanDs
+	; let   ds_ctxt   = DsMatchContext ctxt locn
 		error_doc = matchContextErrString ctxt
 
-	; match_result <- match_fun dflags ds_ctxt vars rhs_ty eqns_info
+	; match_result <- matchCheck ds_ctxt vars rhs_ty eqns_info
 
 	; fail_expr <- mkErrorAppDs pAT_ERROR_ID rhs_ty error_doc
 	; extractMatchResult match_result fail_expr }
-  where 
-    match_fun dflags ds_ctxt
-       = case ctxt of 
-           LambdaExpr | dopt Opt_WarnSimplePatterns dflags -> matchCheck ds_ctxt
-                      | otherwise                          -> match
-           _                                               -> matchCheck ds_ctxt
 \end{code}
 
 %************************************************************************
@@ -734,7 +727,7 @@ matchSimply :: CoreExpr			-- Scrutinee
 	    -> CoreExpr			-- Return this if it matches
 	    -> CoreExpr			-- Return this if it doesn't
 	    -> DsM CoreExpr
-
+-- Do not warn about incomplete patterns; see matchSinglePat comments
 matchSimply scrut hs_ctx pat result_expr fail_expr = do
     let
       match_result = cantFailMatchResult result_expr
@@ -746,16 +739,11 @@ matchSimply scrut hs_ctx pat result_expr fail_expr = do
 
 matchSinglePat :: CoreExpr -> HsMatchContext Name -> LPat Id
 	       -> Type -> MatchResult -> DsM MatchResult
-matchSinglePat (Var var) hs_ctx (L _ pat) ty match_result = do
-    dflags <- getDOptsDs
-    locn <- getSrcSpanDs
-    let
-        match_fn dflags
-           | dopt Opt_WarnSimplePatterns dflags = matchCheck ds_ctx
-           | otherwise                          = match
-           where
-             ds_ctx = DsMatchContext hs_ctx locn
-    match_fn dflags [var] ty [EqnInfo { eqn_pats = [pat], eqn_rhs  = match_result }]
+-- Do not warn about incomplete patterns
+-- Used for things like [ e | pat <- stuff ], where 
+-- incomplete patterns are just fine
+matchSinglePat (Var var) _ (L _ pat) ty match_result 
+  = match [var] ty [EqnInfo { eqn_pats = [pat], eqn_rhs  = match_result }]
 
 matchSinglePat scrut hs_ctx pat ty match_result = do
     var <- selectSimpleMatchVarL pat