From 35e937973f61a7e5534ecd0b1c67111cd82d4238 Mon Sep 17 00:00:00 2001 From: Richard Eisenberg Date: Sat, 19 Mar 2016 16:55:50 -0400 Subject: 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.) --- compiler/iface/BuildTyCl.hs | 48 ++++++++++++++++++++++++++++----------------- 1 file changed, 30 insertions(+), 18 deletions(-) (limited to 'compiler/iface/BuildTyCl.hs') diff --git a/compiler/iface/BuildTyCl.hs b/compiler/iface/BuildTyCl.hs index 87b5f36b7e..e20a6c6a8d 100644 --- a/compiler/iface/BuildTyCl.hs +++ b/compiler/iface/BuildTyCl.hs @@ -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 -- cgit v1.2.1