Commit 63b6a1d4 authored by Ryan Scott's avatar Ryan Scott Committed by Krzysztof Gogolewski

Be mindful of GADT tyvar order when desugaring record updates

Summary:
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
parent 23f6f31d
......@@ -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}
......@@ -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, [''])
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