[commit: ghc] ghc-8.4: Be mindful of GADT tyvar order when desugaring record updates (1a6d7c1)

[git at git.haskell.org]

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

On branch  : ghc-8.4
Link       : http://ghc.haskell.org/trac/ghc/changeset/1a6d7c1888cf241e0b8f77f62911603863b7f124/ghc

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

commit 1a6d7c1888cf241e0b8f77f62911603863b7f124
Author: Ryan Scott <ryan.gl.scott at gmail.com>
Date:   Fri Aug 17 16:31:27 2018 +0200

    Be mindful of GADT tyvar order when desugaring record updates
    
    After commit ef26182e2014b0a2a029ae466a4b121bf235e4e4,
    the type variable binders in GADT constructor type signatures
    are now quantified in toposorted order, instead of always having
    all the universals before all the existentials. Unfortunately, that
    commit forgot to update some code (which was assuming the latter
    scenario) in `DsExpr` which desugars record updates. This wound
    up being the cause of #15499.
    
    This patch makes up for lost time by desugaring record updates in
    a way such that the desugared expression applies type arguments to
    the right-hand side constructor in the correct order—that is, the
    order in which they were quantified by the user.
    
    Test Plan: make test TEST=T15499
    
    Reviewers: simonpj, bgamari
    
    Reviewed By: simonpj
    
    Subscribers: rwbarton, carter
    
    GHC Trac Issues: #15499
    
    Differential Revision: https://phabricator.haskell.org/D5060
    
    (cherry picked from commit 63b6a1d44849c479d2a7cb59211f5c64d133bc62)


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

1a6d7c1888cf241e0b8f77f62911603863b7f124
 compiler/deSugar/DsExpr.hs                         | 25 +++++++++++++++-------
 testsuite/tests/typecheck/should_compile/T15499.hs | 11 ++++++++++
 testsuite/tests/typecheck/should_compile/all.T     |  1 +
 3 files changed, 29 insertions(+), 8 deletions(-)

diff --git a/compiler/deSugar/DsExpr.hs b/compiler/deSugar/DsExpr.hs
index 635a9c6..4d74c1f 100644
--- a/compiler/deSugar/DsExpr.hs
+++ b/compiler/deSugar/DsExpr.hs
@@ -649,12 +649,18 @@ ds_expr _ expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = fields
     mk_alt upd_fld_env con
       = do { let (univ_tvs, ex_tvs, eq_spec,
                   prov_theta, _req_theta, arg_tys, _) = conLikeFullSig con
-                 subst = zipTvSubst univ_tvs in_inst_tys
+                 user_tvs =
+                   case con of
+                     RealDataCon data_con -> dataConUserTyVars data_con
+                     PatSynCon _          -> univ_tvs ++ ex_tvs
+                       -- The order here is because of the order in `TcPatSyn`.
+                 in_subst  = zipTvSubst univ_tvs in_inst_tys
+                 out_subst = zipTvSubst univ_tvs out_inst_tys
 
                 -- I'm not bothering to clone the ex_tvs
-           ; eqs_vars   <- mapM newPredVarDs (substTheta subst (eqSpecPreds eq_spec))
-           ; theta_vars <- mapM newPredVarDs (substTheta subst prov_theta)
-           ; arg_ids    <- newSysLocalsDs (substTysUnchecked subst arg_tys)
+           ; eqs_vars   <- mapM newPredVarDs (substTheta in_subst (eqSpecPreds eq_spec))
+           ; theta_vars <- mapM newPredVarDs (substTheta in_subst prov_theta)
+           ; arg_ids    <- newSysLocalsDs (substTysUnchecked in_subst arg_tys)
            ; let field_labels = conLikeFieldLabels con
                  val_args = zipWithEqual "dsExpr:RecordUpd" mk_val_arg
                                          field_labels arg_ids
@@ -663,13 +669,16 @@ ds_expr _ expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = fields
 
                  inst_con = noLoc $ mkHsWrap wrap (HsConLikeOut con)
                         -- Reconstruct with the WrapId so that unpacking happens
-                 -- The order here is because of the order in `TcPatSyn`.
                  wrap = mkWpEvVarApps theta_vars                                <.>
                         dict_req_wrap                                           <.>
-                        mkWpTyApps    (mkTyVarTys ex_tvs)                       <.>
-                        mkWpTyApps    [ ty
-                                      | (tv, ty) <- univ_tvs `zip` out_inst_tys
+                        mkWpTyApps    [ lookupTyVar out_subst tv
+                                          `orElse` mkTyVarTy tv
+                                      | tv <- user_tvs
                                       , not (tv `elemVarEnv` wrap_subst) ]
+                          -- Be sure to use user_tvs (which may be ordered
+                          -- differently than `univ_tvs ++ ex_tvs) above.
+                          -- See Note [DataCon user type variable binders]
+                          -- in DataCon.
                  rhs = foldl (\a b -> nlHsApp a b) inst_con val_args
 
                         -- Tediously wrap the application in a cast
diff --git a/testsuite/tests/typecheck/should_compile/T15499.hs b/testsuite/tests/typecheck/should_compile/T15499.hs
new file mode 100644
index 0000000..653440a
--- /dev/null
+++ b/testsuite/tests/typecheck/should_compile/T15499.hs
@@ -0,0 +1,11 @@
+{-# LANGUAGE DataKinds, GADTs, KindSignatures #-}
+module T15499 ()
+where
+
+data ADT (p :: Integer) where
+  ADT ::
+    { a :: a
+    , b :: Integer
+    } -> ADT p
+
+foo = undefined {b=undefined}
diff --git a/testsuite/tests/typecheck/should_compile/all.T b/testsuite/tests/typecheck/should_compile/all.T
index 1ea388c..a03fd02 100644
--- a/testsuite/tests/typecheck/should_compile/all.T
+++ b/testsuite/tests/typecheck/should_compile/all.T
@@ -595,3 +595,4 @@ test('T14763', normal, compile, [''])
 test('T14811', normal, compile, [''])
 test('T14934', [extra_files(['T14934.hs', 'T14934a.hs'])], run_command,
                ['$MAKE -s --no-print-directory T14934'])
+test('T15499', normal, compile, [''])