From: simonpj <unknown>
Date: Fri, 16 Dec 2005 15:15:08 +0000 (+0000)
Subject: [project @ 2005-12-16 15:15:08 by simonpj]
X-Git-Tag: final_switch_to_darcs,_this_repo_is_now_live~86
X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=4dd415e9d8e564ca09937042b5c5605f7f2991c9

[project @ 2005-12-16 15:15:08 by simonpj]
-----------------------------------------
	Test for repated type variables in an instance decl context;
	this should require -fallow-undecidable-instances'
	-----------------------------------------

	Merge to stable branch
---

diff --git a/ghc/compiler/typecheck/TcMType.lhs b/ghc/compiler/typecheck/TcMType.lhs
index 4a800a2..7ac2677 100644
--- a/ghc/compiler/typecheck/TcMType.lhs
+++ b/ghc/compiler/typecheck/TcMType.lhs
@@ -53,7 +53,7 @@ import TypeRep		( Type(..), PredType(..),  -- Friend; can see representation
 import TcType		( TcType, TcThetaType, TcTauType, TcPredType,
 			  TcTyVarSet, TcKind, TcTyVar, TcTyVarDetails(..), 
 			  MetaDetails(..), SkolemInfo(..), isMetaTyVar, metaTvRef,
-			  tcCmpPred, isClassPred, 
+			  tcCmpPred, tcEqType, isClassPred, 
 			  tcSplitPhiTy, tcSplitPredTy_maybe, tcSplitAppTy_maybe, 
 			  tcValidInstHeadTy, tcSplitForAllTys,
 			  tcIsTyVarTy, tcSplitSigmaTy, 
@@ -83,7 +83,7 @@ import VarEnv
 import DynFlags	( dopt, DynFlag(..) )
 import UniqSupply	( uniqsFromSupply )
 import Util		( nOfThem, isSingleton, notNull )
-import ListSetOps	( removeDups )
+import ListSetOps	( removeDups, findDupsEq )
 import SrcLoc		( unLoc )
 import Outputable
 \end{code}
@@ -977,13 +977,17 @@ check_class_pred_tys dflags ctxt tys
 	TypeCtxt      -> True	-- {-# SPECIALISE instance Eq (T Int) #-} is fine
 	InstHeadCtxt  -> True	-- We check for instance-head 
 				-- formation in checkValidInstHead
-	InstThetaCtxt -> undecidable_ok || all tcIsTyVarTy tys
+	InstThetaCtxt -> undecidable_ok || distinct_tyvars tys
 	other	      -> gla_exts       || all tyvar_head tys
   where
     undecidable_ok = dopt Opt_AllowUndecidableInstances dflags 
     gla_exts 	   = dopt Opt_GlasgowExts dflags
 
 -------------------------
+distinct_tyvars tys	-- Check that the types are all distinct type variables
+  = all tcIsTyVarTy tys && null (findDupsEq tcEqType tys)
+
+-------------------------
 tyvar_head ty			-- Haskell 98 allows predicates of form 
   | tcIsTyVarTy ty = True	-- 	C (a ty1 .. tyn)
   | otherwise			-- where a is a type variable
@@ -1074,7 +1078,8 @@ checkThetaCtxt ctxt theta
 	  ptext SLIT("While checking") <+> pprSourceTyCtxt ctxt ]
 
 badSourceTyErr sty = ptext SLIT("Illegal constraint") <+> pprPred sty
-predTyVarErr pred  = ptext SLIT("Non-type variables in constraint:") <+> pprPred pred
+predTyVarErr pred  = sep [ptext SLIT("Non-type variables, or repeated type variables,"),
+			  nest 2 (ptext SLIT("in the constraint:") <+> pprPred pred)]
 dupPredWarn dups   = ptext SLIT("Duplicate constraint(s):") <+> pprWithCommas pprPred (map head dups)
 
 arityErr kind name n m