X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcMType.lhs;h=492cbf9edaf8754121e3f9d8658ac2b61b7c2446;hb=0884a2cb09cd5f609b6163a225ca3b8cce942250;hp=94c2d25b60074cb093bd89266d0a43c3e3caa64e;hpb=46b7ded55b37bcfccb1563625af1e45454524120;p=ghc-hetmet.git

diff --git a/compiler/typecheck/TcMType.lhs b/compiler/typecheck/TcMType.lhs
index 94c2d25..492cbf9 100644
--- a/compiler/typecheck/TcMType.lhs
+++ b/compiler/typecheck/TcMType.lhs
@@ -70,7 +70,8 @@ import TyCon
 import Var
 
 -- others:
-import TcRnMonad          -- TcType, amongst others
+import HsSyn		-- HsType
+import TcRnMonad        -- TcType, amongst others
 import FunDeps
 import Name
 import VarEnv
@@ -1078,12 +1079,14 @@ checkValidType ctxt ty = do
 	              ThBrackCtxt | unboxed -> UT_Ok
 	              _                     -> UT_NotOk
 
-	-- Check that the thing has kind Type, and is lifted if necessary
-    checkTc kind_ok (kindErr actual_kind)
-
 	-- Check the internal validity of the type itself
     check_type rank ubx_tup ty
 
+	-- Check that the thing has kind Type, and is lifted if necessary
+	-- Do this second, becuase we can't usefully take the kind of an 
+	-- ill-formed type such as (a~Int)
+    checkTc kind_ok (kindErr actual_kind)
+
     traceTc (text "checkValidType done" <+> ppr ty)
 
 checkValidMonoType :: Type -> TcM ()
@@ -1138,15 +1141,12 @@ check_type rank ubx_tup ty
   where
     (tvs, theta, tau) = tcSplitSigmaTy ty
    
--- 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_type _ _ (PredTy sty)
-  = do	{ dflags <- getDOpts
-	; check_pred_ty dflags TypeCtxt sty }
+-- Naked PredTys should, I think, have been rejected before now
+check_type _ _ ty@(PredTy {})
+  = failWithTc (text "Predicate used as a type:" <+> ppr ty)
 
 check_type _ _ (TyVarTy _) = return ()
+
 check_type rank _ (FunTy arg_ty res_ty)
   = do	{ check_type (decRank rank) UT_NotOk arg_ty
 	; check_type rank 	    UT_Ok    res_ty }
@@ -1639,11 +1639,15 @@ instTypeErr pp_ty msg
 %*									*
 %************************************************************************
 
-
 \begin{code}
-checkValidInstance :: [TyVar] -> ThetaType -> Class -> [TcType] -> TcM ()
-checkValidInstance tyvars theta clas inst_tys
-  = do	{ undecidable_ok <- doptM Opt_UndecidableInstances
+checkValidInstance :: LHsType Name -> [TyVar] -> ThetaType -> Type 
+                   -> TcM (Class, [TcType])
+checkValidInstance hs_type tyvars theta tau
+  = setSrcSpan (getLoc hs_type) $
+    do	{ (clas, inst_tys) <- setSrcSpan head_loc $
+                              checkValidInstHead tau
+
+        ; undecidable_ok <- doptM Opt_UndecidableInstances
 
 	; checkValidTheta InstThetaCtxt theta
 	; checkAmbiguity tyvars theta (tyVarsOfTypes inst_tys)
@@ -1657,10 +1661,17 @@ checkValidInstance tyvars theta clas inst_tys
 	-- The Coverage Condition
 	; checkTc (undecidable_ok || checkInstCoverage clas inst_tys)
 	  	  (instTypeErr (pprClassPred clas inst_tys) msg)
+
+        ; return (clas, inst_tys)
 	}
   where
     msg  = parens (vcat [ptext (sLit "the Coverage Condition fails for one of the functional dependencies;"),
 			 undecidableMsg])
+
+	-- The location of the "head" of the instance
+    head_loc = case hs_type of
+                 L _ (HsForAllTy _ _ _ (L loc _)) -> loc
+                 L loc _                          -> loc
 \end{code}
 
 Termination test: the so-called "Paterson conditions" (see Section 5 of
@@ -1728,7 +1739,6 @@ Notice that this instance (just) satisfies the Paterson termination
 conditions.  Then we *could* derive an instance decl like this:
 
 	instance (C Int a, Eq b, Eq c) => Eq (T a b c) 
-
 even though there is no instance for (C Int a), because there just
 *might* be an instance for, say, (C Int Bool) at a site where we
 need the equality instance for T's.