X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcMatches.lhs;h=07a1094d58de98b08937c346db5965a070bac90f;hb=0c88fe0000481527a0a9f6305512ac2f605340d5;hp=39b4253c23c4e24eada0f3dcede08b64f7c43ea1;hpb=ac10f8408520a30e8437496d320b8b86afda2e8f;p=ghc-hetmet.git

diff --git a/ghc/compiler/typecheck/TcMatches.lhs b/ghc/compiler/typecheck/TcMatches.lhs
index 39b4253..07a1094 100644
--- a/ghc/compiler/typecheck/TcMatches.lhs
+++ b/ghc/compiler/typecheck/TcMatches.lhs
@@ -17,7 +17,7 @@ import {-# SOURCE #-}	TcExpr( tcSyntaxOp, tcInferRho, tcMonoExpr, tcPolyExpr )
 import HsSyn		( HsExpr(..), LHsExpr, MatchGroup(..),
 			  Match(..), LMatch, GRHSs(..), GRHS(..), 
 			  Stmt(..), LStmt, HsMatchContext(..), HsStmtContext(..),
-			  pprMatch, isIrrefutableHsPat,
+			  pprMatch, isIrrefutableHsPat, mkHsCoerce,
 			  pprMatchContext, pprStmtContext, 
 			  noSyntaxExpr, matchGroupArity, pprMatches,
 			  ExprCoFn )
@@ -42,12 +42,9 @@ import TysWiredIn	( stringTy, boolTy, parrTyCon, listTyCon, mkListTy, mkPArrTy )
 import PrelNames	( bindMName, returnMName, mfixName, thenMName, failMName )
 import Id		( idType, mkLocalId )
 import TyCon		( TyCon )
-import Util		( isSingleton )
 import Outputable
-import SrcLoc		( Located(..) )
+import SrcLoc		( Located(..), getLoc )
 import ErrUtils		( Message )
-
-import List		( nub )
 \end{code}
 
 %************************************************************************
@@ -74,7 +71,7 @@ tcMatchesFun fun_name matches exp_ty
 	   -- sensible location.	Note: we have to do this odd
 	   -- ann-grabbing, because we don't always have annotations in
 	   -- hand when we call tcMatchesFun...
-	  checkTc (sameNoOfArgs matches) (varyingArgsErr fun_name matches)
+	  checkArgs fun_name matches
 
 	-- ToDo: Don't use "expected" stuff if there ain't a type signature
 	-- because inconsistency between branches
@@ -115,7 +112,7 @@ tcMatchLambda match res_ty
     doc = sep [ ptext SLIT("The lambda expression")
 		 <+> quotes (pprSetDepth 1 $ pprMatches LambdaExpr match),
 			-- The pprSetDepth makes the abstraction print briefly
-		ptext SLIT("has") <+> speakNOf n_pats (ptext SLIT("arguments"))]
+		ptext SLIT("has") <+> speakNOf n_pats (ptext SLIT("argument"))]
     match_ctxt = MC { mc_what = LambdaExpr,
 		      mc_body = tcPolyExpr }
 \end{code}
@@ -471,7 +468,7 @@ tcMDoStmt tc_rhs ctxt (RecStmt stmts laterNames recNames _ _) res_ty thing_insid
 		-- poly_id may have a polymorphic type
 		-- but mono_ty is just a monomorphic type variable
 	     ; co_fn <- tcSubExp (idType poly_id) mono_ty
-	     ; return (HsCoerce co_fn (HsVar poly_id)) }
+	     ; return (mkHsCoerce co_fn (HsVar poly_id)) }
 
 tcMDoStmt tc_rhs ctxt stmt res_ty thing_inside
   = pprPanic "tcMDoStmt: unexpected Stmt" (ppr stmt)
@@ -489,18 +486,23 @@ tcMDoStmt tc_rhs ctxt stmt res_ty thing_inside
 number of args are used in each equation.
 
 \begin{code}
-sameNoOfArgs :: MatchGroup Name -> Bool
-sameNoOfArgs (MatchGroup matches _)
-   = isSingleton (nub (map args_in_match matches))
+checkArgs :: Name -> MatchGroup Name -> TcM ()
+checkArgs fun (MatchGroup (match1:matches) _)
+    | null bad_matches = return ()
+    | otherwise
+    = failWithTc (vcat [ptext SLIT("Equations for") <+> quotes (ppr fun) <+> 
+			  ptext SLIT("have different numbers of arguments"),
+			nest 2 (ppr (getLoc match1)),
+			nest 2 (ppr (getLoc (head bad_matches)))])
   where
+    n_args1 = args_in_match match1
+    bad_matches = [m | m <- matches, args_in_match m /= n_args1]
+
     args_in_match :: LMatch Name -> Int
     args_in_match (L _ (Match pats _ _)) = length pats
 \end{code}
 
 \begin{code}
-varyingArgsErr name matches
-  = sep [ptext SLIT("Varying number of arguments for function"), quotes (ppr name)]
-
 matchCtxt ctxt match  = hang (ptext SLIT("In") <+> pprMatchContext ctxt <> colon) 
 			   4 (pprMatch ctxt match)