Fix #16008 with a pinch of addConsistencyConstraints

Summary:
#16008 happened because we forgot to typecheck nullary
associated type family instances in a way that's consistent with the
type variables bound by the parent class. Oops. Easily fixed with a
use of `checkConsistencyConstraints`.

Test Plan: make test TEST=T16008

Reviewers: simonpj, goldfire, bgamari

Reviewed By: goldfire

Subscribers: rwbarton, carter

GHC Trac Issues: #16008

Differential Revision: https://phabricator.haskell.org/D5435

2 files changed, 12 insertions, 9 deletions

diff --git a/compiler/typecheck/TcInstDcls.hs b/compiler/typecheck/TcInstDcls.hs
index 2fb9857ed3..c6628a5383 100644
--- a/compiler/typecheck/TcInstDcls.hs
+++ b/compiler/typecheck/TcInstDcls.hs
@@ -793,7 +793,10 @@ tcDataFamHeader mb_clsinfo fam_tc imp_vars mb_bndrs fixity hs_ctxt hs_pats m_ksi
                bindImplicitTKBndrs_Q_Skol imp_vars          $
                bindExplicitTKBndrs_Q_Skol AnyKind exp_bndrs $
                do { stupid_theta <- tcHsContext hs_ctxt
-                  ; (lhs_ty, lhs_kind) <- tcFamTyPats fam_tc mb_clsinfo hs_pats
+                  ; (lhs_ty, lhs_kind) <- tcFamTyPats fam_tc hs_pats
+                    -- Ensure that the instance is consistent with its
+                    -- parent class
+                  ; addConsistencyConstraints mb_clsinfo lhs_ty
                   ; mapM_ (wrapLocM_ kcConDecl) hs_cons
                   ; res_kind <- tc_kind_sig m_ksig
                   ; lhs_ty <- checkExpectedKindX pp_lhs lhs_ty lhs_kind res_kind
diff --git a/compiler/typecheck/TcTyClsDecls.hs b/compiler/typecheck/TcTyClsDecls.hs
index 877166dfd5..cc9779a0bc 100644
--- a/compiler/typecheck/TcTyClsDecls.hs
+++ b/compiler/typecheck/TcTyClsDecls.hs
@@ -18,7 +18,7 @@ module TcTyClsDecls (
         kcConDecl, tcConDecls, dataDeclChecks, checkValidTyCon,
         tcFamTyPats, tcTyFamInstEqn,
         tcAddTyFamInstCtxt, tcMkDataFamInstCtxt, tcAddDataFamInstCtxt,
-        unravelFamInstPats,
+        unravelFamInstPats, addConsistencyConstraints,
         wrongKindOfFamily
     ) where
 
@@ -1741,7 +1741,7 @@ kcTyFamInstEqn tc_fam_tc
        ; discardResult $
          bindImplicitTKBndrs_Q_Tv imp_vars $
          bindExplicitTKBndrs_Q_Tv AnyKind (mb_expl_bndrs `orElse` []) $
-         do { (_, res_kind) <- tcFamTyPats tc_fam_tc NotAssociated hs_pats
+         do { (_, res_kind) <- tcFamTyPats tc_fam_tc hs_pats
             ; tcCheckLHsType hs_rhs_ty res_kind }
              -- Why "_Tv" here?  Consider (Trac #14066
              --  type family Bar x y where
@@ -1870,6 +1870,9 @@ tcTyFamInstEqnGuts fam_tc mb_clsinfo imp_vars exp_bndrs hs_pats hs_rhs_ty
                   bindImplicitTKBndrs_Q_Skol imp_vars          $
                   bindExplicitTKBndrs_Q_Skol AnyKind exp_bndrs $
                   do { (lhs_ty, rhs_kind) <- tc_lhs
+                       -- Ensure that the instance is consistent with its
+                       -- parent class (#16008)
+                     ; addConsistencyConstraints mb_clsinfo lhs_ty
                      ; rhs_ty <- tcCheckLHsType hs_rhs_ty rhs_kind
                      ; return (lhs_ty, rhs_ty) }
 
@@ -1900,7 +1903,7 @@ tcTyFamInstEqnGuts fam_tc mb_clsinfo imp_vars exp_bndrs hs_pats hs_rhs_ty
                                                            (tyConKind  fam_tc)
                 ; return (mkTyConApp fam_tc args, rhs_kind) }
            | otherwise
-           = tcFamTyPats fam_tc mb_clsinfo hs_pats
+           = tcFamTyPats fam_tc hs_pats
 
 {- Note [Apparently-nullary families]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1932,11 +1935,11 @@ Inferred quantifiers always come first.
 
 
 -----------------
-tcFamTyPats :: TyCon -> AssocInstInfo
+tcFamTyPats :: TyCon
             -> HsTyPats GhcRn                -- Patterns
             -> TcM (TcType, TcKind)          -- (lhs_type, lhs_kind)
 -- Used for both type and data families
-tcFamTyPats fam_tc mb_clsinfo hs_pats
+tcFamTyPats fam_tc hs_pats
   = do { traceTc "tcFamTyPats {" $
          vcat [ ppr fam_tc <+> dcolon <+> ppr fam_kind
               , text "arity:" <+> ppr fam_arity
@@ -1951,9 +1954,6 @@ tcFamTyPats fam_tc mb_clsinfo hs_pats
          vcat [ ppr fam_tc <+> dcolon <+> ppr fam_kind
               , text "res_kind:" <+> ppr res_kind ]
 
-       -- Ensure that the instance is consistent its parent class
-       ; addConsistencyConstraints mb_clsinfo fam_app
-
        ; return (fam_app, res_kind) }
   where
     fam_name  = tyConName fam_tc