[Git][ghc/ghc][wip/T23329] Fix type variable substitution in gen_Newtype_fam_insts

[Ryan Scott (@RyanGlScott)]

Ryan Scott pushed to branch wip/T23329 at Glasgow Haskell Compiler / GHC


Commits:
c3e83ddb by Ryan Scott at 2023-05-01T20:11:17-04:00
Fix type variable substitution in gen_Newtype_fam_insts

Previously, `gen_Newtype_fam_insts` was substituting the type variable binders
of a type family instance using `substTyVars`, which failed to take type
variable dependencies into account. There is similar code in
`GHC.Tc.TyCl.Class.tcATDefault` that _does_ perform this substitution properly,
so this patch copies the same code over to `gen_Newtype_fam_insts`.

Fixes #23329.

- - - - -


5 changed files:

- compiler/GHC/Tc/Deriv/Generate.hs
- compiler/GHC/Tc/TyCl/Class.hs
- + testsuite/tests/deriving/should_compile/T23329.hs
- + testsuite/tests/deriving/should_compile/T23329_M.hs
- testsuite/tests/deriving/should_compile/all.T


Changes:

=====================================
compiler/GHC/Tc/Deriv/Generate.hs
=====================================
@@ -92,7 +92,7 @@ import GHC.Unit.Module
 
 import Language.Haskell.Syntax.Basic (FieldLabelString(..))
 
-import Data.List  ( find, partition, intersperse )
+import Data.List  ( find, mapAccumL, partition, intersperse )
 
 -- | A declarative description of an auxiliary binding that should be
 -- generated. See @Note [Auxiliary binders]@ for a more detailed description
@@ -2089,6 +2089,18 @@ gen_Newtype_fam_insts loc' cls inst_tvs inst_tys rhs_ty
     rhs_env   = zipTyEnv cls_tvs underlying_inst_tys
     rhs_subst = mkTvSubst in_scope rhs_env
 
+    subst_tvs :: Subst -> [TyVar] -> (Subst, [Type])
+    subst_tvs = mapAccumL subst_tv
+
+    subst_tv :: Subst -> TyVar -> (Subst, Type)
+    subst_tv subst tc_tv
+      | Just ty <- lookupVarEnv (getTvSubstEnv subst) tc_tv
+      = (subst, ty)
+      | otherwise
+      = (extendTvSubst subst tc_tv ty', ty')
+      where
+        ty' = mkTyVarTy (updateTyVarKind (substTyUnchecked subst) tc_tv)
+
     mk_atf_inst :: TyCon -> TcM FamInst
     mk_atf_inst fam_tc = do
         rep_tc_name <- newFamInstTyConName (L locn (tyConName fam_tc))
@@ -2100,8 +2112,8 @@ gen_Newtype_fam_insts loc' cls inst_tvs inst_tys rhs_ty
         newFamInst SynFamilyInst axiom
       where
         fam_tvs     = tyConTyVars fam_tc
-        rep_lhs_tys = substTyVars lhs_subst fam_tvs
-        rep_rhs_tys = substTyVars rhs_subst fam_tvs
+        (_, rep_lhs_tys) = subst_tvs lhs_subst fam_tvs
+        (_, rep_rhs_tys) = subst_tvs rhs_subst fam_tvs
         rep_rhs_ty  = mkTyConApp fam_tc rep_rhs_tys
         rep_tcvs    = tyCoVarsOfTypesList rep_lhs_tys
         (rep_tvs, rep_cvs) = partition isTyVar rep_tcvs


=====================================
compiler/GHC/Tc/TyCl/Class.hs
=====================================
@@ -526,6 +526,7 @@ tcATDefault loc inst_subst defined_ats (ATI fam_tc defs)
   = do { warnMissingAT (tyConName fam_tc)
        ; return [] }
   where
+    subst_tv :: Subst -> TyVar -> (Subst, Type)
     subst_tv subst tc_tv
       | Just ty <- lookupVarEnv (getTvSubstEnv subst) tc_tv
       = (subst, ty)


=====================================
testsuite/tests/deriving/should_compile/T23329.hs
=====================================
@@ -0,0 +1,9 @@
+module T23329 where
+
+import Data.Kind (Type)
+import Data.Proxy (Proxy(Proxy))
+
+import T23329_M
+
+foo :: ()
+foo = myMethod @Type @MyMaybe @() () Proxy Proxy


=====================================
testsuite/tests/deriving/should_compile/T23329_M.hs
=====================================
@@ -0,0 +1,17 @@
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
+module T23329_M where
+
+import Data.Kind (Type)
+import Data.Proxy (Proxy)
+
+class MyClass (f :: k -> Type) where
+  type MyTypeFamily f (i :: k) :: Type
+  myMethod :: MyTypeFamily f i -> Proxy f -> Proxy i -> ()
+
+instance MyClass Maybe where
+  type MyTypeFamily Maybe i = ()
+  myMethod = undefined
+
+newtype MyMaybe a = MyMaybe (Maybe a)
+  deriving MyClass


=====================================
testsuite/tests/deriving/should_compile/all.T
=====================================
@@ -141,3 +141,4 @@ test('T20994', normal, compile, [''])
 test('T22167', normal, compile, [''])
 test('T22696a', normal, compile, [''])
 test('T22696c', normal, compile, [''])
+test('T23329', normal, multimod_compile, ['T23329', '-v0'])



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c3e83ddb4c4cb2ef4c263bc350ee452ba8c4a30d

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c3e83ddb4c4cb2ef4c263bc350ee452ba8c4a30d
You're receiving this email because of your account on gitlab.haskell.org.


-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20230501/f6d36a42/attachment-0001.html>