Commit 35e93797 authored by eir@cis.upenn.edu's avatar eir@cis.upenn.edu

Track specified/invisible more carefully.

In particular, this allows correct tracking of specified/invisible
for variables in Haskell98 data constructors and in pattern synonyms.
GADT-syntax constructors are harder, and are left until #11721.

This was all inspired by Simon's comments to my fix for #11512,
which this subsumes.

Test case: ghci/scripts/TypeAppData

[skip ci]  (The test case fails because of an unrelated problem
fixed in the next commit.)
parent 94770939
......@@ -18,7 +18,7 @@ module DataCon (
-- ** Equality specs
EqSpec, mkEqSpec, eqSpecTyVar, eqSpecType,
eqSpecPair, eqSpecPreds,
substEqSpec,
substEqSpec, filterEqSpec,
-- ** Field labels
FieldLbl(..), FieldLabel, FieldLabelString,
......@@ -30,7 +30,9 @@ module DataCon (
dataConRepType, dataConSig, dataConInstSig, dataConFullSig,
dataConName, dataConIdentity, dataConTag, dataConTyCon,
dataConOrigTyCon, dataConUserType,
dataConUnivTyVars, dataConExTyVars, dataConAllTyVars,
dataConUnivTyVars, dataConUnivTyBinders,
dataConExTyVars, dataConExTyBinders,
dataConAllTyVars,
dataConEqSpec, dataConTheta,
dataConStupidTheta,
dataConInstArgTys, dataConOrigArgTys, dataConOrigResTy,
......@@ -301,6 +303,13 @@ data DataCon
dcUnivTyVars :: [TyVar], -- Universally-quantified type vars [a,b,c]
-- INVARIANT: length matches arity of the dcRepTyCon
--- result type of (rep) data con is exactly (T a b c)
dcUnivTyBinders :: [TyBinder], -- Binders for universal tyvars. These will all
-- be Named, and all be Invisible or Specified.
-- Storing these separately from dcUnivTyVars
-- is solely because we usually don't need the
-- binders, and the extraction of the tyvars is
-- unnecessary work. See also
-- Note [TyBinders in DataCons]
dcExTyVars :: [TyVar], -- Existentially-quantified type vars
-- In general, the dcUnivTyVars are NOT NECESSARILY THE SAME AS THE TYVARS
......@@ -309,6 +318,8 @@ data DataCon
-- [This is a change (Oct05): previously, vanilla datacons guaranteed to
-- have the same type variables as their parent TyCon, but that seems ugly.]
dcExTyBinders :: [TyBinder], -- see dcUnivTyBinders
-- INVARIANT: the UnivTyVars and ExTyVars all have distinct OccNames
-- Reason: less confusing, and easier to generate IfaceSyn
......@@ -529,6 +540,14 @@ substEqSpec subst (EqSpec tv ty)
where
tv' = getTyVar "substEqSpec" (substTyVar subst tv)
-- | Filter out any TyBinders mentioned in an EqSpec
filterEqSpec :: [EqSpec] -> [TyBinder] -> [TyBinder]
filterEqSpec eq_spec
= filter not_in_eq_spec
where
not_in_eq_spec bndr = let var = binderVar "filterEqSpec" bndr in
all (not . (== var) . eqSpecTyVar) eq_spec
instance Outputable EqSpec where
ppr (EqSpec tv ty) = ppr (tv, ty)
......@@ -705,6 +724,42 @@ isMarkedStrict _ = True -- All others are strict
\subsection{Construction}
* *
************************************************************************
Note [TyBinders in DataCons]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
A DataCon needs to keep track of the visibility of its universals and
existentials, so that visible type application can work properly. This
is done by storing the universal and existential TyBinders, along with
the TyVars. These TyBinders should all be Named and should all be
Invisible or Specified; we don't have Visible or Anon type arguments.
During construction of a DataCon, we often have the TyBinders of the
parent TyCon. But those TyBinders are *different* than those of the
DataCon. Here is an example:
data Proxy a = P
The TyCon has these TyBinders:
[ Named (k :: *) Invisible, Anon k ]
Note that Proxy's kind is forall k. k -> *. But the DataCon P should
have (universal) TyBinders
[ Named (k :: *) Invisible, Named (a :: k) Specified ]
So we want to take the TyCon's TyBinders and the TyCon's TyVars and
merge them, pulling variable names from the TyVars but visibilities
from the TyBinders, perserving Invisible but changing Visible to
Specified. (The `a` in Proxy is indeed Visible, but the `a` in P should
be Specified.) This merging operation is done in buildDataCon. In contrast,
the TyBinders passed to mkDataCon are the real TyBinders stored in the
DataCon. Note that passing the TyVars into mkDataCon is redundant, but
convenient for both caller and the function's implementation.
In most places in GHC, it's just the TyVars that are needed,
so that's what's returned from, say, dataConFullSig.
-}
-- | Build a new data constructor
......@@ -714,8 +769,9 @@ mkDataCon :: Name
-> [HsSrcBang] -- ^ Strictness/unpack annotations, from user
-> [FieldLabel] -- ^ Field labels for the constructor,
-- if it is a record, otherwise empty
-> [TyVar] -- ^ Universally quantified type variables
-> [TyVar] -- ^ Existentially quantified type variables
-> [TyVar] -> [TyBinder] -- ^ Universals. See Note [TyBinders in DataCons]
-> [TyVar] -> [TyBinder] -- ^ Existentials.
-- (These last two must be Named and Invisible/Specified)
-> [EqSpec] -- ^ GADT equalities
-> ThetaType -- ^ Theta-type occuring before the arguments proper
-> [Type] -- ^ Original argument types
......@@ -732,7 +788,7 @@ mkDataCon :: Name
mkDataCon name declared_infix prom_info
arg_stricts -- Must match orig_arg_tys 1-1
fields
univ_tvs ex_tvs
univ_tvs univ_bndrs ex_tvs ex_bndrs
eq_spec theta
orig_arg_tys orig_res_ty rep_info rep_tycon
stupid_theta work_id rep
......@@ -749,7 +805,8 @@ mkDataCon name declared_infix prom_info
is_vanilla = null ex_tvs && null eq_spec && null theta
con = MkData {dcName = name, dcUnique = nameUnique name,
dcVanilla = is_vanilla, dcInfix = declared_infix,
dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs,
dcUnivTyVars = univ_tvs, dcUnivTyBinders = univ_bndrs,
dcExTyVars = ex_tvs, dcExTyBinders = ex_bndrs,
dcEqSpec = eq_spec,
dcOtherTheta = theta,
dcStupidTheta = stupid_theta,
......@@ -769,16 +826,14 @@ mkDataCon name declared_infix prom_info
tag = assoc "mkDataCon" (tyConDataCons rep_tycon `zip` [fIRST_TAG..]) con
rep_arg_tys = dataConRepArgTys con
-- NB: This type is user-facing for datatypes that don't need wrappers;
-- so it's important to use mkSpecForAllTys
rep_ty = mkSpecForAllTys univ_tvs $ mkSpecForAllTys ex_tvs $
rep_ty = mkForAllTys univ_bndrs $ mkForAllTys ex_bndrs $
mkFunTys rep_arg_tys $
mkTyConApp rep_tycon (mkTyVarTys univ_tvs)
-- See Note [Promoted data constructors] in TyCon
prom_binders = map (mkNamedBinder Specified)
((univ_tvs `minusList` map eqSpecTyVar eq_spec) ++
ex_tvs) ++
prom_binders = filterEqSpec eq_spec univ_bndrs ++
ex_bndrs ++
map mkAnonBinder theta ++
map mkAnonBinder orig_arg_tys
prom_res_kind = orig_res_ty
......@@ -821,10 +876,18 @@ dataConIsInfix = dcInfix
dataConUnivTyVars :: DataCon -> [TyVar]
dataConUnivTyVars = dcUnivTyVars
-- | 'TyBinder's for the universally-quantified type variables
dataConUnivTyBinders :: DataCon -> [TyBinder]
dataConUnivTyBinders = dcUnivTyBinders
-- | The existentially-quantified type variables of the constructor
dataConExTyVars :: DataCon -> [TyVar]
dataConExTyVars = dcExTyVars
-- | 'TyBinder's for the existentially-quantified type variables
dataConExTyBinders :: DataCon -> [TyBinder]
dataConExTyBinders = dcExTyBinders
-- | Both the universal and existentiatial type variables of the constructor
dataConAllTyVars :: DataCon -> [TyVar]
dataConAllTyVars (MkData { dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs })
......@@ -1030,15 +1093,16 @@ dataConUserType :: DataCon -> Type
--
-- NB: If the constructor is part of a data instance, the result type
-- mentions the family tycon, not the internal one.
dataConUserType (MkData { dcUnivTyVars = univ_tvs,
dcExTyVars = ex_tvs, dcEqSpec = eq_spec,
dataConUserType (MkData { dcUnivTyBinders = univ_bndrs,
dcExTyBinders = ex_bndrs, dcEqSpec = eq_spec,
dcOtherTheta = theta, dcOrigArgTys = arg_tys,
dcOrigResTy = res_ty })
= mkSpecForAllTys ((univ_tvs `minusList` map eqSpecTyVar eq_spec) ++
ex_tvs) $
= mkForAllTys (filterEqSpec eq_spec univ_bndrs) $
mkForAllTys ex_bndrs $
mkFunTys theta $
mkFunTys arg_tys $
res_ty
where
-- | Finds the instantiated types of the arguments required to construct a 'DataCon' representation
-- NB: these INCLUDE any dictionary args
......
......@@ -6,16 +6,18 @@ import FieldLabel ( FieldLabel )
import Unique ( Uniquable )
import Outputable ( Outputable, OutputableBndr )
import BasicTypes (Arity)
import {-# SOURCE #-} TyCoRep (Type, ThetaType)
import {-# SOURCE #-} TyCoRep (Type, ThetaType, TyBinder)
data DataCon
data DataConRep
data EqSpec
eqSpecTyVar :: EqSpec -> TyVar
filterEqSpec :: [EqSpec] -> [TyBinder] -> [TyBinder]
dataConName :: DataCon -> Name
dataConTyCon :: DataCon -> TyCon
dataConUnivTyBinders :: DataCon -> [TyBinder]
dataConExTyVars :: DataCon -> [TyVar]
dataConExTyBinders :: DataCon -> [TyBinder]
dataConSourceArity :: DataCon -> Arity
dataConFieldLabels :: DataCon -> [FieldLabel]
dataConInstOrigArgTys :: DataCon -> [Type] -> [Type]
......
......@@ -274,25 +274,15 @@ mkDictSelId name clas
sel_names = map idName (classAllSelIds clas)
new_tycon = isNewTyCon tycon
[data_con] = tyConDataCons tycon
binders = dataConUnivTyBinders data_con
tyvars = dataConUnivTyVars data_con
tc_binders = tyConBinders tycon
arg_tys = dataConRepArgTys data_con -- Includes the dictionary superclasses
val_index = assoc "MkId.mkDictSelId" (sel_names `zip` [0..]) name
sel_ty = mkForAllTys (zipWith mk_binder tc_binders tyvars) $
sel_ty = mkForAllTys binders $
mkFunTy (mkClassPred clas (mkTyVarTys tyvars)) $
getNth arg_tys val_index
-- copy the visibility from the tycon binders. Consider:
-- class C a where foo :: Proxy a
-- In the type of foo, `a` must be Specified but `k` must be Invisible
mk_binder tc_binder tyvar
| Invisible <- binderVisibility tc_binder
= mkNamedBinder Invisible tyvar
| otherwise
= mkNamedBinder Specified tyvar -- don't just copy from tc_binder, because
-- tc_binders can be Visible
base_info = noCafIdInfo
`setArityInfo` 1
`setStrictnessInfo` strict_sig
......
......@@ -15,7 +15,7 @@ module PatSyn (
patSynName, patSynArity, patSynIsInfix,
patSynArgs, patSynType,
patSynMatcher, patSynBuilder,
patSynExTyVars, patSynSig,
patSynUnivTyBinders, patSynExTyVars, patSynExTyBinders, patSynSig,
patSynInstArgTys, patSynInstResTy, patSynFieldLabels,
patSynFieldType,
......@@ -65,12 +65,14 @@ data PatSyn
-- psArgs
psUnivTyVars :: [TyVar], -- Universially-quantified type variables
psUnivTyBinders :: [TyBinder], -- same, with visibility info
psReqTheta :: ThetaType, -- Required dictionaries
-- these constraints are very much like
-- stupid thetas (which is a useful
-- guideline when implementing)
-- but are actually needed.
psExTyVars :: [TyVar], -- Existentially-quantified type vars
psExTyBinders :: [TyBinder], -- same, with visibility info
psProvTheta :: ThetaType, -- Provided dictionaries
psOrigResTy :: Type, -- Mentions only psUnivTyVars
......@@ -288,9 +290,11 @@ instance Data.Data PatSyn where
-- | Build a new pattern synonym
mkPatSyn :: Name
-> Bool -- ^ Is the pattern synonym declared infix?
-> ([TyVar], ThetaType) -- ^ Universially-quantified type variables
-> ([TyVar], [TyBinder], ThetaType)
-- ^ Universially-quantified type variables
-- and required dicts
-> ([TyVar], ThetaType) -- ^ Existentially-quantified type variables
-> ([TyVar], [TyBinder], ThetaType)
-- ^ Existentially-quantified type variables
-- and provided dicts
-> [Type] -- ^ Original arguments
-> Type -- ^ Original result type
......@@ -299,14 +303,17 @@ mkPatSyn :: Name
-> [FieldLabel] -- ^ Names of fields for
-- a record pattern synonym
-> PatSyn
-- NB: The univ and ex vars are both in TyBinder form and TyVar form for
-- convenience. All the TyBinders should be Named!
mkPatSyn name declared_infix
(univ_tvs, req_theta)
(ex_tvs, prov_theta)
(univ_tvs, univ_bndrs, req_theta)
(ex_tvs, ex_bndrs, prov_theta)
orig_args
orig_res_ty
matcher builder field_labels
= MkPatSyn {psName = name, psUnique = getUnique name,
psUnivTyVars = univ_tvs, psExTyVars = ex_tvs,
psUnivTyVars = univ_tvs, psUnivTyBinders = univ_bndrs,
psExTyVars = ex_tvs, psExTyBinders = ex_bndrs,
psProvTheta = prov_theta, psReqTheta = req_theta,
psInfix = declared_infix,
psArgs = orig_args,
......@@ -352,9 +359,15 @@ patSynFieldType ps label
Just (_, ty) -> ty
Nothing -> pprPanic "dataConFieldType" (ppr ps <+> ppr label)
patSynUnivTyBinders :: PatSyn -> [TyBinder]
patSynUnivTyBinders = psUnivTyBinders
patSynExTyVars :: PatSyn -> [TyVar]
patSynExTyVars = psExTyVars
patSynExTyBinders :: PatSyn -> [TyBinder]
patSynExTyBinders = psExTyBinders
patSynSig :: PatSyn -> ([TyVar], ThetaType, [TyVar], ThetaType, [Type], Type)
patSynSig (MkPatSyn { psUnivTyVars = univ_tvs, psExTyVars = ex_tvs
, psProvTheta = prov, psReqTheta = req
......
......@@ -111,7 +111,9 @@ buildDataCon :: FamInstEnvs
-> Maybe [HsImplBang]
-- See Note [Bangs on imported data constructors] in MkId
-> [FieldLabel] -- Field labels
-> [TyVar] -> [TyVar] -- Univ and ext
-> [TyVar] -> [TyBinder] -- Universals; see
-- Note [TyBinders in DataCons] in DataCon
-> [TyVar] -> [TyBinder] -- existentials
-> [EqSpec] -- Equality spec
-> ThetaType -- Does not include the "stupid theta"
-- or the GADT equalities
......@@ -122,8 +124,9 @@ buildDataCon :: FamInstEnvs
-- a) makes the worker Id
-- b) makes the wrapper Id if necessary, including
-- allocating its unique (hence monadic)
-- c) Sorts out the TyBinders. See Note [TyBinders in DataCons] in DataCon
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 univ_bndrs ex_tvs ex_bndrs 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
......@@ -133,16 +136,23 @@ buildDataCon fam_envs src_name declared_infix prom_info src_bangs impl_bangs fie
; traceIf (text "buildDataCon 1" <+> ppr src_name)
; us <- newUniqueSupply
; dflags <- getDynFlags
; 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
arg_tys res_ty NoRRI rep_tycon
stupid_ctxt dc_wrk dc_rep
dc_wrk = mkDataConWorkId work_name data_con
dc_rep = initUs_ us (mkDataConRep dflags fam_envs wrap_name
impl_bangs data_con)
; let -- See Note [TyBinders in DataCons] in DataCon
dc_bndrs = zipWith mk_binder univ_tvs univ_bndrs
mk_binder tv bndr = mkNamedBinder vis tv
where
vis = case binderVisibility bndr of
Invisible -> Invisible
_ -> Specified
stupid_ctxt = mkDataConStupidTheta rep_tycon arg_tys univ_tvs
data_con = mkDataCon src_name declared_infix prom_info
src_bangs field_lbls
univ_tvs dc_bndrs ex_tvs ex_bndrs eq_spec ctxt
arg_tys res_ty NoRRI rep_tycon
stupid_ctxt dc_wrk dc_rep
dc_wrk = mkDataConWorkId work_name data_con
dc_rep = initUs_ us (mkDataConRep dflags fam_envs wrap_name
impl_bangs data_con)
; traceIf (text "buildDataCon 2" <+> ppr src_name)
; return data_con }
......@@ -170,15 +180,15 @@ mkDataConStupidTheta tycon arg_tys univ_tvs
------------------------------------------------------
buildPatSyn :: Name -> Bool
-> (Id,Bool) -> Maybe (Id, Bool)
-> ([TyVar], ThetaType) -- ^ Univ and req
-> ([TyVar], ThetaType) -- ^ Ex and prov
-> ([TyVar], [TyBinder], ThetaType) -- ^ Univ and req
-> ([TyVar], [TyBinder], ThetaType) -- ^ Ex and prov
-> [Type] -- ^ Argument types
-> Type -- ^ Result type
-> [FieldLabel] -- ^ Field labels for
-- a record pattern synonym
-> PatSyn
buildPatSyn src_name declared_infix matcher@(matcher_id,_) builder
(univ_tvs, req_theta) (ex_tvs, prov_theta) arg_tys
(univ_tvs, univ_bndrs, req_theta) (ex_tvs, ex_bndrs, prov_theta) arg_tys
pat_ty field_labels
= -- The assertion checks that the matcher is
-- compatible with the pattern synonym
......@@ -196,7 +206,7 @@ buildPatSyn src_name declared_infix matcher@(matcher_id,_) builder
, ppr req_theta <+> twiddle <+> ppr req_theta1
, ppr arg_tys <+> twiddle <+> ppr arg_tys1]))
mkPatSyn src_name declared_infix
(univ_tvs, req_theta) (ex_tvs, prov_theta)
(univ_tvs, univ_bndrs, req_theta) (ex_tvs, ex_bndrs, prov_theta)
arg_tys pat_ty
matcher builder field_labels
where
......@@ -215,7 +225,7 @@ type TcMethInfo = (Name, Type, Maybe (DefMethSpec Type))
buildClass :: Name -- Name of the class/tycon (they have the same Name)
-> [TyVar] -> [Role] -> ThetaType
-> [TyBinder]
-> [TyBinder] -- of the tycon
-> [FunDep TyVar] -- Functional dependencies
-> [ClassATItem] -- Associated types
-> [TcMethInfo] -- Method info
......@@ -273,7 +283,9 @@ buildClass tycon_name tvs roles sc_theta binders
(map (const no_bang) args)
(Just (map (const HsLazy) args))
[{- No fields -}]
tvs [{- no existentials -}]
tvs binders
[{- no existentials -}]
[{- no existentials -}]
[{- No GADT equalities -}]
[{- No theta -}]
arg_tys
......
......@@ -146,8 +146,8 @@ data IfaceDecl
ifPatBuilder :: Maybe (IfExtName, Bool),
-- Everything below is redundant,
-- but needed to implement pprIfaceDecl
ifPatUnivTvs :: [IfaceTvBndr],
ifPatExTvs :: [IfaceTvBndr],
ifPatUnivBndrs :: [IfaceForAllBndr],
ifPatExBndrs :: [IfaceForAllBndr],
ifPatProvCtxt :: IfaceContext,
ifPatReqCtxt :: IfaceContext,
ifPatArgs :: [IfaceType],
......@@ -215,7 +215,7 @@ data IfaceConDecl
-- but it's not so easy for the original TyCon/DataCon
-- So this guarantee holds for IfaceConDecl, but *not* for DataCon
ifConExTvs :: [IfaceTvBndr], -- Existential tyvars
ifConExTvs :: [IfaceForAllBndr], -- Existential tyvars (w/ visibility)
ifConEqSpec :: IfaceEqSpec, -- Equality constraints
ifConCtxt :: IfaceContext, -- Non-stupid context
ifConArgTys :: [IfaceType], -- Arg types
......@@ -753,7 +753,7 @@ pprIfaceDecl ss (IfaceFamily { ifName = tycon
pp_branches _ = Outputable.empty
pprIfaceDecl _ (IfacePatSyn { ifName = name,
ifPatUnivTvs = univ_tvs, ifPatExTvs = ex_tvs,
ifPatUnivBndrs = univ_bndrs, ifPatExBndrs = ex_bndrs,
ifPatProvCtxt = prov_ctxt, ifPatReqCtxt = req_ctxt,
ifPatArgs = arg_tys,
ifPatTy = pat_ty} )
......@@ -766,8 +766,8 @@ pprIfaceDecl _ (IfacePatSyn { ifName = name,
, ex_msg, pprIfaceContextArr prov_ctxt
, pprIfaceType $ foldr IfaceFunTy pat_ty arg_tys]
where
univ_msg = pprUserIfaceForAll $ map tv_to_forall_bndr univ_tvs
ex_msg = pprUserIfaceForAll $ map tv_to_forall_bndr ex_tvs
univ_msg = pprUserIfaceForAll univ_bndrs
ex_msg = pprUserIfaceForAll ex_bndrs
insert_empty_ctxt = null req_ctxt
&& not (null prov_ctxt && isEmpty dflags ex_msg)
......@@ -883,7 +883,7 @@ pprIfaceConDecl ss gadt_style fls tycon tc_binders parent
pp_prefix_con = pprPrefixIfDeclBndr ss name
(univ_tvs, pp_res_ty) = mk_user_con_res_ty eq_spec
ppr_ty = pprIfaceForAllPart (map tv_to_forall_bndr (univ_tvs ++ ex_tvs))
ppr_ty = pprIfaceForAllPart (map tv_to_forall_bndr univ_tvs ++ ex_tvs)
ctxt pp_tau
-- A bit gruesome this, but we can't form the full con_tau, and ppr it,
......@@ -1177,8 +1177,8 @@ freeNamesIfDecl d@IfaceAxiom{} =
freeNamesIfDecl d@IfacePatSyn{} =
unitNameSet (fst (ifPatMatcher d)) &&&
maybe emptyNameSet (unitNameSet . fst) (ifPatBuilder d) &&&
freeNamesIfTvBndrs (ifPatUnivTvs d) &&&
freeNamesIfTvBndrs (ifPatExTvs d) &&&
fnList freeNamesIfForAllBndr (ifPatUnivBndrs d) &&&
fnList freeNamesIfForAllBndr (ifPatExBndrs d) &&&
freeNamesIfContext (ifPatProvCtxt d) &&&
freeNamesIfContext (ifPatReqCtxt d) &&&
fnList freeNamesIfType (ifPatArgs d) &&&
......@@ -1234,7 +1234,7 @@ freeNamesIfConDecls _ = emptyNameSet
freeNamesIfConDecl :: IfaceConDecl -> NameSet
freeNamesIfConDecl c
= freeNamesIfTvBndrs (ifConExTvs c) &&&
= fnList freeNamesIfForAllBndr (ifConExTvs c) &&&
freeNamesIfContext (ifConCtxt c) &&&
fnList freeNamesIfType (ifConArgTys c) &&&
fnList freeNamesIfType (map snd (ifConEqSpec c)) -- equality constraints
......
......@@ -32,6 +32,7 @@ module IfaceType (
toIfaceTyCon, toIfaceTyCon_name,
toIfaceTcArgs, toIfaceTvBndrs,
zipIfaceBinders, toDegenerateBinders,
binderToIfaceForAllBndr,
-- Conversion from IfaceTcArgs -> IfaceType
tcArgsIfaceTypes,
......@@ -1341,6 +1342,11 @@ varToIfaceForAllBndr :: TyVar -> VisibilityFlag -> IfaceForAllBndr
varToIfaceForAllBndr v vis
= IfaceTv (toIfaceTvBndr v) vis
binderToIfaceForAllBndr :: TyBinder -> IfaceForAllBndr
binderToIfaceForAllBndr (Named v vis) = IfaceTv (toIfaceTvBndr v) vis
binderToIfaceForAllBndr binder
= pprPanic "binderToIfaceForAllBndr" (ppr binder)
----------------
toIfaceTyCon :: TyCon -> IfaceTyCon
toIfaceTyCon tc
......
......@@ -1304,8 +1304,8 @@ patSynToIfaceDecl ps
, ifPatMatcher = to_if_pr (patSynMatcher ps)
, ifPatBuilder = fmap to_if_pr (patSynBuilder ps)
, ifPatIsInfix = patSynIsInfix ps
, ifPatUnivTvs = toIfaceTvBndrs univ_tvs'
, ifPatExTvs = toIfaceTvBndrs ex_tvs'
, ifPatUnivBndrs = map binderToIfaceForAllBndr univ_bndrs'
, ifPatExBndrs = map binderToIfaceForAllBndr ex_bndrs'
, ifPatProvCtxt = tidyToIfaceContext env2 prov_theta
, ifPatReqCtxt = tidyToIfaceContext env2 req_theta
, ifPatArgs = map (tidyToIfaceType env2) args
......@@ -1313,9 +1313,11 @@ patSynToIfaceDecl ps
, ifFieldLabels = (patSynFieldLabels ps)
}
where
(univ_tvs, req_theta, ex_tvs, prov_theta, args, rhs_ty) = patSynSig ps
(env1, univ_tvs') = tidyTyCoVarBndrs emptyTidyEnv univ_tvs
(env2, ex_tvs') = tidyTyCoVarBndrs env1 ex_tvs
(_univ_tvs, req_theta, _ex_tvs, prov_theta, args, rhs_ty) = patSynSig ps
univ_bndrs = patSynUnivTyBinders ps
ex_bndrs = patSynExTyBinders ps
(env1, univ_bndrs') = tidyTyBinders emptyTidyEnv univ_bndrs
(env2, ex_bndrs') = tidyTyBinders env1 ex_bndrs
to_if_pr (id, needs_dummy) = (idName id, needs_dummy)
--------------------------
......@@ -1470,7 +1472,7 @@ tyConToIfaceDecl env tycon
= IfCon { ifConOcc = getOccName (dataConName data_con),
ifConInfix = dataConIsInfix data_con,
ifConWrapper = isJust (dataConWrapId_maybe data_con),
ifConExTvs = toIfaceTvBndrs ex_tvs',
ifConExTvs = map binderToIfaceForAllBndr ex_bndrs',
ifConEqSpec = map (to_eq_spec . eqSpecPair) eq_spec,
ifConCtxt = tidyToIfaceContext con_env2 theta,
ifConArgTys = map (tidyToIfaceType con_env2) arg_tys,
......@@ -1481,8 +1483,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 = dataConExTyBinders data_con
-- Tidy the univ_tvs of the data constructor to be identical
-- to the tyConTyVars of the type constructor. This means
......@@ -1494,7 +1497,7 @@ 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_tvs') = tidyTyCoVarBndrs con_env1 ex_tvs
(con_env2, ex_bndrs') = tidyTyBinders con_env1 ex_bndrs
to_eq_spec (tv,ty) = (toIfaceTyVar (tidyTyVar con_env2 tv), tidyToIfaceType con_env2 ty)
ifaceOverloaded flds = case fsEnvElts flds of
......
......@@ -325,7 +325,7 @@ tc_iface_decl _ _ (IfaceData {ifName = occ_name,
; tycon <- fixM $ \ tycon -> do
{ stupid_theta <- tcIfaceCtxt ctxt
; parent' <- tc_parent tc_name mb_parent
; cons <- tcIfaceDataCons tc_name tycon tyvars rdr_cons
; cons <- tcIfaceDataCons tc_name tycon tyvars binders' rdr_cons
; return (mkAlgTyCon tc_name binders' res_kind' tyvars roles cType stupid_theta
cons parent' is_rec gadt_syn) }
; traceIf (text "tcIfaceDecl4" <+> ppr tycon)
......@@ -476,8 +476,8 @@ tc_iface_decl _ _ (IfacePatSyn{ ifName = occ_name
, ifPatMatcher = if_matcher
, ifPatBuilder = if_builder
, ifPatIsInfix = is_infix
, ifPatUnivTvs = univ_tvs
, ifPatExTvs = ex_tvs
, ifPatUnivBndrs = univ_bndrs
, ifPatExBndrs = ex_bndrs
, ifPatProvCtxt = prov_ctxt
, ifPatReqCtxt = req_ctxt
, ifPatArgs = args
......@@ -487,15 +487,16 @@ tc_iface_decl _ _ (IfacePatSyn{ ifName = occ_name
; traceIf (text "tc_iface_decl" <+> ppr name)
; matcher <- tc_pr if_matcher
; builder <- fmapMaybeM tc_pr if_builder
; bindIfaceTvBndrs univ_tvs $ \univ_tvs -> do
{ bindIfaceTvBndrs ex_tvs $ \ex_tvs -> do
; bindIfaceForAllBndrs univ_bndrs $ \univ_tvs univ_bndrs -> do
{ bindIfaceForAllBndrs ex_bndrs $ \ex_tvs ex_bndrs -> do
{ patsyn <- forkM (mk_doc name) $
do { prov_theta <- tcIfaceCtxt prov_ctxt
; req_theta <- tcIfaceCtxt req_ctxt
; pat_ty <- tcIfaceType pat_ty
; arg_tys <- mapM tcIfaceType args
; return $ buildPatSyn name is_infix matcher builder
(univ_tvs, req_theta) (ex_tvs, prov_theta)
(univ_tvs, univ_bndrs, req_theta)
(ex_tvs, ex_bndrs, prov_theta)
arg_tys pat_ty field_labels }
; return $ AConLike . PatSynCon $ patsyn }}}
where
......@@ -527,8 +528,8 @@ tc_ax_branch prev_branches
, cab_incomps = map (prev_branches `getNth`) incomps }
; return (prev_branches ++ [br]) }
tcIfaceDataCons :: Name -> TyCon -> [TyVar] -> IfaceConDecls -> IfL AlgTyConRhs
tcIfaceDataCons tycon_name tycon tc_tyvars if_cons
tcIfaceDataCons :: Name -> TyCon -> [TyVar] -> [TyBinder] -> IfaceConDecls -> IfL AlgTyConRhs
tcIfaceDataCons tycon_name tycon tc_tyvars tc_tybinders if_cons
= case if_cons of
IfAbstractTyCon dis -> return (AbstractTyCon dis)
IfDataTyCon cons _ _ -> do { field_lbls <- mapM (traverse lookupIfaceTop) (ifaceConDeclFields if_cons)
......@@ -539,14 +540,14 @@ tcIfaceDataCons tycon_name tycon tc_tyvars if_cons
; mkNewTyConRhs tycon_name tycon data_con }
where
tc_con_decl field_lbls (IfCon { ifConInfix = is_infix,
ifConExTvs = ex_tvs,
ifConExTvs = ex_bndrs,
ifConOcc = occ, ifConCtxt = ctxt, ifConEqSpec = spec,
ifConArgTys = args, ifConFields = my_lbls,
ifConStricts = if_stricts,
ifConSrcStricts = if_src_stricts})
= -- Universally-quantified tyvars are shared with
-- parent TyCon, and are alrady in scope
bindIfaceTvBndrs ex_tvs $ \ ex_tyvars -> do
bindIfaceForAllBndrs ex_bndrs $ \ ex_tvs ex_binders' -> do
{ traceIf (text "Start interface-file tc_con_decl" <+> ppr occ)
; dc_name <- lookupIfaceTop occ
......@@ -588,7 +589,7 @@ tcIfaceDataCons tycon_name tycon tc_tyvars if_cons
-- worker.
-- See Note [Bangs on imported data constructors] in MkId
lbl_names