[commit: ghc] master: Fix typecheck of default associated type decls (cb24e68)

git at git.haskell.org git at git.haskell.org
Mon Jan 18 10:43:27 UTC 2016


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

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

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

commit cb24e684759f3d181a104cde76f0f95da896a7ef
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date:   Mon Jan 18 10:43:47 2016 +0000

    Fix typecheck of default associated type decls
    
    This bug was thrown up by Trac #11361, but I found that the
    problem was deeper: GHC was allowing
    
      class C a where
        type F (a :: k) :: *
        type F (x :: *) = x    -- Not right!
    
    (Which is now indexed-types/should_compile/T11361a.)
    
    Anyway the fix is relatively simple; use tcMatchTys in
    tcDefaultAssocDecl.
    
    Merge to 8.0 branch.


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

cb24e684759f3d181a104cde76f0f95da896a7ef
 compiler/typecheck/TcTyClsDecls.hs                 | 67 +++++++++++++++-------
 .../should_compile/T11361.hs}                      |  5 +-
 .../tests/indexed-types/should_compile/T11361a.hs  |  7 +++
 .../indexed-types/should_compile/T11361a.stderr    |  5 ++
 testsuite/tests/indexed-types/should_compile/all.T |  2 +
 5 files changed, 65 insertions(+), 21 deletions(-)

diff --git a/compiler/typecheck/TcTyClsDecls.hs b/compiler/typecheck/TcTyClsDecls.hs
index e622c15..f6a5c9f 100644
--- a/compiler/typecheck/TcTyClsDecls.hs
+++ b/compiler/typecheck/TcTyClsDecls.hs
@@ -971,42 +971,64 @@ tcDefaultAssocDecl _ (d1:_:_)
 tcDefaultAssocDecl fam_tc [L loc (TyFamEqn { tfe_tycon = L _ tc_name
                                            , tfe_pats = hs_tvs
                                            , tfe_rhs = rhs })]
