Turn AThing into ATcTyCon, in TcTyThing

This change tidies up and simplifies (a bit) the knot-tying
when kind-checking groups of type and class declarations.

The trouble (shown by Trac #11356) was that we wanted an error message
(a kind-mismatch) that involved a type mentioned a (AThing k), which
blew up.

Since we now seem to have TcTyCons, I decided to use them here.
It's still not great, but it's easier to understand and more robust.

7 files changed, 62 insertions, 46 deletions

diff --git a/compiler/typecheck/TcEnv.hs b/compiler/typecheck/TcEnv.hs
index 5381a6d09e..aa87b0ecf8 100644
--- a/compiler/typecheck/TcEnv.hs
+++ b/compiler/typecheck/TcEnv.hs
@@ -23,7 +23,7 @@ module TcEnv(
         lookupGlobal,
 
         -- Local environment
-        tcExtendKindEnv, tcExtendKindEnv2,
+        tcExtendKindEnv2,
         tcExtendTyVarEnv, tcExtendTyVarEnv2,
         tcExtendLetEnv, tcExtendLetEnvIds,
         tcExtendIdEnv, tcExtendIdEnv1, tcExtendIdEnv2,
@@ -367,17 +367,14 @@ getInLocalScope = do { lcl_env <- getLclTypeEnv
 
 tcExtendKindEnv2 :: [(Name, TcTyThing)] -> TcM r -> TcM r
 -- Used only during kind checking, for TcThings that are
---      AThing or APromotionErr
+--      ATcTyCon or APromotionErr
 -- No need to update the global tyvars, or tcl_th_bndrs, or tcl_rdr
 tcExtendKindEnv2 things thing_inside
-  = updLclEnv upd_env thing_inside
+  = do { traceTc "txExtendKindEnv" (ppr things)
+       ; updLclEnv upd_env thing_inside }
   where
     upd_env env = env { tcl_env = extendNameEnvList (tcl_env env) things }
 
-tcExtendKindEnv :: [(Name, TcKind)] -> TcM r -> TcM r
-tcExtendKindEnv nks
-  = tcExtendKindEnv2 $ mapSnd AThing nks
-
 -----------------------
 -- Scoped type and kind variables
 tcExtendTyVarEnv :: [TyVar] -> TcM r -> TcM r
@@ -517,7 +514,7 @@ tcExtendLocalTypeEnv lcl_env@(TcLclEnv { tcl_env = lcl_type_env }) tc_ty_things
     get_tvs (_, ATyVar _ tv) tvs          -- See Note [Global TyVars]
       = tvs `unionVarSet` tyCoVarsOfType (tyVarKind tv) `extendVarSet` tv
 
-    get_tvs (_, AThing k) tvs = tvs `unionVarSet` tyCoVarsOfType k
+    get_tvs (_, ATcTyCon tc) tvs = tvs `unionVarSet` tyCoVarsOfType (tyConKind tc)
 
     get_tvs (_, AGlobal {})       tvs = tvs
     get_tvs (_, APromotionErr {}) tvs = tvs
diff --git a/compiler/typecheck/TcHsType.hs b/compiler/typecheck/TcHsType.hs
index 7e4e1d6d20..f8bf291d5d 100644
--- a/compiler/typecheck/TcHsType.hs
+++ b/compiler/typecheck/TcHsType.hs
@@ -999,12 +999,12 @@ tcTyVar mode name         -- Could be a tyvar, a tycon, or a datacon
        ; case thing of
            ATyVar _ tv -> return (mkTyVarTy tv, tyVarKind tv)
 
-           AThing kind -> do { data_kinds <- xoptM LangExt.DataKinds
-                             ; unless (isTypeLevel (mode_level mode) ||
-                                       data_kinds) $
-                               promotionErr name NoDataKinds
-                             ; tc <- get_loopy_tc name
-                             ; return (mkNakedTyConApp tc [], kind) }
+           ATcTyCon tc_tc -> do { data_kinds <- xoptM LangExt.DataKinds
+                                ; unless (isTypeLevel (mode_level mode) ||
+                                          data_kinds) $
+                                  promotionErr name NoDataKinds
+                                ; tc <- get_loopy_tc name tc_tc
+                                ; return (mkNakedTyConApp tc [], tyConKind tc_tc) }
                              -- mkNakedTyConApp: see Note [Type-checking inside the knot]
                  -- NB: we really should check if we're at the kind level
                  -- and if the tycon is promotable if -XNoTypeInType is set.
@@ -1041,17 +1041,23 @@ tcTyVar mode name         -- Could be a tyvar, a tycon, or a datacon
 
            _  -> wrongThingErr "type" thing name }
   where
-    get_loopy_tc name
+    get_loopy_tc :: Name -> TyCon -> TcM TyCon
+    -- Return the knot-tied global TyCon if there is one
+    -- Otherwise the local TcTyCon; we must be doing kind checking
+    -- but we still want to return a TyCon of some sort to use in
+    -- error messages
+    get_loopy_tc name tc_tc
       = do { env <- getGblEnv
            ; case lookupNameEnv (tcg_type_env env) name of
                 Just (ATyCon tc) -> return tc
-                _                -> return (aThingErr "tcTyVar" name) }
+                _                -> do { traceTc "lk1 (loopy)" (ppr name)
+                                       ; return tc_tc } }
 
 tcClass :: Name -> TcM (Class, TcKind)
 tcClass cls     -- Must be a class
   = do { thing <- tcLookup cls
        ; case thing of
-           AThing kind -> return (aThingErr "tcClass" cls, kind)
+           ATcTyCon tc -> return (aThingErr "tcClass" cls, tyConKind tc)
            AGlobal (ATyCon tc)
              | Just cls <- tyConClass_maybe tc
              -> return (cls, tyConKind tc)
@@ -1651,7 +1657,7 @@ kcLookupKind :: Name -> TcM Kind
 kcLookupKind nm
   = do { tc_ty_thing <- tcLookup nm
        ; case tc_ty_thing of
-           AThing k            -> return k
+           ATcTyCon tc         -> return (tyConKind tc)
            AGlobal (ATyCon tc) -> return (tyConKind tc)
            _                   -> pprPanic "kcLookupKind" (ppr tc_ty_thing) }
 
diff --git a/compiler/typecheck/TcRnTypes.hs b/compiler/typecheck/TcRnTypes.hs
index 7e0a737565..bc2870ba10 100644
--- a/compiler/typecheck/TcRnTypes.hs
+++ b/compiler/typecheck/TcRnTypes.hs
@@ -874,9 +874,10 @@ data TcTyThing
                                 -- for error-message purposes; it is the corresponding
                                 -- Name in the domain of the envt
 
-  | AThing  TcKind   -- Used temporarily, during kind checking, for the
+  | ATcTyCon TyCon   -- Used temporarily, during kind checking, for the
                      -- tycons and clases in this recursive group
-                     -- Can be a mono-kind or a poly-kind; in TcTyClsDcls see
+                     -- The TyCon is always a TcTyCon.  Its kind
+                     -- can be a mono-kind or a poly-kind; in TcTyClsDcls see
                      -- Note [Type checking recursive type and class declarations]
 
   | APromotionErr PromotionErr
@@ -904,7 +905,7 @@ instance Outputable TcTyThing where     -- Debugging only
                                  <> ppr (varType (tct_id elt)) <> comma
                                  <+> ppr (tct_closed elt))
    ppr (ATyVar n tv)    = text "Type variable" <+> quotes (ppr n) <+> equals <+> ppr tv
-   ppr (AThing k)       = text "AThing" <+> ppr k
+   ppr (ATcTyCon tc)    = text "ATcTyCon" <+> ppr tc
    ppr (APromotionErr err) = text "APromotionErr" <+> ppr err
 
 instance Outputable PromotionErr where
@@ -921,7 +922,7 @@ pprTcTyThingCategory :: TcTyThing -> SDoc
 pprTcTyThingCategory (AGlobal thing)    = pprTyThingCategory thing
 pprTcTyThingCategory (ATyVar {})        = ptext (sLit "Type variable")
 pprTcTyThingCategory (ATcId {})         = ptext (sLit "Local identifier")
-pprTcTyThingCategory (AThing {})        = ptext (sLit "Kinded thing")
+pprTcTyThingCategory (ATcTyCon {})     = ptext (sLit "Local tycon")
 pprTcTyThingCategory (APromotionErr pe) = pprPECategory pe
 
 pprPECategory :: PromotionErr -> SDoc
diff --git a/compiler/typecheck/TcTyClsDecls.hs b/compiler/typecheck/TcTyClsDecls.hs
index 482aadcc92..612de5769f 100644
--- a/compiler/typecheck/TcTyClsDecls.hs
+++ b/compiler/typecheck/TcTyClsDecls.hs
@@ -149,7 +149,8 @@ tcTyClGroup tyclds
                  -- Also extend the local type envt with bindings giving
                  -- the (polymorphic) kind of each knot-tied TyCon or Class
                  -- See Note [Type checking recursive type and class declarations]
-             tcExtendKindEnv names_w_poly_kinds              $
+             tcExtendKindEnv2 [ mkTcTyConPair name kind
+                              | (name, kind) <-  names_w_poly_kinds ]    $
 
                  -- Kind and type check declarations for this group
              mapM (tcTyClDecl rec_flags) decls }
