diff options
| author | Ryan Scott <ryan.gl.scott@gmail.com> | 2021-08-25 06:45:27 -0400 |
|---|---|---|
| committer | Krzysztof Gogolewski <krzysztof.gogolewski@tweag.io> | 2021-09-09 15:30:37 +0200 |
| commit | fc57077acb12a4d9f640d1a94b04cf5af1008cd1 (patch) | |
| tree | 8a3e0aab492cc3e10c41347ef8898797a0b0dfe3 | |
| parent | 141dc8d8ba7244ab5a2eb5848b76eeb723beef72 (diff) | |
| download | haskell-wip/backports-to-9.2.tar.gz | |
Desugarer: Bring existentials in scope when substituting into record GADTswip/backports-to-9.2
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.
(cherry picked from commit 0759c069e7cf328c8e397623bb2e5403de52e869)
| -rw-r--r-- | compiler/GHC/HsToCore/Expr.hs | 14 | ||||
| -rw-r--r-- | testsuite/tests/gadt/T20278.hs | 19 | ||||
| -rw-r--r-- | testsuite/tests/gadt/all.T | 1 |
3 files changed, 31 insertions, 3 deletions
diff --git a/compiler/GHC/HsToCore/Expr.hs b/compiler/GHC/HsToCore/Expr.hs index aefecfb2c4..aaf2b0f3cd 100644 --- a/compiler/GHC/HsToCore/Expr.hs +++ b/compiler/GHC/HsToCore/Expr.hs @@ -657,8 +657,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)) @@ -674,7 +682,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 225d8e8650..276302fb57 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, ['']) |