Be mindful of GADT tyvar order when desugaring record updates
authorRyan Scott <ryan.gl.scott@gmail.com>
Fri, 17 Aug 2018 14:31:27 +0000 (16:31 +0200)
committerKrzysztof Gogolewski <krz.gogolewski@gmail.com>
Fri, 17 Aug 2018 14:31:27 +0000 (16:31 +0200)
Summary:
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

compiler/deSugar/DsExpr.hs
testsuite/tests/typecheck/should_compile/T15499.hs [new file with mode: 0644]
testsuite/tests/typecheck/should_compile/all.T

index 954ca9c..7142cfb 100644 (file)
@@ -636,12 +636,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
@@ -650,13 +656,16 @@ ds_expr _ expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = fields
 
                  inst_con = noLoc $ mkHsWrap wrap (HsConLikeOut noExt 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 (file)
index 0000000..653440a
--- /dev/null
@@ -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}
index c36eaea..75f9aba 100644 (file)
@@ -627,9 +627,9 @@ test('T15232', normal, compile, [''])
 test('T13833', normal, compile, [''])
 test('T14185', expect_broken(14185), compile, [''])
 
-def onlyHsParLocs(x): 
-    """ 
-    We only want to check that all the parentheses are present with the correct location, 
+def onlyHsParLocs(x):
+    """
+    We only want to check that all the parentheses are present with the correct location,
     not compare the entire typechecked AST.
     Located (HsPar GhcTc) are pretty printed with the form
     ({ <location info>
@@ -637,7 +637,7 @@ def onlyHsParLocs(x):
     This function tries to extract all such location infos from the typechecked AST.
     """
     ls = x.split("\n")
-    filteredLines = (loc.strip() for (loc,hspar) in zip(ls,ls[1:]) 
+    filteredLines = (loc.strip() for (loc,hspar) in zip(ls,ls[1:])
                       if hspar.strip().startswith("(HsPar")
                         and not "<no location info>" in loc)
     return '\n'.join(filteredLines)
@@ -648,3 +648,4 @@ test('T15428', normal, compile, [''])
 test('T15412', normal, compile, [''])
 test('T15141', normal, compile, [''])
 test('T15473', expect_broken(15473), compile, [''])
+test('T15499', normal, compile, [''])