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