Commit 2d308da2 authored by Ryan Scott's avatar Ryan Scott Committed by Ben Gamari

Be mindful of GADT tyvar order when desugaring record updates

After commit ef26182e,
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 63b6a1d4)
parent beca6421
......@@ -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
......
{-# LANGUAGE DataKinds, GADTs, KindSignatures #-}
module T15499 ()
where
data ADT (p :: Integer) where
ADT ::
{ a :: a
, b :: Integer
} -> ADT p
foo = undefined {b=undefined}
......@@ -646,3 +646,4 @@ test('T15428', normal, compile, [''])
test('T15431', normal, compile, [''])
test('T15431a', normal, compile, [''])
test('T15412', normal, compile, [''])
test('T15499', normal, compile, [''])
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment