From: simonpj <unknown>
Date: Tue, 14 Aug 2001 16:28:00 +0000 (+0000)
Subject: [project @ 2001-08-14 16:28:00 by simonpj]
X-Git-Tag: Approximately_9120_patches~1260
X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=ba7c8891f00bd0d62c707678fec8865f15abefe7;hp=2b09da898f6f208ab6407aa5507fb11cf24a562e;p=ghc-hetmet.git

[project @ 2001-08-14 16:28:00 by simonpj]
More wibbles in checking type validity
---

diff --git a/ghc/compiler/typecheck/TcMType.lhs b/ghc/compiler/typecheck/TcMType.lhs
index df60bee..d2d052b 100644
--- a/ghc/compiler/typecheck/TcMType.lhs
+++ b/ghc/compiler/typecheck/TcMType.lhs
@@ -831,19 +831,19 @@ freeErr pred
 	 nest 4 (ptext SLIT("At least one must be universally quantified here"))
     ]
 
-forAllTyErr     ty = ptext SLIT("Illegal polymorphic type:") <+> ppr ty
-usageTyErr      ty = ptext SLIT("Illegal usage 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
+forAllTyErr     ty = ptext SLIT("Illegal polymorphic type:") <+> ppr_ty ty
+usageTyErr      ty = ptext SLIT("Illegal usage type:") <+> ppr_ty ty
+unliftedArgErr  ty = ptext SLIT("Illegal unlifted type argument:") <+> ppr_ty ty
+ubxArgTyErr     ty = ptext SLIT("Illegal unboxed tuple type as function argument:") <+> ppr_ty ty
 badSourceTyErr sty = ptext SLIT("Illegal constraint") <+> pprSourceType sty
 predTyVarErr pred  = ptext SLIT("Non-type variables in constraint:") <+> pprPred pred
 kindErr kind       = ptext SLIT("Expecting an ordinary type, but found a type of kind") <+> ppr kind
 dupPredWarn dups   = ptext SLIT("Duplicate constraint(s):") <+> pprWithCommas pprPred (map head dups)
 
 checkTypeCtxt ctxt ty
-  = vcat [ptext SLIT("In the type:") <+> ppr_ty,
+  = vcat [ptext SLIT("In the type:") <+> ppr_ty ty,
 	  ptext SLIT("While checking") <+> pprUserTypeCtxt ctxt ]
-  where  
+
 	-- Hack alert.  If there are no tyvars, (ppr sigma_ty) will print
 	-- something strange like {Eq k} -> k -> k, because there is no
 	-- ForAll at the top of the type.  Since this is going to the user
@@ -852,9 +852,10 @@ checkTypeCtxt ctxt ty
 	-- This shows up in the complaint about
 	--	case C a where
 	--	  op :: Eq a => a -> a
-    ppr_ty | null forall_tyvars = pprTheta theta <+> ptext SLIT("=>") <+> ppr tau
-	   | otherwise	 	= ppr ty
-    (forall_tyvars, theta, tau) = tcSplitSigmaTy ty
+ppr_ty ty | null forall_tvs && not (null theta) = pprTheta theta <+> ptext SLIT("=>") <+> ppr tau
+          | otherwise	 		     = ppr ty
+          where
+	    (forall_tvs, theta, tau) = tcSplitSigmaTy ty
 
 checkThetaCtxt ctxt theta
   = vcat [ptext SLIT("In the context:") <+> pprTheta theta,
diff --git a/ghc/compiler/typecheck/TcTyClsDecls.lhs b/ghc/compiler/typecheck/TcTyClsDecls.lhs
index ecc43a8..d26184d 100644
--- a/ghc/compiler/typecheck/TcTyClsDecls.lhs
+++ b/ghc/compiler/typecheck/TcTyClsDecls.lhs
@@ -173,10 +173,12 @@ tcGroup unf_env this_mod scc
     )						`thenTc` \ (_, tyclss, env) ->
 
 
-	-- Step 7: Check validity; but only for things defined in this module
-    traceTc (text "ready for validity check")				`thenTc_`
-    mapTc_ checkValidTyCl (filter (isLocalThing this_mod) tyclss)	`thenTc_`
-    traceTc (text "done")						`thenTc_`
+	-- Step 7: Check validity
+    traceTc (text "ready for validity check")	`thenTc_`
+    tcSetEnv env (
+	mapTc_ (checkValidTyCl this_mod) decls
+    )						`thenTc_`
+    traceTc (text "done")			`thenTc_`
    
     returnTc env
 
@@ -193,8 +195,16 @@ tcTyClDecl1 unf_env decl
   | isClassDecl decl = tcAddDeclCtxt decl (tcClassDecl1 unf_env decl)
   | otherwise	     = tcAddDeclCtxt decl (tcTyDecl     unf_env decl)
 
-checkValidTyCl (ATyCon tc) = checkValidTyCon tc
-checkValidTyCl (AClass cl) = checkValidClass cl
+checkValidTyCl this_mod decl
+  = tcLookup (tcdName decl)	`thenNF_Tc` \ (AGlobal thing) ->
+    if not (isLocalThing this_mod thing) then
+	-- Don't bother to check validity for non-local things
+	returnTc ()
+    else
+    tcAddDeclCtxt decl $
+    case thing of
+	ATyCon tc -> checkValidTyCon tc
+	AClass cl -> checkValidClass cl
 \end{code}