From: simonpj <unknown>
Date: Fri, 10 Oct 2003 15:45:07 +0000 (+0000)
Subject: [project @ 2003-10-10 15:45:04 by simonpj]
X-Git-Tag: Approx_11550_changesets_converted~373
X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=ffa4651e23a4c382dd3bdc43674a60b1a91c3b56;p=ghc-hetmet.git

[project @ 2003-10-10 15:45:04 by simonpj]
Use tcIsTyVarTy not isTyVarTy; and move isPredTy
---

diff --git a/ghc/compiler/typecheck/Inst.lhs b/ghc/compiler/typecheck/Inst.lhs
index 2a2663a..f035eef 100644
--- a/ghc/compiler/typecheck/Inst.lhs
+++ b/ghc/compiler/typecheck/Inst.lhs
@@ -56,7 +56,7 @@ import TcMType	( zonkTcType, zonkTcTypes, zonkTcPredType,
 import TcType	( Type, TcType, TcThetaType, TcTyVarSet,
 		  PredType(..), TyVarDetails(VanillaTv),
 		  tcSplitForAllTys, tcSplitForAllTys, mkTyConApp,
-		  tcSplitPhiTy, isTyVarTy, tcSplitDFunTy,
+		  tcSplitPhiTy, tcIsTyVarTy, tcSplitDFunTy,
 		  isIntTy,isFloatTy, isIntegerTy, isDoubleTy,
 		  tcIsTyVarTy, mkPredTy, mkTyVarTy, mkTyVarTys,
 		  tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tidyPred,
@@ -622,7 +622,8 @@ lookupInst inst@(LitInst u (HsFractional f from_rat_name) ty loc)
 
 -- Dictionaries
 lookupInst dict@(Dict _ pred@(ClassP clas tys) loc)
-  | all isTyVarTy tys	 -- Common special case; no lookup
+  | all tcIsTyVarTy tys	 -- Common special case; no lookup
+			 -- NB: tcIsTyVarTy... don't look through newtypes!
   = returnM NoInstance
 	
   | otherwise
@@ -632,7 +633,10 @@ lookupInst dict@(Dict _ pred@(ClassP clas tys) loc)
 	; dflags  <- getDOpts
 	; case lookupInstEnv dflags (pkg_ie, tcg_inst_env tcg_env) clas tys of {
 	    ([(tenv, (_,_,dfun_id))], []) -> instantiate_dfun tenv dfun_id pred loc ;
-	    other 			  -> return NoInstance } }
+	    (matches, unifs)		  -> do
+	{ traceTc (text "lookupInst" <+> vcat [text "matches" <+> ppr matches,
+					       text "unifs" <+> ppr unifs])
+	; return NoInstance } } }
 		-- In the case of overlap (multiple matches) we report
 		-- NoInstance here.  That has the effect of making the 
 		-- context-simplifier return the dict as an irreducible one.
@@ -654,7 +658,6 @@ instantiate_dfun tenv dfun_id pred loc
     getStage						`thenM` \ use_stage ->
     checkWellStaged (ptext SLIT("instance for") <+> quotes (ppr pred))
     		    (topIdLvl dfun_id) use_stage		`thenM_`
-    traceTc (text "lookupInst" <+> ppr dfun_id <+> ppr (topIdLvl dfun_id) <+> ppr use_stage) `thenM_`
     let
     	(tyvars, rho) = tcSplitForAllTys (idType dfun_id)
     	mk_ty_arg tv  = case lookupSubstEnv tenv tv of
