Fix #16008 with a pinch of addConsistencyConstraints
authorRyan Scott <ryan.gl.scott@gmail.com>
Tue, 11 Dec 2018 11:22:49 +0000 (06:22 -0500)
committerRyan Scott <ryan.gl.scott@gmail.com>
Tue, 11 Dec 2018 11:22:49 +0000 (06:22 -0500)
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

compiler/typecheck/TcInstDcls.hs
compiler/typecheck/TcTyClsDecls.hs
testsuite/tests/typecheck/should_compile/T16008.hs [new file with mode: 0644]
testsuite/tests/typecheck/should_compile/all.T

index 2fb9857..c6628a5 100644 (file)
@@ -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
index 877166d..cc9779a 100644 (file)
@@ -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 (file)
index 0000000..26426e5
--- /dev/null
@@ -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
index 99c2259..bebdc6c 100644 (file)
@@ -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, [''])