From 0759c069e7cf328c8e397623bb2e5403de52e869 Mon Sep 17 00:00:00 2001
From: Ryan Scott <ryan.gl.scott@gmail.com>
Date: Wed, 25 Aug 2021 06:45:27 -0400
Subject: Desugarer: Bring existentials in scope when substituting into record
 GADTs

This fixes an outright bug in which the desugarer did not bring the
existentially quantified type variables of a record GADT into `in_subst`'s
in-scope set, leading to #20278. It also addresses a minor inefficiency in
which `out_subst` was made into a substitution when a simpler `TvSubstEnv`
would suffice.

Fixes #20278.
---
 compiler/GHC/HsToCore/Expr.hs  | 14 +++++++++++---
 testsuite/tests/gadt/T20278.hs | 19 +++++++++++++++++++
 testsuite/tests/gadt/all.T     |  1 +
 3 files changed, 31 insertions(+), 3 deletions(-)
 create mode 100644 testsuite/tests/gadt/T20278.hs

diff --git a/compiler/GHC/HsToCore/Expr.hs b/compiler/GHC/HsToCore/Expr.hs
index 1f0a0ddde5..0241f611ed 100644
--- a/compiler/GHC/HsToCore/Expr.hs
+++ b/compiler/GHC/HsToCore/Expr.hs
@@ -652,8 +652,16 @@ dsExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = Left fields
                    -- Record updates consume the source record with multiplicity
                    -- Many. Therefore all the fields need to be scaled thus.
                  user_tvs  = binderVars $ conLikeUserTyVarBinders con
-                 in_subst  = zipTvSubst univ_tvs in_inst_tys
-                 out_subst = zipTvSubst univ_tvs out_inst_tys
+
+                 in_subst :: TCvSubst
+                 in_subst  = extendTCvInScopeList (zipTvSubst univ_tvs in_inst_tys) ex_tvs
+                   -- The in_subst clones the universally quantified type
+                   -- variables. It will be used to substitute into types that
+                   -- contain existentials, however, so make sure to extend the
+                   -- in-scope set with ex_tvs (#20278).
+
+                 out_tv_env :: TvSubstEnv
+                 out_tv_env = zipTyEnv univ_tvs out_inst_tys
 
                 -- I'm not bothering to clone the ex_tvs
            ; eqs_vars   <- mapM newPredVarDs (substTheta in_subst (eqSpecPreds eq_spec))
@@ -669,7 +677,7 @@ dsExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = Left fields
                         -- Reconstruct with the WrapId so that unpacking happens
                  wrap = mkWpEvVarApps theta_vars                                <.>
                         dict_req_wrap                                           <.>
-                        mkWpTyApps    [ lookupTyVar out_subst tv
+                        mkWpTyApps    [ lookupVarEnv out_tv_env tv
                                           `orElse` mkTyVarTy tv
                                       | tv <- user_tvs ]
                           -- Be sure to use user_tvs (which may be ordered
diff --git a/testsuite/tests/gadt/T20278.hs b/testsuite/tests/gadt/T20278.hs
new file mode 100644
index 0000000000..436ff425cb
--- /dev/null
+++ b/testsuite/tests/gadt/T20278.hs
@@ -0,0 +1,19 @@
+{-# LANGUAGE GADTs #-}
+module T20278 where
+
+import Data.Kind
+import GHC.Exts
+
+type X1 :: TYPE rep -> Type
+data X1 a where
+  MkX1 :: { fld1a :: a, fld1b :: Int } -> X1 a
+
+upd1 :: forall rep (a :: TYPE rep). X1 a -> X1 a
+upd1 x = x { fld1b = 3 }
+
+type X2 :: Type -> Type
+data X2 a where
+  MkX2 :: { fld2a :: b, fld2b :: Int } -> X2 (Maybe b)
+
+upd2 :: X2 a -> X2 a
+upd2 x = x { fld2b = 3 }
diff --git a/testsuite/tests/gadt/all.T b/testsuite/tests/gadt/all.T
index 91ba74b722..9179a40288 100644
--- a/testsuite/tests/gadt/all.T
+++ b/testsuite/tests/gadt/all.T
@@ -120,4 +120,5 @@ test('T15009', normal, compile, [''])
 test('T15558', normal, compile, [''])
 test('T16427', normal, compile_fail, [''])
 test('T18191', normal, compile_fail, [''])
+test('T20278', normal, compile, [''])
 test('SynDataRec', normal, compile, [''])
-- 
cgit v1.2.1