Commit ef26182e authored by Ryan Scott's avatar Ryan Scott Committed by Ben Gamari

Track the order of user-written tyvars in DataCon

After typechecking a data constructor's type signature, its type
variables are partitioned into two distinct groups: the universally
quantified type variables and the existentially quantified type
variables. Then, when prompted for the type of the data constructor,
GHC gives this:

```lang=haskell
MkT :: forall <univs> <exis>. (...)
```

For H98-style datatypes, this is a fine thing to do. But for GADTs,
this can sometimes produce undesired results with respect to
`TypeApplications`. For instance, consider this datatype:

```lang=haskell
data T a where
  MkT :: forall b a. b -> T a
```

Here, the user clearly intended to have `b` be available for visible
type application before `a`. That is, the user would expect
`MkT @Int @Char` to be of type `Int -> T Char`, //not//
`Char -> T Int`. But alas, up until now that was not how GHC
operated—regardless of the order in which the user actually wrote
the tyvars, GHC would give `MkT` the type:

```lang=haskell
MkT :: forall a b. b -> T a
```

Since `a` is universal and `b` is existential. This makes predicting
what order to use for `TypeApplications` quite annoying, as
demonstrated in #11721 and #13848.

This patch cures the problem by tracking more carefully the order in
which a user writes type variables in data constructor type
signatures, either explicitly (with a `forall`) or implicitly
(without a `forall`, in which case the order is inferred). This is
accomplished by adding a new field `dcUserTyVars` to `DataCon`, which
is a subset of `dcUnivTyVars` and `dcExTyVars` that is permuted to
the order in which the user wrote them. For more details, refer to
`Note [DataCon user type variables]` in `DataCon.hs`.

An interesting consequence of this design is that more data
constructors require wrappers. This is because the workers always
expect the first arguments to be the universal tyvars followed by the
existential tyvars, so when the user writes the tyvars in a different
order, a wrapper type is needed to swizzle the tyvars around to match
the order that the worker expects. For more details, refer to
`Note [Data con wrappers and GADT syntax]` in `MkId.hs`.

Test Plan: ./validate

Reviewers: austin, goldfire, bgamari, simonpj

Reviewed By: goldfire, simonpj

Subscribers: ezyang, goldfire, rwbarton, thomie

GHC Trac Issues: #11721, #13848

