From 428d8026a26575512aff9abc23a598ab005fa702 Mon Sep 17 00:00:00 2001
From: simonpj <unknown>
Date: Fri, 8 Jul 2005 15:05:16 +0000
Subject: [PATCH] [project @ 2005-07-08 15:05:15 by simonpj] MERGE TO STABLE

Add a check for Haskell-98 mode, to check that there is no type
synonym in an instance declaration.

tcfail139 tests this case
---
 ghc/compiler/typecheck/TcInstDcls.lhs |    2 +-
 ghc/compiler/typecheck/TcMType.lhs    |   14 +++++---------
 ghc/compiler/typecheck/TcType.lhs     |   33 +++++++++++++++++++++++++++++----
 3 files changed, 35 insertions(+), 14 deletions(-)

diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs
index 8366dad..c08dc7a 100644
--- a/ghc/compiler/typecheck/TcInstDcls.lhs
+++ b/ghc/compiler/typecheck/TcInstDcls.lhs
@@ -15,7 +15,7 @@ import TcClassDcl	( tcMethodBind, mkMethodBind, badMethodErr,
 import TcRnMonad       
 import TcMType		( tcSkolSigType, checkValidTheta, checkValidInstHead, instTypeErr, 
 			  checkAmbiguity, SourceTyCtxt(..) )
-import TcType		( mkClassPred, tyVarsOfType, 
+import TcType		( mkClassPred, tyVarsOfType, tcSplitInstHeadTy_maybe,
 			  tcSplitSigmaTy, tcSplitDFunHead, mkTyVarTys,
 			  SkolemInfo(InstSkol), tcSplitDFunTy, pprClassPred )
 import Inst		( tcInstClassOp, newDicts, instToId, showLIE, 
diff --git a/ghc/compiler/typecheck/TcMType.lhs b/ghc/compiler/typecheck/TcMType.lhs
index 49da076..d8e4c0e 100644
--- a/ghc/compiler/typecheck/TcMType.lhs
+++ b/ghc/compiler/typecheck/TcMType.lhs
@@ -55,7 +55,7 @@ import TcType		( TcType, TcThetaType, TcTauType, TcPredType,
 			  MetaDetails(..), SkolemInfo(..), isMetaTyVar, metaTvRef,
 			  tcCmpPred, isClassPred, 
 			  tcSplitPhiTy, tcSplitPredTy_maybe, tcSplitAppTy_maybe, 
-			  tcSplitTyConApp_maybe, tcSplitForAllTys,
+			  tcValidInstHeadTy, tcSplitForAllTys,
 			  tcIsTyVarTy, tcSplitSigmaTy, 
 			  isUnLiftedType, isIPPred, isImmutableTyVar,
 			  typeKind, isFlexi, isSkolemTyVar,
@@ -82,7 +82,7 @@ import VarSet
 import VarEnv
 import DynFlags	( dopt, DynFlag(..) )
 import UniqSupply	( uniqsFromSupply )
-import Util		( nOfThem, isSingleton, equalLength, notNull )
+import Util		( nOfThem, isSingleton, notNull )
 import ListSetOps	( removeDups )
 import SrcLoc		( unLoc )
 import Outputable
@@ -1129,20 +1129,16 @@ check_inst_head dflags clas tys
   | dopt Opt_GlasgowExts dflags
   = check_tyvars dflags clas tys
 
-	-- WITH HASKELL 1.4, MUST HAVE C (T a b c)
+	-- WITH HASKELL 98, MUST HAVE C (T a b c)
   | isSingleton tys,
-    Just (tycon, arg_tys) <- tcSplitTyConApp_maybe first_ty,
-    not (isSynTyCon tycon), 		-- ...but not a synonym
-    all tcIsTyVarTy arg_tys,  		-- Applied to type variables
-    equalLength (varSetElems (tyVarsOfTypes arg_tys)) arg_tys
-          -- This last condition checks that all the type variables are distinct
+    tcValidInstHeadTy first_ty
   = returnM ()
 
   | otherwise
   = failWithTc (instTypeErr (pprClassPred clas tys) head_shape_msg)
 
   where
-    (first_ty : _)       = tys
+    (first_ty : _) = tys
 
     head_shape_msg = parens (text "The instance type must be of form (T a b c)" $$
 			     text "where T is not a synonym, and a,b,c are distinct type variables")
diff --git a/ghc/compiler/typecheck/TcType.lhs b/ghc/compiler/typecheck/TcType.lhs
index 9ca2703..3beaf55 100644
--- a/ghc/compiler/typecheck/TcType.lhs
+++ b/ghc/compiler/typecheck/TcType.lhs
@@ -38,7 +38,7 @@ module TcType (
   tcSplitFunTy_maybe, tcSplitFunTys, tcFunArgTy, tcFunResultTy,
   tcSplitTyConApp, tcSplitTyConApp_maybe, tcTyConAppTyCon, tcTyConAppArgs,
   tcSplitAppTy_maybe, tcSplitAppTy, tcSplitAppTys, tcSplitSigmaTy,
-  tcGetTyVar_maybe, tcGetTyVar,
+  tcValidInstHeadTy, tcGetTyVar_maybe, tcGetTyVar,
 
   ---------------------------------
   -- Predicates. 
@@ -156,7 +156,7 @@ import Type		(	-- Re-exports
 			  pprType, pprParendType, pprTyThingCategory,
 			  pprPred, pprTheta, pprThetaArrow, pprClassPred
 			)
-import TyCon		( TyCon, isUnLiftedTyCon, tyConUnique )
+import TyCon		( TyCon, isUnLiftedTyCon, isSynTyCon, tyConUnique )
 import DataCon		( DataCon )
 import Class		( Class )
 import Var		( TyVar, Id, isTcTyVar, mkTcTyVar, tyVarName, tyVarKind, tcTyVarDetails )
@@ -173,8 +173,9 @@ import PrelNames	-- Lots (e.g. in isFFIArgumentTy)
 import TysWiredIn	( unitTyCon, charTyCon, listTyCon )
 import BasicTypes	( IPName(..), ipNameName )
 import SrcLoc		( SrcLoc, SrcSpan )
-import Util		( snocView )
-import Maybes		( maybeToBool, expectJust )
+import Util		( snocView, equalLength )
+import Maybes		( maybeToBool, expectJust, mapCatMaybes )
+import ListSetOps	( hasNoDups )
 import Outputable
 import DATA_IOREF
 \end{code}
@@ -486,6 +487,30 @@ tcSplitTyConApp_maybe (NoteTy n ty)     = tcSplitTyConApp_maybe ty
 	-- as tycon applications by the type checker
 tcSplitTyConApp_maybe other	        	= Nothing
 
+tcValidInstHeadTy :: Type -> Bool
+-- Used in Haskell-98 mode, for the argument types of an instance head
+-- These must not be type synonyms, but everywhere else type synonyms
+-- are transparent, so we need a special function here
+tcValidInstHeadTy ty 
+  = case ty of
+	TyConApp tc tys -> ASSERT( not (isSynTyCon tc) ) ok tys
+			   -- A synonym would be a NoteTy
+	FunTy arg res        -> ok [arg, res]
+	NoteTy (SynNote _) _ -> False
+	NoteTy other_note ty -> tcValidInstHeadTy ty
+	other		     -> False
+  where
+	-- Check that all the types are type variables,
+	-- and that each is distinct
+    ok tys = equalLength tvs tys && hasNoDups tvs
+	   where
+	     tvs = mapCatMaybes get_tv tys
+
+    get_tv (TyVarTy tv) 	  = Just tv	  -- Again, do not look
+    get_tv (NoteTy (SynNote _) _) = Nothing  	-- through synonyms
+    get_tv (NoteTy other_note ty) = get_tv ty
+    get_tv other  		  = Nothing
+
 tcSplitFunTys :: Type -> ([Type], Type)
 tcSplitFunTys ty = case tcSplitFunTy_maybe ty of
 			Nothing	       -> ([], ty)
-- 
1.7.10.4