From 912f10aaeb2c8ddfdce94ab6a50046c8cb70e76b Mon Sep 17 00:00:00 2001
From: simonpj <unknown>
Date: Thu, 20 Jun 2002 08:33:20 +0000
Subject: [PATCH] [project @ 2002-06-20 08:33:20 by simonpj] Fix validity
 checking of an instance-decl context

---
 ghc/compiler/typecheck/TcMType.lhs |   21 +++++++++++++--------
 ghc/compiler/typecheck/TcType.lhs  |    4 ++--
 2 files changed, 15 insertions(+), 10 deletions(-)

diff --git a/ghc/compiler/typecheck/TcMType.lhs b/ghc/compiler/typecheck/TcMType.lhs
index 5a7e000..28c45f0 100644
--- a/ghc/compiler/typecheck/TcMType.lhs
+++ b/ghc/compiler/typecheck/TcMType.lhs
@@ -51,7 +51,7 @@ import TcType		( TcType, TcThetaType, TcTauType, TcPredType,
 			  tcSplitPhiTy, tcSplitPredTy_maybe, tcSplitAppTy_maybe, 
 			  tcSplitTyConApp_maybe, tcSplitForAllTys,
 			  tcIsTyVarTy, tcSplitSigmaTy, 
-			  isUnLiftedType, isIPPred, isHoleTyVar,
+			  isUnLiftedType, isIPPred, isHoleTyVar, isTyVarTy,
 
 			  mkAppTy, mkTyVarTy, mkTyVarTys, 
 			  tyVarsOfPred, getClassPredTys_maybe,
@@ -910,7 +910,7 @@ check_source_ty dflags ctxt pred@(ClassP cls tys)
   = 	-- Class predicates are valid in all contexts
     mapTc_ check_arg_type tys		`thenTc_`
     checkTc (arity == n_tys) arity_err		`thenTc_`
-    checkTc (all tyvar_head tys || arby_preds_ok)
+    checkTc (check_class_pred_tys dflags ctxt tys)
 	    (predTyVarErr pred $$ how_to_allow)
 
   where
@@ -919,12 +919,6 @@ check_source_ty dflags ctxt pred@(ClassP cls tys)
     n_tys      = length tys
     arity_err  = arityErr "Class" class_name arity n_tys
 
-    arby_preds_ok = case ctxt of
-			InstHeadCtxt  -> True	-- We check for instance-head formation
-						-- in checkValidInstHead
-			InstThetaCtxt -> dopt Opt_AllowUndecidableInstances dflags
-			other	      -> dopt Opt_GlasgowExts               dflags
-
     how_to_allow = case ctxt of
 		     InstHeadCtxt  -> empty	-- Should not happen
 		     InstThetaCtxt -> parens undecidableMsg
@@ -946,6 +940,17 @@ check_source_ty dflags TypeCtxt  (NType tc tys)   = mapTc_ check_arg_type tys
 check_source_ty dflags ctxt sty = failWithTc (badSourceTyErr sty)
 
 -------------------------
+check_class_pred_tys dflags ctxt tys 
+  = case ctxt of
+	InstHeadCtxt  -> True	-- We check for instance-head 
+				-- formation in checkValidInstHead
+	InstThetaCtxt -> undecidable_ok || all isTyVarTy tys
+	other	      -> gla_exts       || all tyvar_head tys
+  where
+    undecidable_ok = dopt Opt_AllowUndecidableInstances dflags 
+    gla_exts 	   = dopt Opt_GlasgowExts dflags
+
+-------------------------
 tyvar_head ty			-- Haskell 98 allows predicates of form 
   | tcIsTyVarTy ty = True	-- 	C (a ty1 .. tyn)
   | otherwise			-- where a is a type variable
diff --git a/ghc/compiler/typecheck/TcType.lhs b/ghc/compiler/typecheck/TcType.lhs
index d498e7b..8e3862c 100644
--- a/ghc/compiler/typecheck/TcType.lhs
+++ b/ghc/compiler/typecheck/TcType.lhs
@@ -92,7 +92,7 @@ module TcType (
 
   isUnLiftedType,	-- Source types are always lifted
   isUnboxedTupleType,	-- Ditto
-  isPrimitiveType,
+  isPrimitiveType, isTyVarTy,
 
   tidyTopType, tidyType, tidyPred, tidyTypes, tidyFreeTyVars, tidyOpenType, tidyOpenTypes,
   tidyTyVarBndr, tidyOpenTyVar, tidyOpenTyVars,
@@ -114,7 +114,7 @@ import Type		(	-- Re-exports
 			  Kind, Type, SourceType(..), PredType, ThetaType, 
 			  unliftedTypeKind, liftedTypeKind, openTypeKind, mkArrowKind, mkArrowKinds,
 			  mkForAllTy, mkForAllTys, defaultKind, isTypeKind, isAnyTypeKind,
-			  mkFunTy, mkFunTys, zipFunTys, 
+			  mkFunTy, mkFunTys, zipFunTys, isTyVarTy,
 			  mkTyConApp, mkGenTyConApp, mkAppTy, mkAppTys, mkSynTy, applyTy, applyTys,
 			  mkTyVarTy, mkTyVarTys, mkTyConTy, mkPredTy, mkPredTys,
 			  isUnLiftedType, isUnboxedTupleType, isPrimitiveType,
-- 
1.7.10.4