[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 (file)
--- 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 (file)
--- 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 (file)
--- 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}