X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcMatches.lhs;h=51de6d477b544288d9ffa618748100908e15aebd;hp=68e1398972480836cb973866a99dcaefdb141f1b;hb=ad94d40948668032189ad22a0ad741ac1f645f50;hpb=ab22f4e6456820c1b5169d75f5975a94e61f54ce

diff --git a/compiler/typecheck/TcMatches.lhs b/compiler/typecheck/TcMatches.lhs
index 68e1398..51de6d4 100644
--- a/compiler/typecheck/TcMatches.lhs
+++ b/compiler/typecheck/TcMatches.lhs
@@ -6,6 +6,13 @@
 TcMatches: Typecheck some @Matches@
 
 \begin{code}
+{-# OPTIONS -w #-}
+-- The above warning supression flag is a temporary kludge.
+-- While working on this module you are encouraged to remove it and fix
+-- any warnings in the module. See
+--     http://hackage.haskell.org/trac/ghc/wiki/CodingStyle#Warnings
+-- for details
+
 module TcMatches ( tcMatchesFun, tcGRHSsPat, tcMatchesCase, tcMatchLambda,
 		   matchCtxt, TcMatchCtxt(..), 
 		   tcStmts, tcDoStmts, tcBody,
@@ -48,12 +55,12 @@ is used in error messages.  It checks that all the equations have the
 same number of arguments before using @tcMatches@ to do the work.
 
 \begin{code}
-tcMatchesFun :: Name
+tcMatchesFun :: Name -> Bool
 	     -> MatchGroup Name
 	     -> BoxyRhoType 		-- Expected type of function
 	     -> TcM (HsWrapper, MatchGroup TcId)	-- Returns type of body
 
-tcMatchesFun fun_name matches exp_ty
+tcMatchesFun fun_name inf matches exp_ty
   = do	{  -- Check that they all have the same no of arguments
 	   -- Location is in the monad, set the caller so that 
 	   -- any inter-equation error messages get some vaguely
@@ -76,7 +83,7 @@ tcMatchesFun fun_name matches exp_ty
     doc = ptext SLIT("The equation(s) for") <+> quotes (ppr fun_name)
 	  <+> ptext SLIT("have") <+> speakNOf n_pats (ptext SLIT("argument"))
     n_pats = matchGroupArity matches
-    match_ctxt = MC { mc_what = FunRhs fun_name, mc_body = tcBody }
+    match_ctxt = MC { mc_what = FunRhs fun_name inf, mc_body = tcBody }
 \end{code}
 
 @tcMatchesCase@ doesn't do the argument-count check because the
@@ -153,7 +160,7 @@ tcMatch ctxt pat_tys rhs_ty match
   = wrapLocM (tc_match ctxt pat_tys rhs_ty) match
   where
     tc_match ctxt pat_tys rhs_ty match@(Match pats maybe_rhs_sig grhss)
-      = addErrCtxt (matchCtxt (mc_what ctxt) match)	$	
+      = add_match_ctxt match $
         do { (pats', grhss') <- tcLamPats pats pat_tys rhs_ty $
     			        tc_grhss ctxt maybe_rhs_sig grhss
 	   ; return (Match pats' Nothing grhss') }
@@ -167,6 +174,13 @@ tcMatch ctxt pat_tys rhs_ty match
 			<+> ppr res_sig)
     	   ; tcGRHSs ctxt grhss (co, rhs_ty) }
 
+	-- For (\x -> e), tcExpr has already said "In the expresssion \x->e"
+	-- so we don't want to add "In the lambda abstraction \x->e"
+    add_match_ctxt match thing_inside
+	= case mc_what ctxt of
+	    LambdaExpr -> thing_inside
+	    m_ctxt     -> addErrCtxt (matchCtxt m_ctxt match) thing_inside
+
 -------------
 tcGRHSs :: TcMatchCtxt -> GRHSs Name -> (Refinement, BoxyRhoType) 
 	-> TcM (GRHSs TcId)