[Git][ghc/ghc][master] Fix type variable substitution in gen_Newtype_fam_insts

Marge Bot (@marge-bot) gitlab at gitlab.haskell.org
Thu May 4 19:02:25 UTC 2023



Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC


Commits:
e8b72ff6 by Ryan Scott at 2023-05-04T15:02:02-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:

1. Factors out this code into a top-level `substATBndrs` function, and
2. Uses `substATBndrs` in `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
=====================================
@@ -46,6 +46,7 @@ import GHC.Prelude
 
 import GHC.Hs
 
+import GHC.Tc.TyCl.Class ( substATBndrs )
 import GHC.Tc.Utils.Monad
 import GHC.Tc.Utils.Instantiate( newFamInst )
 import GHC.Tc.Utils.Env
@@ -2100,8 +2101,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) = substATBndrs lhs_subst fam_tvs
+        (_, rep_rhs_tys) = substATBndrs 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
=====================================
@@ -22,6 +22,7 @@ module GHC.Tc.TyCl.Class
    , instDeclCtxt2
    , instDeclCtxt3
    , tcATDefault
+   , substATBndrs
    )
 where
 
@@ -42,7 +43,7 @@ import GHC.Tc.Utils.TcType
 import GHC.Tc.Utils.Monad
 import GHC.Tc.TyCl.Build( TcMethInfo )
 
-import GHC.Core.Type     ( piResultTys )
+import GHC.Core.Type     ( extendTvSubstWithClone, piResultTys )
 import GHC.Core.Predicate
 import GHC.Core.Multiplicity
 import GHC.Core.Class
@@ -58,7 +59,7 @@ import GHC.Types.Name
 import GHC.Types.Name.Env
 import GHC.Types.Name.Set
 import GHC.Types.Var
-import GHC.Types.Var.Env
+import GHC.Types.Var.Env ( lookupVarEnv )
 import GHC.Types.SourceFile (HscSource(..))
 import GHC.Types.SrcLoc
 import GHC.Types.Basic
@@ -501,8 +502,7 @@ tcATDefault loc inst_subst defined_ats (ATI fam_tc defs)
    --            instance C [x]
    -- Then we want to generate the decl:   type F [x] b = ()
   | Just (rhs_ty, _loc) <- defs
-  = do { let (subst', pat_tys') = mapAccumL subst_tv inst_subst
-                                            (tyConTyVars fam_tc)
+  = do { let (subst', pat_tys') = substATBndrs inst_subst (tyConTyVars fam_tc)
              rhs'     = substTyUnchecked subst' rhs_ty
              tcv' = tyCoVarsOfTypesList pat_tys'
              (tv', cv') = partition isTyVar tcv'
@@ -525,14 +525,73 @@ tcATDefault loc inst_subst defined_ats (ATI fam_tc defs)
   | otherwise  -- defs = Nothing
   = do { warnMissingAT (tyConName fam_tc)
        ; return [] }
+
+-- | Apply a substitution to the type variable binders of an associated type
+-- family. This is used to compute default instances for associated type
+-- families (see 'tcATDefault') as well as @newtype at -derived associated type
+-- family instances (see @gen_Newtype_fam_insts@ in "GHC.Tc.Deriv.Generate").
+--
+-- As a concrete example, consider the following class and associated type
+-- family:
+--
+-- @
+--   class C k (a :: k) where
+--     type F k a (b :: k) :: Type
+--     type F j p q = (Proxy @j p, Proxy @j (q :: j))
+-- @
+--
+-- If a user defines this instance:
+--
+-- @
+-- instance C (Type -> Type) Maybe where {}
+-- @
+--
+-- Then in order to typecheck the default @F@ instance, we must apply the
+-- substitution @[k :-> (Type -> Type), a :-> Maybe]@ to @F@'s binders, which
+-- are @[k, a, (b :: k)]@. The result should look like this:
+--
+-- @
+--   type F (Type -> Type) Maybe (b :: Type -> Type) =
+--     (Proxy @(Type -> Type) Maybe, Proxy @(Type -> Type) (b :: Type -> Type))
+-- @
+--
+-- Making this work requires some care. There are two cases:
+--
+-- 1. If we encounter a type variable in the domain of the substitution (e.g.,
+--    @k@ or @a@), then we apply the substitution directly.
+--
+-- 2. Otherwise, we substitute into the type variable's kind (e.g., turn
+--    @b :: k@ to @b :: Type -> Type@). We then return an extended substitution
+--    where the old @b@ (of kind @k@) maps to the new @b@ (of kind @Type -> Type@).
+--
+--    This step is important to do in case there are later occurrences of @b@,
+--    which we must ensure have the correct kind. Otherwise, we might end up
+--    with @Proxy \@(Type -> Type) (b :: k)@ on the right-hand side of the
+--    default instance, which would be completely wrong.
+--
+-- Contrast 'substATBndrs' function with similar substitution functions:
+--
+-- * 'substTyVars' does not substitute into the kinds of each type variable,
+--   nor does it extend the substitution. 'substTyVars' is meant for occurrences
+--   of type variables, whereas 'substATBndr's is meant for binders.
+--
+-- * 'substTyVarBndrs' does substitute into kinds and extends the substitution,
+--   but it does not apply the substitution to the variables themselves. As
+--   such, 'substTyVarBndrs' returns a list of 'TyVar's rather than a list of
+--   'Type's.
+substATBndrs :: Subst -> [TyVar] -> (Subst, [Type])
+substATBndrs = mapAccumL substATBndr
   where
-    subst_tv subst tc_tv
+    substATBndr :: Subst -> TyVar -> (Subst, Type)
+    substATBndr subst tc_tv
+        -- Case (1) in the Haddocks
       | Just ty <- lookupVarEnv (getTvSubstEnv subst) tc_tv
       = (subst, ty)
+        -- Case (2) in the Haddocks
       | otherwise
-      = (extendTvSubst subst tc_tv ty', ty')
+      = (extendTvSubstWithClone subst tc_tv tc_tv', mkTyVarTy tc_tv')
       where
-        ty' = mkTyVarTy (updateTyVarKind (substTyUnchecked subst) tc_tv)
+        tc_tv' = updateTyVarKind (substTy subst) tc_tv
 
 warnMissingAT :: Name -> TcM ()
 warnMissingAT name


=====================================
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/e8b72ff6e4aee1f889a9168df57bb1b00168fd21

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e8b72ff6e4aee1f889a9168df57bb1b00168fd21
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/20230504/2dae66f1/attachment-0001.html>


More information about the ghc-commits mailing list