[commit: ghc] master: Fix #16008 with a pinch of addConsistencyConstraints (3899966)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/3899966e4613ec18f365c28d64e9acc163cc1165/ghc

>---------------------------------------------------------------

commit 3899966e4613ec18f365c28d64e9acc163cc1165
Author: Ryan Scott <ryan.gl.scott at gmail.com>
Date:   Tue Dec 11 06:22:49 2018 -0500

    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


>---------------------------------------------------------------

3899966e4613ec18f365c28d64e9acc163cc1165
 compiler/typecheck/TcInstDcls.hs                   |  5 ++++-
 compiler/typecheck/TcTyClsDecls.hs                 | 16 ++++++++--------
 testsuite/tests/typecheck/should_compile/T16008.hs | 16 ++++++++++++++++
 testsuite/tests/typecheck/should_compile/all.T     |  1 +
 4 files changed, 29 insertions(+), 9 deletions(-)

diff --git a/compiler/typecheck/TcInstDcls.hs b/compiler/typecheck/TcInstDcls.hs
index 2fb9857..c6628a5 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 877166d..cc9779a 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
diff --git a/testsuite/tests/typecheck/should_compile/T16008.hs b/testsuite/tests/typecheck/should_compile/T16008.hs
new file mode 100644
index 0000000..26426e5
--- /dev/null
+++ b/testsuite/tests/typecheck/should_compile/T16008.hs
@@ -0,0 +1,16 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
+module T16008 where
+
+import Data.Kind
+
+class C k where
+  type S :: k -> Type
+
+data D :: Type -> Type
+data SD :: forall a. D a -> Type
+
+instance C (D a) where
+  type S = SD
diff --git a/testsuite/tests/typecheck/should_compile/all.T b/testsuite/tests/typecheck/should_compile/all.T
index 99c2259..bebdc6c 100644
--- a/testsuite/tests/typecheck/should_compile/all.T
+++ b/testsuite/tests/typecheck/should_compile/all.T
@@ -655,3 +655,4 @@ test('T15586', normal, compile, [''])
 test('T15368', normal, compile, ['-fdefer-type-errors'])
 test('T15778', normal, compile, [''])
 test('T14761c', normal, compile, [''])
+test('T16008', normal, compile, [''])