X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcMType.lhs;h=09bbc26fbd3aeb721bbc7c946843b492072d6740;hb=8459e1aa09423e15bddccb97820bc1481c40a520;hp=a44484285516ad646f0d15dfc20157c276f5d39d;hpb=23f40f0e9be6d4aa5cf9ea31d73f4013f8e7b4bd;p=ghc-hetmet.git

diff --git a/ghc/compiler/typecheck/TcMType.lhs b/ghc/compiler/typecheck/TcMType.lhs
index a444842..09bbc26 100644
--- a/ghc/compiler/typecheck/TcMType.lhs
+++ b/ghc/compiler/typecheck/TcMType.lhs
@@ -52,7 +52,7 @@ import TypeRep		( Type(..), PredType(..), TyNote(..),	 -- Friend; can see repres
 import TcType		( TcType, TcThetaType, TcTauType, TcPredType,
 			  TcTyVarSet, TcKind, TcTyVar, TcTyVarDetails(..), 
 			  MetaDetails(..), SkolemInfo(..), isMetaTyVar, metaTvRef,
-			  tcEqType, tcCmpPred, isClassPred, 
+			  tcCmpPred, isClassPred, 
 			  tcSplitPhiTy, tcSplitPredTy_maybe, tcSplitAppTy_maybe, 
 			  tcSplitTyConApp_maybe, tcSplitForAllTys,
 			  tcIsTyVarTy, tcSplitSigmaTy, tcIsTyVarTy,
@@ -70,7 +70,7 @@ import Type		( TvSubst, zipTopTvSubst, substTy )
 import Class		( Class, classArity, className )
 import TyCon		( TyCon, isSynTyCon, isUnboxedTupleTyCon, 
 			  tyConArity, tyConName )
-import Var		( TyVar, tyVarKind, tyVarName, isTyVar, 
+import Var		( TyVar, tyVarKind, tyVarName, 
 			  mkTyVar, mkTcTyVar, tcTyVarDetails, isTcTyVar )
 
 -- others:
@@ -394,7 +394,7 @@ zonkTcPredType (IParam n t)
 \begin{code}
 zonkQuantifiedTyVar :: TcTyVar -> TcM TyVar
 -- zonkQuantifiedTyVar is applied to the a TcTyVar when quantifying over it.
--- It might be a meta TyVar, in which case we freeze it inot ano ordinary TyVar.
+-- It might be a meta TyVar, in which case we freeze it into an ordinary TyVar.
 -- When we do this, we also default the kind -- see notes with Kind.defaultKind
 -- The meta tyvar is updated to point to the new regular TyVar.  Now any 
 -- bound occurences of the original type variable will get zonked to 
@@ -486,9 +486,6 @@ zonkType unbound_var_fn rflag ty
     go (TyConApp tycon tys)	  = mappM go tys	`thenM` \ tys' ->
 				    returnM (TyConApp tycon tys')
 
-    go (NewTcApp tycon tys)	  = mappM go tys	`thenM` \ tys' ->
-				    returnM (NewTcApp tycon tys')
-
     go (NoteTy (SynNote ty1) ty2) = go ty1		`thenM` \ ty1' ->
 				    go ty2		`thenM` \ ty2' ->
 				    returnM (NoteTy (SynNote ty1') ty2')
@@ -525,9 +522,8 @@ zonkTyVar :: (TcTyVar -> TcM Type)		-- What to do for an unbound mutable variabl
           -> Bool                               -- Consult the type refinement?
  	  -> TcTyVar -> TcM TcType
 zonkTyVar unbound_var_fn rflag tyvar 
-  | not (isTcTyVar tyvar)	-- This can happen when
-				-- zonking a forall type, when the bound type variable
-				-- needn't be mutable
+  | not (isTcTyVar tyvar)	-- When zonking (forall a.  ...a...), the occurrences of 
+				-- the quantified variable a are TyVars not TcTyVars
   = returnM (TyVarTy tyvar)
 
   | otherwise
@@ -765,9 +761,17 @@ check_tau_type :: Rank -> UbxTupFlag -> Type -> TcM ()
 -- Rank is allowed rank for function args
 -- No foralls otherwise
 
-check_tau_type rank ubx_tup ty@(ForAllTy _ _) = failWithTc (forAllTyErr ty)
-check_tau_type rank ubx_tup (PredTy sty)    = getDOpts		`thenM` \ dflags ->
-						check_source_ty dflags TypeCtxt sty
+check_tau_type rank ubx_tup ty@(ForAllTy _ _)       = failWithTc (forAllTyErr ty)
+check_tau_type rank ubx_tup ty@(FunTy (PredTy _) _) = failWithTc (forAllTyErr ty)
+	-- Reject e.g. (Maybe (?x::Int => Int)), with a decent error message
+
+-- Naked PredTys don't usually show up, but they can as a result of
+--	{-# SPECIALISE instance Ord Char #-}
+-- The Right Thing would be to fix the way that SPECIALISE instance pragmas
+-- are handled, but the quick thing is just to permit PredTys here.
+check_tau_type rank ubx_tup (PredTy sty) = getDOpts		`thenM` \ dflags ->
+					   check_source_ty dflags TypeCtxt sty
+
 check_tau_type rank ubx_tup (TyVarTy _)       = returnM ()
 check_tau_type rank ubx_tup ty@(FunTy arg_ty res_ty)
   = check_poly_type rank UT_NotOk arg_ty	`thenM_`
@@ -802,9 +806,6 @@ check_tau_type rank ubx_tup (NoteTy (SynNote syn) ty)
 check_tau_type rank ubx_tup (NoteTy other_note ty)
   = check_tau_type rank ubx_tup ty
 
-check_tau_type rank ubx_tup (NewTcApp tc tys)
-  = mappM_ check_arg_type tys
-
 check_tau_type rank ubx_tup ty@(TyConApp tc tys)
   | isSynTyCon tc	
   = 	-- NB: Type.mkSynTy builds a TyConApp (not a NoteTy) for an unsaturated
@@ -838,7 +839,7 @@ check_tau_type rank ubx_tup ty@(TyConApp tc tys)
     ubx_tup_msg = ubxArgTyErr ty
 
 ----------------------------------------
-forAllTyErr     ty = ptext SLIT("Illegal polymorphic type:") <+> ppr ty
+forAllTyErr     ty = ptext SLIT("Illegal polymorphic or qualified type:") <+> ppr ty
 unliftedArgErr  ty = ptext SLIT("Illegal unlifted type argument:") <+> ppr ty
 ubxArgTyErr     ty = ptext SLIT("Illegal unboxed tuple type as function argument:") <+> ppr ty
 kindErr kind       = ptext SLIT("Expecting an ordinary type, but found a type of kind") <+> ppr kind