Differential Revision: https://phabricator.haskell.org/D3687
parent 8d647450
......@@ -523,7 +523,8 @@ rnIfaceConDecls IfAbstractTyCon = pure IfAbstractTyCon
rnIfaceConDecl :: Rename IfaceConDecl
rnIfaceConDecl d = do
con_name <- rnIfaceGlobal (ifConName d)
con_ex_tvs <- mapM rnIfaceForAllBndr (ifConExTvs d)
con_ex_tvs <- mapM rnIfaceTvBndr (ifConExTvs d)
con_user_tvbs <- mapM rnIfaceForAllBndr (ifConUserTvBinders d)
let rnIfConEqSpec (n,t) = (,) n <$> rnIfaceType t
con_eq_spec <- mapM rnIfConEqSpec (ifConEqSpec d)
con_ctxt <- mapM rnIfaceType (ifConCtxt d)
......@@ -534,6 +535,7 @@ rnIfaceConDecl d = do
con_stricts <- mapM rnIfaceBang (ifConStricts d)
return d { ifConName = con_name
, ifConExTvs = con_ex_tvs
, ifConUserTvBinders = con_user_tvbs
, ifConEqSpec = con_eq_spec
, ifConCtxt = con_ctxt
, ifConArgTys = con_arg_tys
......
This diff is collapsed.
......@@ -13,13 +13,13 @@ import {-# SOURCE #-} TyCoRep ( Type, ThetaType )
data DataCon
data DataConRep
data EqSpec
filterEqSpec :: [EqSpec] -> [TyVarBinder] -> [TyVarBinder]
filterEqSpec :: [EqSpec] -> [TyVar] -> [TyVar]
dataConName :: DataCon -> Name
dataConTyCon :: DataCon -> TyCon
dataConUnivTyVarBinders :: DataCon -> [TyVarBinder]
dataConExTyVars :: DataCon -> [TyVar]
dataConExTyVarBinders :: DataCon -> [TyVarBinder]
dataConUserTyVars :: DataCon -> [TyVar]
dataConUserTyVarBinders :: DataCon -> [TyVarBinder]
dataConSourceArity :: DataCon -> Arity
dataConFieldLabels :: DataCon -> [FieldLabel]
dataConInstOrigArgTys :: DataCon -> [Type] -> [Type]
......
......@@ -278,7 +278,7 @@ mkDictSelId name clas
sel_names = map idName (classAllSelIds clas)
new_tycon = isNewTyCon tycon
[data_con] = tyConDataCons tycon
tyvars = dataConUnivTyVarBinders data_con
tyvars = dataConUserTyVarBinders data_con
n_ty_args = length tyvars
arg_tys = dataConRepArgTys data_con -- Includes the dictionary superclasses
val_index = assoc "MkId.mkDictSelId" (sel_names `zip` [0..]) name
......@@ -553,7 +553,6 @@ mkDataConRep dflags fam_envs wrap_name mb_bangs data_con
-- Passing Nothing here allows the wrapper to inline when
-- unsaturated.
wrap_unf = mkInlineUnfolding wrap_rhs
wrap_tvs = (univ_tvs `minusList` map eqSpecTyVar eq_spec) ++ ex_tvs
wrap_rhs = mkLams wrap_tvs $
mkLams wrap_args $
wrapFamInstBody tycon res_ty_args $
......@@ -568,6 +567,7 @@ mkDataConRep dflags fam_envs wrap_name mb_bangs data_con
where
(univ_tvs, ex_tvs, eq_spec, theta, orig_arg_tys, _orig_res_ty)
= dataConFullSig data_con
wrap_tvs = dataConUserTyVars data_con
res_ty_args = substTyVars (mkTvSubstPrs (map eqSpecPair eq_spec)) univ_tvs
tycon = dataConTyCon data_con -- The representation TyCon (not family)
......@@ -595,11 +595,20 @@ mkDataConRep dflags fam_envs wrap_name mb_bangs data_con
(unboxers, boxers) = unzip wrappers
(rep_tys, rep_strs) = unzip (concat rep_tys_w_strs)
wrapper_reqd = not (isNewTyCon tycon) -- Newtypes have only a worker
&& (any isBanged (ev_ibangs ++ arg_ibangs)
-- Some forcing/unboxing (includes eq_spec)
|| isFamInstTyCon tycon -- Cast result
|| (not $ null eq_spec)) -- GADT
wrapper_reqd =
(not (isNewTyCon tycon)
-- (Most) newtypes have only a worker, with the exception
-- of some newtypes written with GADT syntax. See below.
&& (any isBanged (ev_ibangs ++ arg_ibangs)
-- Some forcing/unboxing (includes eq_spec)
|| isFamInstTyCon tycon -- Cast result
|| (not $ null eq_spec))) -- GADT
|| dataConUserTyVarsArePermuted data_con
-- If the data type was written with GADT syntax and
-- orders the type variables differently from what the
-- worker expects, it needs a data con wrapper to reorder
-- the type variables.
-- See Note [Data con wrappers and GADT syntax].
initial_wrap_app = Var (dataConWorkId data_con)
`mkTyApps` res_ty_args
......@@ -677,6 +686,40 @@ For a start, it's still to generate a no-op. But worse, since wrappers
are currently injected at TidyCore, we don't even optimise it away!
So the stupid case expression stays there. This actually happened for
the Integer data type (see Trac #1600 comment:66)!
Note [Data con wrappers and GADT syntax]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider these two very similar data types:
data T1 a b = MkT1 b
data T2 a b where
MkT2 :: forall b a. b -> T2 a b
Despite their similar appearance, T2 will have a data con wrapper but T1 will
not. What sets them apart? The types of their constructors, which are:
MkT1 :: forall a b. b -> T1 a b
MkT2 :: forall b a. b -> T2 a b
MkT2's use of GADT syntax allows it to permute the order in which `a` and `b`
would normally appear. See Note [DataCon user type variable binders] in DataCon
for further discussion on this topic.
The worker data cons for T1 and T2, however, both have types such that `a` is
expected to come before `b` as arguments. Because MkT2 permutes this order, it
needs a data con wrapper to swizzle around the type variables to be in the
order the worker expects.
A somewhat surprising consequence of this is that *newtypes* can have data con
wrappers! After all, a newtype can also be written with GADT syntax:
newtype T3 a b where
MkT3 :: forall b a. b -> T3 a b
Again, this needs a wrapper data con to reorder the type variables. It does
mean that this newtype constructor requires another level of indirection when
being called, but the inliner should make swift work of that.
-}
-------------------------
......
......@@ -72,9 +72,12 @@ mkNewTyConRhs tycon_name tycon con
where
tvs = tyConTyVars tycon
roles = tyConRoles tycon
inst_con_ty = piResultTys (dataConUserType con) (mkTyVarTys tvs)
rhs_ty = ASSERT( isFunTy inst_con_ty ) funArgTy inst_con_ty
-- Instantiate the data con with the
con_arg_ty = case dataConRepArgTys con of
[arg_ty] -> arg_ty
tys -> pprPanic "mkNewTyConRhs" (ppr con <+> ppr tys)
rhs_ty = substTyWith (dataConUnivTyVars con)
(mkTyVarTys tvs) con_arg_ty
-- Instantiate the newtype's RHS with the
-- type variables from the tycon
-- NB: a newtype DataCon has a type that must look like
-- forall tvs. <arg-ty> -> T tvs
......@@ -109,8 +112,9 @@ buildDataCon :: FamInstEnvs
-> Maybe [HsImplBang]
-- See Note [Bangs on imported data constructors] in MkId
-> [FieldLabel] -- Field labels
-> [TyVarBinder] -- Universals
-> [TyVarBinder] -- Existentials
-> [TyVar] -- Universals
-> [TyVar] -- Existentials
-> [TyVarBinder] -- User-written 'TyVarBinder's
-> [EqSpec] -- Equality spec
-> ThetaType -- Does not include the "stupid theta"
-- or the GADT equalities
......@@ -122,7 +126,7 @@ buildDataCon :: FamInstEnvs
-- b) makes the wrapper Id if necessary, including
-- allocating its unique (hence monadic)
buildDataCon fam_envs src_name declared_infix prom_info src_bangs impl_bangs field_lbls
univ_tvs ex_tvs eq_spec ctxt arg_tys res_ty rep_tycon
univ_tvs ex_tvs user_tvbs eq_spec ctxt arg_tys res_ty rep_tycon
= do { wrap_name <- newImplicitBinder src_name mkDataConWrapperOcc
; work_name <- newImplicitBinder src_name mkDataConWorkerOcc
-- This last one takes the name of the data constructor in the source
......@@ -135,7 +139,7 @@ buildDataCon fam_envs src_name declared_infix prom_info src_bangs impl_bangs fie
; let stupid_ctxt = mkDataConStupidTheta rep_tycon arg_tys univ_tvs
data_con = mkDataCon src_name declared_infix prom_info
src_bangs field_lbls
univ_tvs ex_tvs eq_spec ctxt
univ_tvs ex_tvs user_tvbs eq_spec ctxt
arg_tys res_ty NoRRI rep_tycon
stupid_ctxt dc_wrk dc_rep
dc_wrk = mkDataConWorkId work_name data_con
......@@ -150,13 +154,13 @@ buildDataCon fam_envs src_name declared_infix prom_info src_bangs impl_bangs fie
-- the type variables mentioned in the arg_tys
-- ToDo: Or functionally dependent on?
-- This whole stupid theta thing is, well, stupid.
mkDataConStupidTheta :: TyCon -> [Type] -> [TyVarBinder] -> [PredType]
mkDataConStupidTheta :: TyCon -> [Type] -> [TyVar] -> [PredType]
mkDataConStupidTheta tycon arg_tys univ_tvs
| null stupid_theta = [] -- The common case
| otherwise = filter in_arg_tys stupid_theta
where
tc_subst = zipTvSubst (tyConTyVars tycon)
(mkTyVarTys (binderVars univ_tvs))
(mkTyVarTys univ_tvs)
stupid_theta = substTheta tc_subst (tyConStupidTheta tycon)
-- Start by instantiating the master copy of the
-- stupid theta, taken from the TyCon
......@@ -308,8 +312,9 @@ buildClass tycon_name binders roles fds
(map (const no_bang) args)
(Just (map (const HsLazy) args))
[{- No fields -}]
univ_bndrs
univ_tvs
[{- no existentials -}]
univ_bndrs
[{- No GADT equalities -}]
[{- No theta -}]
arg_tys
......
......@@ -66,7 +66,7 @@ import Binary
import BooleanFormula ( BooleanFormula, pprBooleanFormula, isTrue )
import Var( TyVarBndr(..) )
import TyCon ( Role (..), Injectivity(..) )
import Util( filterOut, filterByList )
import Util( dropList, filterByList )
import DataCon (SrcStrictness(..), SrcUnpackedness(..))
import Lexeme (isLexSym)
import DynFlags
......@@ -240,7 +240,14 @@ data IfaceConDecl
-- but it's not so easy for the original TyCon/DataCon
-- So this guarantee holds for IfaceConDecl, but *not* for DataCon
ifConExTvs :: [IfaceForAllBndr], -- Existential tyvars (w/ visibility)
ifConExTvs :: [IfaceTvBndr], -- Existential tyvars
ifConUserTvBinders :: [IfaceForAllBndr],
-- The tyvars, in the order the user wrote them
-- INVARIANT: the set of tyvars in ifConUserTvBinders is exactly the
-- set of ifConExTvs, unioned with the set of ifBinders
-- (from the parent IfaceDecl) whose tyvars do not appear
-- in ifConEqSpec
-- See Note [DataCon user type variable binders] in DataCon
ifConEqSpec :: IfaceEqSpec, -- Equality constraints
ifConCtxt :: IfaceContext, -- Non-stupid context
ifConArgTys :: [IfaceType], -- Arg types
......@@ -961,7 +968,7 @@ pprIfaceConDecl :: ShowSub -> Bool
-> IfaceConDecl -> SDoc
pprIfaceConDecl ss gadt_style tycon tc_binders parent
(IfCon { ifConName = name, ifConInfix = is_infix,
ifConExTvs = ex_tvs,
ifConUserTvBinders = user_tvbs,
ifConEqSpec = eq_spec, ifConCtxt = ctxt, ifConArgTys = arg_tys,
ifConStricts = stricts, ifConFields = fields })
| gadt_style = pp_prefix_con <+> dcolon <+> ppr_gadt_ty
......@@ -981,19 +988,24 @@ pprIfaceConDecl ss gadt_style tycon tc_binders parent
tys_w_strs = zip stricts arg_tys
pp_prefix_con = pprPrefixIfDeclBndr how_much (occName name)
(univ_tvs, pp_res_ty) = mk_user_con_res_ty eq_spec
ppr_ex_quant = pprIfaceForAllPartMust ex_tvs ctxt
ppr_gadt_ty = pprIfaceForAllPart (map tv_to_forall_bndr univ_tvs ++ ex_tvs)
ctxt pp_tau
-- If we're pretty-printing a H98-style declaration with existential
-- quantification, then user_tvbs will always consist of the universal
-- tyvar binders followed by the existential tyvar binders. So to recover
-- the visibilities of the existential tyvar binders, we can simply drop
-- the universal tyvar binders from user_tvbs.
ex_tvbs = dropList tc_binders user_tvbs
ppr_ex_quant = pprIfaceForAllPartMust ex_tvbs ctxt
pp_gadt_res_ty = mk_user_con_res_ty eq_spec
ppr_gadt_ty = pprIfaceForAllPart user_tvbs ctxt pp_tau
-- A bit gruesome this, but we can't form the full con_tau, and ppr it,
-- because we don't have a Name for the tycon, only an OccName
pp_tau | null fields
= case pp_args ++ [pp_res_ty] of
= case pp_args ++ [pp_gadt_res_ty] of
(t:ts) -> fsep (t : map (arrow <+>) ts)
[] -> panic "pp_con_taus"
| otherwise
= sep [pp_field_args, arrow <+> pp_res_ty]
= sep [pp_field_args, arrow <+> pp_gadt_res_ty]
ppr_bang IfNoBang = whenPprDebug $ char '_'
ppr_bang IfStrict = char '!'
......@@ -1029,17 +1041,15 @@ pprIfaceConDecl ss gadt_style tycon tc_binders parent
sel = flSelector lbl
occ = mkVarOccFS (flLabel lbl)
mk_user_con_res_ty :: IfaceEqSpec -> ([IfaceTvBndr], SDoc)
mk_user_con_res_ty :: IfaceEqSpec -> SDoc
-- See Note [Result type of a data family GADT]
mk_user_con_res_ty eq_spec
| IfDataInstance _ tc tys <- parent
= (con_univ_tvs, pprIfaceType (IfaceTyConApp tc (substIfaceTcArgs gadt_subst tys)))
= pprIfaceType (IfaceTyConApp tc (substIfaceTcArgs gadt_subst tys))
| otherwise
= (con_univ_tvs, sdocWithDynFlags (ppr_tc_app gadt_subst))
= sdocWithDynFlags (ppr_tc_app gadt_subst)
where
gadt_subst = mkIfaceTySubst eq_spec
con_univ_tvs = filterOut (inDomIfaceTySubst gadt_subst) $
map ifTyConBinderTyVar tc_binders
ppr_tc_app gadt_subst dflags
= pprPrefixIfDeclBndr how_much (occName tycon)
......@@ -1081,9 +1091,6 @@ ppr_rough :: Maybe IfaceTyCon -> SDoc
ppr_rough Nothing = dot
ppr_rough (Just tc) = ppr tc
tv_to_forall_bndr :: IfaceTvBndr -> IfaceForAllBndr
tv_to_forall_bndr tv = TvBndr tv Specified
{-
Note [Result type of a data family GADT]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
......@@ -1381,7 +1388,7 @@ freeNamesIfConDecl (IfCon { ifConExTvs = ex_tvs, ifConCtxt = ctxt
, ifConFields = flds
, ifConEqSpec = eq_spec
, ifConStricts = bangs })
= freeNamesIfTyVarBndrs ex_tvs &&&
= fnList freeNamesIfTvBndr ex_tvs &&&
freeNamesIfContext ctxt &&&
fnList freeNamesIfType arg_tys &&&
mkNameSet (map flSelector flds) &&&
......@@ -1865,7 +1872,7 @@ instance Binary IfaceConDecls where
_ -> error "Binary(IfaceConDecls).get: Invalid IfaceConDecls"
instance Binary IfaceConDecl where
put_ bh (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9 a10) = do
put_ bh (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11) = do
putIfaceTopBndr bh a1
put_ bh a2
put_ bh a3
......@@ -1873,10 +1880,11 @@ instance Binary IfaceConDecl where
put_ bh a5
put_ bh a6
put_ bh a7
put_ bh (length a8)
mapM_ (put_ bh) a8
put_ bh a9
put_ bh a8
put_ bh (length a9)
mapM_ (put_ bh) a9
put_ bh a10
put_ bh a11
get bh = do
a1 <- getIfaceTopBndr bh
a2 <- get bh
......@@ -1885,11 +1893,12 @@ instance Binary IfaceConDecl where
a5 <- get bh
a6 <- get bh
a7 <- get bh
a8 <- get bh
n_fields <- get bh
a8 <- replicateM n_fields (get bh)
a9 <- get bh
a9 <- replicateM n_fields (get bh)
a10 <- get bh
return (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9 a10)
a11 <- get bh
return (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11)
instance Binary IfaceBang where
put_ bh IfNoBang = putByte bh 0
......
......@@ -21,6 +21,7 @@ module IfaceType (
IfaceTvBndr, IfaceIdBndr, IfaceTyConBinder,
IfaceForAllBndr, ArgFlag(..), ShowForAllFlag(..),
ifForAllBndrTyVar, ifForAllBndrName,
ifTyConBinderTyVar, ifTyConBinderName,
-- Equality testing
......@@ -336,11 +337,19 @@ stripIfaceInvisVars dflags tyvars
| gopt Opt_PrintExplicitKinds dflags = tyvars
| otherwise = filterOut isInvisibleTyConBinder tyvars
-- | Extract a IfaceTvBndr from a IfaceTyConBinder
-- | Extract an 'IfaceTvBndr' from an 'IfaceForAllBndr'.
ifForAllBndrTyVar :: IfaceForAllBndr -> IfaceTvBndr
ifForAllBndrTyVar = binderVar
-- | Extract the variable name from an 'IfaceForAllBndr'.
ifForAllBndrName :: IfaceForAllBndr -> IfLclName
ifForAllBndrName fab = ifaceTvBndrName (ifForAllBndrTyVar fab)
-- | Extract an 'IfaceTvBndr' from an 'IfaceTyConBinder'.
ifTyConBinderTyVar :: IfaceTyConBinder -> IfaceTvBndr
ifTyConBinderTyVar = binderVar
-- | Extract the variable name from a IfaceTyConBinder
-- | Extract the variable name from an 'IfaceTyConBinder'.
ifTyConBinderName :: IfaceTyConBinder -> IfLclName
ifTyConBinderName tcb = ifaceTvBndrName (ifTyConBinderTyVar tcb)
......
......@@ -1643,7 +1643,8 @@ tyConToIfaceDecl env tycon
= IfCon { ifConName = dataConName data_con,
ifConInfix = dataConIsInfix data_con,
ifConWrapper = isJust (dataConWrapId_maybe data_con),
ifConExTvs = map toIfaceForAllBndr ex_bndrs',
ifConExTvs = map toIfaceTvBndr ex_tvs',
ifConUserTvBinders = map toIfaceForAllBndr user_bndrs',
ifConEqSpec = map (to_eq_spec . eqSpecPair) eq_spec,
ifConCtxt = tidyToIfaceContext con_env2 theta,
ifConArgTys = map (tidyToIfaceType con_env2) arg_tys,
......@@ -1653,9 +1654,9 @@ tyConToIfaceDecl env tycon
ifConSrcStricts = map toIfaceSrcBang
(dataConSrcBangs data_con)}
where
(univ_tvs, _ex_tvs, eq_spec, theta, arg_tys, _)
(univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _)
= dataConFullSig data_con
ex_bndrs = dataConExTyVarBinders data_con
user_bndrs = dataConUserTyVarBinders data_con
-- Tidy the univ_tvs of the data constructor to be identical
-- to the tyConTyVars of the type constructor. This means
......@@ -1667,9 +1668,21 @@ tyConToIfaceDecl env tycon
con_env1 = (fst tc_env1, mkVarEnv (zipEqual "ifaceConDecl" univ_tvs tc_tyvars))
-- A bit grimy, perhaps, but it's simple!
(con_env2, ex_bndrs') = tidyTyVarBinders con_env1 ex_bndrs
(con_env2, ex_tvs') = tidyTyCoVarBndrs con_env1 ex_tvs
user_bndrs' = map (tidyUserTyVarBinder con_env2) user_bndrs
to_eq_spec (tv,ty) = (tidyTyVar con_env2 tv, tidyToIfaceType con_env2 ty)
-- By this point, we have tidied every universal and existential
-- tyvar. Because of the dcUserTyVarBinders invariant
-- (see Note [DataCon user type variable binders]), *every*
-- user-written tyvar must be contained in the substitution that
-- tidying produced. Therefore, tidying the user-written tyvars is a
-- simple matter of looking up each variable in the substitution,
-- which tidyTyVarOcc accomplishes.
tidyUserTyVarBinder :: TidyEnv -> TyVarBinder -> TyVarBinder
tidyUserTyVarBinder env (TvBndr tv vis) =
TvBndr (tidyTyVarOcc env tv) vis
classToIfaceDecl :: TidyEnv -> Class -> (TidyEnv, IfaceDecl)
classToIfaceDecl env clas
= ( env1
......
......@@ -894,11 +894,12 @@ tcIfaceDataCons tycon_name tycon tc_tybinders if_cons
IfNewTyCon con -> do { data_con <- tc_con_decl con
; mkNewTyConRhs tycon_name tycon data_con }
where
univ_tv_bndrs :: [TyVarBinder]
univ_tv_bndrs = tyConTyVarBinders tc_tybinders
univ_tvs :: [TyVar]
univ_tvs = binderVars (tyConTyVarBinders tc_tybinders)
tc_con_decl (IfCon { ifConInfix = is_infix,
ifConExTvs = ex_bndrs,
ifConUserTvBinders = user_bndrs,
ifConName = dc_name,
ifConCtxt = ctxt, ifConEqSpec = spec,
ifConArgTys = args, ifConFields = lbl_names,
......@@ -906,9 +907,19 @@ tcIfaceDataCons tycon_name tycon tc_tybinders if_cons
ifConSrcStricts = if_src_stricts})
= -- Universally-quantified tyvars are shared with
-- parent TyCon, and are already in scope
bindIfaceForAllBndrs ex_bndrs $ \ ex_tv_bndrs -> do
bindIfaceTyVars ex_bndrs $ \ ex_tvs -> do
{ traceIf (text "Start interface-file tc_con_decl" <+> ppr dc_name)
-- By this point, we have bound every universal and existential
-- tyvar. Because of the dcUserTyVarBinders invariant
-- (see Note [DataCon user type variable binders]), *every* tyvar in
-- ifConUserTvBinders has a matching counterpart somewhere in the
-- bound universals/existentials. As a result, calling tcIfaceTyVar
-- below is always guaranteed to succeed.
; user_tv_bndrs <- mapM (\(TvBndr (name, _) vis) ->
TvBndr <$> tcIfaceTyVar name <*> pure vis)
user_bndrs
-- Read the context and argument types, but lazily for two reasons
-- (a) to avoid looking tugging on a recursive use of
-- the type itself, which is knot-tied
......@@ -947,7 +958,7 @@ tcIfaceDataCons tycon_name tycon tc_tybinders if_cons
-- worker.
-- See Note [Bangs on imported data constructors] in MkId
lbl_names
univ_tv_bndrs ex_tv_bndrs
univ_tvs ex_tvs user_tv_bndrs
eq_spec theta
arg_tys orig_res_ty tycon
; traceIf (text "Done interface-file tc_con_decl" <+> ppr dc_name)
......@@ -1839,6 +1850,13 @@ bindIfaceForAllBndr :: IfaceForAllBndr -> (TyVar -> ArgFlag -> IfL a) -> IfL a
bindIfaceForAllBndr (TvBndr tv vis) thing_inside
= bindIfaceTyVar tv $ \tv' -> thing_inside tv' vis
bindIfaceTyVars :: [IfaceTvBndr] -> ([TyVar] -> IfL a) -> IfL a
bindIfaceTyVars [] thing_inside = thing_inside []
bindIfaceTyVars (tv:tvs) thing_inside
= bindIfaceTyVar tv $ \tv' ->
bindIfaceTyVars tvs $ \tvs' ->
thing_inside (tv' : tvs')
bindIfaceTyVar :: IfaceTvBndr -> (TyVar -> IfL a) -> IfL a
bindIfaceTyVar (occ,kind) thing_inside
= do { name <- newIfaceName (mkTyVarOccFS occ)
......
......@@ -490,12 +490,15 @@ pcTyCon is_enum name cType tyvars cons
False -- Not in GADT syntax
pcDataCon :: Name -> [TyVar] -> [Type] -> TyCon -> DataCon
pcDataCon n univs = pcDataConWithFixity False n univs [] -- no ex_tvs
pcDataCon n univs = pcDataConWithFixity False n univs
[] -- no ex_tvs
univs -- the univs are precisely the user-written tyvars
pcDataConWithFixity :: Bool -- ^ declared infix?
-> Name -- ^ datacon name
-> [TyVar] -- ^ univ tyvars
-> [TyVar] -- ^ ex tyvars
-> [TyVar] -- ^ user-written tyvars
-> [Type] -- ^ args
-> TyCon
-> DataCon
......@@ -509,19 +512,20 @@ pcDataConWithFixity infx n = pcDataConWithFixity' infx n (dataConWorkerUnique (n
-- one DataCon unique per pair of Ints.
pcDataConWithFixity' :: Bool -> Name -> Unique -> RuntimeRepInfo
-> [TyVar] -> [TyVar]
-> [TyVar] -> [TyVar] -> [TyVar]
-> [Type] -> TyCon -> DataCon
-- The Name should be in the DataName name space; it's the name
-- of the DataCon itself.
pcDataConWithFixity' declared_infix dc_name wrk_key rri tyvars ex_tyvars arg_tys tycon
pcDataConWithFixity' declared_infix dc_name wrk_key rri
tyvars ex_tyvars user_tyvars arg_tys tycon
= data_con
where
data_con = mkDataCon dc_name declared_infix prom_info
(map (const no_bang) arg_tys)
[] -- No labelled fields
(mkTyVarBinders Specified tyvars)
(mkTyVarBinders Specified ex_tyvars)
tyvars ex_tyvars
(mkTyVarBinders Specified user_tyvars)
[] -- No equality spec
[] -- No theta
arg_tys (mkTyConApp tycon (mkTyVarTys tyvars))
......@@ -552,7 +556,7 @@ mkDataConWorkerName data_con wrk_key =
pcSpecialDataCon :: Name -> [Type] -> TyCon -> RuntimeRepInfo -> DataCon
pcSpecialDataCon dc_name arg_tys tycon rri
= pcDataConWithFixity' False dc_name (dataConWorkerUnique (nameUnique dc_name)) rri
[] [] arg_tys tycon
[] [] [] arg_tys tycon
{-
************************************************************************
......@@ -1418,7 +1422,8 @@ nilDataCon = pcDataCon nilDataConName alpha_tyvar [] listTyCon
consDataCon :: DataCon
consDataCon = pcDataConWithFixity True {- Declared infix -}
consDataConName
alpha_tyvar [] [alphaTy, mkTyConApp listTyCon alpha_ty] listTyCon
alpha_tyvar [] alpha_tyvar
[alphaTy, mkTyConApp listTyCon alpha_ty] listTyCon
-- Interesting: polymorphic recursion would help here.
-- We can't use (mkListTy alphaTy) in the defn of consDataCon, else mkListTy
-- gets the over-specific type (Type -> Type)
......
This diff is collapsed.
......@@ -138,8 +138,8 @@ module TyCoRep (
import GhcPrelude
import {-# SOURCE #-} DataCon( dataConFullSig
, dataConUnivTyVarBinders, dataConExTyVarBinders
, DataCon, filterEqSpec )
, dataConUserTyVarBinders
, DataCon )
import {-# SOURCE #-} Type( isPredTy, isCoercionTy, mkAppTy, mkCastTy
, tyCoVarsOfTypeWellScoped
, tyCoVarsOfTypesWellScoped
......@@ -2651,12 +2651,11 @@ pprDataCons = sepWithVBars . fmap pprDataConWithArgs . tyConDataCons
pprDataConWithArgs :: DataCon -> SDoc
pprDataConWithArgs dc = sep [forAllDoc, thetaDoc, ppr dc <+> argsDoc]
where
(_univ_tvs, _ex_tvs, eq_spec, theta, arg_tys, _res_ty) = dataConFullSig dc
univ_bndrs = dataConUnivTyVarBinders dc
ex_bndrs = dataConExTyVarBinders dc
forAllDoc = pprUserForAll $ (filterEqSpec eq_spec univ_bndrs ++ ex_bndrs)
thetaDoc = pprThetaArrowTy theta
argsDoc = hsep (fmap pprParendType arg_tys)
(_univ_tvs, _ex_tvs, _eq_spec, theta, arg_tys, _res_ty) = dataConFullSig dc
user_bndrs = dataConUserTyVarBinders dc
forAllDoc = pprUserForAll user_bndrs
thetaDoc = pprThetaArrowTy theta
argsDoc = hsep (fmap pprParendType arg_tys)
pprTypeApp :: TyCon -> [Type] -> SDoc
......
......@@ -78,14 +78,16 @@ buildPDataDataCon orig_name vect_tc repr_tc repr
comp_tys <- mkSumTys repr_sel_ty mkPDataType repr
fam_envs <- readGEnv global_fam_inst_env
rep_nm <- liftDs $ newTyConRepName dc_name
let univ_tvbs = mkTyVarBinders Specified tvs
liftDs $ buildDataCon fam_envs dc_name
False -- not infix
rep_nm
(map (const no_bang) comp_tys)
(Just $ map (const HsLazy) comp_tys)
[] -- no field labels
(mkTyVarBinders Specified tvs)
tvs
[] -- no existentials
univ_tvbs
[] -- no eq spec
[] -- no context
comp_tys
......@@ -122,14 +124,16 @@ buildPDatasDataCon orig_name vect_tc repr_tc repr
comp_tys <- mkSumTys repr_sels_ty mkPDatasType repr
fam_envs <- readGEnv global_fam_inst_env
rep_nm <- liftDs $ newTyConRepName dc_name
let univ_tvbs = mkTyVarBinders Specified tvs
liftDs $ buildDataCon fam_envs dc_name
False -- not infix
rep_nm
(map (const no_bang) comp_tys)
(Just $ map (const HsLazy) comp_tys)
[] -- no field labels
(mkTyVarBinders Specified tvs)
tvs
[] -- no existentials
univ_tvbs
[] -- no eq spec
[] -- no context
comp_tys
......
......@@ -200,8 +200,9 @@ vectDataCon dc
(dataConSrcBangs dc) -- strictness as original constructor
(Just $ dataConImplBangs dc)
[] -- no labelled fields for now
univ_bndrs -- universally quantified vars
univ_tvs -- universally quantified vars
[] -- no existential tvs for now
user_bndrs
[] -- no equalities for now
[] -- no context for now
arg_tys -- argument types
......@@ -213,4 +214,4 @@ vectDataCon dc
rep_arg_tys = dataConRepArgTys dc
tycon = dataConTyCon dc
(univ_tvs, ex_tvs, eq_spec, theta, _arg_tys, _res_ty) = dataConFullSig dc
univ_bndrs = dataConUnivTyVarBinders dc
user_bndrs = dataConUserTyVarBinders dc
......@@ -77,6 +77,17 @@ Language
GInt :: G Int
GMaybe :: G Maybe
- The order in which type variables are quantified in GADT constructor type
signatures has changed. Before, if you had ``MkT`` as below: ::
data T a where
MkT :: forall b a. b -> T a
Then the type of ``MkT`` would (counterintuitively) be
``forall a b. b -> T a``! Now, GHC quantifies the type variables in the
order that the users writes them, so the type of ``MkT`` is now
``forall b a. b -> T a`` (this matters for :ghc-flag:`-XTypeApplications`).
Compiler
~~~~~~~~
......
gadtSyntaxFail003.hs:7:5: error:
• Data constructor ‘C1’ has existential type variables, a context, or a specialised result type
C1 :: forall b a c. a -> Int -> c -> Foo b a
C1 :: forall a c b. a -> Int -> c -> Foo b a
(Use ExistentialQuantification or GADTs to allow this)
• In the definition of data constructor ‘C1’
In the data type declaration for ‘Foo’
:set -XGADTs -XPolyKinds -XTypeApplications
:set -fprint-explicit-foralls
import Data.Proxy
data X a where { MkX :: b -> Proxy a -> X a }
:type +v MkX
:type +v MkX @Int
:type +v MkX @Int @Maybe
MkX :: forall {k} b (a :: k). b -> Proxy a -> X a
MkX @Int :: forall {k} (a :: k). Int -> Proxy a -> X a
MkX @Int @Maybe :: Int -> Proxy Maybe -> X Maybe
......@@ -239,6 +239,7 @@ test('T12007', normal, ghci_script, ['T12007.script'])
test('T11975', normal, ghci_script, ['T11975.script'])
test('T10963', normal, ghci_script, ['T10963.script'])
test('T11547', normal, ghci_script, ['T11547.script'])
test('T11721', normal, ghci_script, ['T11721.script'])
test('T12520', normal, ghci_script, ['T12520.script'])
test('T12091', [extra_run_opts('-fobject-code')], ghci_script,
['T12091.script'])
......
......@@ -3,7 +3,7 @@ T11010.hs:9:36: error:
• Couldn't match type ‘a1’ with ‘Int’
‘a1’ is a rigid type variable bound by
a pattern with constructor:
Fun :: forall b a. String -> (a -> b) -> Expr a -> Expr b,
Fun :: forall a b. String -> (a -> b) -> Expr a -> Expr b,
in a pattern synonym declaration
at T11010.hs:9:26-36
Expected type: a -> b
......
......@@ -6,7 +6,7 @@ T8566.hs:32:9: error:
bound by the instance declaration at T8566.hs:30:10-67
or from: 'AA t (a : as) ~ 'AA t1 as1
bound by a pattern with constructor:
A :: forall (r :: [*]) v (t :: v) (as :: [U *]). I ('AA t as) r,
A :: forall v (t :: v) (as :: [U *]) (r :: [*]). I ('AA t as) r,
in an equation for ‘c’
at T8566.hs:32:5
The type variable ‘fs0’ is ambiguous
......
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
module T13848 where
data N = Z | S N
data Vec1 (n :: N) a where
VNil1 :: forall a. Vec1 Z a
<