-  = setSrcSpan loc $
+  | HsQTvs { hsq_implicit = imp_vars, hsq_explicit = exp_vars } <- hs_tvs
+  = -- See Note [Type-checking default assoc decls]
+    setSrcSpan loc $
     tcAddFamInstCtxt (ptext (sLit "default type instance")) tc_name $
     do { traceTc "tcDefaultAssocDecl" (ppr tc_name)
-       ; let shape@(fam_name, fam_pat_arity, _) = famTyConShape fam_tc
-             fam_tc_tvs                         = tyConTyVars fam_tc
+       ; let shape@(fam_tc_name, fam_arity, _) = famTyConShape fam_tc
 
        -- Kind of family check
-       ; checkTc (isTypeFamilyTyCon fam_tc) (wrongKindOfFamily fam_tc)
+       ; ASSERT( fam_tc_name == tc_name )
+         checkTc (isTypeFamilyTyCon fam_tc) (wrongKindOfFamily fam_tc)
 
        -- Arity check
-       ; ASSERT( fam_name == tc_name )
-         checkTc (length (hsQTvExplicit hs_tvs) == fam_pat_arity)
-                 (wrongNumberOfParmsErr fam_pat_arity)
+       ; checkTc (length exp_vars == fam_arity)
+                 (wrongNumberOfParmsErr fam_arity)
 
        -- Typecheck RHS
-       -- Oddly, we don't pass in any enclosing class info, and we treat
-       -- this as a top-level type instance. Type family defaults are renamed
-       -- outside the scope of their enclosing class and so the ClsInfo would
-       -- be of no use.
-       ; let HsQTvs { hsq_implicit = imp_vars, hsq_explicit = exp_vars } = hs_tvs
-             pats = HsIB { hsib_vars = imp_vars ++ map hsLTyVarName exp_vars
+       ; let pats = HsIB { hsib_vars = imp_vars ++ map hsLTyVarName exp_vars
                          , hsib_body = map hsLTyVarBndrToType exp_vars }
           -- NB: Use tcFamTyPats, not tcTyClTyVars. The latter expects to get
           -- the LHsQTyVars used for declaring a tycon, but the names here
           -- are different.
-       ; (ktvs, rhs_ty)
+       ; (pats', rhs_ty)
            <- tcFamTyPats shape Nothing pats
-              (discardResult . tcCheckLHsType rhs) $ \ktvs _ rhs_kind ->
+              (discardResult . tcCheckLHsType rhs) $ \_ pats' rhs_kind ->
               do { rhs_ty <- solveEqualities $
                              tcCheckLHsType rhs rhs_kind
-                 ; return (ktvs, rhs_ty) }
-
+                 ; return (pats', rhs_ty) }
+       -- pats' is fully zonked already
        ; rhs_ty <- zonkTcTypeToType emptyZonkEnv rhs_ty
-       ; let subst = zipTopTCvSubst ktvs (mkTyVarTys fam_tc_tvs)
-       ; return ( Just (substTy subst rhs_ty, loc) ) }
-    -- We check for well-formedness and validity later, in checkValidClass
+
+         -- See Note [Type-checking default assoc decls]
+       ; case tcMatchTys pats' (mkTyVarTys (tyConTyVars fam_tc)) of
+           Just subst -> return ( Just (substTy subst rhs_ty, loc) )
+           Nothing    -> failWithTc (defaultAssocKindErr fam_tc)
+           -- We check for well-formedness and validity later,
+           -- in checkValidClass
+     }
+
+{- Note [Type-checking default assoc decls]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider this default declaration for an associated type
+
+   class C a where
+      type F (a :: k) b :: *
+      type F x y = Proxy x -> y
+
+Note that the class variable 'a' doesn't scope over the default assoc
+decl (rather oddly I think), and (less oddly) neither does the second
+argument 'b' of the associated type 'F', or the kind variable 'k'.
+Instead, the default decl is treated more like a top-level type
+instance.
+
+However we store the default rhs (Proxy x -> y) in F's TyCon, using
+F's own type variables, so we need to convert it to (Proxy a -> b).
+We do this by calling tcMatchTys to match them up.  This also ensures
+that x's kind matches a's and similarly for y and b.  The error
+message isnt' great, mind you.  (Trac #11361 was caused by not doing a
+proper tcMatchTys here.)  -}
 
 -------------------------
 kcTyFamInstEqn :: FamTyConShape -> LTyFamInstEqn Name -> TcM ()
@@ -2544,6 +2566,11 @@ wrongNumberOfParmsErr max_args
   = ptext (sLit "Number of parameters must match family declaration; expected")
     <+> ppr max_args
 
+defaultAssocKindErr :: TyCon -> SDoc
+defaultAssocKindErr fam_tc
+  = ptext (sLit "Kind mis-match on LHS of default declaration for")
+    <+> quotes (ppr fam_tc)
+
 wrongTyFamName :: Name -> Name -> SDoc
 wrongTyFamName fam_tc_name eqn_tc_name
   = hang (ptext (sLit "Mismatched type name in type family instance."))
diff --git a/testsuite/tests/typecheck/should_compile/tc253.hs b/testsuite/tests/indexed-types/should_compile/T11361.hs
similarity index 83%
copy from testsuite/tests/typecheck/should_compile/tc253.hs
copy to testsuite/tests/indexed-types/should_compile/T11361.hs
index 2fd528b..61b412a 100644
--- a/testsuite/tests/typecheck/should_compile/tc253.hs
+++ b/testsuite/tests/indexed-types/should_compile/T11361.hs
@@ -1,7 +1,10 @@
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE UndecidableInstances #-}
   -- this is needed because |FamHelper a x| /< |Fam a x|
-module ShouldCompile where
+{-# OPTIONS_GHC -dinitial-unique=16777000 -dunique-increment=-1 #-}
+  -- This is what made GHC crash before
+
+module T11361 where
 
 class Cls a where
     type Fam a b :: *
diff --git a/testsuite/tests/indexed-types/should_compile/T11361a.hs b/testsuite/tests/indexed-types/should_compile/T11361a.hs
new file mode 100644
index 0000000..66ab056
--- /dev/null
+++ b/testsuite/tests/indexed-types/should_compile/T11361a.hs
@@ -0,0 +1,7 @@
+{-# LANGUAGE TypeFamilies, PolyKinds #-}
+
+module T11361a where
+
+class C a where
+  type F (a :: k) :: *
+  type F (x :: *) = x    -- Not right!
diff --git a/testsuite/tests/indexed-types/should_compile/T11361a.stderr b/testsuite/tests/indexed-types/should_compile/T11361a.stderr
new file mode 100644
index 0000000..f7052ae
--- /dev/null
+++ b/testsuite/tests/indexed-types/should_compile/T11361a.stderr
@@ -0,0 +1,5 @@
+
+T11361a.hs:7:3: error:
+    • Kind mis-match on LHS of default declaration for ‘F’
+    • In the default type instance declaration for ‘F’
+      In the class declaration for ‘C’
diff --git a/testsuite/tests/indexed-types/should_compile/all.T b/testsuite/tests/indexed-types/should_compile/all.T
index fe2688e..28ea8bd 100644
--- a/testsuite/tests/indexed-types/should_compile/all.T
+++ b/testsuite/tests/indexed-types/should_compile/all.T
@@ -271,3 +271,5 @@ test('T10318', normal, compile, [''])
 test('UnusedTyVarWarnings', normal, compile, ['-W'])
 test('UnusedTyVarWarningsNamedWCs', normal, compile, ['-W'])
 test('T11408', normal, compile, [''])
+test('T11361', normal, compile, [''])
+test('T11361a', normal, compile_fail, [''])



More information about the ghc-commits mailing list