Simplify the plumbing for checkValidTyCl

Instead of walking over the source decls, and looking up the Name
to find the TyCon or whatever, we just walk over the list of
TyThings that have been brought into scope.  This is much tidier.

The only wrinkle is that, since we don't have the original declaration,
we don't have its SrcSpan to put in the error message.  I fixed this
by making the SrcSpan for the TyCon itself be the span of the whole
declaration.  This actually makes sense anyway.

There are bunch of error message wibbles in consequence.

2 files changed, 42 insertions, 40 deletions

diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs
index 715af25d12..363d49fae0 100644
--- a/compiler/parser/RdrHsSyn.lhs
+++ b/compiler/parser/RdrHsSyn.lhs
@@ -120,7 +120,7 @@ mkClassDecl loc (L _ (mcxt, tycl_hdr)) fds where_cls
              cxt = fromMaybe (noLoc []) mcxt
        ; (cls, tparams) <- checkTyClHdr tycl_hdr
        ; tyvars <- checkTyVars tycl_hdr tparams      -- Only type vars allowed
-       ; return (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls, tcdTyVars = tyvars,
+       ; return (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = reLocate loc cls, tcdTyVars = tyvars,
                                     tcdFDs = unLoc fds, tcdSigs = sigs, tcdMeths = binds,
                                     tcdATs = ats, tcdATDefs = at_defs, tcdDocs  = docs,
                                     tcdFVs = placeHolderNames })) }
