X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcMatches.lhs;h=bd83a55e29bce3e1361ee0cb5794077bfd883990;hp=d9146d9041297398e858ccd900b8dc077c385902;hb=a8427a4125e9b78e88a487eeabf018f1c6e8bc08;hpb=e6d057711f4d6d6ff6342c39fa2b9e44d25447f1

diff --git a/compiler/typecheck/TcMatches.lhs b/compiler/typecheck/TcMatches.lhs
index d9146d9..bd83a55 100644
--- a/compiler/typecheck/TcMatches.lhs
+++ b/compiler/typecheck/TcMatches.lhs
@@ -1,7 +1,9 @@
 %
+% (c) The University of Glasgow 2006
 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 %
-\section[TcMatches]{Typecheck some @Matches@}
+
+TcMatches: Typecheck some @Matches@
 
 \begin{code}
 module TcMatches ( tcMatchesFun, tcGRHSsPat, tcMatchesCase, tcMatchLambda,
@@ -14,36 +16,24 @@ module TcMatches ( tcMatchesFun, tcGRHSsPat, tcMatchesCase, tcMatchLambda,
 
 import {-# SOURCE #-}	TcExpr( tcSyntaxOp, tcInferRho, tcMonoExpr, tcPolyExpr )
 
-import HsSyn		( HsExpr(..), LHsExpr, MatchGroup(..),
-			  Match(..), LMatch, GRHSs(..), GRHS(..), 
-			  Stmt(..), LStmt, HsMatchContext(..),
-			  HsStmtContext(..), 
-			  pprMatch, isIrrefutableHsPat, mkHsWrap,
-			  mkLHsWrap, pprMatchContext, pprStmtContext,  
-			  noSyntaxExpr, matchGroupArity, pprMatches,
-			  HsWrapper )
-
+import HsSyn
 import TcRnMonad
-import TcGadt		( Refinement, emptyRefinement, refineResType )
-import Inst		( newMethodFromName )
-import TcEnv		( TcId, tcLookupLocalIds, tcLookupId, tcExtendIdEnv )
-import TcPat		( tcLamPats, tcLamPat )
-import TcMType		( newFlexiTyVarTy, newFlexiTyVarTys ) 
-import TcType		( TcType, TcRhoType, 
-			  BoxySigmaType, BoxyRhoType, 
-			  mkFunTys, mkFunTy, mkAppTy, mkTyConApp,
-			  liftedTypeKind )
-import TcBinds		( tcLocalBinds )
-import TcUnify		( boxySplitAppTy, boxySplitTyConApp, boxySplitListTy,
-			  subFunTys, tcSubExp, withBox )
-import TcSimplify	( bindInstsOfLocalFuns )
-import Name		( Name )
-import TysWiredIn	( stringTy, boolTy, parrTyCon, listTyCon, mkListTy, mkPArrTy )
-import PrelNames	( bindMName, returnMName, mfixName, thenMName, failMName )
-import Id		( idType, mkLocalId )
-import TyCon		( TyCon )
+import TcGadt
+import Inst
+import TcEnv
+import TcPat
+import TcMType
+import TcType
+import TcBinds
+import TcUnify
+import TcSimplify
+import Name
+import TysWiredIn
+import PrelNames
+import Id
+import TyCon
 import Outputable
-import SrcLoc		( Located(..), getLoc )
+import SrcLoc
 \end{code}
 
 %************************************************************************
@@ -58,12 +48,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
@@ -86,7 +76,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
@@ -163,7 +153,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') }
@@ -177,6 +167,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)