@@ -289,8 +290,6 @@ kcTyClGroup (TyClGroup { group_tyclds = decls })
 
              -- Step 3: Set extended envt, kind-check the non-synonyms
              ; setLclEnv lcl_env $
-               tcExtendRecEnv (tcTyConPairs initial_kinds) $
-              -- See Note [Kind checking recursive type and class declarations]
                mapM_ kcLTyClDecl non_syn_decls
 
              ; return lcl_env }
@@ -304,16 +303,11 @@ kcTyClGroup (TyClGroup { group_tyclds = decls })
         ; return res }
 
   where
-    tcTyConPairs :: [(Name,TcTyThing)] -> [(Name,TyThing)]
-    tcTyConPairs initial_kinds = [ (name, ATyCon tc)
-                                 | (name, AThing kind) <- initial_kinds
-                                 , let tc = mkTcTyCon name kind ]
-
     generalise :: TcTypeEnv -> Name -> TcM (Name, Kind)
     -- For polymorphic things this is a no-op
     generalise kind_env name
       = do { let kc_kind = case lookupNameEnv kind_env name of
-                               Just (AThing k) -> k
+                               Just (ATcTyCon tc) -> tyConKind tc
                                _ -> pprPanic "kcTyClGroup" (ppr name $$ ppr kind_env)
            ; kvs <- kindGeneralize kc_kind
            ; kc_kind' <- zonkTcTypeToType emptyZonkEnv kc_kind
@@ -343,6 +337,11 @@ kcTyClGroup (TyClGroup { group_tyclds = decls })
     generaliseFamDecl kind_env (FamilyDecl { fdLName = L _ name })
       = generalise kind_env name
 
+mkTcTyConPair :: Name -> TcKind -> (Name, TcTyThing)
+-- Makes a binding to put in the local envt, binding
+-- a name to a TcTyCon with the specified kind
+mkTcTyConPair name kind = (name,  ATcTyCon (mkTcTyCon name kind))
+
 mk_thing_env :: [LTyClDecl Name] -> [(Name, TcTyThing)]
 mk_thing_env [] = []
 mk_thing_env (decl : decls)
@@ -361,9 +360,10 @@ getInitialKinds decls
     do { pairss <- mapM (addLocM getInitialKind) decls
        ; return (concat pairss) }
 
-getInitialKind :: TyClDecl Name -> TcM [(Name, TcTyThing)]
+getInitialKind :: TyClDecl Name
+               -> TcM [(Name, TcTyThing)]    -- Mixture of ATcTyCon and APromotionErr
 -- Allocate a fresh kind variable for each TyCon and Class
--- For each tycon, return   (tc, AThing k)
+-- For each tycon, return   (name, ATcTyCon (TcCyCon with kind k))
 --                 where k is the kind of tc, derived from the LHS
 --                       of the definition (and probably including
 --                       kind unification variables)
@@ -375,7 +375,7 @@ getInitialKind :: TyClDecl Name -> TcM [(Name, TcTyThing)]
 --   * The result kinds signature on a TyClDecl
 --
 -- ALSO for each datacon, return (dc, APromotionErr RecDataConPE)
--- Note [ARecDataCon: Recursion and promoting data constructors]
+--    See Note [ARecDataCon: Recursion and promoting data constructors]
 --
 -- No family instances are passed to getInitialKinds
 
@@ -385,7 +385,7 @@ getInitialKind decl@(ClassDecl { tcdLName = L _ name, tcdTyVars = ktvs, tcdATs =
            do { inner_prs <- getFamDeclInitialKinds ats
               ; return (constraintKind, inner_prs) }
        ; cl_kind <- zonkTcType cl_kind
-       ; let main_pr = (name, AThing cl_kind)
+       ; let main_pr = mkTcTyConPair name cl_kind
        ; return (main_pr : inner_prs) }
 
 getInitialKind decl@(DataDecl { tcdLName = L _ name
@@ -399,7 +399,7 @@ getInitialKind decl@(DataDecl { tcdLName = L _ name
                            Nothing   -> return liftedTypeKind
               ; return (res_k, ()) }
         ; decl_kind <- zonkTcType decl_kind
-        ; let main_pr = (name, AThing decl_kind)
+        ; let main_pr = mkTcTyConPair name decl_kind
               inner_prs = [ (unLoc con, APromotionErr RecDataConPE)
                           | L _ con' <- cons, con <- getConNames con' ]
         ; return (main_pr : inner_prs) }
@@ -434,7 +434,7 @@ getFamDeclInitialKind decl@(FamilyDecl { fdLName     = L _ name
                         | otherwise                -> newMetaKindVar
               ; return (res_k, ()) }
        ; fam_kind <- zonkTcType fam_kind
-       ; return [ (name, AThing fam_kind) ] }
+       ; return [ mkTcTyConPair name fam_kind ] }
 
 ----------------
 kcSynDecls :: [SCC (LTyClDecl Name)]
@@ -442,8 +442,8 @@ kcSynDecls :: [SCC (LTyClDecl Name)]
 kcSynDecls [] = getLclEnv
 kcSynDecls (group : groups)
   = do  { (n,k) <- kcSynDecl1 group
-        ; lcl_env <- tcExtendKindEnv [(n,k)] (kcSynDecls groups)
-        ; return lcl_env }
+        ; tcExtendKindEnv2 [ mkTcTyConPair n k ] $
+          kcSynDecls groups }
 
 kcSynDecl1 :: SCC (LTyClDecl Name)
            -> TcM (Name,TcKind) -- Kind bindings
@@ -553,10 +553,10 @@ Consider:
 
 When kind checking the `data T' declaration the local env contains the
 mappings:
-  T -> AThing <some initial kind>
-  K -> ARecDataCon
+  T -> ATcTyCon <some initial kind>
+  K -> APromotionErr
 
-ANothing is only used for DataCons, and only used during type checking
+APromotionErr is only used for DataCons, and only used during type checking
 in tcTyClGroup.
 
 
@@ -594,8 +594,8 @@ kind-checking the RHS of T's decl, we *do* need to know T's kind (so
 that we can correctly elaboarate (T k f a).  How can we get T's kind
 without looking at T?  Delicate answer: during tcTyClDecl, we extend
 
-  *Global* env with T -> ATyCon (the (not yet built) TyCon for T)
-  *Local*  env with T -> AThing (polymorphic kind of T)
+  *Global* env with T -> ATyCon (the (not yet built) final TyCon for T)
+  *Local*  env with T -> ATcTyCon (TcTyCon with the polymorphic kind of T)
 
 Then:
 
@@ -621,7 +621,7 @@ using this initial kind for recursive occurrences.
 
 The initial kind is stored in exactly the same way during kind-checking
 as it is during type-checking (Note [Type checking recursive type and class
-declarations]): in the *local* environment, with AThing. But we still
+declarations]): in the *local* environment, with ATcTyCon. But we still
 must store *something* in the *global* environment. Even though we
 discard the result of kind-checking, we sometimes need to produce error
 messages. These error messages will want to refer to the tycons being
diff --git a/testsuite/tests/typecheck/should_fail/T11356.hs b/testsuite/tests/typecheck/should_fail/T11356.hs
new file mode 100644
index 0000000000..8139135b7e
--- /dev/null
+++ b/testsuite/tests/typecheck/should_fail/T11356.hs
@@ -0,0 +1,6 @@
+module T11356 where
+
+class T p p => C p
+
+type T x = C x
+
diff --git a/testsuite/tests/typecheck/should_fail/T11356.stderr b/testsuite/tests/typecheck/should_fail/T11356.stderr
new file mode 100644
index 0000000000..803dcabf95
--- /dev/null
+++ b/testsuite/tests/typecheck/should_fail/T11356.stderr
@@ -0,0 +1,5 @@
+
+T11356.hs:3:7: error:
+    • Expecting one fewer argument to ‘T p’
+      Expected kind ‘k0 -> Constraint’, but ‘T p’ has kind ‘Constraint’
+    • In the class declaration for ‘C’
diff --git a/testsuite/tests/typecheck/should_fail/all.T b/testsuite/tests/typecheck/should_fail/all.T
index 93dd0c770e..753708d27f 100644
--- a/testsuite/tests/typecheck/should_fail/all.T
+++ b/testsuite/tests/typecheck/should_fail/all.T
@@ -398,4 +398,5 @@ test('T11112', normal, compile_fail, [''])
 test('ClassOperator', normal, compile_fail, [''])
 test('T11274', normal, compile_fail, [''])
 test('T10619', normal, compile_fail, [''])
-test('T11347', expect_broken(11347), compile_fail, [''])
+test('T11347', normal, compile_fail, [''])
+test('T11356', normal, compile_fail, [''])