diff --git a/ghc/compiler/typecheck/TcType.lhs b/ghc/compiler/typecheck/TcType.lhs
index 6f7fdde..3a10ed1 100644
--- a/ghc/compiler/typecheck/TcType.lhs
+++ b/ghc/compiler/typecheck/TcType.lhs
@@ -59,7 +59,7 @@ module TcType (
   getClassPredTys_maybe, getClassPredTys, 
   isClassPred, isTyVarClassPred, 
   mkDictTy, tcSplitPredTy_maybe, 
-  isDictTy, tcSplitDFunTy, predTyUnique, 
+  isPredTy, isDictTy, tcSplitDFunTy, predTyUnique, 
   mkClassPred, isInheritablePred, isLinearPred, isIPPred, mkPredName, 
 
   ---------------------------------
@@ -96,7 +96,7 @@ module TcType (
 
   isUnLiftedType,	-- Source types are always lifted
   isUnboxedTupleType,	-- Ditto
-  isPrimitiveType, isTyVarTy, isPredTy,
+  isPrimitiveType, 
 
   tidyTopType, tidyType, tidyPred, tidyTypes, tidyFreeTyVars, tidyOpenType, tidyOpenTypes,
   tidyTyVarBndr, tidyOpenTyVar, tidyOpenTyVars,
@@ -125,7 +125,7 @@ import Type		(	-- Re-exports
 			  mkTyConApp, mkGenTyConApp, mkAppTy,
 			  mkAppTys, mkSynTy, applyTy, applyTys,
 			  mkTyVarTy, mkTyVarTys, mkTyConTy, mkPredTy,
-			  mkPredTys, isUnLiftedType, isPredTy,
+			  mkPredTys, isUnLiftedType, 
 			  isUnboxedTupleType, isPrimitiveType,
 			  splitTyConApp_maybe,
 			  tidyTopType, tidyType, tidyPred, tidyTypes,
@@ -669,6 +669,12 @@ isOverloadedTy (ForAllTy tyvar ty) = isOverloadedTy ty
 isOverloadedTy (FunTy a b)	   = isPredTy a
 isOverloadedTy (NoteTy n ty)	   = isOverloadedTy ty
 isOverloadedTy _		   = False
+
+isPredTy :: Type -> Bool	-- Belongs in TcType because it does 
+				-- not look through newtypes, or predtypes (of course)
+isPredTy (NoteTy _ ty) = isPredTy ty
+isPredTy (PredTy sty)  = True
+isPredTy _	       = False
 \end{code}
 
 \begin{code}
diff --git a/ghc/compiler/types/Type.lhs b/ghc/compiler/types/Type.lhs
index 333b589..9720470 100644
--- a/ghc/compiler/types/Type.lhs
+++ b/ghc/compiler/types/Type.lhs
@@ -41,7 +41,7 @@ module Type (
 	applyTy, applyTys, isForAllTy, dropForAlls,
 
 	-- Source types
-	isPredTy, predTypeRep, mkPredTy, mkPredTys,
+	predTypeRep, mkPredTy, mkPredTys,
 
 	-- Newtypes
 	splitRecNewType_maybe,
@@ -182,8 +182,7 @@ invariant: use it.
 
 \begin{code}
 mkAppTy orig_ty1 orig_ty2
-  = ASSERT2( not (isPredTy orig_ty1), crudePprType orig_ty1 )	-- Source types are of kind *
-    mk_app orig_ty1
+  = mk_app orig_ty1
   where
     mk_app (NoteTy _ ty1)    = mk_app ty1
     mk_app (NewTcApp tc tys) = NewTcApp tc (tys ++ [orig_ty2])
@@ -206,8 +205,7 @@ mkAppTys orig_ty1 []	    = orig_ty1
 	--   returns to (Ratio Integer), which has needlessly lost
 	--   the Rational part.
 mkAppTys orig_ty1 orig_tys2
-  = ASSERT( not (isPredTy orig_ty1) )	-- Source types are of kind *
-    mk_app orig_ty1
+  = mk_app orig_ty1
   where
     mk_app (NoteTy _ ty1)    = mk_app ty1
     mk_app (NewTcApp tc tys) = NewTcApp tc (tys ++ orig_tys2)
@@ -555,11 +553,6 @@ predTypeRep (IParam _ ty)     = ty
 predTypeRep (ClassP clas tys) = mkTyConApp (classTyCon clas) tys
 	-- Result might be a NewTcApp, but the consumer will
 	-- look through that too if necessary
-
-isPredTy :: Type -> Bool
-isPredTy (NoteTy _ ty) = isPredTy ty
-isPredTy (PredTy sty)  = True
-isPredTy _	       = False
 \end{code}