@@ -137,7 +137,7 @@ mkTyData loc new_or_data cType (L _ (mcxt, tycl_hdr)) ksig data_cons maybe_deriv
   = do { (tc, tparams) <- checkTyClHdr tycl_hdr
        ; tyvars <- checkTyVars tycl_hdr tparams
        ; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv
-       ; return (L loc (DataDecl { tcdLName = tc, tcdTyVars = tyvars,
+       ; return (L loc (DataDecl { tcdLName = reLocate loc tc, tcdTyVars = tyvars,
                                    tcdDataDefn = defn,
                                    tcdFVs = placeHolderNames })) }
 
@@ -166,7 +166,7 @@ mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv
   = do { checkDatatypeContext mcxt
        ; let cxt = fromMaybe (noLoc []) mcxt
        ; return (HsDataDefn { dd_ND = new_or_data, dd_cType = cType
-                            , dd_ctxt = cxt 
+                            , dd_ctxt = cxt
                             , dd_cons = data_cons
                             , dd_kindSig = ksig
                             , dd_derivs = maybe_deriv }) }
@@ -178,8 +178,8 @@ mkTySynonym :: SrcSpan
 mkTySynonym loc lhs rhs
   = do { (tc, tparams) <- checkTyClHdr lhs
        ; tyvars <- checkTyVars lhs tparams
-       ; return (L loc (SynDecl { tcdLName = tc, tcdTyVars = tyvars,
-                                 tcdRhs = rhs, tcdFVs = placeHolderNames })) }
+       ; return (L loc (SynDecl { tcdLName = reLocate loc tc, tcdTyVars = tyvars
+                                , tcdRhs = rhs, tcdFVs = placeHolderNames })) }
 
 mkTyFamInstEqn :: LHsType RdrName
                -> LHsType RdrName
@@ -205,7 +205,15 @@ mkFamDecl :: SrcSpan
 mkFamDecl loc info lhs ksig
   = do { (tc, tparams) <- checkTyClHdr lhs
        ; tyvars <- checkTyVars lhs tparams
-       ; return (L loc (FamilyDecl info tc tyvars ksig)) }
+       ; return (L loc (FamilyDecl { fdInfo = info, fdLName = reLocate loc tc
+                                   , fdTyVars = tyvars, fdKindSig = ksig })) }
+
+reLocate :: SrcSpan -> Located a -> Located a
+-- For the main binder of a declaration, we make its SrcSpan to
+-- cover the whole declaration, rather than just the syntactic occurrence
+-- of the binder. This makes error messages refer to the declaration as
+-- a whole, rather than just the binding site
+reLocate loc (L _ x) = L loc x
 
 mkTopSpliceDecl :: LHsExpr RdrName -> HsDecl RdrName
 -- If the user wrote
diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs
index c4d24d4188..6736e2d5dc 100644
--- a/compiler/typecheck/TcTyClsDecls.lhs
+++ b/compiler/typecheck/TcTyClsDecls.lhs
@@ -156,7 +156,7 @@ tcTyClGroup boot_details tyclds
            -- expects well-formed TyCons
        ; tcExtendGlobalEnv tyclss $ do
        { traceTc "Starting validity check" (ppr tyclss)
-       ; mapM_ (recoverM (return ()) . addLocM (checkValidTyCl role_annots)) decls
+       ; mapM_ (recoverM (return ()) . checkValidTyCl role_annots) tyclss
            -- We recover, which allows us to report multiple validity errors
 
            -- Step 4: Add the implicit things;
@@ -1350,39 +1350,33 @@ checkClassCycleErrs cls
   = unless (null cls_cycles) $ mapM_ recClsErr cls_cycles
   where cls_cycles = calcClassCycles cls
 
-checkValidDecl :: SDoc -- the context for error checking
-               -> Located Name -> RoleAnnots -> TcM ()
-checkValidDecl ctxt lname role_annots
-  = addErrCtxt ctxt $
-    do  { traceTc "Validity of 1" (ppr lname)
-        ; env <- getGblEnv
-        ; traceTc "Validity of 1a" (ppr (tcg_type_env env))
-        ; thing <- tcLookupLocatedGlobal lname
-        ; traceTc "Validity of 2" (ppr lname)
-        ; traceTc "Validity of" (ppr thing)
-        ; case thing of
-            ATyCon tc -> do
-                traceTc "  of kind" (ppr (tyConKind tc))
-                checkValidTyCon tc role_annots
-            AnId _    -> return ()  -- Generic default methods are checked
-                                    -- with their parent class
-            _         -> panic "checkValidTyCl"
-        ; traceTc "Done validity of" (ppr thing)
-        }
-                          
-checkValidTyCl :: RoleAnnots -> TyClDecl Name -> TcM ()
-checkValidTyCl role_annots decl
-  = do { checkValidDecl (tcMkDeclCtxt decl) (tyClDeclLName decl) role_annots
-       ; case decl of
-           ClassDecl { tcdATs = ats } ->
-             mapM_ (checkValidFamDecl role_annots . unLoc) ats
-           _ -> return () }
-
-checkValidFamDecl :: RoleAnnots -> FamilyDecl Name -> TcM ()
-checkValidFamDecl role_annots (FamilyDecl { fdLName = lname, fdInfo = flav })
-  = checkValidDecl (hsep [ptext (sLit "In the"), ppr flav,
-                          ptext (sLit "declaration for"), quotes (ppr lname)])
-                   lname role_annots
+checkValidTyCl :: RoleAnnots -> TyThing -> TcM ()
+checkValidTyCl role_annots thing
+  = setSrcSpan (getSrcSpan name) $
+    addErrCtxt ctxt $
+    case thing of
+      ATyCon tc -> checkValidTyCon tc role_annots
+      AnId _    -> return ()  -- Generic default methods are checked
+                              -- with their parent class
+      ACoAxiom _ -> return () -- Axioms checked with their parent
+                              -- closed family tycon
+      _         -> pprTrace "checkValidTyCl" (ppr thing) $ return ()
+  where
+    name = getName thing
+    flav = case thing of
+             ATyCon tc
+                | isClassTyCon tc      -> ptext (sLit "class")
+                | isSynFamilyTyCon tc  -> ptext (sLit "type family")
+                | isDataFamilyTyCon tc -> ptext (sLit "data family")
+                | isSynTyCon tc        -> ptext (sLit "type")
+                | isNewTyCon tc        -> ptext (sLit "newtype")
+                | isDataTyCon tc       -> ptext (sLit "data")
+
+             _ -> pprTrace "checkValidTyCl strange" (ppr thing)
+                  empty
+
+    ctxt = hsep [ ptext (sLit "In the"), flav
+                , ptext (sLit "declaration for"), quotes (ppr name) ]
 
 -------------------------
 -- For data types declared with record syntax, we require