diff options
82 files changed, 1121 insertions, 1114 deletions
diff --git a/compiler/basicTypes/DataCon.hs b/compiler/basicTypes/DataCon.hs index 138e5d2b0b..b5a22631ae 100644 --- a/compiler/basicTypes/DataCon.hs +++ b/compiler/basicTypes/DataCon.hs @@ -30,8 +30,8 @@ module DataCon ( dataConRepType, dataConSig, dataConInstSig, dataConFullSig, dataConName, dataConIdentity, dataConTag, dataConTyCon, dataConOrigTyCon, dataConUserType, - dataConUnivTyVars, dataConUnivTyBinders, - dataConExTyVars, dataConExTyBinders, + dataConUnivTyVars, dataConUnivTyVarBinders, + dataConExTyVars, dataConExTyVarBinders, dataConAllTyVars, dataConEqSpec, dataConTheta, dataConStupidTheta, @@ -307,14 +307,10 @@ data DataCon -- Universally-quantified type vars [a,b,c] -- INVARIANT: length matches arity of the dcRepTyCon -- INVARIANT: result type of data con worker is exactly (T a b c) - dcUnivTyVars :: [TyVar], -- Two linked fields - dcUnivTyBinders :: [TyBinder], -- see Note [TyBinders in DataCons] - + dcUnivTyVars :: [TyVarBinder], -- Existentially-quantified type vars [x,y] - dcExTyVars :: [TyVar], -- Two linked fields - dcExTyBinders :: [TyBinder], -- see Note [TyBinders in DataCons] - + dcExTyVars :: [TyVarBinder], -- INVARIANT: the UnivTyVars and ExTyVars all have distinct OccNames -- Reason: less confusing, and easier to generate IfaceSyn @@ -416,38 +412,18 @@ data DataCon } -{- Note [TyBinders in DataCons] +{- Note [TyVarBinders in DataCons] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -DataCons and PatSyns store their universal and existential type -variables in a pair of fields, e.g. - dcUnivTyVars :: [TyVar], - dcUnivTyBinders :: [TyBinder], -and similarly dcExTyVars/dcExTyVarBinders - -Of these, the former is always redundant: - dcUnivTyVars = [ tv | Named tv _ <- dcUnivTyBinders ] - -Specifically: - - * The two fields correspond 1-1 +For the TyVarBinders in a DataCon and PatSyn: - * Each TyBinder a Named (no Anons) - - * The TyVar in each TyBinder is the same as the TyVar in - the corresponding tyvar in the TyVars list. - - * Each Visibilty flag (va, vb, etc) is Invisible or Specified. + * Each Visibilty flag is Invisible or Specified. None are Visible. (A DataCon is a term-level function; see Note [No Visible TyBinder in terms] in TyCoRep.) -Why store these fields redundantly? Purely convenience. In most -places in GHC, it's just the TyVars that are needed, so that's what's -returned from, say, dataConFullSig. - -Why do we need the TyBinders? So that we can construct the right -type for the DataCon with its foralls attributed the correce visiblity. -That in turn governs whether you can use visible type application -at a call of the data constructor. +Why do we need the TyVarBinders, rather than just the TyVars? So that +we can construct the right type for the DataCon with its foralls +attributed the correce visiblity. That in turn governs whether you +can use visible type application at a call of the data constructor. -} data DataConRep @@ -571,11 +547,11 @@ substEqSpec subst (EqSpec tv ty) tv' = getTyVar "substEqSpec" (substTyVar subst tv) -- | Filter out any TyBinders mentioned in an EqSpec -filterEqSpec :: [EqSpec] -> [TyBinder] -> [TyBinder] +filterEqSpec :: [EqSpec] -> [TyVarBinder] -> [TyVarBinder] filterEqSpec eq_spec = filter not_in_eq_spec where - not_in_eq_spec bndr = let var = binderVar "filterEqSpec" bndr in + not_in_eq_spec bndr = let var = binderVar bndr in all (not . (== var) . eqSpecTyVar) eq_spec instance Outputable EqSpec where @@ -761,8 +737,8 @@ mkDataCon :: Name -> [HsSrcBang] -- ^ Strictness/unpack annotations, from user -> [FieldLabel] -- ^ Field labels for the constructor, -- if it is a record, otherwise empty - -> [TyVar] -> [TyBinder] -- ^ Universals. See Note [TyBinders in DataCons] - -> [TyVar] -> [TyBinder] -- ^ Existentials. + -> [TyVarBinder] -- ^ Universals. See Note [TyVarBinders in DataCons] + -> [TyVarBinder] -- ^ Existentials. -- (These last two must be Named and Invisible/Specified) -> [EqSpec] -- ^ GADT equalities -> ThetaType -- ^ Theta-type occuring before the arguments proper @@ -780,7 +756,7 @@ mkDataCon :: Name mkDataCon name declared_infix prom_info arg_stricts -- Must match orig_arg_tys 1-1 fields - univ_tvs univ_bndrs ex_tvs ex_bndrs + univ_tvs ex_tvs eq_spec theta orig_arg_tys orig_res_ty rep_info rep_tycon stupid_theta work_id rep @@ -797,8 +773,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, dcUnivTyBinders = univ_bndrs, - dcExTyVars = ex_tvs, dcExTyBinders = ex_bndrs, + dcUnivTyVars = univ_tvs, + dcExTyVars = ex_tvs, dcEqSpec = eq_spec, dcOtherTheta = theta, dcStupidTheta = stupid_theta, @@ -819,18 +795,18 @@ mkDataCon name declared_infix prom_info tag = assoc "mkDataCon" (tyConDataCons rep_tycon `zip` [fIRST_TAG..]) con rep_arg_tys = dataConRepArgTys con - rep_ty = mkForAllTys univ_bndrs $ mkForAllTys ex_bndrs $ + rep_ty = mkForAllTys univ_tvs $ mkForAllTys ex_tvs $ mkFunTys rep_arg_tys $ - mkTyConApp rep_tycon (mkTyVarTys univ_tvs) + mkTyConApp rep_tycon (mkTyVarTys (map binderVar univ_tvs)) -- See Note [Promoted data constructors] in TyCon - prom_binders = filterEqSpec eq_spec univ_bndrs ++ - ex_bndrs ++ + prom_binders = map mkNamedBinder (filterEqSpec eq_spec univ_tvs) ++ + map mkNamedBinder ex_tvs ++ map mkAnonBinder theta ++ map mkAnonBinder orig_arg_tys prom_res_kind = orig_res_ty - promoted - = mkPromotedDataCon con name prom_info prom_binders prom_res_kind roles rep_info + promoted = mkPromotedDataCon con name prom_info prom_binders + prom_res_kind roles rep_info roles = map (const Nominal) (univ_tvs ++ ex_tvs) ++ map (const Representational) orig_arg_tys @@ -866,24 +842,24 @@ dataConIsInfix = dcInfix -- | The universally-quantified type variables of the constructor dataConUnivTyVars :: DataCon -> [TyVar] -dataConUnivTyVars = dcUnivTyVars +dataConUnivTyVars (MkData { dcUnivTyVars = tvbs }) = map binderVar tvbs -- | 'TyBinder's for the universally-quantified type variables -dataConUnivTyBinders :: DataCon -> [TyBinder] -dataConUnivTyBinders = dcUnivTyBinders +dataConUnivTyVarBinders :: DataCon -> [TyVarBinder] +dataConUnivTyVarBinders = dcUnivTyVars -- | The existentially-quantified type variables of the constructor dataConExTyVars :: DataCon -> [TyVar] -dataConExTyVars = dcExTyVars +dataConExTyVars (MkData { dcExTyVars = tvbs }) = map binderVar tvbs -- | 'TyBinder's for the existentially-quantified type variables -dataConExTyBinders :: DataCon -> [TyBinder] -dataConExTyBinders = dcExTyBinders +dataConExTyVarBinders :: DataCon -> [TyVarBinder] +dataConExTyVarBinders = dcExTyVars -- | Both the universal and existentiatial type variables of the constructor dataConAllTyVars :: DataCon -> [TyVar] dataConAllTyVars (MkData { dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs }) - = univ_tvs ++ ex_tvs + = map binderVar (univ_tvs ++ ex_tvs) -- | Equalities derived from the result type of the data constructor, as written -- by the programmer in any GADT declaration. This includes *all* GADT-like @@ -1020,9 +996,8 @@ dataConBoxer _ = Nothing -- -- 4) The /original/ result type of the 'DataCon' dataConSig :: DataCon -> ([TyVar], ThetaType, [Type], Type) -dataConSig con@(MkData {dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs, - dcOrigArgTys = arg_tys, dcOrigResTy = res_ty}) - = (univ_tvs ++ ex_tvs, dataConTheta con, arg_tys, res_ty) +dataConSig con@(MkData {dcOrigArgTys = arg_tys, dcOrigResTy = res_ty}) + = (dataConAllTyVars con, dataConTheta con, arg_tys, res_ty) dataConInstSig :: DataCon @@ -1035,12 +1010,13 @@ dataConInstSig (MkData { dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs , dcEqSpec = eq_spec, dcOtherTheta = theta , dcOrigArgTys = arg_tys }) univ_tys - = (ex_tvs' + = ( ex_tvs' , substTheta subst (eqSpecPreds eq_spec ++ theta) , substTys subst arg_tys) where - univ_subst = zipTvSubst univ_tvs univ_tys - (subst, ex_tvs') = mapAccumL Type.substTyVarBndr univ_subst ex_tvs + univ_subst = zipTvSubst (map binderVar univ_tvs) univ_tys + (subst, ex_tvs') = mapAccumL Type.substTyVarBndr univ_subst $ + map binderVar ex_tvs -- | The \"full signature\" of the 'DataCon' returns, in order: @@ -1062,7 +1038,7 @@ dataConFullSig :: DataCon dataConFullSig (MkData {dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs, dcEqSpec = eq_spec, dcOtherTheta = theta, dcOrigArgTys = arg_tys, dcOrigResTy = res_ty}) - = (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, res_ty) + = (map binderVar univ_tvs, map binderVar ex_tvs, eq_spec, theta, arg_tys, res_ty) dataConOrigResTy :: DataCon -> Type dataConOrigResTy dc = dcOrigResTy dc @@ -1085,12 +1061,12 @@ 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 { dcUnivTyBinders = univ_bndrs, - dcExTyBinders = ex_bndrs, dcEqSpec = eq_spec, +dataConUserType (MkData { dcUnivTyVars = univ_tvs, + dcExTyVars = ex_tvs, dcEqSpec = eq_spec, dcOtherTheta = theta, dcOrigArgTys = arg_tys, dcOrigResTy = res_ty }) - = mkForAllTys (filterEqSpec eq_spec univ_bndrs) $ - mkForAllTys ex_bndrs $ + = mkForAllTys (filterEqSpec eq_spec univ_tvs) $ + mkForAllTys ex_tvs $ mkFunTys theta $ mkFunTys arg_tys $ res_ty @@ -1110,7 +1086,7 @@ dataConInstArgTys dc@(MkData {dcUnivTyVars = univ_tvs, = ASSERT2( length univ_tvs == length inst_tys , text "dataConInstArgTys" <+> ppr dc $$ ppr univ_tvs $$ ppr inst_tys) ASSERT2( null ex_tvs, ppr dc ) - map (substTyWith univ_tvs inst_tys) (dataConRepArgTys dc) + map (substTyWith (map binderVar univ_tvs) inst_tys) (dataConRepArgTys dc) -- | Returns just the instantiated /value/ argument types of a 'DataCon', -- (excluding dictionary args) @@ -1128,7 +1104,7 @@ dataConInstOrigArgTys dc@(MkData {dcOrigArgTys = arg_tys, , text "dataConInstOrigArgTys" <+> ppr dc $$ ppr tyvars $$ ppr inst_tys ) map (substTyWith tyvars inst_tys) arg_tys where - tyvars = univ_tvs ++ ex_tvs + tyvars = map binderVar (univ_tvs ++ ex_tvs) -- | Returns the argument types of the wrapper, excluding all dictionary arguments -- and without substituting for any type variables diff --git a/compiler/basicTypes/DataCon.hs-boot b/compiler/basicTypes/DataCon.hs-boot index d8e3230bf4..6de1f2707c 100644 --- a/compiler/basicTypes/DataCon.hs-boot +++ b/compiler/basicTypes/DataCon.hs-boot @@ -6,18 +6,18 @@ import FieldLabel ( FieldLabel ) import Unique ( Uniquable ) import Outputable ( Outputable, OutputableBndr ) import BasicTypes (Arity) -import {-# SOURCE #-} TyCoRep (Type, ThetaType, TyBinder) +import {-# SOURCE #-} TyCoRep (Type, ThetaType, TyVarBinder) data DataCon data DataConRep data EqSpec -filterEqSpec :: [EqSpec] -> [TyBinder] -> [TyBinder] +filterEqSpec :: [EqSpec] -> [TyVarBinder] -> [TyVarBinder] dataConName :: DataCon -> Name dataConTyCon :: DataCon -> TyCon -dataConUnivTyBinders :: DataCon -> [TyBinder] +dataConUnivTyVarBinders :: DataCon -> [TyVarBinder] dataConExTyVars :: DataCon -> [TyVar] -dataConExTyBinders :: DataCon -> [TyBinder] +dataConExTyVarBinders :: DataCon -> [TyVarBinder] dataConSourceArity :: DataCon -> Arity dataConFieldLabels :: DataCon -> [FieldLabel] dataConInstOrigArgTys :: DataCon -> [Type] -> [Type] diff --git a/compiler/basicTypes/MkId.hs b/compiler/basicTypes/MkId.hs index fe301d5a2a..1ac5597d3e 100644 --- a/compiler/basicTypes/MkId.hs +++ b/compiler/basicTypes/MkId.hs @@ -274,13 +274,13 @@ 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 + tyvars = dataConUnivTyVarBinders 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 - sel_ty = mkForAllTys binders $ - mkFunTy (mkClassPred clas (mkTyVarTys tyvars)) $ + sel_ty = mkForAllTys tyvars $ + mkFunTy (mkClassPred clas (mkTyVarTys (map binderVar tyvars))) $ getNth arg_tys val_index base_info = noCafIdInfo @@ -299,8 +299,6 @@ mkDictSelId name clas -- so that the rule is always available to fire. -- See Note [ClassOp/DFun selection] in TcInstDcls - n_ty_args = length tyvars - -- This is the built-in rule that goes -- op (dfT d1 d2) ---> opT d1 d2 rule = BuiltinRule { ru_name = fsLit "Class op " `appendFS` @@ -971,10 +969,9 @@ mkFCallId dflags uniq fcall ty `setArityInfo` arity `setStrictnessInfo` strict_sig - (bndrs, _) = tcSplitPiTys ty - arity = count isIdLikeBinder bndrs - - strict_sig = mkClosedStrictSig (replicate arity topDmd) topRes + (bndrs, _) = tcSplitPiTys ty + arity = count isAnonTyBinder bndrs + strict_sig = mkClosedStrictSig (replicate arity topDmd) topRes -- the call does not claim to be strict in its arguments, since they -- may be lifted (foreign import prim) and the called code doesn't -- necessarily force them. See Trac #11076. diff --git a/compiler/basicTypes/PatSyn.hs b/compiler/basicTypes/PatSyn.hs index 3c5e709f47..2510d71ec0 100644 --- a/compiler/basicTypes/PatSyn.hs +++ b/compiler/basicTypes/PatSyn.hs @@ -15,7 +15,7 @@ module PatSyn ( patSynName, patSynArity, patSynIsInfix, patSynArgs, patSynMatcher, patSynBuilder, - patSynUnivTyBinders, patSynExTyVars, patSynExTyBinders, patSynSig, + patSynUnivTyVarBinders, patSynExTyVars, patSynExTyVarBinders, patSynSig, patSynInstArgTys, patSynInstResTy, patSynFieldLabels, patSynFieldType, @@ -63,15 +63,13 @@ data PatSyn -- psArgs -- Universially-quantified type variables - psUnivTyVars :: [TyVar], -- Two linked fields; see DataCon - psUnivTyBinders :: [TyBinder], -- Note [TyBinders in DataCons] + psUnivTyVars :: [TyVarBinder], -- Required dictionaries (may mention psUnivTyVars) psReqTheta :: ThetaType, -- Existentially-quantified type vars - psExTyVars :: [TyVar], -- Two linked fields; see DataCon - psExTyBinders :: [TyBinder], -- Note [TyBinders in DataCons] + psExTyVars :: [TyVarBinder], -- Provided dictionaries (may mention psUnivTyVars or psExTyVars) psProvTheta :: ThetaType, @@ -300,11 +298,9 @@ instance Data.Data PatSyn where -- | Build a new pattern synonym mkPatSyn :: Name -> Bool -- ^ Is the pattern synonym declared infix? - -> ([TyVar], [TyBinder], ThetaType) - -- ^ Universially-quantified type variables + -> ([TyVarBinder], ThetaType) -- ^ Universially-quantified type variables -- and required dicts - -> ([TyVar], [TyBinder], ThetaType) - -- ^ Existentially-quantified type variables + -> ([TyVarBinder], ThetaType) -- ^ Existentially-quantified type variables -- and provided dicts -> [Type] -- ^ Original arguments -> Type -- ^ Original result type @@ -316,14 +312,14 @@ mkPatSyn :: Name -- 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, univ_bndrs, req_theta) - (ex_tvs, ex_bndrs, prov_theta) + (univ_tvs, req_theta) + (ex_tvs, prov_theta) orig_args orig_res_ty matcher builder field_labels = MkPatSyn {psName = name, psUnique = getUnique name, - psUnivTyVars = univ_tvs, psUnivTyBinders = univ_bndrs, - psExTyVars = ex_tvs, psExTyBinders = ex_bndrs, + psUnivTyVars = univ_tvs, + psExTyVars = ex_tvs, psProvTheta = prov_theta, psReqTheta = req_theta, psInfix = declared_infix, psArgs = orig_args, @@ -359,20 +355,20 @@ patSynFieldType ps label Just (_, ty) -> ty Nothing -> pprPanic "dataConFieldType" (ppr ps <+> ppr label) -patSynUnivTyBinders :: PatSyn -> [TyBinder] -patSynUnivTyBinders = psUnivTyBinders +patSynUnivTyVarBinders :: PatSyn -> [TyVarBinder] +patSynUnivTyVarBinders = psUnivTyVars patSynExTyVars :: PatSyn -> [TyVar] -patSynExTyVars = psExTyVars +patSynExTyVars ps = map binderVar (psExTyVars ps) -patSynExTyBinders :: PatSyn -> [TyBinder] -patSynExTyBinders = psExTyBinders +patSynExTyVarBinders :: PatSyn -> [TyVarBinder] +patSynExTyVarBinders = psExTyVars patSynSig :: PatSyn -> ([TyVar], ThetaType, [TyVar], ThetaType, [Type], Type) patSynSig (MkPatSyn { psUnivTyVars = univ_tvs, psExTyVars = ex_tvs , psProvTheta = prov, psReqTheta = req , psArgs = arg_tys, psOrigResTy = res_ty }) - = (univ_tvs, req, ex_tvs, prov, arg_tys, res_ty) + = (map binderVar univ_tvs, req, map binderVar ex_tvs, prov, arg_tys, res_ty) patSynMatcher :: PatSyn -> (Id,Bool) patSynMatcher = psMatcher @@ -401,7 +397,7 @@ patSynInstArgTys (MkPatSyn { psName = name, psUnivTyVars = univ_tvs , text "patSynInstArgTys" <+> ppr name $$ ppr tyvars $$ ppr inst_tys ) map (substTyWith tyvars inst_tys) arg_tys where - tyvars = univ_tvs ++ ex_tvs + tyvars = map binderVar (univ_tvs ++ ex_tvs) patSynInstResTy :: PatSyn -> [Type] -> Type -- Return the type of whole pattern @@ -414,19 +410,19 @@ patSynInstResTy (MkPatSyn { psName = name, psUnivTyVars = univ_tvs inst_tys = ASSERT2( length univ_tvs == length inst_tys , text "patSynInstResTy" <+> ppr name $$ ppr univ_tvs $$ ppr inst_tys ) - substTyWith univ_tvs inst_tys res_ty + substTyWith (map binderVar univ_tvs) inst_tys res_ty -- | Print the type of a pattern synonym. The foralls are printed explicitly pprPatSynType :: PatSyn -> SDoc pprPatSynType (MkPatSyn { psUnivTyVars = univ_tvs, psReqTheta = req_theta , psExTyVars = ex_tvs, psProvTheta = prov_theta , psArgs = orig_args, psOrigResTy = orig_res_ty }) - = sep [ pprForAllImplicit univ_tvs + = sep [ pprForAll univ_tvs , pprThetaArrowTy req_theta , ppWhen insert_empty_ctxt $ parens empty <+> darrow , pprType sigma_ty ] where - sigma_ty = mkForAllTys (mkNamedBinders Specified ex_tvs) $ + sigma_ty = mkForAllTys ex_tvs $ mkFunTys prov_theta $ mkFunTys orig_args orig_res_ty insert_empty_ctxt = null req_theta && not (null prov_theta && null ex_tvs) diff --git a/compiler/codeGen/StgCmmClosure.hs b/compiler/codeGen/StgCmmClosure.hs index ca6b404084..c612366904 100644 --- a/compiler/codeGen/StgCmmClosure.hs +++ b/compiler/codeGen/StgCmmClosure.hs @@ -970,15 +970,15 @@ getTyDescription ty TyVarTy _ -> "*" AppTy fun _ -> getTyDescription fun TyConApp tycon _ -> getOccString tycon - ForAllTy (Anon _) res -> '-' : '>' : fun_result res - ForAllTy (Named {}) ty -> getTyDescription ty + FunTy _ res -> '-' : '>' : fun_result res + ForAllTy _ ty -> getTyDescription ty LitTy n -> getTyLitDescription n CastTy ty _ -> getTyDescription ty CoercionTy co -> pprPanic "getTyDescription" (ppr co) } where - fun_result (ForAllTy (Anon _) res) = '>' : fun_result res - fun_result other = getTyDescription other + fun_result (FunTy _ res) = '>' : fun_result res + fun_result other = getTyDescription other getTyLitDescription :: TyLit -> String getTyLitDescription l = diff --git a/compiler/coreSyn/CoreArity.hs b/compiler/coreSyn/CoreArity.hs index 812f12ca83..ef87656a0e 100644 --- a/compiler/coreSyn/CoreArity.hs +++ b/compiler/coreSyn/CoreArity.hs @@ -106,10 +106,11 @@ typeArity ty = go initRecTc ty where go rec_nts ty - | Just (bndr, ty') <- splitPiTy_maybe ty - = if isIdLikeBinder bndr - then typeOneShot (binderType bndr) : go rec_nts ty' - else go rec_nts ty' + | Just (_, ty') <- splitForAllTy_maybe ty + = go rec_nts ty' + + | Just (arg,res) <- splitFunTy_maybe ty + = typeOneShot arg : go rec_nts res | Just (tc,tys) <- splitTyConApp_maybe ty , Just (ty', _) <- instNewTyCon_maybe tc tys @@ -970,13 +971,15 @@ mkEtaWW orig_n orig_expr in_scope orig_ty | n == 0 = (getTCvInScope subst, reverse eis) - | Just (bndr,ty') <- splitPiTy_maybe ty - = let ((subst', eta_id'), new_n) = caseBinder bndr - (\tv -> (Type.substTyVarBndr subst tv, n)) - (\arg_ty -> (freshEtaVar n subst arg_ty, n-1)) - in - -- Avoid free vars of the original expression - go new_n subst' ty' (EtaVar eta_id' : eis) + | Just (tv,ty') <- splitForAllTy_maybe ty + , let (subst', tv') = Type.substTyVarBndr subst tv + -- Avoid free vars of the original expression + = go n subst' ty' (EtaVar tv' : eis) + + | Just (arg_ty, res_ty) <- splitFunTy_maybe ty + , let (subst', eta_id') = freshEtaId n subst arg_ty + -- Avoid free vars of the original expression + = go (n-1) subst' res_ty (EtaVar eta_id' : eis) | Just (co, ty') <- topNormaliseNewType_maybe ty = -- Given this: @@ -1009,7 +1012,7 @@ subst_bind = substBindSC -------------- -freshEtaVar :: Int -> TCvSubst -> Type -> (TCvSubst, Var) +freshEtaId :: Int -> TCvSubst -> Type -> (TCvSubst, Id) -- Make a fresh Id, with specified type (after applying substitution) -- It should be "fresh" in the sense that it's not in the in-scope set -- of the TvSubstEnv; and it should itself then be added to the in-scope @@ -1017,7 +1020,7 @@ freshEtaVar :: Int -> TCvSubst -> Type -> (TCvSubst, Var) -- -- The Int is just a reasonable starting point for generating a unique; -- it does not necessarily have to be unique itself. -freshEtaVar n subst ty +freshEtaId n subst ty = (subst', eta_id') where ty' = Type.substTy subst ty diff --git a/compiler/coreSyn/CoreFVs.hs b/compiler/coreSyn/CoreFVs.hs index a71569e487..09ef7f8866 100644 --- a/compiler/coreSyn/CoreFVs.hs +++ b/compiler/coreSyn/CoreFVs.hs @@ -352,8 +352,10 @@ orphNamesOfType (TyVarTy _) = emptyNameSet orphNamesOfType (LitTy {}) = emptyNameSet orphNamesOfType (TyConApp tycon tys) = orphNamesOfTyCon tycon `unionNameSet` orphNamesOfTypes tys -orphNamesOfType (ForAllTy bndr res) = unitNameSet funTyConName -- NB! See Trac #8535 - `unionNameSet` orphNamesOfType (binderType bndr) +orphNamesOfType (ForAllTy bndr res) = orphNamesOfType (binderType bndr) + `unionNameSet` orphNamesOfType res +orphNamesOfType (FunTy arg res) = unitNameSet funTyConName -- NB! See Trac #8535 + `unionNameSet` orphNamesOfType arg `unionNameSet` orphNamesOfType res orphNamesOfType (AppTy fun arg) = orphNamesOfType fun `unionNameSet` orphNamesOfType arg orphNamesOfType (CastTy ty co) = orphNamesOfType ty `unionNameSet` orphNamesOfCo co diff --git a/compiler/coreSyn/CoreLint.hs b/compiler/coreSyn/CoreLint.hs index 9c5b033f38..36a7e2bdb3 100644 --- a/compiler/coreSyn/CoreLint.hs +++ b/compiler/coreSyn/CoreLint.hs @@ -558,9 +558,10 @@ lintRhs rhs , length args == 5 = flip fix binders0 $ \loopBinders binders -> case binders of -- imitate @lintCoreExpr (Lam ...)@ - var : vars -> addLoc (LambdaBodyOf var) $ lintBinder var $ \var' -> do - body_ty <- loopBinders vars - return $ mkPiType var' body_ty + var : vars -> addLoc (LambdaBodyOf var) $ + lintBinder var $ \var' -> + do { body_ty <- loopBinders vars + ; return $ mkLamType var' body_ty } -- imitate @lintCoreExpr (App ...)@ [] -> do fun_ty <- lintCoreExpr fun @@ -703,7 +704,7 @@ lintCoreExpr (Lam var expr) = addLoc (LambdaBodyOf var) $ lintBinder var $ \ var' -> do { body_ty <- lintCoreExpr expr - ; return $ mkPiType var' body_ty } + ; return $ mkLamType var' body_ty } lintCoreExpr e@(Case scrut var alt_ty alts) = -- Check the scrutinee @@ -1097,12 +1098,12 @@ lintType ty@(TyConApp tc tys) -- arrows can related *unlifted* kinds, so this has to be separate from -- a dependent forall. -lintType ty@(ForAllTy (Anon t1) t2) +lintType ty@(FunTy t1 t2) = do { k1 <- lintType t1 ; k2 <- lintType t2 ; lintArrow (text "type or kind" <+> quotes (ppr ty)) k1 k2 } -lintType t@(ForAllTy (Named tv _vis) ty) +lintType t@(ForAllTy (TvBndr tv _vis) ty) = do { lintL (isTyVar tv) (text "Covar bound in type:" <+> ppr t) ; lintTyBndr tv $ \tv' -> do { k <- lintType ty @@ -1192,11 +1193,11 @@ lint_app doc kfn kas | Just kfn' <- coreView kfn = go_app in_scope kfn' ka - go_app _ (ForAllTy (Anon kfa) kfb) (_,ka) + go_app _ (FunTy kfa kfb) (_,ka) = do { unless (ka `eqType` kfa) (addErrL fail_msg) ; return kfb } - go_app in_scope (ForAllTy (Named kv _vis) kfn) (ta,ka) + go_app in_scope (ForAllTy (TvBndr kv _vis) kfn) (ta,ka) = do { unless (ka `eqType` tyVarKind kv) (addErrL fail_msg) ; return (substTyWithInScope in_scope [kv] [ta] kfn) } @@ -1346,7 +1347,7 @@ lintCoercion (ForAllCo tv1 kind_co co) do { ; (k3, k4, t1, t2, r) <- lintCoercion co ; in_scope <- getInScope - ; let tyl = mkNamedForAllTy tv1 Invisible t1 + ; let tyl = mkInvForAllTy tv1 t1 subst = mkTvSubst in_scope $ -- We need both the free vars of the `t2` and the -- free vars of the range of the substitution in @@ -1355,7 +1356,7 @@ lintCoercion (ForAllCo tv1 kind_co co) -- linted and `tv2` has the same unique as `tv1`. -- See Note [The substitution invariant] unitVarEnv tv1 (TyVarTy tv2 `mkCastTy` mkSymCo kind_co) - tyr = mkNamedForAllTy tv2 Invisible $ + tyr = mkInvForAllTy tv2 $ substTy subst t2 ; return (k3, k4, tyl, tyr, r) } } diff --git a/compiler/coreSyn/CoreUtils.hs b/compiler/coreSyn/CoreUtils.hs index 46232b3e9a..7e0dc11c58 100644 --- a/compiler/coreSyn/CoreUtils.hs +++ b/compiler/coreSyn/CoreUtils.hs @@ -103,7 +103,7 @@ exprType (Let bind body) exprType (Case _ _ ty _) = ty exprType (Cast _ co) = pSnd (coercionKind co) exprType (Tick _ e) = exprType e -exprType (Lam binder expr) = mkPiType binder (exprType expr) +exprType (Lam binder expr) = mkLamType binder (exprType expr) exprType e@(App _ _) = case collectArgs e of (fun, args) -> applyTypeToArgs e (exprType fun) args diff --git a/compiler/coreSyn/TrieMap.hs b/compiler/coreSyn/TrieMap.hs index fbff260055..a37758c182 100644 --- a/compiler/coreSyn/TrieMap.hs +++ b/compiler/coreSyn/TrieMap.hs @@ -793,7 +793,7 @@ data TypeMapX a trieMapView :: Type -> Maybe Type trieMapView ty | Just ty' <- coreViewOneStarKind ty = Just ty' trieMapView (TyConApp tc tys@(_:_)) = Just $ foldl AppTy (TyConApp tc []) tys -trieMapView (ForAllTy (Anon arg) res) +trieMapView (FunTy arg res) = Just ((TyConApp funTyCon [] `AppTy` arg) `AppTy` res) trieMapView _ = Nothing @@ -824,13 +824,13 @@ instance Eq (DeBruijn Type) where -> D env t1 == D env' t1' && D env t2 == D env' t2' (s, AppTy t1' t2') | Just (t1, t2) <- repSplitAppTy_maybe s -> D env t1 == D env' t1' && D env t2 == D env' t2' - (ForAllTy (Anon t1) t2, ForAllTy (Anon t1') t2') + (FunTy t1 t2, FunTy t1' t2') -> D env t1 == D env' t1' && D env t2 == D env' t2' (TyConApp tc tys, TyConApp tc' tys') -> tc == tc' && D env tys == D env' tys' (LitTy l, LitTy l') -> l == l' - (ForAllTy (Named tv _) ty, ForAllTy (Named tv' _) ty') + (ForAllTy (TvBndr tv _) ty, ForAllTy (TvBndr tv' _) ty') -> D env (tyVarKind tv) == D env' (tyVarKind tv') && D (extendCME env tv) ty == D (extendCME env' tv') ty' (CoercionTy {}, CoercionTy {}) @@ -870,9 +870,9 @@ lkT (D env ty) m = go ty m go (TyConApp tc []) = tm_tycon >.> lkDNamed tc go ty@(TyConApp _ (_:_)) = pprPanic "lkT TyConApp" (ppr ty) go (LitTy l) = tm_tylit >.> lkTyLit l - go (ForAllTy (Named tv _) ty) = tm_forall >.> lkG (D (extendCME env tv) ty) + go (ForAllTy (TvBndr tv _) ty) = tm_forall >.> lkG (D (extendCME env tv) ty) >=> lkBndr env tv - go ty@(ForAllTy (Anon _) _) = pprPanic "lkT FunTy" (ppr ty) + go ty@(FunTy {}) = pprPanic "lkT FunTy" (ppr ty) go (CastTy t _) = go t go (CoercionTy {}) = tm_coerce @@ -887,11 +887,11 @@ xtT (D _ (TyConApp tc [])) f m = m { tm_tycon = tm_tycon m |> xtDNamed tc f xtT (D _ (LitTy l)) f m = m { tm_tylit = tm_tylit m |> xtTyLit l f } xtT (D env (CastTy t _)) f m = xtT (D env t) f m xtT (D _ (CoercionTy {})) f m = m { tm_coerce = tm_coerce m |> f } -xtT (D env (ForAllTy (Named tv _) ty)) f m +xtT (D env (ForAllTy (TvBndr tv _) ty)) f m = m { tm_forall = tm_forall m |> xtG (D (extendCME env tv) ty) |>> xtBndr env tv f } -xtT (D _ ty@(TyConApp _ (_:_))) _ _ = pprPanic "xtT TyConApp" (ppr ty) -xtT (D _ ty@(ForAllTy (Anon _) _)) _ _ = pprPanic "xtT FunTy" (ppr ty) +xtT (D _ ty@(TyConApp _ (_:_))) _ _ = pprPanic "xtT TyConApp" (ppr ty) +xtT (D _ ty@(FunTy {})) _ _ = pprPanic "xtT FunTy" (ppr ty) fdT :: (a -> b -> b) -> TypeMapX a -> b -> b fdT k m = foldTM k (tm_var m) diff --git a/compiler/deSugar/DsBinds.hs b/compiler/deSugar/DsBinds.hs index c27168a042..30e1707b57 100644 --- a/compiler/deSugar/DsBinds.hs +++ b/compiler/deSugar/DsBinds.hs @@ -624,7 +624,7 @@ dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl)) spec_name = mkInternalName uniq spec_occ (getSrcSpan poly_name) ; (bndrs, ds_lhs) <- liftM collectBinders (dsHsWrapper spec_co (Var poly_id)) - ; let spec_ty = mkPiTypes bndrs (exprType ds_lhs) + ; let spec_ty = mkLamTypes bndrs (exprType ds_lhs) ; -- pprTrace "dsRule" (vcat [ text "Id:" <+> ppr poly_id -- , text "spec_co:" <+> ppr spec_co -- , text "ds_rhs:" <+> ppr ds_lhs ]) $ diff --git a/compiler/deSugar/DsForeign.hs b/compiler/deSugar/DsForeign.hs index 26c84c764d..00ed621bd2 100644 --- a/compiler/deSugar/DsForeign.hs +++ b/compiler/deSugar/DsForeign.hs @@ -195,15 +195,9 @@ dsFCall :: Id -> Coercion -> ForeignCall -> Maybe Header -> DsM ([(Id, Expr TyVar)], SDoc, SDoc) dsFCall fn_id co fcall mDeclHeader = do let - ty = pFst $ coercionKind co - (all_bndrs, io_res_ty) = tcSplitPiTys ty - (named_bndrs, arg_tys) = partitionBindersIntoBinders all_bndrs - tvs = ASSERT( fst (span isNamedBinder all_bndrs) - `equalLength` named_bndrs ) - -- ensure that the named binders all come first - map (binderVar "dsFCall") named_bndrs - -- Must use tcSplit* functions because we want to - -- see that (IO t) in the corner + ty = pFst $ coercionKind co + (tv_bndrs, rho) = tcSplitForAllTyVarBndrs ty + (arg_tys, io_res_ty) = tcSplitFunTys rho args <- newSysLocalsDs arg_tys (val_args, arg_wrappers) <- mapAndUnzipM unboxArg (map Var args) @@ -266,7 +260,8 @@ dsFCall fn_id co fcall mDeclHeader = do return (fcall, empty) let -- Build the worker - worker_ty = mkForAllTys named_bndrs (mkFunTys (map idType work_arg_ids) ccall_result_ty) + worker_ty = mkForAllTys tv_bndrs (mkFunTys (map idType work_arg_ids) ccall_result_ty) + tvs = map binderVar tv_bndrs the_ccall_app = mkFCall dflags ccall_uniq fcall' val_args ccall_result_ty work_rhs = mkLams tvs (mkLams work_arg_ids the_ccall_app) work_id = mkSysLocal (fsLit "$wccall") work_uniq worker_ty @@ -300,12 +295,9 @@ dsPrimCall :: Id -> Coercion -> ForeignCall dsPrimCall fn_id co fcall = do let ty = pFst $ coercionKind co - (bndrs, io_res_ty) = tcSplitPiTys ty - (tvs, arg_tys) = partitionBinders bndrs - -- Must use tcSplit* functions because we want to - -- see that (IO t) in the corner + (tvs, fun_ty) = tcSplitForAllTys ty + (arg_tys, io_res_ty) = tcSplitFunTys fun_ty - MASSERT( fst (span isNamedBinder bndrs) `equalLength` tvs ) args <- newSysLocalsDs arg_tys ccall_uniq <- newUnique @@ -416,8 +408,6 @@ dsFExportDynamic :: Id -> CCallConv -> DsM ([Binding], SDoc, SDoc) dsFExportDynamic id co0 cconv = do - MASSERT( fst (span isNamedBinder bndrs) `equalLength` tvs ) - -- make sure that the named binders all come first fe_id <- newSysLocalDs ty mod <- getModule dflags <- getDynFlags @@ -481,8 +471,8 @@ dsFExportDynamic id co0 cconv = do where ty = pFst (coercionKind co0) - (bndrs, fn_res_ty) = tcSplitPiTys ty - (tvs, [arg_ty]) = partitionBinders bndrs + (tvs,sans_foralls) = tcSplitForAllTys ty + ([arg_ty], fn_res_ty) = tcSplitFunTys sans_foralls Just (io_tc, res_ty) = tcSplitIOType_maybe fn_res_ty -- Must have an IO type; hence Just diff --git a/compiler/hsSyn/HsUtils.hs b/compiler/hsSyn/HsUtils.hs index 23c8d911ad..f530272b23 100644 --- a/compiler/hsSyn/HsUtils.hs +++ b/compiler/hsSyn/HsUtils.hs @@ -586,12 +586,12 @@ toLHsSigWcType ty = mkLHsSigWcType (go ty) where go :: Type -> LHsType RdrName - go ty@(ForAllTy (Anon arg) _) + go ty@(FunTy arg _) | isPredTy arg , (theta, tau) <- tcSplitPhiTy ty = noLoc (HsQualTy { hst_ctxt = noLoc (map go theta) , hst_body = go tau }) - go (ForAllTy (Anon arg) res) = nlHsFunTy (go arg) (go res) + go (FunTy arg res) = nlHsFunTy (go arg) (go res) go ty@(ForAllTy {}) | (tvs, tau) <- tcSplitForAllTys ty = noLoc (HsForAllTy { hst_bndrs = map go_tv tvs diff --git a/compiler/iface/BuildTyCl.hs b/compiler/iface/BuildTyCl.hs index f62e5eeacb..c20a5ee9e2 100644 --- a/compiler/iface/BuildTyCl.hs +++ b/compiler/iface/BuildTyCl.hs @@ -29,7 +29,7 @@ import MkId import Class import TyCon import Type -import TyCoRep( TyBinder(..) ) +import TyCoRep( TyBinder(..), TyVarBinder(..) ) import Id import TcType @@ -112,9 +112,8 @@ buildDataCon :: FamInstEnvs -> Maybe [HsImplBang] -- See Note [Bangs on imported data constructors] in MkId -> [FieldLabel] -- Field labels - -> [TyVar] -> [TyBinder] -- Universals; see - -- Note [TyBinders in DataCons] in DataCon - -> [TyVar] -> [TyBinder] -- existentials + -> [TyVar] -> [TyBinder] -- Universals + -> [TyVarBinder] -- existentials -> [EqSpec] -- Equality spec -> ThetaType -- Does not include the "stupid theta" -- or the GADT equalities @@ -125,9 +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 +-- c) Sorts out the TyVarBinders. See mkDataConUnivTyBinders buildDataCon fam_envs src_name declared_infix prom_info src_bangs impl_bangs field_lbls - univ_tvs univ_bndrs ex_tvs ex_bndrs eq_spec ctxt arg_tys res_ty rep_tycon + univ_tvs univ_bndrs ex_tvs 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 @@ -137,11 +136,11 @@ 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 dc_bndrs = mkDataConUnivTyBinders univ_bndrs univ_tvs + ; let dc_bndrs = mkDataConUnivTyVarBinders univ_tvs univ_bndrs 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 + dc_bndrs 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 @@ -171,25 +170,25 @@ mkDataConStupidTheta tycon arg_tys univ_tvs tyCoVarsOfType pred `intersectVarSet` arg_tyvars -mkDataConUnivTyBinders :: [TyBinder] -> [TyVar] -- From the TyCon - -> [TyBinder] -- For the DataCon +mkDataConUnivTyVarBinders :: [TyVar] -> [TyBinder] -- From the TyCon + -> [TyVarBinder] -- For the DataCon -- See Note [Building the TyBinders for a DataCon] -mkDataConUnivTyBinders bndrs tvs - = zipWith mk_binder bndrs tvs +mkDataConUnivTyVarBinders tvs bndrs + = zipWith mk_binder tvs bndrs where - mk_binder bndr tv = mkNamedBinder vis tv + mk_binder tv bndr = mkTyVarBinder vis tv where vis = case bndr of - Anon _ -> Specified - Named _ Visible -> Specified - Named _ vis -> vis + Anon _ -> Specified + Named (TvBndr _ Visible) -> Specified + Named (TvBndr _ vis) -> vis {- Note [Building the TyBinders for a DataCon] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 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. See Note [TyBinders in DataCons] in DataCon. +is done by storing the universal and existential TyVarBinders. +See Note [TyVarBinders in DataCons] in DataCon. During construction of a DataCon, we often start from the TyBinders of the parent TyCon. For example @@ -203,8 +202,8 @@ of the DataCon. Here is an example: The TyCon has - tyConTyVars = [ k:*, a:k->*, b:k] - tyConTyBinders = [ Named (k :: *) Invisible, Anon (k->*), Anon k ] + tyConTyVars = [ k:*, a:k->*, b:k] + tyConTyBinders = [ Named (TvBndr (k :: *) Invisible), Anon (k->*), Anon k ] The TyBinders for App line up with App's kind, given above. @@ -213,9 +212,9 @@ But the DataCon MkApp has the type That is, its TyBinders should be - dataConUnivTyVars = [ Named (k:*) Invisible - , Named (a:k->*) Specified - , Named (b:k) Specified ] + dataConUnivTyVarBinders = [ TvBndr (k:*) Invisible + , TvBndr (a:k->*) Specified + , TvBndr (b:k) Specified ] So we want to take the TyCon's TyBinders and the TyCon's TyVars and merge them, pulling @@ -237,15 +236,15 @@ DataCon (mkDataCon does no further work). ------------------------------------------------------ buildPatSyn :: Name -> Bool -> (Id,Bool) -> Maybe (Id, Bool) - -> ([TyVar], [TyBinder], ThetaType) -- ^ Univ and req - -> ([TyVar], [TyBinder], ThetaType) -- ^ Ex and prov + -> ([TyVarBinder], ThetaType) -- ^ Univ and req + -> ([TyVarBinder], 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, univ_bndrs, req_theta) (ex_tvs, ex_bndrs, prov_theta) arg_tys + (univ_tvs, req_theta) (ex_tvs, prov_theta) arg_tys pat_ty field_labels = -- The assertion checks that the matcher is -- compatible with the pattern synonym @@ -263,17 +262,17 @@ 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, univ_bndrs, req_theta) (ex_tvs, ex_bndrs, prov_theta) + (univ_tvs, req_theta) (ex_tvs, prov_theta) arg_tys pat_ty matcher builder field_labels where ((_:_:univ_tvs1), req_theta1, tau) = tcSplitSigmaTy $ idType matcher_id - ([pat_ty1, cont_sigma, _], _) = tcSplitFunTys tau - (ex_tvs1, prov_theta1, cont_tau) = tcSplitSigmaTy cont_sigma + ([pat_ty1, cont_sigma, _], _) = tcSplitFunTys tau + (ex_tvs1, prov_theta1, cont_tau) = tcSplitSigmaTy cont_sigma (arg_tys1, _) = tcSplitFunTys cont_tau twiddle = char '~' subst = zipTvSubst (univ_tvs1 ++ ex_tvs1) - (mkTyVarTys (univ_tvs ++ ex_tvs)) + (mkTyVarTys (map binderVar (univ_tvs ++ ex_tvs))) ------------------------------------------------------ type TcMethInfo = (Name, Type, Maybe (DefMethSpec Type)) @@ -342,7 +341,6 @@ buildClass tycon_name tvs roles sc_theta binders [{- No fields -}] tvs binders [{- no existentials -}] - [{- no existentials -}] [{- No GADT equalities -}] [{- No theta -}] arg_tys diff --git a/compiler/iface/IfaceSyn.hs b/compiler/iface/IfaceSyn.hs index a95d8c92af..0ad4b0f5db 100644 --- a/compiler/iface/IfaceSyn.hs +++ b/compiler/iface/IfaceSyn.hs @@ -1314,8 +1314,8 @@ freeNamesIfForAllBndr :: IfaceForAllBndr -> NameSet freeNamesIfForAllBndr (IfaceTv tv _) = freeNamesIfTvBndr tv freeNamesIfTyBinder :: IfaceTyConBinder -> NameSet -freeNamesIfTyBinder (IfaceAnon _ ty) = freeNamesIfType ty -freeNamesIfTyBinder (IfaceNamed b) = freeNamesIfForAllBndr b +freeNamesIfTyBinder (IfaceAnon b) = freeNamesIfTvBndr b +freeNamesIfTyBinder (IfaceNamed b) = freeNamesIfForAllBndr b freeNamesIfTyBinders :: [IfaceTyConBinder] -> NameSet freeNamesIfTyBinders = fnList freeNamesIfTyBinder diff --git a/compiler/iface/IfaceType.hs b/compiler/iface/IfaceType.hs index 45732ca5f7..fb2b3df1cc 100644 --- a/compiler/iface/IfaceType.hs +++ b/compiler/iface/IfaceType.hs @@ -101,13 +101,15 @@ data IfaceBndr -- Local (non-top-level) binders type IfaceIdBndr = (IfLclName, IfaceType) type IfaceTvBndr = (IfLclName, IfaceKind) +ifaceTvBndrName :: IfaceTvBndr -> IfLclName +ifaceTvBndrName (n,_) = n + +type IfaceLamBndr = (IfaceBndr, IfaceOneShot) data IfaceOneShot -- See Note [Preserve OneShotInfo] in CoreTicy = IfaceNoOneShot -- and Note [The oneShot function] in MkId | IfaceOneShot -type IfaceLamBndr - = (IfaceBndr, IfaceOneShot) {- %************************************************************************ @@ -148,8 +150,8 @@ data IfaceForAllBndr = IfaceTv IfaceTvBndr VisibilityFlag data IfaceTyConBinder - = IfaceAnon IfLclName IfaceType -- like Anon, but it includes a name from - -- which to produce a tyConTyVar + = IfaceAnon IfaceTvBndr -- Like Anon, but it includes a name from + -- which to produce a tyConTyVar | IfaceNamed IfaceForAllBndr -- See Note [Suppressing invisible arguments] @@ -159,8 +161,9 @@ data IfaceTyConBinder -- type/kind) there'll just be one. data IfaceTcArgs = ITC_Nil - | ITC_Vis IfaceType IfaceTcArgs - | ITC_Invis IfaceKind IfaceTcArgs + | ITC_Vis IfaceType IfaceTcArgs -- "Vis" means show when pretty-printing + | ITC_Invis IfaceKind IfaceTcArgs -- "Invis" means don't show when pretty-printin + -- except with -fprint-explicit-kinds -- Encodes type constructors, kind constructors, -- coercion constructors, the lot. @@ -266,13 +269,12 @@ isIfaceInvisBndr _ = False -- | Extract a IfaceTvBndr from a IfaceTyConBinder ifTyConBinderTyVar :: IfaceTyConBinder -> IfaceTvBndr -ifTyConBinderTyVar (IfaceAnon name ki) = (name, ki) +ifTyConBinderTyVar (IfaceAnon tv) = tv ifTyConBinderTyVar (IfaceNamed (IfaceTv tv _)) = tv -- | Extract the variable name from a IfaceTyConBinder ifTyConBinderName :: IfaceTyConBinder -> IfLclName -ifTyConBinderName (IfaceAnon name _) = name -ifTyConBinderName (IfaceNamed (IfaceTv (name, _) _)) = name +ifTyConBinderName tcb = ifaceTvBndrName (ifTyConBinderTyVar tcb) ifTyVarsOfType :: IfaceType -> UniqSet IfLclName ifTyVarsOfType ty @@ -533,12 +535,15 @@ toIfaceTcArgs tc ty_args go env ty ts | Just ty' <- coreView ty = go env ty' ts - go env (ForAllTy bndr res) (t:ts) - | isVisibleBinder bndr = ITC_Vis t' ts' - | otherwise = ITC_Invis t' ts' + go env (ForAllTy (TvBndr tv vis) res) (t:ts) + | isVisible vis = ITC_Vis t' ts' + | otherwise = ITC_Invis t' ts' where t' = toIfaceType t - ts' = go (extendTvSubstBinder env bndr t) res ts + ts' = go (extendTvSubst env tv t) res ts + + go env (FunTy _ res) (t:ts) -- No type-class args in tycon apps + = ITC_Vis (toIfaceType t) (go env res ts) go env (TyVarTy tv) ts | Just ki <- lookupTyVar env tv = go env ki ts @@ -554,9 +559,8 @@ tcArgsIfaceTypes (ITC_Vis t ts) = t : tcArgsIfaceTypes ts Note [Suppressing invisible arguments] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We use the IfaceTcArgs to specify which of the arguments to a type -constructor should be visible. -This in turn used to control suppression when printing types, -under the control of -fprint-explicit-kinds. +constructor should be displayed when pretty-printing, under +the control of -fprint-explicit-kinds. See also Type.filterOutInvisibleTypes. For example, given T :: forall k. (k->*) -> k -> * -- Ordinary kind polymorphism @@ -608,8 +612,7 @@ pprIfaceTvBndr (tv, ki) pprIfaceTyConBinders :: [IfaceTyConBinder] -> SDoc pprIfaceTyConBinders = sep . map go where - go (IfaceAnon name ki) = pprIfaceTvBndr (name, ki) - go (IfaceNamed (IfaceTv tv _)) = pprIfaceTvBndr tv + go tcb = pprIfaceTvBndr (ifTyConBinderTyVar tcb) instance Binary IfaceBndr where put_ bh (IfaceIdBndr aa) = do @@ -1004,16 +1007,15 @@ instance Binary IfaceForAllBndr where return (IfaceTv tv vis) instance Binary IfaceTyConBinder where - put_ bh (IfaceAnon n ty) = putByte bh 0 >> put_ bh n >> put_ bh ty - put_ bh (IfaceNamed b) = putByte bh 1 >> put_ bh b + put_ bh (IfaceAnon b) = putByte bh 0 >> put_ bh b + put_ bh (IfaceNamed b) = putByte bh 1 >> put_ bh b get bh = do c <- getByte bh case c of 0 -> do - n <- get bh - ty <- get bh - return $! IfaceAnon n ty + b <- get bh + return $! IfaceAnon b _ -> do b <- get bh return $! IfaceNamed b @@ -1283,7 +1285,7 @@ instance Binary (DefMethSpec IfaceType) where -} ---------------- -toIfaceTvBndr :: TyVar -> (IfLclName, IfaceKind) +toIfaceTvBndr :: TyVar -> IfaceTvBndr toIfaceTvBndr tyvar = ( occNameFS (getOccName tyvar) , toIfaceKind (tyVarKind tyvar) ) @@ -1308,9 +1310,8 @@ toIfaceType :: Type -> IfaceType toIfaceType (TyVarTy tv) = IfaceTyVar (toIfaceTyVar tv) toIfaceType (AppTy t1 t2) = IfaceAppTy (toIfaceType t1) (toIfaceType t2) toIfaceType (LitTy n) = IfaceLitTy (toIfaceTyLit n) -toIfaceType (ForAllTy (Named tv vis) t) - = IfaceForAllTy (varToIfaceForAllBndr tv vis) (toIfaceType t) -toIfaceType (ForAllTy (Anon t1) t2) +toIfaceType (ForAllTy b t) = IfaceForAllTy (toIfaceForAllBndr b) (toIfaceType t) +toIfaceType (FunTy t1 t2) | isPredTy t1 = IfaceDFunTy (toIfaceType t1) (toIfaceType t2) | otherwise = IfaceFunTy (toIfaceType t1) (toIfaceType t2) toIfaceType (CastTy ty co) = IfaceCastTy (toIfaceType ty) (toIfaceCoercion co) @@ -1338,14 +1339,12 @@ toIfaceTyVar = occNameFS . getOccName toIfaceCoVar :: CoVar -> FastString toIfaceCoVar = occNameFS . getOccName -varToIfaceForAllBndr :: TyVar -> VisibilityFlag -> IfaceForAllBndr -varToIfaceForAllBndr v vis +toIfaceForAllBndr :: TyVarBinder -> IfaceForAllBndr +toIfaceForAllBndr (TvBndr v vis) = IfaceTv (toIfaceTvBndr v) vis -binderToIfaceForAllBndr :: TyBinder -> IfaceForAllBndr -binderToIfaceForAllBndr (Named v vis) = IfaceTv (toIfaceTvBndr v) vis -binderToIfaceForAllBndr binder - = pprPanic "binderToIfaceForAllBndr" (ppr binder) +binderToIfaceForAllBndr :: TyVarBinder -> IfaceForAllBndr +binderToIfaceForAllBndr (TvBndr v vis) = IfaceTv (toIfaceTvBndr v) vis ---------------- toIfaceTyCon :: TyCon -> IfaceTyCon @@ -1419,14 +1418,15 @@ toIfaceUnivCoProv (HoleProv h) = pprPanic "toIfaceUnivCoProv hit a hole" (ppr h) zipIfaceBinders :: [TyVar] -> [TyBinder] -> [IfaceTyConBinder] zipIfaceBinders = zipWith go where - go tv (Anon _) = let (name, ki) = toIfaceTvBndr tv in - IfaceAnon name ki - go tv (Named _ vis) = IfaceNamed (IfaceTv (toIfaceTvBndr tv) vis) + go tv (Anon _) = IfaceAnon (toIfaceTvBndr tv) + go tv (Named tvb) = IfaceNamed (IfaceTv (toIfaceTvBndr tv) (binderVisibility tvb)) + -- Ugh! take the tidied tyvar from the first arg, + -- and visiblity from the second -- | Make IfaceTyConBinders without tyConTyVars. Used for pretty-printing only toDegenerateBinders :: [TyBinder] -> [IfaceTyConBinder] toDegenerateBinders = zipWith go [1..] where go :: Int -> TyBinder -> IfaceTyConBinder - go n (Anon ty) = IfaceAnon (mkFastString ("t" ++ show n)) (toIfaceType ty) - go _ (Named tv vis) = IfaceNamed (IfaceTv (toIfaceTvBndr tv) vis) + go n (Anon ty) = IfaceAnon (mkFastString ("t" ++ show n), toIfaceType ty) + go _ (Named tvb) = IfaceNamed (toIfaceForAllBndr tvb) diff --git a/compiler/iface/MkIface.hs b/compiler/iface/MkIface.hs index fcf63af369..aedec424ae 100644 --- a/compiler/iface/MkIface.hs +++ b/compiler/iface/MkIface.hs @@ -1321,10 +1321,10 @@ patSynToIfaceDecl ps } where (_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 + univ_bndrs = patSynUnivTyVarBinders ps + ex_bndrs = patSynExTyVarBinders ps + (env1, univ_bndrs') = tidyTyVarBinders emptyTidyEnv univ_bndrs + (env2, ex_bndrs') = tidyTyVarBinders env1 ex_bndrs to_if_pr (id, needs_dummy) = (idName id, needs_dummy) -------------------------- @@ -1415,12 +1415,15 @@ tyConToIfaceDecl env tycon ifParent = parent }) | otherwise -- FunTyCon, PrimTyCon, promoted TyCon/DataCon - -- For pretty printing purposes only. + -- We only convert these TyCons to IfaceTyCons when we are + -- just about to pretty-print them, not because we are going + -- to put them into interface files = ( env , IfaceData { ifName = getOccName tycon, ifBinders = if_degenerate_binders, ifResKind = if_degenerate_res_kind, - -- These don't have `tyConTyVars`, hence "degenerate" + -- FunTyCon, PrimTyCon etc don't have + -- `tyConTyVars`, hence "degenerate" ifCType = Nothing, ifRoles = tyConRoles tycon, ifCtxt = [], @@ -1438,7 +1441,7 @@ tyConToIfaceDecl env tycon if_syn_type ty = tidyToIfaceType tc_env1 ty if_res_var = getOccFS `fmap` tyConFamilyResVar_maybe tycon - -- use these when you don't have tyConTyVars + -- Use these when you don't have tyConTyVars (degenerate_binders, degenerate_res_kind) = splitPiTys (tidyType env (tyConKind tycon)) if_degenerate_binders = toDegenerateBinders degenerate_binders @@ -1492,7 +1495,7 @@ tyConToIfaceDecl env tycon where (univ_tvs, _ex_tvs, eq_spec, theta, arg_tys, _) = dataConFullSig data_con - ex_bndrs = dataConExTyBinders data_con + ex_bndrs = dataConExTyVarBinders data_con -- Tidy the univ_tvs of the data constructor to be identical -- to the tyConTyVars of the type constructor. This means @@ -1504,8 +1507,8 @@ 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') = tidyTyBinders con_env1 ex_bndrs - to_eq_spec (tv,ty) = (toIfaceTyVar (tidyTyVar con_env2 tv), tidyToIfaceType con_env2 ty) + (con_env2, ex_bndrs') = tidyTyVarBinders con_env1 ex_bndrs + to_eq_spec (tv,ty) = (toIfaceTyVar (tidyTyVar con_env2 tv), tidyToIfaceType con_env2 ty) ifaceOverloaded flds = case dFsEnvElts flds of fl:_ -> flIsOverloaded fl diff --git a/compiler/iface/TcIface.hs b/compiler/iface/TcIface.hs index a6486f3222..35d83259aa 100644 --- a/compiler/iface/TcIface.hs +++ b/compiler/iface/TcIface.hs @@ -493,16 +493,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 - ; bindIfaceForAllBndrs univ_bndrs $ \univ_tvs univ_bndrs -> do - { bindIfaceForAllBndrs ex_bndrs $ \ex_tvs ex_bndrs -> do + ; bindIfaceForAllBndrs univ_bndrs $ \univ_tvs -> do + { bindIfaceForAllBndrs ex_bndrs $ \ex_tvs -> 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, univ_bndrs, req_theta) - (ex_tvs, ex_bndrs, prov_theta) + (univ_tvs, req_theta) + (ex_tvs, prov_theta) arg_tys pat_ty field_labels } ; return $ AConLike . PatSynCon $ patsyn }}} where @@ -553,7 +553,7 @@ tcIfaceDataCons tycon_name tycon tc_tyvars tc_tybinders if_cons ifConSrcStricts = if_src_stricts}) = -- Universally-quantified tyvars are shared with -- parent TyCon, and are alrady in scope - bindIfaceForAllBndrs ex_bndrs $ \ ex_tvs ex_binders' -> do + bindIfaceForAllBndrs ex_bndrs $ \ ex_tvs -> do { traceIf (text "Start interface-file tc_con_decl" <+> ppr occ) ; dc_name <- lookupIfaceTop occ @@ -595,7 +595,7 @@ tcIfaceDataCons tycon_name tycon tc_tyvars tc_tybinders if_cons -- worker. -- See Note [Bangs on imported data constructors] in MkId lbl_names - tc_tyvars tc_tybinders ex_tvs ex_binders' + tc_tyvars tc_tybinders ex_tvs eq_spec theta arg_tys orig_res_ty tycon ; traceIf (text "Done interface-file tc_con_decl" <+> ppr dc_name) @@ -890,15 +890,16 @@ tcIfaceType = go go (IfaceTyVar n) = TyVarTy <$> tcIfaceTyVar n go (IfaceAppTy t1 t2) = AppTy <$> go t1 <*> go t2 go (IfaceLitTy l) = LitTy <$> tcIfaceTyLit l - go (IfaceFunTy t1 t2) = ForAllTy <$> (Anon <$> go t1) <*> go t2 - go (IfaceDFunTy t1 t2) = ForAllTy <$> (Anon <$> go t1) <*> go t2 + go (IfaceFunTy t1 t2) = FunTy <$> go t1 <*> go t2 + go (IfaceDFunTy t1 t2) = FunTy <$> go t1 <*> go t2 go (IfaceTupleTy s i tks) = tcIfaceTupleTy s i tks go (IfaceTyConApp tc tks) = do { tc' <- tcIfaceTyCon tc ; tks' <- mapM go (tcArgsIfaceTypes tks) ; return (mkTyConApp tc' tks') } go (IfaceForAllTy bndr t) - = bindIfaceForAllBndr bndr $ \ tv' vis -> mkNamedForAllTy tv' vis <$> go t + = bindIfaceForAllBndr bndr $ \ tv' vis -> + ForAllTy (TvBndr tv' vis) <$> go t go (IfaceCastTy ty co) = CastTy <$> go ty <*> tcIfaceCo co go (IfaceCoercionTy co) = CoercionTy <$> tcIfaceCo co @@ -1436,12 +1437,12 @@ bindIfaceBndrs (b:bs) thing_inside thing_inside (b':bs') ----------------------- -bindIfaceForAllBndrs :: [IfaceForAllBndr] -> ([TyVar] -> [TyBinder] -> IfL a) -> IfL a -bindIfaceForAllBndrs [] thing_inside = thing_inside [] [] +bindIfaceForAllBndrs :: [IfaceForAllBndr] -> ([TyVarBinder] -> IfL a) -> IfL a +bindIfaceForAllBndrs [] thing_inside = thing_inside [] bindIfaceForAllBndrs (bndr:bndrs) thing_inside = bindIfaceForAllBndr bndr $ \tv vis -> - bindIfaceForAllBndrs bndrs $ \tvs bndrs' -> - thing_inside (tv:tvs) (mkNamedBinder vis tv : bndrs') + bindIfaceForAllBndrs bndrs $ \bndrs' -> + thing_inside (mkTyVarBinder vis tv : bndrs') bindIfaceForAllBndr :: IfaceForAllBndr -> (TyVar -> VisibilityFlag -> IfL a) -> IfL a bindIfaceForAllBndr (IfaceTv tv vis) thing_inside @@ -1488,9 +1489,9 @@ bindIfaceTyConBinders_AT (b : bs) thing_inside bindIfaceTyConBinderX :: (IfaceTvBndr -> (TyVar -> IfL a) -> IfL a) -> IfaceTyConBinder -> (TyVar -> TyBinder -> IfL a) -> IfL a -bindIfaceTyConBinderX bind_tv (IfaceAnon name ki) thing_inside - = bind_tv (name, ki) $ \ tv' -> +bindIfaceTyConBinderX bind_tv (IfaceAnon tv) thing_inside + = bind_tv tv $ \ tv' -> thing_inside tv' (Anon (tyVarKind tv')) bindIfaceTyConBinderX bind_tv (IfaceNamed (IfaceTv tv vis)) thing_inside = bind_tv tv $ \tv' -> - thing_inside tv' (Named tv' vis) + thing_inside tv' (Named (mkTyVarBinder vis tv')) diff --git a/compiler/main/HscTypes.hs b/compiler/main/HscTypes.hs index a5eee7c5d8..4529353ef3 100644 --- a/compiler/main/HscTypes.hs +++ b/compiler/main/HscTypes.hs @@ -1974,23 +1974,23 @@ lookupTypeHscEnv hsc_env name = do -- | Get the 'TyCon' from a 'TyThing' if it is a type constructor thing. Panics otherwise tyThingTyCon :: TyThing -> TyCon tyThingTyCon (ATyCon tc) = tc -tyThingTyCon other = pprPanic "tyThingTyCon" (pprTyThing other) +tyThingTyCon other = pprPanic "tyThingTyCon" (ppr other) -- | Get the 'CoAxiom' from a 'TyThing' if it is a coercion axiom thing. Panics otherwise tyThingCoAxiom :: TyThing -> CoAxiom Branched tyThingCoAxiom (ACoAxiom ax) = ax -tyThingCoAxiom other = pprPanic "tyThingCoAxiom" (pprTyThing other) +tyThingCoAxiom other = pprPanic "tyThingCoAxiom" (ppr other) -- | Get the 'DataCon' from a 'TyThing' if it is a data constructor thing. Panics otherwise tyThingDataCon :: TyThing -> DataCon tyThingDataCon (AConLike (RealDataCon dc)) = dc -tyThingDataCon other = pprPanic "tyThingDataCon" (pprTyThing other) +tyThingDataCon other = pprPanic "tyThingDataCon" (ppr other) -- | Get the 'Id' from a 'TyThing' if it is a id *or* data constructor thing. Panics otherwise tyThingId :: TyThing -> Id tyThingId (AnId id) = id tyThingId (AConLike (RealDataCon dc)) = dataConWrapId dc -tyThingId other = pprPanic "tyThingId" (pprTyThing other) +tyThingId other = pprPanic "tyThingId" (ppr other) {- ************************************************************************ diff --git a/compiler/prelude/TysPrim.hs b/compiler/prelude/TysPrim.hs index 1850e55b7d..e0be093420 100644 --- a/compiler/prelude/TysPrim.hs +++ b/compiler/prelude/TysPrim.hs @@ -682,7 +682,7 @@ mkProxyPrimTy k ty = TyConApp proxyPrimTyCon [k, ty] proxyPrimTyCon :: TyCon proxyPrimTyCon = mkPrimTyCon proxyPrimTyConName binders res_kind [Nominal,Nominal] - where binders = [ Named kv Specified + where binders = [ Named (TvBndr kv Specified) , Anon k ] res_kind = tYPE voidRepDataConTy kv = kKiVar @@ -699,8 +699,8 @@ proxyPrimTyCon = mkPrimTyCon proxyPrimTyConName binders res_kind [Nominal,Nomina eqPrimTyCon :: TyCon -- The representation type for equality predicates -- See Note [The equality types story] eqPrimTyCon = mkPrimTyCon eqPrimTyConName binders res_kind roles - where binders = [ Named kv1 Specified - , Named kv2 Specified + where binders = [ Named (TvBndr kv1 Specified) + , Named (TvBndr kv2 Specified) , Anon k1 , Anon k2 ] res_kind = tYPE voidRepDataConTy @@ -714,8 +714,8 @@ eqPrimTyCon = mkPrimTyCon eqPrimTyConName binders res_kind roles -- interpreted in coercionRole eqReprPrimTyCon :: TyCon -- See Note [The equality types story] eqReprPrimTyCon = mkPrimTyCon eqReprPrimTyConName binders res_kind roles - where binders = [ Named kv1 Specified - , Named kv2 Specified + where binders = [ Named (TvBndr kv1 Specified) + , Named (TvBndr kv2 Specified) , Anon k1 , Anon k2 ] res_kind = tYPE voidRepDataConTy @@ -730,8 +730,8 @@ eqReprPrimTyCon = mkPrimTyCon eqReprPrimTyConName binders res_kind roles eqPhantPrimTyCon :: TyCon eqPhantPrimTyCon = mkPrimTyCon eqPhantPrimTyConName binders res_kind [Nominal, Nominal, Phantom, Phantom] - where binders = [ Named kv1 Specified - , Named kv2 Specified + where binders = [ Named (TvBndr kv1 Specified) + , Named (TvBndr kv2 Specified) , Anon k1 , Anon k2 ] res_kind = tYPE voidRepDataConTy diff --git a/compiler/prelude/TysWiredIn.hs b/compiler/prelude/TysWiredIn.hs index 5613d86749..82c5bfb389 100644 --- a/compiler/prelude/TysWiredIn.hs +++ b/compiler/prelude/TysWiredIn.hs @@ -130,7 +130,6 @@ import Type import DataCon import {-# SOURCE #-} ConLike import TyCon -import TyCoRep ( TyBinder(..) ) import Class ( Class, mkClass ) import RdrName import Name @@ -353,7 +352,7 @@ anyTyCon = mkFamilyTyCon anyTyConName binders res_kind [kKiVar] Nothing Nothing NotInjective where - binders = [Named kKiVar Specified] + binders = [mkNamedBinder (mkTyVarBinder Specified kKiVar)] res_kind = mkTyVarTy kKiVar anyTy :: Type @@ -496,8 +495,8 @@ pcDataConWithFixity' declared_infix dc_name wrk_key rri tyvars ex_tyvars arg_tys data_con = mkDataCon dc_name declared_infix prom_info (map (const no_bang) arg_tys) [] -- No labelled fields - tyvars (mkNamedBinders Specified tyvars) - ex_tyvars (mkNamedBinders Specified ex_tyvars) + (mkTyVarBinders Specified tyvars) + (mkTyVarBinders Specified ex_tyvars) [] -- No equality spec [] -- No theta arg_tys (mkTyConApp tycon (mkTyVarTys tyvars)) @@ -758,7 +757,7 @@ mk_tuple boxity arity = (tycon, tuple_con) in ( UnboxedTuple , gHC_PRIM - , mkNamedBinders Specified rr_tvs ++ + , map (mkNamedBinder . mkTyVarBinder Specified) rr_tvs ++ map (mkAnonBinder . tyVarKind) open_tvs , unboxedTupleKind , arity * 2 @@ -819,8 +818,8 @@ heqSCSelId, coercibleSCSelId :: Id klass = mkClass tvs [] [sc_pred] [sc_sel_id] [] [] (mkAnd []) tycon datacon = pcDataCon heqDataConName tvs [sc_pred] tycon - binders = [ mkNamedBinder Specified kv1 - , mkNamedBinder Specified kv2 + binders = [ mkNamedBinder (mkTyVarBinder Specified kv1) + , mkNamedBinder (mkTyVarBinder Specified kv2) , mkAnonBinder k1 , mkAnonBinder k2 ] kv1:kv2:_ = drop 9 alphaTyVars -- gets "j" and "k" @@ -843,7 +842,7 @@ heqSCSelId, coercibleSCSelId :: Id klass = mkClass tvs [] [sc_pred] [sc_sel_id] [] [] (mkAnd []) tycon datacon = pcDataCon coercibleDataConName tvs [sc_pred] tycon - binders = [ mkNamedBinder Specified kKiVar + binders = [ mkNamedBinder (mkTyVarBinder Specified kKiVar) , mkAnonBinder k , mkAnonBinder k ] k = mkTyVarTy kKiVar diff --git a/compiler/simplCore/SetLevels.hs b/compiler/simplCore/SetLevels.hs index 94a7e9e90e..e9a0004cac 100644 --- a/compiler/simplCore/SetLevels.hs +++ b/compiler/simplCore/SetLevels.hs @@ -78,7 +78,7 @@ import Literal ( litIsTrivial ) import Demand ( StrictSig ) import Name ( getOccName, mkSystemVarName ) import OccName ( occNameString ) -import Type ( isUnliftedType, Type, mkPiTypes ) +import Type ( isUnliftedType, Type, mkLamTypes ) import BasicTypes ( Arity, RecFlag(..) ) import UniqSupply import Util @@ -1092,7 +1092,7 @@ newPolyBndrs dest_lvl mkSysLocalOrCoVar (mkFastString str) uniq poly_ty where str = "poly_" ++ occNameString (getOccName bndr) - poly_ty = mkPiTypes abs_vars (substTy subst (idType bndr)) + poly_ty = mkLamTypes abs_vars (substTy subst (idType bndr)) newLvlVar :: LevelledExpr -- The RHS of the new binding -> Bool -- Whether it is bottom diff --git a/compiler/simplCore/Simplify.hs b/compiler/simplCore/Simplify.hs index debc7d8fda..6e6a6aa424 100644 --- a/compiler/simplCore/Simplify.hs +++ b/compiler/simplCore/Simplify.hs @@ -2525,8 +2525,8 @@ mkDupableAlt env case_bndr (con, bndrs', rhs') = do else do { rw_id <- newId (fsLit "w") voidPrimTy ; return ([setOneShotLambda rw_id], [Var voidPrimId]) } - ; join_bndr <- newId (fsLit "$j") (mkPiTypes final_bndrs' rhs_ty') - -- Note [Funky mkPiTypes] + ; join_bndr <- newId (fsLit "$j") (mkLamTypes final_bndrs' rhs_ty') + -- Note [Funky mkLamTypes] ; let -- We make the lambdas into one-shot-lambdas. The -- join point is sure to be applied at most once, and doing so @@ -2643,9 +2643,9 @@ but we only have one env shared between all the alts. (Remember we must zap the subst-env before re-simplifying something). Rather than do this we simply agree to re-simplify the original (small) thing later. -Note [Funky mkPiTypes] +Note [Funky mkLamTypes] ~~~~~~~~~~~~~~~~~~~~~~ -Notice the funky mkPiTypes. If the contructor has existentials +Notice the funky mkLamTypes. If the contructor has existentials it's possible that the join point will be abstracted over type variables as well as term variables. Example: Suppose we have diff --git a/compiler/specialise/SpecConstr.hs b/compiler/specialise/SpecConstr.hs index 2b78705755..00c68535f3 100644 --- a/compiler/specialise/SpecConstr.hs +++ b/compiler/specialise/SpecConstr.hs @@ -1643,7 +1643,7 @@ spec_one env fn arg_bndrs body (call_pat@(qvars, pats), rule_number) -- return () -- And build the results - ; let spec_id = mkLocalIdOrCoVar spec_name (mkPiTypes spec_lam_args body_ty) + ; let spec_id = mkLocalIdOrCoVar spec_name (mkLamTypes spec_lam_args body_ty) -- See Note [Transfer strictness] `setIdStrictness` spec_str `setIdArity` count isId spec_lam_args diff --git a/compiler/specialise/Specialise.hs b/compiler/specialise/Specialise.hs index b69c9140b9..d587eebab9 100644 --- a/compiler/specialise/Specialise.hs +++ b/compiler/specialise/Specialise.hs @@ -1266,7 +1266,7 @@ specCalls mb_mod env rules_for_me calls_for_me fn rhs | isUnliftedType body_ty -- C.f. WwLib.mkWorkerArgs = (poly_tyvars ++ [voidArgId], poly_tyvars ++ [voidPrimId]) | otherwise = (poly_tyvars, poly_tyvars) - spec_id_ty = mkPiTypes lam_args body_ty + spec_id_ty = mkLamTypes lam_args body_ty ; spec_f <- newSpecIdSM fn spec_id_ty ; (spec_rhs, rhs_uds) <- specExpr rhs_env2 (mkLams lam_args body) diff --git a/compiler/typecheck/FamInst.hs b/compiler/typecheck/FamInst.hs index a789a7b1a6..a18bd9c3f1 100644 --- a/compiler/typecheck/FamInst.hs +++ b/compiler/typecheck/FamInst.hs @@ -473,12 +473,12 @@ unusedInjTvsInRHS tycon injList lhs rhs = | otherwise = mapUnionVarSet collectInjVars tys collectInjVars (LitTy {}) = emptyVarSet - collectInjVars (ForAllTy (Anon arg) res) + collectInjVars (FunTy arg res) = collectInjVars arg `unionVarSet` collectInjVars res collectInjVars (AppTy fun arg) = collectInjVars fun `unionVarSet` collectInjVars arg -- no forall types in the RHS of a type family - collectInjVars (ForAllTy _ _) = + collectInjVars (ForAllTy {}) = panic "unusedInjTvsInRHS.collectInjVars" collectInjVars (CastTy ty _) = collectInjVars ty collectInjVars (CoercionTy {}) = emptyVarSet diff --git a/compiler/typecheck/Inst.hs b/compiler/typecheck/Inst.hs index 27382c5f98..7ed98de881 100644 --- a/compiler/typecheck/Inst.hs +++ b/compiler/typecheck/Inst.hs @@ -46,6 +46,7 @@ import CoreSyn ( isOrphan ) import FunDeps import TcMType import Type +import TyCoRep ( TyBinder(..), TyVarBinder(..) ) import TcType import HscTypes import Class( Class ) @@ -183,7 +184,7 @@ top_instantiate inst_all orig ty | otherwise = ([], theta) in_scope = mkInScopeSet (tyCoVarsOfType ty) empty_subst = mkEmptyTCvSubst in_scope - inst_tvs = map (binderVar "top_inst") inst_bndrs + inst_tvs = binderVars inst_bndrs ; (subst, inst_tvs') <- mapAccumLM newMetaTyVarX empty_subst inst_tvs ; let inst_theta' = substTheta subst inst_theta sigma' = substTy subst (mkForAllTys leave_bndrs $ @@ -212,7 +213,7 @@ top_instantiate inst_all orig ty | otherwise = return (idHsWrapper, ty) where - (binders, phi) = tcSplitNamedPiTys ty + (binders, phi) = tcSplitForAllTyVarBndrs ty (theta, rho) = tcSplitPhiTy phi should_inst bndr @@ -367,13 +368,17 @@ tcInstBindersX subst mb_kind_info bndrs -- | Used only in *types* tcInstBinderX :: Maybe (VarEnv Kind) -> TCvSubst -> TyBinder -> TcM (TCvSubst, TcType) -tcInstBinderX mb_kind_info subst binder - | Just tv <- binderVar_maybe binder +tcInstBinderX mb_kind_info subst (Named (TvBndr tv _)) = case lookup_tv tv of Just ki -> return (extendTvSubstAndInScope subst tv ki, ki) Nothing -> do { (subst', tv') <- newMetaTyVarX subst tv ; return (subst', mkTyVarTy tv') } + where + lookup_tv tv = do { env <- mb_kind_info -- `Maybe` monad + ; lookupVarEnv env tv } + +tcInstBinderX _ subst (Anon ty) -- This is the *only* constraint currently handled in types. | Just (mk, role, k1, k2) <- get_pred_tys_maybe substed_ty = do { let origin = TypeEqOrigin { uo_actual = k1 @@ -382,7 +387,7 @@ tcInstBinderX mb_kind_info subst binder ; co <- case role of Nominal -> unifyKind noThing k1 k2 Representational -> emitWantedEq origin KindLevel role k1 k2 - Phantom -> pprPanic "tcInstBinderX Phantom" (ppr binder) + Phantom -> pprPanic "tcInstBinderX Phantom" (ppr ty) ; arg' <- mk co k1 k2 ; return (subst, arg') } @@ -397,14 +402,11 @@ tcInstBinderX mb_kind_info subst binder | otherwise - = do { ty <- newFlexiTyVarTy substed_ty - ; return (subst, ty) } + = do { tv_ty <- newFlexiTyVarTy substed_ty + ; return (subst, tv_ty) } where - substed_ty = substTy subst (binderType binder) - - lookup_tv tv = do { env <- mb_kind_info -- `Maybe` monad - ; lookupVarEnv env tv } + substed_ty = substTy subst ty -- handle boxed equality constraints, because it's so easy get_pred_tys_maybe ty diff --git a/compiler/typecheck/TcArrows.hs b/compiler/typecheck/TcArrows.hs index f2424eacc6..8285276fae 100644 --- a/compiler/typecheck/TcArrows.hs +++ b/compiler/typecheck/TcArrows.hs @@ -297,7 +297,7 @@ tc_cmd env cmd@(HsCmdArrForm expr fixity cmd_args) (cmd_stk, res_ty) = addErrCtxt (cmdCtxt cmd) $ do { (cmd_args', cmd_tys) <- mapAndUnzipM tc_cmd_arg cmd_args -- We use alphaTyVar for 'w' - ; let e_ty = mkNamedForAllTy alphaTyVar Invisible $ + ; let e_ty = mkInvForAllTy alphaTyVar $ mkFunTys cmd_tys $ mkCmdArrTy env (mkPairTy alphaTy cmd_stk) res_ty ; expr' <- tcPolyExpr expr e_ty diff --git a/compiler/typecheck/TcBinds.hs b/compiler/typecheck/TcBinds.hs index 4517b737e7..fb89416e04 100644 --- a/compiler/typecheck/TcBinds.hs +++ b/compiler/typecheck/TcBinds.hs @@ -35,6 +35,7 @@ import FamInstEnv( normaliseType ) import FamInst( tcGetFamInstEnvs ) import TyCon import TcType +import Type( mkStrLitTy, tidyOpenType, TyVarBinder, mkTyVarBinder ) import TysPrim import TysWiredIn( cTupleTyConName ) import Id @@ -54,7 +55,6 @@ import Maybes import Util import BasicTypes import Outputable -import Type(mkStrLitTy, tidyOpenType) import PrelNames( gHC_PRIM, ipClassName ) import TcValidity (checkValidType) import UniqFM @@ -835,13 +835,13 @@ chooseInferredQuantifiers :: TcThetaType -- inferred -> TcTyVarSet -- tvs free in tau type -> [TcTyVar] -- inferred quantified tvs -> Maybe TcIdSigInst - -> TcM ([TcTyBinder], TcThetaType) + -> TcM ([TyVarBinder], TcThetaType) chooseInferredQuantifiers inferred_theta tau_tvs qtvs Nothing = -- No type signature (partial or complete) for this binder, do { let free_tvs = closeOverKinds (growThetaTyVars inferred_theta tau_tvs) -- Include kind variables! Trac #7916 my_theta = pickCapturedPreds free_tvs inferred_theta - binders = [ mkNamedBinder Invisible tv + binders = [ mkTyVarBinder Invisible tv | tv <- qtvs , tv `elemVarSet` free_tvs ] ; return (binders, my_theta) } @@ -886,7 +886,7 @@ chooseInferredQuantifiers inferred_theta tau_tvs qtvs where spec_tv_set = mkVarSet $ map snd annotated_tvs mk_binders free_tvs - = [ mkNamedBinder vis tv + = [ mkTyVarBinder vis tv | tv <- qtvs , tv `elemVarSet` free_tvs , let vis | tv `elemVarSet` spec_tv_set = Specified diff --git a/compiler/typecheck/TcCanonical.hs b/compiler/typecheck/TcCanonical.hs index cde6478123..3d05a554b2 100644 --- a/compiler/typecheck/TcCanonical.hs +++ b/compiler/typecheck/TcCanonical.hs @@ -594,10 +594,10 @@ can_eq_nc' _flat _rdr_env _envs ev eq_rel ty1 _ ty2 _ = canTyConApp ev eq_rel tc1 tys1 tc2 tys2 can_eq_nc' _flat _rdr_env _envs ev eq_rel - s1@(ForAllTy (Named {}) _) _ s2@(ForAllTy (Named {}) _) _ + s1@(ForAllTy {}) _ s2@(ForAllTy {}) _ | CtWanted { ctev_loc = loc, ctev_dest = orig_dest } <- ev - = do { let (bndrs1,body1) = tcSplitNamedPiTys s1 - (bndrs2,body2) = tcSplitNamedPiTys s2 + = do { let (bndrs1,body1) = tcSplitForAllTyVarBndrs s1 + (bndrs2,body2) = tcSplitForAllTyVarBndrs s2 ; if not (equalLength bndrs1 bndrs2) then do { traceTcS "Forall failure" $ vcat [ ppr s1, ppr s2, ppr bndrs1, ppr bndrs2 @@ -1138,7 +1138,7 @@ canDecomposableTyConAppOK ev eq_rel tc tys1 tys2 -- in error messages bndrs = tyConBinders tc kind_loc = toKindLoc loc - is_kinds = map isNamedBinder bndrs + is_kinds = map isNamedTyBinder bndrs new_locs | Just KindLevel <- ctLocTypeOrKind_maybe loc = repeat loc | otherwise @@ -1896,7 +1896,7 @@ unifyWanted loc role orig_ty1 orig_ty2 go ty1 ty2 | Just ty1' <- coreView ty1 = go ty1' ty2 go ty1 ty2 | Just ty2' <- coreView ty2 = go ty1 ty2' - go (ForAllTy (Anon s1) t1) (ForAllTy (Anon s2) t2) + go (FunTy s1 t1) (FunTy s2 t2) = do { co_s <- unifyWanted loc role s1 s2 ; co_t <- unifyWanted loc role t1 t2 ; return (mkTyConAppCo role funTyCon [co_s,co_t]) } @@ -1945,7 +1945,7 @@ unify_derived loc role orig_ty1 orig_ty2 go ty1 ty2 | Just ty1' <- coreView ty1 = go ty1' ty2 go ty1 ty2 | Just ty2' <- coreView ty2 = go ty1 ty2' - go (ForAllTy (Anon s1) t1) (ForAllTy (Anon s2) t2) + go (FunTy s1 t1) (FunTy s2 t2) = do { unify_derived loc role s1 s2 ; unify_derived loc role t1 t2 } go (TyConApp tc1 tys1) (TyConApp tc2 tys2) diff --git a/compiler/typecheck/TcDeriv.hs b/compiler/typecheck/TcDeriv.hs index 030de0762f..2418517a12 100644 --- a/compiler/typecheck/TcDeriv.hs +++ b/compiler/typecheck/TcDeriv.hs @@ -1087,8 +1087,8 @@ inferConstraints tvs main_cls cls_tys inst_ty rep_tc rep_tc_args mkTheta where tc_binders = tyConBinders rep_tc choose_level bndr - | isNamedBinder bndr = KindLevel - | otherwise = TypeLevel + | isNamedTyBinder bndr = KindLevel + | otherwise = TypeLevel t_or_ks = map choose_level tc_binders ++ repeat TypeLevel -- want to report *kind* errors when possible diff --git a/compiler/typecheck/TcErrors.hs b/compiler/typecheck/TcErrors.hs index d5b003b3c5..2a87975442 100644 --- a/compiler/typecheck/TcErrors.hs +++ b/compiler/typecheck/TcErrors.hs @@ -1800,17 +1800,17 @@ expandSynonymsToMatch ty1 ty2 = (ty1_ret, ty2_ret) (t1_2', t2_2') = go t1_2 t2_2 in (mkAppTy t1_1' t1_2', mkAppTy t2_1' t2_2') - go (ForAllTy (Anon t1_1) t1_2) (ForAllTy (Anon t2_1) t2_2) = + go (FunTy t1_1 t1_2) (FunTy t2_1 t2_2) = let (t1_1', t2_1') = go t1_1 t2_1 (t1_2', t2_2') = go t1_2 t2_2 in (mkFunTy t1_1' t1_2', mkFunTy t2_1' t2_2') - go (ForAllTy (Named tv1 vis1) t1) (ForAllTy (Named tv2 vis2) t2) = + go (ForAllTy b1 t1) (ForAllTy b2 t2) = -- NOTE: We may have a bug here, but we just can't reproduce it easily. -- See D1016 comments for details and our attempts at producing a test -- case. Short version: We probably need RnEnv2 to really get this right. let (t1', t2') = go t1 t2 - in (ForAllTy (Named tv1 vis1) t1', ForAllTy (Named tv2 vis2) t2') + in (ForAllTy b1 t1', ForAllTy b2 t2') go (CastTy ty1 _) ty2 = go ty1 ty2 go ty1 (CastTy ty2 _) = go ty1 ty2 @@ -1864,13 +1864,13 @@ expandSynonymsToMatch ty1 ty2 = (ty1_ret, ty2_ret) | otherwise = followExpansions tss sameShapes :: Type -> Type -> Bool - sameShapes AppTy{} AppTy{} = True - sameShapes (TyConApp tc1 _) (TyConApp tc2 _) = tc1 == tc2 - sameShapes (ForAllTy Anon{} _) (ForAllTy Anon{} _) = True - sameShapes (ForAllTy Named{} _) (ForAllTy Named{} _) = True - sameShapes (CastTy ty1 _) ty2 = sameShapes ty1 ty2 - sameShapes ty1 (CastTy ty2 _) = sameShapes ty1 ty2 - sameShapes _ _ = False + sameShapes AppTy{} AppTy{} = True + sameShapes (TyConApp tc1 _) (TyConApp tc2 _) = tc1 == tc2 + sameShapes (FunTy {}) (FunTy {}) = True + sameShapes (ForAllTy {}) (ForAllTy {}) = True + sameShapes (CastTy ty1 _) ty2 = sameShapes ty1 ty2 + sameShapes ty1 (CastTy ty2 _) = sameShapes ty1 ty2 + sameShapes _ _ = False sameOccExtra :: TcType -> TcType -> SDoc -- See Note [Disambiguating (X ~ X) errors] diff --git a/compiler/typecheck/TcExpr.hs b/compiler/typecheck/TcExpr.hs index 816fd9b031..0e3c655f76 100644 --- a/compiler/typecheck/TcExpr.hs +++ b/compiler/typecheck/TcExpr.hs @@ -1189,13 +1189,14 @@ tcArgs fun orig_fun_ty fun_orig orig_args herald = do { (wrap1, upsilon_ty) <- topInstantiateInferred fun_orig fun_ty -- wrap1 :: fun_ty "->" upsilon_ty ; case tcSplitForAllTy_maybe upsilon_ty of - Just (binder, inner_ty) - | Just tv <- binderVar_maybe binder -> - ASSERT2( binderVisibility binder == Specified - , (vcat [ ppr fun_ty, ppr upsilon_ty, ppr binder + Just (tvb, inner_ty) -> + do { let tv = binderVar tvb + vis = binderVisibility tvb + kind = tyVarKind tv + ; MASSERT2( vis == Specified + , (vcat [ ppr fun_ty, ppr upsilon_ty, ppr tvb , ppr inner_ty, pprTvBndr tv - , ppr (binderVisibility binder) ]) ) - do { let kind = tyVarKind tv + , ppr vis ]) ) ; ty_arg <- tcHsTypeApp hs_ty_arg kind ; let insted_ty = substTyWithUnchecked [tv] [ty_arg] inner_ty ; (inner_wrap, args', res_ty) diff --git a/compiler/typecheck/TcFlatten.hs b/compiler/typecheck/TcFlatten.hs index 5005abc04b..f31c122ff4 100644 --- a/compiler/typecheck/TcFlatten.hs +++ b/compiler/typecheck/TcFlatten.hs @@ -972,21 +972,21 @@ flatten_one (TyConApp tc tys) -- _ -> fmode = flatten_ty_con_app tc tys -flatten_one (ForAllTy (Anon ty1) ty2) +flatten_one (FunTy ty1 ty2) = do { (xi1,co1) <- flatten_one ty1 ; (xi2,co2) <- flatten_one ty2 ; role <- getRole ; return (mkFunTy xi1 xi2, mkFunCo role co1 co2) } -flatten_one ty@(ForAllTy (Named {}) _) +flatten_one ty@(ForAllTy {}) -- TODO (RAE): This is inadequate, as it doesn't flatten the kind of -- the bound tyvar. Doing so will require carrying around a substitution -- and the usual substTyVarBndr-like silliness. Argh. -- We allow for-alls when, but only when, no type function -- applications inside the forall involve the bound type variables. - = do { let (bndrs, rho) = splitNamedPiTys ty - tvs = map (binderVar "flatten") bndrs + = do { let (bndrs, rho) = splitForAllTyVarBndrs ty + tvs = map binderVar bndrs ; (rho', co) <- setMode FM_SubstOnly $ flatten_one rho -- Substitute only under a forall -- See Note [Flattening under a forall] diff --git a/compiler/typecheck/TcForeign.hs b/compiler/typecheck/TcForeign.hs index cb4c9ce385..99838fe92a 100644 --- a/compiler/typecheck/TcForeign.hs +++ b/compiler/typecheck/TcForeign.hs @@ -128,11 +128,11 @@ normaliseFfiType' env ty0 = go initRecTc ty0 | Just (tc, tys) <- splitTyConApp_maybe ty = go_tc_app rec_nts tc tys - | Just (bndr, inner_ty) <- splitPiTy_maybe ty - , Just tyvar <- binderVar_maybe bndr + | (bndrs, inner_ty) <- splitForAllTyVarBndrs ty + , not (null bndrs) = do (coi, nty1, gres1) <- go rec_nts inner_ty - return ( mkHomoForAllCos [tyvar] coi - , mkForAllTy bndr nty1, gres1 ) + return ( mkHomoForAllCos (map binderVar bndrs) coi + , mkForAllTys bndrs nty1, gres1 ) | otherwise -- see Note [Don't recur in normaliseFfiType'] = return (mkRepReflCo ty, ty, emptyBag) diff --git a/compiler/typecheck/TcGenDeriv.hs b/compiler/typecheck/TcGenDeriv.hs index e01586c300..b085135180 100644 --- a/compiler/typecheck/TcGenDeriv.hs +++ b/compiler/typecheck/TcGenDeriv.hs @@ -1640,8 +1640,8 @@ functorLikeTraverse var (FT { ft_triv = caseTrivial, ft_var = caseVar go co ty | Just ty' <- coreView ty = go co ty' go co (TyVarTy v) | v == var = (if co then caseCoVar else caseVar,True) - go co (ForAllTy (Anon x) y) | isPredTy x = go co y - | xc || yc = (caseFun xr yr,True) + go co (FunTy x y) | isPredTy x = go co y + | xc || yc = (caseFun xr yr,True) where (xr,xc) = go (not co) x (yr,yc) = go co y go co (AppTy x y) | xc = (caseWrongArg, True) @@ -1659,9 +1659,10 @@ functorLikeTraverse var (FT { ft_triv = caseTrivial, ft_var = caseVar | otherwise = (caseWrongArg, True) -- Non-decomposable (eg type function) where (xrs,xcs) = unzip (map (go co) args) - go _ (ForAllTy (Named _ Visible) _) = panic "unexpected visible binder" - go co (ForAllTy (Named v _) x) | v /= var && xc = (caseForAll v xr,True) - where (xr,xc) = go co x + go co (ForAllTy (TvBndr v vis) x) + | isVisible vis = panic "unexpected visible binder" + | v /= var && xc = (caseForAll v xr,True) + where (xr,xc) = go co x go _ _ = (caseTrivial,False) diff --git a/compiler/typecheck/TcHsSyn.hs b/compiler/typecheck/TcHsSyn.hs index 2e6ab35c8e..87f333bc92 100644 --- a/compiler/typecheck/TcHsSyn.hs +++ b/compiler/typecheck/TcHsSyn.hs @@ -48,7 +48,7 @@ import TcEvidence import TysPrim import TysWiredIn import Type -import TyCoRep ( TyBinder(..) ) +import TyCoRep ( TyBinder(..), TyVarBinder(..) ) import TyCon import Coercion import ConLike @@ -345,9 +345,9 @@ zonkTyBinders = mapAccumLM zonkTyBinder zonkTyBinder :: ZonkEnv -> TcTyBinder -> TcM (ZonkEnv, TyBinder) zonkTyBinder env (Anon ty) = (env, ) <$> (Anon <$> zonkTcTypeToType env ty) -zonkTyBinder env (Named tv vis) +zonkTyBinder env (Named (TvBndr tv vis)) = do { (env', tv') <- zonkTyBndrX env tv - ; return (env', Named tv' vis) } + ; return (env', Named (TvBndr tv' vis)) } zonkTopExpr :: HsExpr TcId -> TcM (HsExpr Id) zonkTopExpr e = zonkExpr emptyZonkEnv e diff --git a/compiler/typecheck/TcHsType.hs b/compiler/typecheck/TcHsType.hs index 7fb77e6a39..7297066966 100644 --- a/compiler/typecheck/TcHsType.hs +++ b/compiler/typecheck/TcHsType.hs @@ -57,6 +57,7 @@ import TcSimplify ( solveEqualities ) import TcType import Inst ( tcInstBinders, tcInstBindersX ) import Type +import TyCoRep( TyBinder(..) ) import Kind import RdrName( lookupLocalRdrOcc ) import Var @@ -521,7 +522,7 @@ tc_hs_type mode (HsForAllTy { hst_bndrs = hs_tvs, hst_body = ty }) exp_kind -- Why exp_kind? See Note [Body kind of HsForAllTy] do { ty' <- tc_lhs_type mode ty exp_kind ; let bound_vars = allBoundVariables ty' - bndrs = mkNamedBinders Specified tvs' + bndrs = mkTyVarBinders Specified tvs' ; return (mkForAllTys bndrs ty', bound_vars) } tc_hs_type mode (HsQualTy { hst_ctxt = ctxt, hst_body = ty }) exp_kind @@ -788,10 +789,10 @@ tc_infer_args mode orig_ty binders mb_kind_info orig_args n0 = ASSERT( isVisibleBinder binder ) do { traceTc "tc_infer_args 2" (ppr binder $$ ppr arg) ; arg' <- addErrCtxt (funAppCtxt orig_ty arg n) $ - tc_lhs_type mode arg (substTyUnchecked subst $ binderType binder) - ; let subst' = case binderVar_maybe binder of - Just tv -> extendTvSubst subst tv arg' - Nothing -> subst + tc_lhs_type mode arg (substTyUnchecked subst $ tyBinderType binder) + ; let subst' = case binder of + Named bndr -> extendTvSubst subst (binderVar bndr) arg' + Anon {} -> subst ; go subst' binders args (n+1) (arg' : acc) } go subst [] all_args n acc @@ -816,7 +817,7 @@ tcInferApps mode orig_ty ty ki args = go ty ki args 1 = do { (subst, leftover_binders, args', leftover_args, n') <- tc_infer_args mode orig_ty binders Nothing args n ; let fun_kind' = substTyUnchecked subst $ - mkForAllTys leftover_binders res_kind + mkPiTys leftover_binders res_kind ; go (mkNakedAppTys fun args') fun_kind' leftover_args n' } go fun fun_kind all_args@(arg:args) n @@ -875,7 +876,7 @@ instantiateTyN n ty ki in if num_to_inst <= 0 then return (ty, ki) else do { (subst, inst_args) <- tcInstBinders inst_bndrs - ; let rebuilt_ki = mkForAllTys leftover_bndrs inner_ki + ; let rebuilt_ki = mkPiTys leftover_bndrs inner_ki ki' = substTy subst rebuilt_ki ; return (mkNakedAppTys ty inst_args, ki') } @@ -1008,7 +1009,7 @@ So we must be careful not to use "smart constructors" for types that look at the TyCon or Class involved. * Hence the use of mkNakedXXX functions. These do *not* enforce - the invariants (for example that we use (ForAllTy (Anon s) t) rather + the invariants (for example that we use (FunTy s t) rather than (TyConApp (->) [s,t])). * The zonking functions establish invariants (even zonkTcType, a change from @@ -1247,12 +1248,12 @@ kcHsTyVarBndrs name cusk open_fam all_kind_vars -- kind vars, in dependency order. ; binders <- mapM zonkTcTyBinder binders ; res_kind <- zonkTcType res_kind - ; let qkvs = tyCoVarsOfTypeWellScoped (mkForAllTys binders res_kind) + ; let qkvs = tyCoVarsOfTypeWellScoped (mkPiTys binders res_kind) -- the visibility of tvs doesn't matter here; we just -- want the free variables not to include the tvs - -- if there are any meta-tvs left, the user has lied about having - -- a CUSK. Error. + -- If there are any meta-tvs left, the user has + -- lied about having a CUSK. Error. ; let (meta_tvs, good_tvs) = partition isMetaTyVar qkvs ; when (not (null meta_tvs)) $ report_non_cusk_tvs (qkvs ++ tvs) @@ -1268,7 +1269,7 @@ kcHsTyVarBndrs name cusk open_fam all_kind_vars scoped_kvs ; reportFloatingKvs name tycon_tyvars unmentioned_kvs - ; let final_binders = mkNamedBinders Specified good_tvs ++ binders + ; let final_binders = mkNamedTyBinders Specified good_tvs ++ binders mk_tctc unsat = mkTcTyCon name tycon_tyvars final_binders res_kind unsat (scoped_kvs ++ tvs) @@ -1318,7 +1319,7 @@ kcHsTyVarBndrs name cusk open_fam all_kind_vars thing -- See Note [Dependent LHsQTyVars] ; let new_binder | hsTyVarName hs_tv `elemNameSet` dep_names - = mkNamedBinder Visible tv + = mkNamedBinder (mkTyVarBinder Visible tv) | otherwise = mkAnonBinder (tyVarKind tv) ; return ( tv : tvs @@ -1681,13 +1682,13 @@ tcDataKindSig kind -- NB: Use the tv from a binder if there is one. Otherwise, -- we end up inventing a new Unique for it, and any other tv -- that mentions the first ends up with the wrong kind. - ; return ( [ tv - | ((bndr, occ), uniq) <- bndrs `zip` occs `zip` uniqs - , let tv | Just bndr_tv <- binderVar_maybe bndr - = bndr_tv - | otherwise - = mk_tv span uniq occ (binderType bndr) ] - , bndrs, res_kind ) } + tvs = [ tv + | (bndr, occ, uniq) <- zip3 bndrs occs uniqs + , let tv = case bndr of + Named tvb -> binderVar tvb + Anon kind -> mk_tv span uniq occ kind ] + + ; return (tvs, bndrs, res_kind) } where (bndrs, res_kind) = splitPiTys kind mk_tv loc uniq occ kind diff --git a/compiler/typecheck/TcInstDcls.hs b/compiler/typecheck/TcInstDcls.hs index d078e2dac5..8c968df18c 100644 --- a/compiler/typecheck/TcInstDcls.hs +++ b/compiler/typecheck/TcInstDcls.hs @@ -983,7 +983,7 @@ tcSuperClasses dfun_id cls tyvars dfun_evs inst_tys dfun_ev_binds _fam_envs sc_t ; sc_top_name <- newName (mkSuperDictAuxOcc n (getOccName cls)) ; sc_ev_id <- newEvVar sc_pred ; addTcEvBind ev_binds_var $ mkWantedEvBind sc_ev_id sc_ev_tm - ; let sc_top_ty = mkInvForAllTys tyvars (mkPiTypes dfun_evs sc_pred) + ; let sc_top_ty = mkInvForAllTys tyvars (mkLamTypes dfun_evs sc_pred) sc_top_id = mkLocalId sc_top_name sc_top_ty export = ABE { abe_wrap = idHsWrapper , abe_poly = sc_top_id diff --git a/compiler/typecheck/TcInteract.hs b/compiler/typecheck/TcInteract.hs index 8cd606613c..f6a59e1c9e 100644 --- a/compiler/typecheck/TcInteract.hs +++ b/compiler/typecheck/TcInteract.hs @@ -2034,8 +2034,8 @@ doTyConApp clas ty args -- polymorphism, but no more. onlyNamedBndrsApplied :: TyCon -> [KindOrType] -> Bool onlyNamedBndrsApplied tc ks - = all isNamedBinder used_bndrs && - not (any isNamedBinder leftover_bndrs) + = all isNamedTyBinder used_bndrs && + all isAnonTyBinder leftover_bndrs where bndrs = tyConBinders tc (used_bndrs, leftover_bndrs) = splitAtList ks bndrs diff --git a/compiler/typecheck/TcMType.hs b/compiler/typecheck/TcMType.hs index 5f11e10d0b..c2cf82edde 100644 --- a/compiler/typecheck/TcMType.hs +++ b/compiler/typecheck/TcMType.hs @@ -1375,8 +1375,10 @@ zonkTcTyCoVarBndr tyvar -- | Zonk a TyBinder zonkTcTyBinder :: TcTyBinder -> TcM TcTyBinder -zonkTcTyBinder (Anon ty) = Anon <$> zonkTcType ty -zonkTcTyBinder (Named tv vis) = Named <$> zonkTcTyCoVarBndr tv <*> pure vis +zonkTcTyBinder (Anon ty) = Anon <$> zonkTcType ty +zonkTcTyBinder (Named (TvBndr tv vis)) + = do { tv' <- zonkTcTyCoVarBndr tv + ; return (Named (TvBndr tv' vis)) } zonkTcTyVar :: TcTyVar -> TcM TcType -- Simply look through all Flexis diff --git a/compiler/typecheck/TcMatches.hs b/compiler/typecheck/TcMatches.hs index 8d59b8f92d..85a7e30fdf 100644 --- a/compiler/typecheck/TcMatches.hs +++ b/compiler/typecheck/TcMatches.hs @@ -501,7 +501,7 @@ tcLcStmt m_tc ctxt (TransStmt { trS_form = form, trS_stmts = stmts tup_ty = mkBigCoreVarTupTy bndr_ids poly_arg_ty = m_app alphaTy poly_res_ty = m_app (n_app alphaTy) - using_poly_ty = mkNamedForAllTy alphaTyVar Invisible $ + using_poly_ty = mkInvForAllTy alphaTyVar $ by_arrow $ poly_arg_ty `mkFunTy` poly_res_ty @@ -638,7 +638,7 @@ tcMcStmt ctxt (TransStmt { trS_stmts = stmts, trS_bndrs = bindersMap using_arg_ty = m1_ty `mkAppTy` tup_ty poly_res_ty = m2_ty `mkAppTy` n_app alphaTy using_res_ty = m2_ty `mkAppTy` n_app tup_ty - using_poly_ty = mkNamedForAllTy alphaTyVar Invisible $ + using_poly_ty = mkInvForAllTy alphaTyVar $ by_arrow $ poly_arg_ty `mkFunTy` poly_res_ty @@ -678,8 +678,8 @@ tcMcStmt ctxt (TransStmt { trS_stmts = stmts, trS_bndrs = bindersMap ; fmap_op' <- case form of ThenForm -> return noExpr _ -> fmap unLoc . tcPolyExpr (noLoc fmap_op) $ - mkNamedForAllTy alphaTyVar Invisible $ - mkNamedForAllTy betaTyVar Invisible $ + mkInvForAllTy alphaTyVar $ + mkInvForAllTy betaTyVar $ (alphaTy `mkFunTy` betaTy) `mkFunTy` (n_app alphaTy) `mkFunTy` (n_app betaTy) diff --git a/compiler/typecheck/TcPatSyn.hs b/compiler/typecheck/TcPatSyn.hs index c5a0c270b4..e2d26384e6 100644 --- a/compiler/typecheck/TcPatSyn.hs +++ b/compiler/typecheck/TcPatSyn.hs @@ -16,6 +16,7 @@ import HsSyn import TcPat import Type( binderVar, mkNamedBinders, binderVisibility, mkEmptyTCvSubst , tidyTyCoVarBndrs, tidyTypes, tidyType ) + , tcHsContext, tcHsLiftedType, tcHsOpenType, kindGeneralize ) import TcRnMonad import TcSigs( emptyPragEnv, completeSigFromId ) import TcEnv @@ -90,9 +91,9 @@ tcInferPatSynDecl PSB{ psb_id = lname@(L _ name), psb_args = details, ; traceTc "tcInferPatSynDecl }" $ ppr name ; tc_patsyn_finish lname dir is_infix lpat' - (univ_tvs, mkNamedBinders Invisible univ_tvs + (mkTyVarBinders Invisible univ_tvs , req_theta, ev_binds, req_dicts) - (ex_tvs, mkNamedBinders Invisible ex_tvs + (mkTyVarBinders Invisible ex_tvs , mkTyVarTys ex_tvs, prov_theta, map EvId prov_dicts) (map nlHsVar args, map idType args) pat_ty rec_fields } @@ -185,8 +186,8 @@ tcCheckPatSynDecl psb@PSB{ psb_id = lname@(L _ name), psb_args = details ; traceTc "tcCheckPatSynDecl }" $ ppr name ; tc_patsyn_finish lname dir is_infix lpat' - (univ_tvs, univ_bndrs, req_theta, ev_binds, req_dicts) - (ex_tvs, ex_bndrs, mkTyVarTys ex_tvs', prov_theta, prov_dicts) + (univ_bndrs, req_theta, ev_binds, req_dicts) + (ex_bndrs, mkTyVarTys ex_tvs', prov_theta, prov_dicts) (args', arg_tys) pat_ty rec_fields } where @@ -284,74 +285,54 @@ tc_patsyn_finish :: Located Name -- ^ PatSyn Name -> HsPatSynDir Name -- ^ PatSyn type (Uni/Bidir/ExplicitBidir) -> Bool -- ^ Whether infix -> LPat Id -- ^ Pattern of the PatSyn - -> ([TcTyVar], [TcTyBinder], [PredType], TcEvBinds, [EvVar]) - -> ([TcTyVar], [TcTyBinder], [TcType], [PredType], [EvTerm]) + -> ([TcTyVarBinder], [PredType], TcEvBinds, [EvVar]) + -> ([TcTyVarBinder], [TcType], [PredType], [EvTerm]) -> ([LHsExpr TcId], [TcType]) -- ^ Pattern arguments and types -> TcType -- ^ Pattern type -> [Name] -- ^ Selector names -- ^ Whether fields, empty if not record PatSyn -> TcM (LHsBinds Id, TcGblEnv) tc_patsyn_finish lname dir is_infix lpat' - (univ_tvs, univ_bndrs, req_theta, req_ev_binds, req_dicts) - (ex_tvs, ex_bndrs, ex_tys, prov_theta, prov_dicts) + (univ_bndrs, req_theta, req_ev_binds, req_dicts) + (ex_bndrs, ex_tys, prov_theta, prov_dicts) (args, arg_tys) pat_ty field_labels = do { -- Zonk everything. We are about to build a final PatSyn -- so there had better be no unification variables in there - univ_tvs' <- mapMaybeM (zonkQuantifiedTyVar False) univ_tvs - ; ex_tvs' <- mapMaybeM (zonkQuantifiedTyVar False) ex_tvs - -- ToDo: The False means that we behave here as if - -- -XPolyKinds was always on, which isn't right. + univ_tvs' <- mapMaybeM zonk_qtv univ_bndrs + ; ex_tvs' <- mapMaybeM zonk_qtv ex_bndrs ; prov_theta' <- zonkTcTypes prov_theta ; req_theta' <- zonkTcTypes req_theta ; pat_ty' <- zonkTcType pat_ty ; arg_tys' <- zonkTcTypes arg_tys - ; let (env1, univ_tvs) = tidyTyCoVarBndrs emptyTidyEnv univ_tvs' - (env2, ex_tvs) = tidyTyCoVarBndrs env1 ex_tvs' + ; let (env1, univ_tvs) = tidyTyVarBinders emptyTidyEnv univ_tvs' + (env2, ex_tvs) = tidyTyVarBinders env1 ex_tvs' req_theta = tidyTypes env2 req_theta' prov_theta = tidyTypes env2 prov_theta' arg_tys = tidyTypes env2 arg_tys' pat_ty = tidyType env2 pat_ty' - -- We need to update the univ and ex binders after zonking. - -- But zonking may have defaulted some erstwhile binders, - -- so we need to make sure the tyvars and tybinders remain - -- lined up - ; let update_binders :: [TyVar] -> [TcTyBinder] -> [TyBinder] - update_binders [] _ = [] - update_binders all_tvs@(tv:tvs) (bndr:bndrs) - | tv == bndr_var - = mkNamedBinder (binderVisibility bndr) tv : update_binders tvs bndrs - | otherwise - = update_binders all_tvs bndrs - where - bndr_var = binderVar "tc_patsyn_finish" bndr - update_binders tvs _ = pprPanic "tc_patsyn_finish" (ppr lname $$ ppr tvs) - - univ_bndrs' = update_binders univ_tvs univ_bndrs - ex_bndrs' = update_binders ex_tvs ex_bndrs - ; traceTc "tc_patsyn_finish {" $ ppr (unLoc lname) $$ ppr (unLoc lpat') $$ - ppr (univ_tvs, univ_bndrs', req_theta, req_ev_binds, req_dicts) $$ - ppr (ex_tvs, ex_bndrs', prov_theta, prov_dicts) $$ + ppr (univ_tvs, req_theta, req_ev_binds, req_dicts) $$ + ppr (ex_tvs, prov_theta, prov_dicts) $$ ppr args $$ ppr arg_tys $$ ppr pat_ty -- Make the 'matcher' ; (matcher_id, matcher_bind) <- tcPatSynMatcher lname lpat' - (univ_tvs, req_theta, req_ev_binds, req_dicts) - (ex_tvs, ex_tys, prov_theta, prov_dicts) + (map binderVar univ_tvs, req_theta, req_ev_binds, req_dicts) + (map binderVar ex_tvs, ex_tys, prov_theta, prov_dicts) (args, arg_tys) pat_ty -- Make the 'builder' ; builder_id <- mkPatSynBuilderId dir lname - univ_bndrs' req_theta - ex_bndrs' prov_theta + univ_tvs req_theta + ex_tvs prov_theta arg_tys pat_ty -- TODO: Make this have the proper information @@ -360,11 +341,10 @@ tc_patsyn_finish lname dir is_infix lpat' , flSelector = name } field_labels' = map mkFieldLabel field_labels - -- Make the PatSyn itself ; let patSyn = mkPatSyn (unLoc lname) is_infix - (univ_tvs, univ_bndrs', req_theta) - (ex_tvs, ex_bndrs', prov_theta) + (univ_tvs, req_theta) + (ex_tvs, prov_theta) arg_tys pat_ty matcher_id builder_id @@ -378,6 +358,14 @@ tc_patsyn_finish lname dir is_infix lpat' ; traceTc "tc_patsyn_finish }" empty ; return (matcher_bind, tcg_env) } + where + -- This is a bit of an odd functions; why does it not occur elsewhere + zonk_qtv :: TcTyVarBinder -> TcM (Maybe TcTyVarBinder) + zonk_qtv (TvBndr tv vis) + = do { mb_tv' <- zonkQuantifiedTyVar False tv + -- ToDo: The False means that we behave here as if + -- -XPolyKinds was always on, which isn't right. + ; return (fmap (\tv' -> TvBndr tv' vis) mb_tv') } {- ************************************************************************ @@ -496,8 +484,8 @@ isUnidirectional ExplicitBidirectional{} = False -} mkPatSynBuilderId :: HsPatSynDir a -> Located Name - -> [TyBinder] -> ThetaType - -> [TyBinder] -> ThetaType + -> [TyVarBinder] -> ThetaType + -> [TyVarBinder] -> ThetaType -> [Type] -> Type -> TcM (Maybe (Id, Bool)) mkPatSynBuilderId dir (L _ name) diff --git a/compiler/typecheck/TcRnDriver.hs b/compiler/typecheck/TcRnDriver.hs index 378f17a95c..9d3bd99ab9 100644 --- a/compiler/typecheck/TcRnDriver.hs +++ b/compiler/typecheck/TcRnDriver.hs @@ -53,6 +53,7 @@ import TcExpr import TcRnMonad import TcEvidence import PprTyThing( pprTyThing ) +import MkIface( tyThingToIfaceDecl ) import Coercion( pprCoAxiom ) import CoreFVs( orphNamesOfFamInst ) import FamInst @@ -69,7 +70,6 @@ import TcInstDcls import TcIface import TcMType import TcType -import MkIface import TcSimplify import TcTyClsDecls import TcTypeable ( mkTypeableBinds ) @@ -2011,7 +2011,7 @@ tcRnExpr hsc_env rdr_expr -- Ignore the dictionary bindings _ <- simplifyInteractive (andWC stWC lie_top) ; - let { all_expr_ty = mkInvForAllTys qtvs (mkPiTypes dicts res_ty) } ; + let { all_expr_ty = mkInvForAllTys qtvs (mkLamTypes dicts res_ty) } ; ty <- zonkTcType all_expr_ty ; -- We normalise type families, so that the type of an expression is the @@ -2484,10 +2484,13 @@ ppr_sigs ids ppr_tydecls :: [TyCon] -> SDoc ppr_tydecls tycons - -- Print type constructor info; sort by OccName - = vcat (map ppr_tycon (sortBy (comparing getOccName) tycons)) - where - ppr_tycon tycon = vcat [ ppr (tyThingToIfaceDecl (ATyCon tycon)) ] + -- Print type constructor info for debug purposes + -- Sort by OccName to reduce unnecessary changes + = vcat [ ppr (tyThingToIfaceDecl (ATyCon tc)) + | tc <- sortBy (comparing getOccName) tycons ] + -- The Outputable instance for IfaceDecl uses + -- showAll, which is what we want here, whereas + -- pprTyThing uses ShowSome. {- ******************************************************************************** diff --git a/compiler/typecheck/TcRnTypes.hs b/compiler/typecheck/TcRnTypes.hs index a737067678..9ebb1d52ed 100644 --- a/compiler/typecheck/TcRnTypes.hs +++ b/compiler/typecheck/TcRnTypes.hs @@ -918,7 +918,7 @@ data PromotionErr | NoTypeInTypeDC -- -XTypeInType not enabled (for a datacon) instance Outputable TcTyThing where -- Debugging only - ppr (AGlobal g) = pprTyThing g + ppr (AGlobal g) = ppr g ppr elt@(ATcId {}) = text "Identifier" <> brackets (ppr (tct_id elt) <> dcolon <> ppr (varType (tct_id elt)) <> comma diff --git a/compiler/typecheck/TcSMonad.hs b/compiler/typecheck/TcSMonad.hs index 73541399f8..75506b99c3 100644 --- a/compiler/typecheck/TcSMonad.hs +++ b/compiler/typecheck/TcSMonad.hs @@ -3101,8 +3101,8 @@ See TcSMonad.deferTcSForAllEq deferTcSForAllEq :: Role -- Nominal or Representational -> CtLoc -- Original wanted equality flavor -> [Coercion] -- among the kinds of the binders - -> ([TyBinder],TcType) -- ForAll tvs1 body1 - -> ([TyBinder],TcType) -- ForAll tvs2 body2 + -> ([TyVarBinder],TcType) -- ForAll tvs1 body1 + -> ([TyVarBinder],TcType) -- ForAll tvs2 body2 -> TcS Coercion deferTcSForAllEq role loc kind_cos (bndrs1,body1) (bndrs2,body2) = do { let tvs1' = zipWithEqual "deferTcSForAllEq" @@ -3132,5 +3132,5 @@ deferTcSForAllEq role loc kind_cos (bndrs1,body1) (bndrs2,body2) ; let cobndrs = zip skol_tvs kind_cos ; return $ mkForAllCos cobndrs hole_co } where - tvs1 = map (binderVar "deferTcSForAllEq") bndrs1 - tvs2 = map (binderVar "deferTcSForAllEq") bndrs2 + tvs1 = map binderVar bndrs1 + tvs2 = map binderVar bndrs2 diff --git a/compiler/typecheck/TcSigs.hs b/compiler/typecheck/TcSigs.hs index 8bccc35577..62f4db8d62 100644 --- a/compiler/typecheck/TcSigs.hs +++ b/compiler/typecheck/TcSigs.hs @@ -393,8 +393,8 @@ tcPatSynSig name sig_ty , text "prov" <+> ppr prov , text "body_ty" <+> ppr body_ty ] ; return (TPSI { patsig_name = name - , patsig_implicit_bndrs = mkNamedBinders Invisible kvs ++ - mkNamedBinders Specified implicit_tvs + , patsig_implicit_bndrs = mkTyVarBinders Invisible kvs ++ + mkTyVarBinders Specified implicit_tvs , patsig_univ_bndrs = univ_tvs , patsig_req = req , patsig_ex_bndrs = ex_tvs diff --git a/compiler/typecheck/TcSplice.hs b/compiler/typecheck/TcSplice.hs index 828cb95ad7..4614b7034e 100644 --- a/compiler/typecheck/TcSplice.hs +++ b/compiler/typecheck/TcSplice.hs @@ -1612,12 +1612,12 @@ reifyFamilyInstance is_poly_tvs inst@(FamInst { fi_flavor = flavor ------------------------------ reifyType :: TyCoRep.Type -> TcM TH.Type -- Monadic only because of failure -reifyType ty@(ForAllTy (Named _ _) _) = reify_for_all ty +reifyType ty@(ForAllTy {}) = reify_for_all ty reifyType (LitTy t) = do { r <- reifyTyLit t; return (TH.LitT r) } reifyType (TyVarTy tv) = return (TH.VarT (reifyName tv)) reifyType (TyConApp tc tys) = reify_tc_app tc tys -- Do not expand type synonyms here reifyType (AppTy t1 t2) = do { [r1,r2] <- reifyTypes [t1,t2] ; return (r1 `TH.AppT` r2) } -reifyType ty@(ForAllTy (Anon t1) t2) +reifyType ty@(FunTy t1 t2) | isPredTy t1 = reify_for_all ty -- Types like ((?x::Int) => Char -> Char) | otherwise = do { [r1,r2] <- reifyTypes [t1,t2] ; return (TH.ArrowT `TH.AppT` r1 `TH.AppT` r2) } reifyType ty@(CastTy {}) = noTH (sLit "kind casts") (ppr ty) @@ -1663,6 +1663,7 @@ reifyKind ki reifyNonArrowKind k | isLiftedTypeKind k = return TH.StarT | isConstraintKind k = return TH.ConstraintT reifyNonArrowKind (TyVarTy v) = return (TH.VarT (reifyName v)) + reifyNonArrowKind (FunTy _ k) = reifyKind k reifyNonArrowKind (ForAllTy _ k) = reifyKind k reifyNonArrowKind (TyConApp kc kis) = reify_kc_app kc kis reifyNonArrowKind (AppTy k1 k2) = do { k1' <- reifyKind k1 @@ -1780,7 +1781,7 @@ reify_tc_app tc tys isEmptyVarSet $ filterVarSet isTyVar $ tyCoVarsOfType $ - mkForAllTys (dropList tys tc_binders) tc_res_kind + mkPiTys (dropList tys tc_binders) tc_res_kind reifyPred :: TyCoRep.PredType -> TcM TH.Pred reifyPred ty diff --git a/compiler/typecheck/TcTyClsDecls.hs b/compiler/typecheck/TcTyClsDecls.hs index 7f0023e0f0..f8308e80d9 100644 --- a/compiler/typecheck/TcTyClsDecls.hs +++ b/compiler/typecheck/TcTyClsDecls.hs @@ -351,7 +351,7 @@ kcTyClGroup decls kc_binders = tyConBinders tc kc_res_kind = tyConResKind tc kc_tyvars = tyConTyVars tc - ; kvs <- kindGeneralize (mkForAllTys kc_binders kc_res_kind) + ; kvs <- kindGeneralize (mkPiTys kc_binders kc_res_kind) ; (kc_binders', kc_res_kind') <- zonkTcKindToKind kc_binders kc_res_kind ; kc_tyvars <- mapM zonkTcTyVarToTyVar kc_tyvars @@ -362,7 +362,7 @@ kcTyClGroup decls , ppr kc_tyvars, ppr (tcTyConScopedTyVars tc)] ; return (mkTcTyCon name (kvs ++ kc_tyvars) - (mkNamedBinders Invisible kvs ++ kc_binders') + (mkNamedTyBinders Invisible kvs ++ kc_binders') kc_res_kind' (mightBeUnsaturatedTyCon tc) (tcTyConScopedTyVars tc)) } @@ -1491,9 +1491,8 @@ tcConDecl new_or_data rep_tycon tmpl_tvs tmpl_bndrs res_tmpl -- Can't print univ_tvs, arg_tys etc, because we are inside the knot here ; traceTc "tcConDecl 2" (ppr name $$ ppr field_lbls) ; let - ex_tvs = qkvs ++ user_qtvs - ex_binders = mkNamedBinders Invisible qkvs ++ - mkNamedBinders Specified user_qtvs + ex_tvs = mkTyVarBinders Invisible qkvs ++ + mkTyVarBinders Specified user_qtvs buildOneDataCon (L _ name) = do { is_infix <- tcConIsInfixH98 name hs_details ; rep_nm <- newTyConRepName name @@ -1501,7 +1500,7 @@ tcConDecl new_or_data rep_tycon tmpl_tvs tmpl_bndrs res_tmpl ; buildDataCon fam_envs name is_infix rep_nm stricts Nothing field_lbls tmpl_tvs tmpl_bndrs - ex_tvs ex_binders + ex_tvs [{- no eq_preds -}] ctxt arg_tys res_tmpl rep_tycon -- NB: we put data_tc, the type constructor gotten from the @@ -1538,8 +1537,8 @@ tcConDecl _new_or_data rep_tycon tmpl_tvs _tmpl_bndrs res_tmpl -- See Note [Checking GADT return types] -- See Note [Wrong visibility for GADTs] - univ_bndrs = mkNamedBinders Specified univ_tvs - ex_bndrs = mkNamedBinders Specified ex_tvs + univ_bndrs = mkNamedTyBinders Specified univ_tvs + ex_bndrs = mkTyVarBinders Specified ex_tvs ; fam_envs <- tcGetFamInstEnvs @@ -1553,7 +1552,7 @@ tcConDecl _new_or_data rep_tycon tmpl_tvs _tmpl_bndrs res_tmpl ; buildDataCon fam_envs name is_infix rep_nm stricts Nothing field_lbls - univ_tvs univ_bndrs ex_tvs ex_bndrs eq_preds + univ_tvs univ_bndrs ex_bndrs eq_preds (substTys arg_subst ctxt) (substTys arg_subst arg_tys) (substTy arg_subst res_ty') @@ -2608,11 +2607,11 @@ checkValidRoles tc = check_ty_roles env role ty1 >> check_ty_roles env Nominal ty2 - check_ty_roles env role (ForAllTy (Anon ty1) ty2) + check_ty_roles env role (FunTy ty1 ty2) = check_ty_roles env role ty1 >> check_ty_roles env role ty2 - check_ty_roles env role (ForAllTy (Named tv _) ty) + check_ty_roles env role (ForAllTy (TvBndr tv _) ty) = check_ty_roles env Nominal (tyVarKind tv) >> check_ty_roles (extendVarEnv env tv Nominal) role ty diff --git a/compiler/typecheck/TcTyDecls.hs b/compiler/typecheck/TcTyDecls.hs index 7529f15001..025afc967f 100644 --- a/compiler/typecheck/TcTyDecls.hs +++ b/compiler/typecheck/TcTyDecls.hs @@ -29,7 +29,7 @@ import TcRnMonad import TcEnv import TcBinds( tcRecSelBinds ) import RnEnv( RoleAnnotEnv, lookupRoleAnnot ) -import TyCoRep( Type(..), TyBinder(..), delBinderVarFV ) +import TyCoRep( Type(..) ) import TcType import TysWiredIn( unitTy ) import MkCore( rEC_SEL_ERROR_ID ) @@ -47,7 +47,8 @@ import Id import IdInfo import VarEnv import VarSet -import NameSet +import NameSet ( NameSet, unitNameSet, emptyNameSet, unionNameSet + , extendNameSet, mkNameSet, nameSetElems, elemNameSet ) import Coercion ( ltRole ) import Digraph import BasicTypes @@ -608,7 +609,7 @@ initialRoleEnv1 is_boot annots_env tc | otherwise = pprPanic "initialRoleEnv1" (ppr tc) where name = tyConName tc bndrs = tyConBinders tc - visflags = map binderVisibility $ take (tyConArity tc) bndrs + visflags = map tyBinderVisibility $ take (tyConArity tc) bndrs num_exps = count (== Visible) visflags -- if the number of annotations in the role annotation decl @@ -690,11 +691,11 @@ irType = go go lcls (AppTy t1 t2) = go lcls t1 >> markNominal lcls t2 go lcls (TyConApp tc tys) = do { roles <- lookupRolesX tc ; zipWithM_ (go_app lcls) roles tys } - go lcls (ForAllTy (Named tv _) ty) - = let lcls' = extendVarSet lcls tv in - markNominal lcls (tyVarKind tv) >> go lcls' ty - go lcls (ForAllTy (Anon arg) res) - = go lcls arg >> go lcls res + go lcls (ForAllTy tvb ty) = do { let tv = binderVar tvb + lcls' = extendVarSet lcls tv + ; markNominal lcls (tyVarKind tv) + ; go lcls' ty } + go lcls (FunTy arg res) = go lcls arg >> go lcls res go _ (LitTy {}) = return () -- See Note [Coercions in role inference] go lcls (CastTy ty _) = go lcls ty @@ -727,15 +728,15 @@ markNominal lcls ty = let nvars = fvVarList (FV.delFVs lcls $ get_ty_vars ty) in -- get_ty_vars gets all the tyvars (no covars!) from a type *without* -- recurring into coercions. Recall: coercions are totally ignored during -- role inference. See [Coercions in role inference] - get_ty_vars (TyVarTy tv) = FV.unitFV tv - get_ty_vars (AppTy t1 t2) = get_ty_vars t1 `unionFV` get_ty_vars t2 - get_ty_vars (TyConApp _ tys) = mapUnionFV get_ty_vars tys - get_ty_vars (ForAllTy bndr ty) - = delBinderVarFV bndr (get_ty_vars ty) - `unionFV` (tyCoFVsOfType $ binderType bndr) - get_ty_vars (LitTy {}) = emptyFV - get_ty_vars (CastTy ty _) = get_ty_vars ty - get_ty_vars (CoercionTy _) = emptyFV + get_ty_vars :: Type -> FV + get_ty_vars (TyVarTy tv) = unitFV tv + get_ty_vars (AppTy t1 t2) = get_ty_vars t1 `unionFV` get_ty_vars t2 + get_ty_vars (FunTy t1 t2) = get_ty_vars t1 `unionFV` get_ty_vars t2 + get_ty_vars (TyConApp _ tys) = mapUnionFV get_ty_vars tys + get_ty_vars (ForAllTy tvb ty) = tyCoFVsBndr tvb (get_ty_vars ty) + get_ty_vars (LitTy {}) = emptyFV + get_ty_vars (CastTy ty _) = get_ty_vars ty + get_ty_vars (CoercionTy _) = emptyFV -- like lookupRoles, but with Nominal tags at the end for oversaturated TyConApps lookupRolesX :: TyCon -> RoleM [Role] diff --git a/compiler/typecheck/TcType.hs b/compiler/typecheck/TcType.hs index 286ad6398e..a307851f6f 100644 --- a/compiler/typecheck/TcType.hs +++ b/compiler/typecheck/TcType.hs @@ -22,7 +22,7 @@ module TcType ( -- Types TcType, TcSigmaType, TcRhoType, TcTauType, TcPredType, TcThetaType, TcTyVar, TcTyVarSet, TcDTyVarSet, TcTyCoVarSet, TcDTyCoVarSet, - TcKind, TcCoVar, TcTyCoVar, TcTyBinder, TcTyCon, + TcKind, TcCoVar, TcTyCoVar, TcTyBinder, TcTyVarBinder, TcTyCon, ExpType(..), ExpSigmaType, ExpRhoType, mkCheckExpType, @@ -58,7 +58,7 @@ module TcType ( -- These are important because they do not look through newtypes getTyVar, tcSplitForAllTy_maybe, - tcSplitForAllTys, tcSplitPiTys, tcSplitNamedPiTys, + tcSplitForAllTys, tcSplitPiTys, tcSplitForAllTyVarBndrs, tcSplitPhiTy, tcSplitPredFunTy_maybe, tcSplitFunTy_maybe, tcSplitFunTys, tcFunArgTy, tcFunResultTy, tcSplitFunTysN, tcSplitTyConApp, tcSplitTyConApp_maybe, tcRepSplitTyConApp_maybe, @@ -130,7 +130,7 @@ module TcType ( -- Rexported from Type Type, PredType, ThetaType, TyBinder, VisibilityFlag(..), - mkForAllTy, mkForAllTys, mkInvForAllTys, mkSpecForAllTys, mkNamedForAllTy, + mkForAllTy, mkForAllTys, mkInvForAllTys, mkSpecForAllTys, mkInvForAllTy, mkFunTy, mkFunTys, mkTyConApp, mkAppTy, mkAppTys, mkTyConTy, mkTyVarTy, @@ -270,8 +270,10 @@ type TcTyCoVar = Var -- Either a TcTyVar or a CoVar -- forall a. T -- a cannot occur inside a MutTyVar in T; that is, -- T is "flattened" before quantifying over a -type TcTyBinder = TyBinder -type TcTyCon = TyCon -- these can be the TcTyCon constructor + +type TcTyVarBinder = TyVarBinder +type TcTyBinder = TyBinder +type TcTyCon = TyCon -- these can be the TcTyCon constructor -- These types do not have boxy type variables in them type TcPredType = PredType @@ -719,6 +721,7 @@ tcTyFamInsts (TyConApp tc tys) tcTyFamInsts (LitTy {}) = [] tcTyFamInsts (ForAllTy bndr ty) = tcTyFamInsts (binderType bndr) ++ tcTyFamInsts ty +tcTyFamInsts (FunTy ty1 ty2) = tcTyFamInsts ty1 ++ tcTyFamInsts ty2 tcTyFamInsts (AppTy ty1 ty2) = tcTyFamInsts ty1 ++ tcTyFamInsts ty2 tcTyFamInsts (CastTy ty _) = tcTyFamInsts ty tcTyFamInsts (CoercionTy _) = [] -- don't count tyfams in coercions, @@ -771,6 +774,7 @@ exactTyCoVarsOfType ty go (TyConApp _ tys) = exactTyCoVarsOfTypes tys go (LitTy {}) = emptyVarSet go (AppTy fun arg) = go fun `unionVarSet` go arg + go (FunTy arg res) = go arg `unionVarSet` go res go (ForAllTy bndr ty) = delBinderVar (go ty) bndr `unionVarSet` go (binderType bndr) go (CastTy ty co) = go ty `unionVarSet` goCo co go (CoercionTy co) = goCo co @@ -819,8 +823,8 @@ allBoundVariables ty = fvVarSet $ go ty go (TyVarTy tv) = go (tyVarKind tv) go (TyConApp _ tys) = mapUnionFV go tys go (AppTy t1 t2) = go t1 `unionFV` go t2 - go (ForAllTy (Anon t1) t2) = go t1 `unionFV` go t2 - go (ForAllTy (Named tv _) t2) = FV.unitFV tv `unionFV` + go (FunTy t1 t2) = go t1 `unionFV` go t2 + go (ForAllTy (TvBndr tv _) t2) = FV.unitFV tv `unionFV` go (tyVarKind tv) `unionFV` go t2 go (LitTy {}) = emptyFV go (CastTy ty _) = go ty @@ -932,15 +936,15 @@ splitDepVarsOfTypes = foldMap splitDepVarsOfType splitDepVarsOfType :: Type -> TcDepVars splitDepVarsOfType = go where - go (TyVarTy tv) = DV { dv_kvs =tyCoVarsOfTypeDSet $ tyVarKind tv - , dv_tvs = unitDVarSet tv } - go (AppTy t1 t2) = go t1 `mappend` go t2 - go (TyConApp _ tys) = foldMap go tys - go (ForAllTy (Anon arg) res) = go arg `mappend` go res - go (LitTy {}) = mempty - go (CastTy ty co) = go ty `mappend` go_co co - go (CoercionTy co) = go_co co - go (ForAllTy (Named tv _) ty) + go (TyVarTy tv) = DV { dv_kvs =tyCoVarsOfTypeDSet $ tyVarKind tv + , dv_tvs = unitDVarSet tv } + go (AppTy t1 t2) = go t1 `mappend` go t2 + go (TyConApp _ tys) = foldMap go tys + go (FunTy arg res) = go arg `mappend` go res + go (LitTy {}) = mempty + go (CastTy ty co) = go ty `mappend` go_co co + go (CoercionTy co) = go_co co + go (ForAllTy (TvBndr tv _) ty) = let DV { dv_kvs = kvs, dv_tvs = tvs } = go ty in DV { dv_kvs = (kvs `delDVarSet` tv) `extendDVarSetList` tyCoVarsOfTypeList (tyVarKind tv) @@ -1115,18 +1119,16 @@ isRuntimeUnkSkol x ************************************************************************ -} -mkSigmaTy :: [TyBinder] -> [PredType] -> Type -> Type +mkSigmaTy :: [TyVarBinder] -> [PredType] -> Type -> Type mkSigmaTy bndrs theta tau = mkForAllTys bndrs (mkPhiTy theta tau) mkInvSigmaTy :: [TyVar] -> [PredType] -> Type -> Type -mkInvSigmaTy tyvars - = mkSigmaTy (mkNamedBinders Invisible tyvars) +mkInvSigmaTy tyvars ty = mkSigmaTy (mkTyVarBinders Invisible tyvars) ty -- | Make a sigma ty where all type variables are "specified". That is, -- they can be used with visible type application mkSpecSigmaTy :: [TyVar] -> [PredType] -> Type -> Type -mkSpecSigmaTy tyvars - = mkSigmaTy (mkNamedBinders Specified tyvars) +mkSpecSigmaTy tyvars ty = mkSigmaTy (mkTyVarBinders Specified tyvars) ty mkPhiTy :: [PredType] -> Type -> Type mkPhiTy = mkFunTys @@ -1138,7 +1140,7 @@ isTauTy (TyVarTy _) = True isTauTy (LitTy {}) = True isTauTy (TyConApp tc tys) = all isTauTy tys && isTauTyCon tc isTauTy (AppTy a b) = isTauTy a && isTauTy b -isTauTy (ForAllTy (Anon a) b) = isTauTy a && isTauTy b +isTauTy (FunTy a b) = isTauTy a && isTauTy b isTauTy (ForAllTy {}) = False isTauTy (CastTy _ _) = False isTauTy (CoercionTy _) = False @@ -1157,8 +1159,8 @@ getDFunTyKey (TyVarTy tv) = getOccName tv getDFunTyKey (TyConApp tc _) = getOccName tc getDFunTyKey (LitTy x) = getDFunTyLitKey x getDFunTyKey (AppTy fun _) = getDFunTyKey fun -getDFunTyKey (ForAllTy (Anon _) _) = getOccName funTyCon -getDFunTyKey (ForAllTy (Named {}) t) = getDFunTyKey t +getDFunTyKey (FunTy _ _) = getOccName funTyCon +getDFunTyKey (ForAllTy _ t) = getDFunTyKey t getDFunTyKey (CastTy ty _) = getDFunTyKey ty getDFunTyKey t@(CoercionTy _) = pprPanic "getDFunTyKey" (ppr t) @@ -1216,7 +1218,7 @@ variables. It's up to you to make sure this doesn't matter. tcSplitPiTys :: Type -> ([TyBinder], Type) tcSplitPiTys = splitPiTys -tcSplitForAllTy_maybe :: Type -> Maybe (TyBinder, Type) +tcSplitForAllTy_maybe :: Type -> Maybe (TyVarBinder, Type) tcSplitForAllTy_maybe ty | Just ty' <- coreView ty = tcSplitForAllTy_maybe ty' tcSplitForAllTy_maybe (ForAllTy tv ty) = Just (tv, ty) tcSplitForAllTy_maybe _ = Nothing @@ -1227,20 +1229,20 @@ tcSplitForAllTys :: Type -> ([TyVar], Type) tcSplitForAllTys = splitForAllTys -- | Like 'tcSplitForAllTys', but splits off only named binders. -tcSplitNamedPiTys :: Type -> ([TyBinder], Type) -tcSplitNamedPiTys = splitNamedPiTys +tcSplitForAllTyVarBndrs :: Type -> ([TyVarBinder], Type) +tcSplitForAllTyVarBndrs = splitForAllTyVarBndrs -- | Is this a ForAllTy with a named binder? tcIsForAllTy :: Type -> Bool tcIsForAllTy ty | Just ty' <- coreView ty = tcIsForAllTy ty' -tcIsForAllTy (ForAllTy (Named {}) _) = True -tcIsForAllTy _ = False +tcIsForAllTy (ForAllTy {}) = True +tcIsForAllTy _ = False tcSplitPredFunTy_maybe :: Type -> Maybe (PredType, Type) -- Split off the first predicate argument from a type tcSplitPredFunTy_maybe ty | Just ty' <- coreView ty = tcSplitPredFunTy_maybe ty' -tcSplitPredFunTy_maybe (ForAllTy (Anon arg) res) +tcSplitPredFunTy_maybe (FunTy arg res) | isPredTy arg = Just (arg, res) tcSplitPredFunTy_maybe _ = Nothing @@ -1298,9 +1300,9 @@ tcSplitTyConApp_maybe ty | Just ty' <- coreView ty = tcSplitTyConApp_maybe ty' tcSplitTyConApp_maybe ty = tcRepSplitTyConApp_maybe ty tcRepSplitTyConApp_maybe :: Type -> Maybe (TyCon, [Type]) -tcRepSplitTyConApp_maybe (TyConApp tc tys) = Just (tc, tys) -tcRepSplitTyConApp_maybe (ForAllTy (Anon arg) res) = Just (funTyCon, [arg,res]) -tcRepSplitTyConApp_maybe _ = Nothing +tcRepSplitTyConApp_maybe (TyConApp tc tys) = Just (tc, tys) +tcRepSplitTyConApp_maybe (FunTy arg res) = Just (funTyCon, [arg,res]) +tcRepSplitTyConApp_maybe _ = Nothing ----------------------- @@ -1313,8 +1315,7 @@ tcSplitFunTys ty = case tcSplitFunTy_maybe ty of tcSplitFunTy_maybe :: Type -> Maybe (Type, Type) tcSplitFunTy_maybe ty | Just ty' <- coreView ty = tcSplitFunTy_maybe ty' -tcSplitFunTy_maybe (ForAllTy (Anon arg) res) - | not (isPredTy arg) = Just (arg, res) +tcSplitFunTy_maybe (FunTy arg res) | not (isPredTy arg) = Just (arg, res) tcSplitFunTy_maybe _ = Nothing -- Note the typeKind guard -- Consider (?x::Int) => Bool @@ -1480,12 +1481,12 @@ tc_eq_type view_fun orig_ty1 orig_ty2 = go Visible orig_env orig_ty1 orig_ty2 go vis _ (LitTy lit1) (LitTy lit2) = check vis $ lit1 == lit2 - go vis env (ForAllTy (Named tv1 vis1) ty1) - (ForAllTy (Named tv2 vis2) ty2) + go vis env (ForAllTy (TvBndr tv1 vis1) ty1) + (ForAllTy (TvBndr tv2 vis2) ty2) = go vis1 env (tyVarKind tv1) (tyVarKind tv2) <!> go vis (rnBndr2 env tv1 tv2) ty1 ty2 <!> check vis (vis1 == vis2) - go vis env (ForAllTy (Anon arg1) res1) (ForAllTy (Anon arg2) res2) + go vis env (FunTy arg1 res1) (FunTy arg2 res2) = go vis env arg1 arg2 <!> go vis env res1 res2 -- See Note [Equality on AppTys] in Type @@ -1513,7 +1514,7 @@ tc_eq_type view_fun orig_ty1 orig_ty2 = go Visible orig_env orig_ty1 orig_ty2 -- be oversaturated where bndrs = tyConBinders tc - viss = map binderVisibility bndrs + viss = map tyBinderVisibility bndrs tc_vis vis _ = repeat vis -- if we're not in a visible context, our args -- aren't either @@ -1609,9 +1610,9 @@ occurCheckExpand dflags tv ty fast_check (TyVarTy tv') = tv /= tv' && fast_check (tyVarKind tv') fast_check (TyConApp tc tys) = all fast_check tys && (isTauTyCon tc || impredicative) - fast_check (ForAllTy (Anon a) r) = fast_check a && fast_check r + fast_check (FunTy a r) = fast_check a && fast_check r fast_check (AppTy fun arg) = fast_check fun && fast_check arg - fast_check (ForAllTy (Named tv' _) ty) + fast_check (ForAllTy (TvBndr tv' _) ty) = impredicative && fast_check (tyVarKind tv') && (tv == tv' || fast_check ty) @@ -1634,18 +1635,17 @@ occurCheckExpand dflags tv ty go env (AppTy ty1 ty2) = do { ty1' <- go env ty1 ; ty2' <- go env ty2 ; return (mkAppTy ty1' ty2') } - go env (ForAllTy (Anon ty1) ty2) - = do { ty1' <- go env ty1 + go env (FunTy ty1 ty2) = do { ty1' <- go env ty1 ; ty2' <- go env ty2 ; return (mkFunTy ty1' ty2') } - go env ty@(ForAllTy (Named tv' vis) body_ty) + go env ty@(ForAllTy (TvBndr tv' vis) body_ty) | not impredicative = OC_Forall | tv == tv' = return ty | otherwise = do { ki' <- go env ki ; let tv'' = setTyVarKind tv' ki' env' = extendVarEnv env tv' tv'' ; body' <- go env' body_ty - ; return (ForAllTy (Named tv'' vis) body') } + ; return (ForAllTy (TvBndr tv'' vis) body') } where ki = tyVarKind tv' -- For a type constructor application, first try expanding away the @@ -1998,15 +1998,15 @@ isSigmaTy :: TcType -> Bool -- *necessarily* have any foralls. E.g -- f :: (?x::Int) => Int -> Int isSigmaTy ty | Just ty' <- coreView ty = isSigmaTy ty' -isSigmaTy (ForAllTy (Named {}) _) = True -isSigmaTy (ForAllTy (Anon a) _) = isPredTy a -isSigmaTy _ = False +isSigmaTy (ForAllTy {}) = True +isSigmaTy (FunTy a _) = isPredTy a +isSigmaTy _ = False isRhoTy :: TcType -> Bool -- True of TcRhoTypes; see Note [TcRhoType] isRhoTy ty | Just ty' <- coreView ty = isRhoTy ty' -isRhoTy (ForAllTy (Named {}) _) = False -isRhoTy (ForAllTy (Anon a) r) = not (isPredTy a) && isRhoTy r -isRhoTy _ = True +isRhoTy (ForAllTy {}) = False +isRhoTy (FunTy a r) = not (isPredTy a) && isRhoTy r +isRhoTy _ = True -- | Like 'isRhoTy', but also says 'True' for 'Infer' types isRhoExpTy :: ExpType -> Bool @@ -2017,9 +2017,9 @@ isOverloadedTy :: Type -> Bool -- Yes for a type of a function that might require evidence-passing -- Used only by bindLocalMethods isOverloadedTy ty | Just ty' <- coreView ty = isOverloadedTy ty' -isOverloadedTy (ForAllTy (Named {}) ty) = isOverloadedTy ty -isOverloadedTy (ForAllTy (Anon a) _) = isPredTy a -isOverloadedTy _ = False +isOverloadedTy (ForAllTy _ ty) = isOverloadedTy ty +isOverloadedTy (FunTy a _) = isPredTy a +isOverloadedTy _ = False isFloatTy, isDoubleTy, isIntegerTy, isIntTy, isWordTy, isBoolTy, isUnitTy, isCharTy, isAnyTy :: Type -> Bool @@ -2082,6 +2082,7 @@ isTyVarExposed _ (LitTy {}) = False isTyVarExposed tv (AppTy fun arg) = isTyVarExposed tv fun || isTyVarExposed tv arg isTyVarExposed _ (ForAllTy {}) = False +isTyVarExposed _ (FunTy {}) = False isTyVarExposed tv (CastTy ty _) = isTyVarExposed tv ty isTyVarExposed _ (CoercionTy {}) = False @@ -2098,9 +2099,9 @@ isTyVarUnderDatatype tv = go False Representational in any (go under_dt') tys go _ (LitTy {}) = False - go _ (ForAllTy (Anon arg) res) = go True arg || go True res + go _ (FunTy arg res) = go True arg || go True res go under_dt (AppTy fun arg) = go under_dt fun || go under_dt arg - go under_dt (ForAllTy (Named tv' _) inner_ty) + go under_dt (ForAllTy (TvBndr tv' _) inner_ty) | tv' == tv = False | otherwise = go under_dt inner_ty go under_dt (CastTy ty _) = go under_dt ty @@ -2518,9 +2519,9 @@ sizeType = go -- expand to any arbitrary size | otherwise = sizeTypes (filterOutInvisibleTypes tc tys) + 1 go (LitTy {}) = 1 - go (ForAllTy (Anon arg) res) = go arg + go res + 1 + go (FunTy arg res) = go arg + go res + 1 go (AppTy fun arg) = go fun + go arg - go (ForAllTy (Named tv vis) ty) + go (ForAllTy (TvBndr tv vis) ty) | Visible <- vis = go (tyVarKind tv) + go ty + 1 | otherwise = go ty + 1 go (CastTy ty _) = go ty diff --git a/compiler/typecheck/TcUnify.hs b/compiler/typecheck/TcUnify.hs index 5d84a46748..3ca6aa3bfa 100644 --- a/compiler/typecheck/TcUnify.hs +++ b/compiler/typecheck/TcUnify.hs @@ -132,7 +132,7 @@ matchExpectedFunTys herald arity orig_ty thing_inside go acc_arg_tys n ty | Just ty' <- coreView ty = go acc_arg_tys n ty' - go acc_arg_tys n (ForAllTy (Anon arg_ty) res_ty) + go acc_arg_tys n (FunTy arg_ty res_ty) = ASSERT( not (isPredTy arg_ty) ) do { (result, wrap_res) <- go (mkCheckExpType arg_ty : acc_arg_tys) (n-1) res_ty @@ -258,7 +258,7 @@ matchActualFunTysPart herald ct_orig mb_thing arity orig_ty go n acc_args ty | Just ty' <- coreView ty = go n acc_args ty' - go n acc_args (ForAllTy (Anon arg_ty) res_ty) + go n acc_args (FunTy arg_ty res_ty) = ASSERT( not (isPredTy arg_ty) ) do { (wrap_res, tys, ty_r) <- go (n-1) (arg_ty : acc_args) res_ty ; return ( mkWpFun idHsWrapper wrap_res arg_ty ty_r @@ -739,7 +739,7 @@ tc_sub_type_ds eq_orig inst_orig ctxt ty_actual ty_expected | otherwise -> inst_and_unify } - go (ForAllTy (Anon act_arg) act_res) (ForAllTy (Anon exp_arg) exp_res) + go (FunTy act_arg act_res) (FunTy exp_arg exp_res) | not (isPredTy act_arg) , not (isPredTy exp_arg) = -- See Note [Co/contra-variance of subsumption checking] @@ -1147,7 +1147,7 @@ uType origin t_or_k orig_ty1 orig_ty2 ; return (mkCoherenceRightCo co_tys co2) } -- Functions (or predicate functions) just check the two parts - go (ForAllTy (Anon fun1) arg1) (ForAllTy (Anon fun2) arg2) + go (FunTy fun1 arg1) (FunTy fun2 arg2) = do { co_l <- uType origin t_or_k fun1 fun2 ; co_r <- uType origin t_or_k arg1 arg2 ; return $ mkFunCo Nominal co_l co_r } @@ -1459,7 +1459,8 @@ checkTauTvUpdate dflags origin t_or_k tv ty defer_me (TyConApp tc tys) = isTypeFamilyTyCon tc || any defer_me tys || not (impredicative || isTauTyCon tc) defer_me (ForAllTy bndr t) = defer_me (binderType bndr) || defer_me t - || (isNamedBinder bndr && not impredicative) + || not impredicative + defer_me (FunTy fun arg) = defer_me fun || defer_me arg defer_me (AppTy fun arg) = defer_me fun || defer_me arg defer_me (CastTy ty co) = defer_me ty || defer_me_co co defer_me (CoercionTy co) = defer_me_co co @@ -1630,10 +1631,8 @@ matchExpectedFunKind num_args_remaining ty = go Indirect fun_kind -> go fun_kind Flexi -> defer k } - go k@(ForAllTy (Anon arg) res) - = return (mkNomReflCo k, arg, res) - - go other = defer other + go k@(FunTy arg res) = return (mkNomReflCo k, arg, res) + go other = defer other defer k = do { arg_kind <- newMetaKindVar diff --git a/compiler/typecheck/TcValidity.hs b/compiler/typecheck/TcValidity.hs index 679bf04314..2c66f357a4 100644 --- a/compiler/typecheck/TcValidity.hs +++ b/compiler/typecheck/TcValidity.hs @@ -503,7 +503,7 @@ check_type env ctxt rank ty check_type _ _ _ (TyVarTy _) = return () -check_type env ctxt rank (ForAllTy (Anon arg_ty) res_ty) +check_type env ctxt rank (FunTy arg_ty res_ty) = do { check_type env ctxt arg_rank arg_ty ; when (representationPolymorphismForbidden ctxt) $ checkForRepresentationPolymorphism empty arg_ty @@ -1117,13 +1117,13 @@ dropCasts :: Type -> Type -- To consider: drop only UnivCo(HoleProv) casts dropCasts (CastTy ty _) = dropCasts ty dropCasts (AppTy t1 t2) = mkAppTy (dropCasts t1) (dropCasts t2) +dropCasts (FunTy t1 t2) = mkFunTy (dropCasts t1) (dropCasts t2) dropCasts (TyConApp tc tys) = mkTyConApp tc (map dropCasts tys) dropCasts (ForAllTy b ty) = ForAllTy (dropCastsB b) (dropCasts ty) dropCasts ty = ty -- LitTy, TyVarTy, CoercionTy -dropCastsB :: TyBinder -> TyBinder -dropCastsB (Anon ty) = Anon (dropCasts ty) -dropCastsB b = b -- Don't bother in the kind of a forall +dropCastsB :: TyVarBinder -> TyVarBinder +dropCastsB b = b -- Don't bother in the kind of a forall abstractClassKeys :: [Unique] abstractClassKeys = [ heqTyConKey @@ -1872,9 +1872,10 @@ fvType (TyVarTy tv) = [tv] fvType (TyConApp _ tys) = fvTypes tys fvType (LitTy {}) = [] fvType (AppTy fun arg) = fvType fun ++ fvType arg -fvType (ForAllTy bndr ty) - = fvType (binderType bndr) ++ - caseBinder bndr (\tv -> filter (/= tv)) (const id) (fvType ty) +fvType (FunTy arg res) = fvType arg ++ fvType res +fvType (ForAllTy (TvBndr tv _) ty) + = fvType (tyVarKind tv) ++ + filter (/= tv) (fvType ty) fvType (CastTy ty co) = fvType ty ++ fvCo co fvType (CoercionTy co) = fvCo co @@ -1913,10 +1914,8 @@ sizeType (TyVarTy {}) = 1 sizeType (TyConApp _ tys) = sizeTypes tys + 1 sizeType (LitTy {}) = 1 sizeType (AppTy fun arg) = sizeType fun + sizeType arg -sizeType (ForAllTy (Anon arg) res) - = sizeType arg + sizeType res + 1 -sizeType (ForAllTy (Named {}) ty) - = sizeType ty +sizeType (FunTy arg res) = sizeType arg + sizeType res + 1 +sizeType (ForAllTy _ ty) = sizeType ty sizeType (CastTy ty _) = sizeType ty sizeType (CoercionTy _) = 1 diff --git a/compiler/types/Coercion.hs b/compiler/types/Coercion.hs index cc3912d52e..d392a66273 100644 --- a/compiler/types/Coercion.hs +++ b/compiler/types/Coercion.hs @@ -301,7 +301,7 @@ ppr_co_ax_branch ppr_rhs , cab_rhs = rhs , cab_loc = loc }) = foldr1 (flip hangNotEmpty 2) - [ pprUserForAll (mkNamedBinders Invisible (tvs ++ cvs)) + [ pprUserForAll (mkTyVarBinders Invisible (tvs ++ cvs)) , pprTypeApp fam_tc lhs <+> equals <+> ppr_rhs fam_tc rhs , text "-- Defined" <+> pprLoc loc ] where @@ -686,7 +686,7 @@ mkForAllCo :: TyVar -> Coercion -> Coercion -> Coercion mkForAllCo tv kind_co co | Refl r ty <- co , Refl {} <- kind_co - = Refl r (mkNamedForAllTy tv Invisible ty) + = Refl r (mkInvForAllTy tv ty) | otherwise = ForAllCo tv kind_co co @@ -1517,9 +1517,8 @@ ty_co_subst lc role ty liftCoSubstTyVar lc r tv go r (AppTy ty1 ty2) = mkAppCo (go r ty1) (go Nominal ty2) go r (TyConApp tc tys) = mkTyConAppCo r tc (zipWith go (tyConRolesX r tc) tys) - go r (ForAllTy (Anon ty1) ty2) - = mkFunCo r (go r ty1) (go r ty2) - go r (ForAllTy (Named v _) ty) + go r (FunTy ty1 ty2) = mkFunCo r (go r ty1) (go r ty2) + go r (ForAllTy (TvBndr v _) ty) = let (lc', v', h) = liftCoSubstVarBndr lc v in mkForAllCo v' h $! ty_co_subst lc' r ty go r ty@(LitTy {}) = ASSERT( r == Nominal ) @@ -1727,7 +1726,7 @@ coercionKind co = go co -- from Note [The substitution invariant] -- This is doing repeated substitutions and probably doesn't -- need to, see #11735 - mkNamedForAllTy <$> Pair tv1 tv2 <*> pure Invisible <*> Pair ty1 ty2' + mkInvForAllTy <$> Pair tv1 tv2 <*> Pair ty1 ty2' go (CoVarCo cv) = toPair $ coVarTypes cv go (AxiomInstCo ax ind cos) | CoAxBranch { cab_tvs = tvs, cab_cvs = cvs @@ -1807,7 +1806,7 @@ coercionKindRole = go -- from Note [The substitution invariant] -- This is doing repeated substitutions and probably doesn't -- need to, see #11735 - (mkNamedForAllTy <$> Pair tv1 tv2 <*> pure Invisible <*> Pair ty1 ty2', r) + (mkInvForAllTy <$> Pair tv1 tv2 <*> Pair ty1 ty2', r) go (CoVarCo cv) = (toPair $ coVarTypes cv, coVarRole cv) go co@(AxiomInstCo ax _ _) = (coercionKind co, coAxiomRole ax) go (UnivCo _ r ty1 ty2) = (Pair ty1 ty2, r) diff --git a/compiler/types/FamInstEnv.hs b/compiler/types/FamInstEnv.hs index 62906dd6c8..52c1004875 100644 --- a/compiler/types/FamInstEnv.hs +++ b/compiler/types/FamInstEnv.hs @@ -1305,16 +1305,16 @@ normalise_type = do { (co, nty1) <- go ty1 ; (arg, nty2) <- withRole Nominal $ go ty2 ; return (mkAppCo co arg, mkAppTy nty1 nty2) } - go (ForAllTy (Anon ty1) ty2) + go (FunTy ty1 ty2) = do { (co1, nty1) <- go ty1 ; (co2, nty2) <- go ty2 ; r <- getRole ; return (mkFunCo r co1 co2, mkFunTy nty1 nty2) } - go (ForAllTy (Named tyvar vis) ty) + go (ForAllTy (TvBndr tyvar vis) ty) = do { (lc', tv', h, ki') <- normalise_tyvar_bndr tyvar ; (co, nty) <- withLC lc' $ normalise_type ty ; let tv2 = setTyVarKind tv' ki' - ; return (mkForAllCo tv' h co, mkNamedForAllTy tv2 vis nty) } + ; return (mkForAllCo tv' h co, ForAllTy (TvBndr tv2 vis) nty) } go (TyVarTy tv) = normalise_tyvar tv go (CastTy ty co) = do { (nco, nty) <- go ty @@ -1475,14 +1475,14 @@ coreFlattenTy = go = let (env', tys') = coreFlattenTys env tys in (env', mkTyConApp tc tys') - go env (ForAllTy (Anon ty1) ty2) = let (env1, ty1') = go env ty1 - (env2, ty2') = go env1 ty2 in - (env2, mkFunTy ty1' ty2') + go env (FunTy ty1 ty2) = let (env1, ty1') = go env ty1 + (env2, ty2') = go env1 ty2 in + (env2, mkFunTy ty1' ty2') - go env (ForAllTy (Named tv vis) ty) + go env (ForAllTy (TvBndr tv vis) ty) = let (env1, tv') = coreFlattenVarBndr env tv (env2, ty') = go env1 ty in - (env2, mkNamedForAllTy tv' vis ty') + (env2, ForAllTy (TvBndr tv' vis) ty') go env ty@(LitTy {}) = (env, ty) @@ -1556,12 +1556,13 @@ allTyVarsInTy :: Type -> VarSet allTyVarsInTy = go where go (TyVarTy tv) = unitVarSet tv - go (AppTy ty1 ty2) = (go ty1) `unionVarSet` (go ty2) go (TyConApp _ tys) = allTyVarsInTys tys - go (ForAllTy bndr ty) = - caseBinder bndr (\tv -> unitVarSet tv) (const emptyVarSet) - `unionVarSet` go (binderType bndr) `unionVarSet` go ty - -- don't remove the tv from the set! + go (AppTy ty1 ty2) = (go ty1) `unionVarSet` (go ty2) + go (FunTy ty1 ty2) = (go ty1) `unionVarSet` (go ty2) + go (ForAllTy (TvBndr tv _) ty) = unitVarSet tv `unionVarSet` + go (tyVarKind tv) `unionVarSet` + go ty + -- Don't remove the tv from the set! go (LitTy {}) = emptyVarSet go (CastTy ty co) = go ty `unionVarSet` go_co co go (CoercionTy co) = go_co co diff --git a/compiler/types/Kind.hs b/compiler/types/Kind.hs index e3cebcd6fb..c38a533dda 100644 --- a/compiler/types/Kind.hs +++ b/compiler/types/Kind.hs @@ -71,6 +71,7 @@ isConstraintKind _ = False -- ends in @*@ and @Maybe a -> [a]@ ends in @[]@. returnsTyCon :: Unique -> Type -> Bool returnsTyCon tc_u (ForAllTy _ ty) = returnsTyCon tc_u ty +returnsTyCon tc_u (FunTy _ ty) = returnsTyCon tc_u ty returnsTyCon tc_u (TyConApp tc' _) = tc' `hasKey` tc_u returnsTyCon _ _ = False diff --git a/compiler/types/TyCoRep.hs b/compiler/types/TyCoRep.hs index 7df02b63df..edacdad048 100644 --- a/compiler/types/TyCoRep.hs +++ b/compiler/types/TyCoRep.hs @@ -24,7 +24,6 @@ Note [The Type-related module hierarchy] module TyCoRep ( TyThing(..), Type(..), - TyBinder(..), TyLit(..), KindOrType, Kind, PredType, ThetaType, -- Synonyms @@ -37,22 +36,26 @@ module TyCoRep ( -- * Functions over types mkTyConTy, mkTyVarTy, mkTyVarTys, - mkFunTy, mkFunTys, mkForAllTys, + mkFunTy, mkFunTys, mkForAllTy, mkForAllTys, + mkPiTy, mkPiTys, isLiftedTypeKind, isUnliftedTypeKind, isCoercionType, isRuntimeRepTy, isRuntimeRepVar, isRuntimeRepKindedTy, dropRuntimeRepArgs, sameVis, -- * Functions over binders - binderType, delBinderVar, isInvisibleBinder, isVisibleBinder, - isNamedBinder, isAnonBinder, delBinderVarFV, + TyBinder(..), TyVarBinder(..), + binderVar, binderType, binderVisibility, + delBinderVar, + isInvisible, isVisible, + isInvisibleBinder, isVisibleBinder, -- * Functions over coercions pickLR, -- * Pretty-printing pprType, pprParendType, pprTypeApp, pprTvBndr, pprTvBndrs, - pprTyThing, pprTyThingCategory, pprSigmaType, + pprShortTyThing, pprTyThingCategory, pprSigmaType, pprTheta, pprForAll, pprForAllImplicit, pprUserForAll, pprThetaArrowTy, pprClassPred, pprKind, pprParendKind, pprTyLit, @@ -87,10 +90,8 @@ module TyCoRep ( extendCvSubst, extendCvSubstWithClone, extendTvSubst, extendTvSubstWithClone, extendTvSubstList, extendTvSubstAndInScope, - extendTvSubstBinder, unionTCvSubst, zipTyEnv, zipCoEnv, mkTyCoInScopeSet, zipTvSubst, zipCvSubst, - zipTyBinderSubst, mkTvSubstPrs, substTyWith, substTyWithCoVars, substTysWith, substTysWithCoVars, @@ -119,13 +120,13 @@ module TyCoRep ( tidyTopType, tidyKind, tidyCo, tidyCos, - tidyTyBinder, tidyTyBinders + tidyTyVarBinder, tidyTyVarBinders ) where #include "HsVersions.h" import {-# SOURCE #-} DataCon( dataConTyCon, dataConFullSig - , dataConUnivTyBinders, dataConExTyBinders + , dataConUnivTyVarBinders, dataConExTyVarBinders , DataCon, filterEqSpec ) import {-# SOURCE #-} Type( isPredTy, isCoercionTy, mkAppTy , tyCoVarsOfTypesWellScoped @@ -214,11 +215,13 @@ data Type -- can appear as the right hand side of a type synonym. | ForAllTy - TyBinder + {-# UNPACK #-} !TyVarBinder Type -- ^ A Π type. -- This includes arrow types, constructed with -- @ForAllTy (Anon ...)@. See also Note [TyBinder]. + | FunTy Type Type -- ^ t1 -> t2 Very common, so an important special case + | LitTy TyLit -- ^ Type literals are similar to type constructors. | CastTy @@ -374,9 +377,14 @@ same kinds. -- ('Named') or nondependent ('Anon'). They may also be visible or not. -- See Note [TyBinders] data TyBinder - = Named TyVar VisibilityFlag -- Always a TyVar (not CoVar or Id) + = Named TyVarBinder | Anon Type -- Visibility is determined by the type (Constraint vs. *) - deriving Data.Data + deriving Data.Data + +data TyVarBinder + = TvBndr TyVar -- Always a TyVar (not CoVar or Id) + VisibilityFlag + deriving Data.Data -- | Is something required to appear in source Haskell ('Visible'), -- permitted by request ('Specified') (visible type application), or @@ -385,6 +393,29 @@ data TyBinder data VisibilityFlag = Visible | Specified | Invisible deriving (Eq, Data.Data) +binderVar :: TyVarBinder -> TyVar +binderVar (TvBndr v _) = v + +binderType :: TyVarBinder -> Type +binderType (TvBndr v _) = varType v + +binderVisibility :: TyVarBinder -> VisibilityFlag +binderVisibility (TvBndr _ vis) = vis + +-- | Remove the binder's variable from the set, if the binder has +-- a variable. +delBinderVar :: VarSet -> TyVarBinder -> VarSet +delBinderVar vars (TvBndr tv _) = vars `delVarSet` tv + +-- | Does this binder bind an invisible argument? +isInvisibleBinder :: TyBinder -> Bool +isInvisibleBinder (Named (TvBndr _ vis)) = isInvisible vis +isInvisibleBinder (Anon ty) = isPredTy ty + +-- | Does this binder bind a visible argument? +isVisibleBinder :: TyBinder -> Bool +isVisibleBinder = not . isInvisibleBinder + -- | Do these denote the same level of visibility? Except that -- 'Specified' and 'Invisible' are considered the same. Used -- for printing. @@ -394,9 +425,18 @@ sameVis Visible _ = False sameVis _ Visible = False sameVis _ _ = True +isVisible :: VisibilityFlag -> Bool +isVisible Visible = True +isVisible _ = False + +isInvisible :: VisibilityFlag -> Bool +isInvisible v = not (isVisible v) + + {- Note [TyBinders] ~~~~~~~~~~~~~~~~~~~ -A ForAllTy contains a TyBinder. +A ForAllTy contains a TyVarBinder. But a type can be decomposed +to a telescope consisting of a [TyBinder] A TyBinder represents the type of binders -- that is, the type of an argument to a Pi-type. GHC Core currently supports two different @@ -404,11 +444,11 @@ Pi-types: * A non-dependent function, written with ->, e.g. ty1 -> ty2 - represented as ForAllTy (Anon ty1) ty2 + represented as FunTy ty1 ty2 * A dependent compile-time-only polytype, written with forall, e.g. forall (a:*). ty - represented as ForAllTy (Named a v) ty + represented as ForAllTy (TvBndr a v) ty Both Pi-types classify terms/types that take an argument. In other words, if `x` is either a function or a polytype, `x arg` makes sense @@ -421,7 +461,7 @@ The two constructors for TyBinder sort out the two different possibilities. Note [TyBinders and VisibilityFlags] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -A ForAllTy contains a TyBinder. Each Named TyBinders are equipped +A ForAllTy contains a TyVarBinder. Each TyVarBinder is equipped with a VisibilityFlag, which says whether or not arguments for this binder should be visible (explicit) in source Haskell. @@ -624,16 +664,26 @@ mkTyVarTys = map mkTyVarTy -- a common use of mkTyVarTy infixr 3 `mkFunTy` -- Associates to the right -- | Make an arrow type mkFunTy :: Type -> Type -> Type -mkFunTy arg res = ForAllTy (Anon arg) res +mkFunTy arg res = FunTy arg res -- | Make nested arrow types mkFunTys :: [Type] -> Type -> Type mkFunTys tys ty = foldr mkFunTy ty tys +mkForAllTy :: TyVarBinder -> Type -> Type +mkForAllTy = ForAllTy + -- | Wraps foralls over the type using the provided 'TyVar's from left to right -mkForAllTys :: [TyBinder] -> Type -> Type +mkForAllTys :: [TyVarBinder] -> Type -> Type mkForAllTys tyvars ty = foldr ForAllTy ty tyvars +mkPiTy :: TyBinder -> Type -> Type +mkPiTy (Anon ty1) ty2 = FunTy ty1 ty2 +mkPiTy (Named tvb) ty = ForAllTy tvb ty + +mkPiTys :: [TyBinder] -> Type -> Type +mkPiTys tbs ty = foldr mkPiTy ty tbs + -- | Does this type classify a core (unlifted) Coercion? -- At either role nominal or reprsentational -- (t1 ~# t2) or (t1 ~R# t2) @@ -644,38 +694,6 @@ isCoercionType (TyConApp tc tys) = True isCoercionType _ = False -binderType :: TyBinder -> Type -binderType (Named v _) = varType v -binderType (Anon ty) = ty - --- | Remove the binder's variable from the set, if the binder has --- a variable. -delBinderVar :: VarSet -> TyBinder -> VarSet -delBinderVar vars (Named tv _) = vars `delVarSet` tv -delBinderVar vars (Anon {}) = vars - --- | Remove the binder's variable from the set, if the binder has --- a variable. -delBinderVarFV :: TyBinder -> FV -> FV -delBinderVarFV (Named tv _) vars fv_cand in_scope acc = delFV tv vars fv_cand in_scope acc -delBinderVarFV (Anon {}) vars fv_cand in_scope acc = vars fv_cand in_scope acc - --- | Does this binder bind an invisible argument? -isInvisibleBinder :: TyBinder -> Bool -isInvisibleBinder (Named _ vis) = vis /= Visible -isInvisibleBinder (Anon ty) = isPredTy ty - --- | Does this binder bind a visible argument? -isVisibleBinder :: TyBinder -> Bool -isVisibleBinder = not . isInvisibleBinder - -isNamedBinder :: TyBinder -> Bool -isNamedBinder (Named {}) = True -isNamedBinder _ = False - -isAnonBinder :: TyBinder -> Bool -isAnonBinder (Anon {}) = True -isAnonBinder _ = False -- | Create the plain type constructor type which has been applied to no type arguments at all. mkTyConTy :: TyCon -> Type @@ -1383,14 +1401,15 @@ tyCoFVsOfType (TyVarTy v) a b c = (unitFV v `unionFV` tyCoFVsOfType (tyVa tyCoFVsOfType (TyConApp _ tys) a b c = tyCoFVsOfTypes tys a b c tyCoFVsOfType (LitTy {}) a b c = emptyFV a b c tyCoFVsOfType (AppTy fun arg) a b c = (tyCoFVsOfType fun `unionFV` tyCoFVsOfType arg) a b c +tyCoFVsOfType (FunTy arg res) a b c = (tyCoFVsOfType arg `unionFV` tyCoFVsOfType res) a b c tyCoFVsOfType (ForAllTy bndr ty) a b c = tyCoFVsBndr bndr (tyCoFVsOfType ty) a b c tyCoFVsOfType (CastTy ty co) a b c = (tyCoFVsOfType ty `unionFV` tyCoFVsOfCo co) a b c tyCoFVsOfType (CoercionTy co) a b c = tyCoFVsOfCo co a b c -tyCoFVsBndr :: TyBinder -> FV -> FV +tyCoFVsBndr :: TyVarBinder -> FV -> FV -- Free vars of (forall b. <thing with fvs>) -tyCoFVsBndr bndr fvs = delBinderVarFV bndr fvs - `unionFV` tyCoFVsOfType (binderType bndr) +tyCoFVsBndr (TvBndr tv _) fvs = (delFV tv fvs) + `unionFV` tyCoFVsOfType (tyVarKind tv) -- | Returns free variables of types, including kind variables as -- a non-deterministic set. For type synonyms it does /not/ expand the @@ -1478,9 +1497,10 @@ coVarsOfType (TyVarTy v) = coVarsOfType (tyVarKind v) coVarsOfType (TyConApp _ tys) = coVarsOfTypes tys coVarsOfType (LitTy {}) = emptyVarSet coVarsOfType (AppTy fun arg) = coVarsOfType fun `unionVarSet` coVarsOfType arg -coVarsOfType (ForAllTy bndr ty) - = coVarsOfType ty `delBinderVar` bndr - `unionVarSet` coVarsOfType (binderType bndr) +coVarsOfType (FunTy arg res) = coVarsOfType arg `unionVarSet` coVarsOfType res +coVarsOfType (ForAllTy (TvBndr tv _) ty) + = (coVarsOfType ty `delVarSet` tv) + `unionVarSet` coVarsOfType (tyVarKind tv) coVarsOfType (CastTy ty co) = coVarsOfType ty `unionVarSet` coVarsOfCo co coVarsOfType (CoercionTy co) = coVarsOfCo co @@ -1572,10 +1592,12 @@ data TyThing | ACoAxiom (CoAxiom Branched) instance Outputable TyThing where - ppr = pprTyThing + ppr = pprShortTyThing -pprTyThing :: TyThing -> SDoc -pprTyThing thing = pprTyThingCategory thing <+> quotes (ppr (getName thing)) +pprShortTyThing :: TyThing -> SDoc +-- c.f. PprTyThing.pprTyThing, which prints all the details +pprShortTyThing thing + = pprTyThingCategory thing <+> quotes (ppr (getName thing)) pprTyThingCategory :: TyThing -> SDoc pprTyThingCategory (ATyCon tc) @@ -1858,10 +1880,6 @@ extendTvSubstList :: TCvSubst -> [Var] -> [Type] -> TCvSubst extendTvSubstList subst tvs tys = foldl2 extendTvSubst subst tvs tys -extendTvSubstBinder :: TCvSubst -> TyBinder -> Type -> TCvSubst -extendTvSubstBinder env (Anon {}) _ = env -extendTvSubstBinder env (Named tv _) ty = extendTvSubst env tv ty - unionTCvSubst :: TCvSubst -> TCvSubst -> TCvSubst -- Works when the ranges are disjoint unionTCvSubst (TCvSubst in_scope1 tenv1 cenv1) (TCvSubst in_scope2 tenv2 cenv2) @@ -1905,15 +1923,6 @@ zipCvSubst cvs cos where cenv = zipCoEnv cvs cos --- | Create a TCvSubst combining the binders and types provided. --- NB: It is specifically OK if the lists are of different lengths. -zipTyBinderSubst :: [TyBinder] -> [Type] -> TCvSubst -zipTyBinderSubst bndrs tys - = mkTvSubst is tenv - where - is = mkInScopeSet (tyCoVarsOfTypes tys) - tenv = mkVarEnv [ (tv, ty) | (Named tv _, ty) <- zip bndrs tys ] - -- | Generates the in-scope set for the 'TCvSubst' from the types in the -- incoming environment. No CoVars, please! mkTvSubstPrs :: [(TyVar, Type)] -> TCvSubst @@ -2206,12 +2215,11 @@ subst_ty subst ty -- by [Int], represented with TyConApp go (TyConApp tc tys) = let args = map go tys in args `seqList` TyConApp tc args - go (ForAllTy (Anon arg) res) - = (ForAllTy $! (Anon $! go arg)) $! go res - go (ForAllTy (Named tv vis) ty) + go (FunTy arg res) = (FunTy $! go arg) $! go res + go (ForAllTy (TvBndr tv vis) ty) = case substTyVarBndrUnchecked subst tv of (subst', tv') -> - (ForAllTy $! ((Named $! tv') vis)) $! + (ForAllTy $! ((TvBndr $! tv') vis)) $! (subst_ty subst' ty) go (LitTy n) = LitTy $! n go (CastTy ty co) = (CastTy $! (go ty)) $! (subst_co subst co) @@ -2552,17 +2560,17 @@ defaultRuntimeRepVars' :: TyVarSet -- ^ the binders which we should default -> Type -> Type -- TODO: Eventually we should just eliminate the Type pretty-printer -- entirely and simply use IfaceType; this task is tracked as #11660. -defaultRuntimeRepVars' subs (ForAllTy (Named var vis) ty) +defaultRuntimeRepVars' subs (ForAllTy (TvBndr var vis) ty) | isRuntimeRepVar var = let subs' = extendVarSet subs var in defaultRuntimeRepVars' subs' ty | otherwise = let var' = var { varType = defaultRuntimeRepVars' subs (varType var) } - in ForAllTy (Named var' vis) (defaultRuntimeRepVars' subs ty) + in ForAllTy (TvBndr var' vis) (defaultRuntimeRepVars' subs ty) -defaultRuntimeRepVars' subs (ForAllTy (Anon kind) ty) = - ForAllTy (Anon $ defaultRuntimeRepVars' subs kind) - (defaultRuntimeRepVars' subs ty) +defaultRuntimeRepVars' subs (FunTy kind ty) = + FunTy (defaultRuntimeRepVars' subs kind) + (defaultRuntimeRepVars' subs ty) defaultRuntimeRepVars' subs (TyVarTy var) | var `elemVarSet` subs = ptrRepLiftedTy @@ -2650,6 +2658,7 @@ ppr_type _ (TyVarTy tv) = ppr_tvar tv ppr_type p (TyConApp tc tys) = pprTyTcApp p tc tys ppr_type p (LitTy l) = ppr_tylit p l ppr_type p ty@(ForAllTy {}) = ppr_forall_type p ty +ppr_type p ty@(FunTy {}) = ppr_forall_type p ty ppr_type p (AppTy t1 t2) = if_print_coercions @@ -2678,6 +2687,7 @@ ppr_type _ (CoercionTy co) (text "<>") ppr_forall_type :: TyPrec -> Type -> SDoc +-- Used for types starting with ForAllTy or FunTy ppr_forall_type p ty = maybeParen p FunPrec $ sdocWithDynFlags $ \dflags -> @@ -2710,21 +2720,26 @@ if_print_coercions yes no ppr_sigma_type :: DynFlags -> Bool -- ^ True <=> Show the foralls unconditionally -> Type -> SDoc +-- Used for types starting with ForAllTy or FunTy -- Suppose we have (forall a. Show a => forall b. a -> b). When we're not -- printing foralls, we want to drop both the (forall a) and the (forall b). -- This logic does so. ppr_sigma_type dflags False orig_ty | not (gopt Opt_PrintExplicitForalls dflags) - , all (isEmptyVarSet . tyCoVarsOfType . binderType) named + , all (isEmptyVarSet . tyCoVarsOfType . tyVarKind) tv_bndrs -- See Note [When to print foralls] - = sep [ pprThetaArrowTy (map binderType ctxt) + = sep [ pprThetaArrowTy theta , pprArrowChain TopPrec (ppr_fun_tail tau) ] where - (invis_bndrs, tau) = split [] orig_ty - (named, ctxt) = partition isNamedBinder invis_bndrs + (tv_bndrs, theta, tau) = split [] [] orig_ty - split acc (ForAllTy bndr ty) | isInvisibleBinder bndr = split (bndr:acc) ty - split acc ty = (reverse acc, ty) + split :: [TyVar] -> [PredType] -> Type + -> ([TyVar], [PredType], Type) + split bndr_acc theta_acc (ForAllTy (TvBndr tv vis) ty) + | isInvisible vis = split (tv : bndr_acc) theta_acc ty + split bndr_acc theta_acc (FunTy ty1 ty2) + | isPredTy ty1 = split bndr_acc (ty1 : theta_acc) ty2 + split bndr_acc theta_acc ty = (reverse bndr_acc, reverse theta_acc, ty) ppr_sigma_type _ _ ty = sep [ pprForAll bndrs @@ -2734,23 +2749,23 @@ ppr_sigma_type _ _ ty (bndrs, rho) = split1 [] ty (ctxt, tau) = split2 [] rho - split1 bndrs (ForAllTy bndr@(Named {}) ty) = split1 (bndr:bndrs) ty - split1 bndrs ty = (reverse bndrs, ty) + split1 bndrs (ForAllTy bndr ty) = split1 (bndr:bndrs) ty + split1 bndrs ty = (reverse bndrs, ty) - split2 ps (ForAllTy (Anon ty1) ty2) | isPredTy ty1 = split2 (ty1:ps) ty2 - split2 ps ty = (reverse ps, ty) + split2 ps (FunTy ty1 ty2) | isPredTy ty1 = split2 (ty1:ps) ty2 + split2 ps ty = (reverse ps, ty) -- We don't want to lose synonyms, so we mustn't use splitFunTys here. ppr_fun_tail :: Type -> [SDoc] -ppr_fun_tail (ForAllTy (Anon ty1) ty2) +ppr_fun_tail (FunTy ty1 ty2) | not (isPredTy ty1) = ppr_type FunPrec ty1 : ppr_fun_tail ty2 ppr_fun_tail other_ty = [ppr_type TopPrec other_ty] pprSigmaType :: Type -> SDoc pprSigmaType ty = sdocWithDynFlags $ \dflags -> - eliminateRuntimeRep (ppr_sigma_type dflags False) ty + eliminateRuntimeRep (ppr_sigma_type dflags False) ty -pprUserForAll :: [TyBinder] -> SDoc +pprUserForAll :: [TyVarBinder] -> SDoc -- Print a user-level forall; see Note [When to print foralls] pprUserForAll bndrs = sdocWithDynFlags $ \dflags -> @@ -2761,13 +2776,13 @@ pprUserForAll bndrs = not (isEmptyVarSet (tyCoVarsOfType (binderType bndr))) pprForAllImplicit :: [TyVar] -> SDoc -pprForAllImplicit tvs = pprForAll (zipWith Named tvs (repeat Specified)) +pprForAllImplicit tvs = pprForAll [ TvBndr tv Specified | tv <- tvs ] -- | Render the "forall ... ." or "forall ... ->" bit of a type. -- Do not pass in anonymous binders! -pprForAll :: [TyBinder] -> SDoc +pprForAll :: [TyVarBinder] -> SDoc pprForAll [] = empty -pprForAll bndrs@(Named _ vis : _) +pprForAll bndrs@(TvBndr _ vis : _) = add_separator (forAllLit <+> doc) <+> pprForAll bndrs' where (bndrs', doc) = ppr_tv_bndrs bndrs vis @@ -2775,7 +2790,6 @@ pprForAll bndrs@(Named _ vis : _) add_separator stuff = case vis of Visible -> stuff <+> arrow _inv -> stuff <> dot -pprForAll bndrs = pprPanic "pprForAll: anonymous binder" (ppr bndrs) pprTvBndrs :: [TyVar] -> SDoc pprTvBndrs tvs = sep (map pprTvBndr tvs) @@ -2783,10 +2797,10 @@ pprTvBndrs tvs = sep (map pprTvBndr tvs) -- | Render the ... in @(forall ... .)@ or @(forall ... ->)@. -- Returns both the list of not-yet-rendered binders and the doc. -- No anonymous binders here! -ppr_tv_bndrs :: [TyBinder] +ppr_tv_bndrs :: [TyVarBinder] -> VisibilityFlag -- ^ visibility of the first binder in the list - -> ([TyBinder], SDoc) -ppr_tv_bndrs all_bndrs@(Named tv vis : bndrs) vis1 + -> ([TyVarBinder], SDoc) +ppr_tv_bndrs all_bndrs@(TvBndr tv vis : bndrs) vis1 | vis `sameVis` vis1 = let (bndrs', doc) = ppr_tv_bndrs bndrs vis1 pp_tv = sdocWithDynFlags $ \dflags -> if Invisible == vis && @@ -2797,7 +2811,6 @@ ppr_tv_bndrs all_bndrs@(Named tv vis : bndrs) vis1 (bndrs', pp_tv <+> doc) | otherwise = (all_bndrs, empty) ppr_tv_bndrs [] _ = ([], empty) -ppr_tv_bndrs bndrs _ = pprPanic "ppr_tv_bndrs: anonymous binder" (ppr bndrs) pprTvBndr :: TyVar -> SDoc pprTvBndr tv @@ -2813,11 +2826,14 @@ pprTvBndrNoParens tv where kind = tyVarKind tv +instance Outputable TyVarBinder where + ppr (TvBndr v Visible) = ppr v + ppr (TvBndr v Specified) = char '@' <> ppr v + ppr (TvBndr v Invisible) = braces (ppr v) + instance Outputable TyBinder where - ppr (Named v Visible) = ppr v - ppr (Named v Specified) = char '@' <> ppr v - ppr (Named v Invisible) = braces (ppr v) - ppr (Anon ty) = text "[anon]" <+> ppr ty + ppr (Named tvb) = ppr tvb + ppr (Anon ty) = text "[anon]" <+> ppr ty instance Outputable VisibilityFlag where ppr Visible = text "[vis]" @@ -2879,8 +2895,8 @@ 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 = dataConUnivTyBinders dc - ex_bndrs = dataConExTyBinders 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) @@ -3148,16 +3164,14 @@ tidyTyCoVarBndr tidy_env@(occ_env, subst) tyvar else mkVarOcc (occNameString occ ++ "0") | otherwise = occ -tidyTyBinder :: TidyEnv -> TyBinder -> (TidyEnv, TyBinder) -tidyTyBinder tidy_env (Named tv vis) - = (tidy_env', Named tv' vis) +tidyTyVarBinder :: TidyEnv -> TyVarBinder -> (TidyEnv, TyVarBinder) +tidyTyVarBinder tidy_env (TvBndr tv vis) + = (tidy_env', TvBndr tv' vis) where (tidy_env', tv') = tidyTyCoVarBndr tidy_env tv -tidyTyBinder tidy_env (Anon ty) - = (tidy_env, Anon $ tidyType tidy_env ty) -tidyTyBinders :: TidyEnv -> [TyBinder] -> (TidyEnv, [TyBinder]) -tidyTyBinders = mapAccumL tidyTyBinder +tidyTyVarBinders :: TidyEnv -> [TyVarBinder] -> (TidyEnv, [TyVarBinder]) +tidyTyVarBinders = mapAccumL tidyTyVarBinder --------------- tidyFreeTyCoVars :: TidyEnv -> [TyCoVar] -> TidyEnv @@ -3200,10 +3214,9 @@ tidyType env (TyVarTy tv) = TyVarTy (tidyTyVarOcc env tv) tidyType env (TyConApp tycon tys) = let args = tidyTypes env tys in args `seqList` TyConApp tycon args tidyType env (AppTy fun arg) = (AppTy $! (tidyType env fun)) $! (tidyType env arg) -tidyType env (ForAllTy (Anon fun) arg) - = (ForAllTy $! (Anon $! (tidyType env fun))) $! (tidyType env arg) -tidyType env (ForAllTy (Named tv vis) ty) - = (ForAllTy $! ((Named $! tvp) $! vis)) $! (tidyType envp ty) +tidyType env (FunTy fun arg) = (FunTy $! (tidyType env fun)) $! (tidyType env arg) +tidyType env (ForAllTy (TvBndr tv vis) ty) + = (ForAllTy $! ((TvBndr $! tvp) $! vis)) $! (tidyType envp ty) where (envp, tvp) = tidyTyCoVarBndr env tv tidyType env (CastTy ty co) = (CastTy $! tidyType env ty) $! (tidyCo env co) diff --git a/compiler/types/TyCoRep.hs-boot b/compiler/types/TyCoRep.hs-boot index 0bcd9b369e..314eed15a4 100644 --- a/compiler/types/TyCoRep.hs-boot +++ b/compiler/types/TyCoRep.hs-boot @@ -5,13 +5,14 @@ import Data.Data ( Data ) data Type data TyBinder +data TyVarBinder data TyThing data Coercion data LeftOrRight data UnivCoProvenance data TCvSubst -mkForAllTys :: [TyBinder] -> Type -> Type +mkPiTys :: [TyBinder] -> Type -> Type type PredType = Type type Kind = Type diff --git a/compiler/types/TyCon.hs b/compiler/types/TyCon.hs index bafcb2c6b2..c7c225d454 100644 --- a/compiler/types/TyCon.hs +++ b/compiler/types/TyCon.hs @@ -111,7 +111,7 @@ module TyCon( #include "HsVersions.h" -import {-# SOURCE #-} TyCoRep ( Kind, Type, PredType, TyBinder, pprType, mkForAllTys ) +import {-# SOURCE #-} TyCoRep ( Kind, Type, PredType, TyBinder, pprType, mkPiTys ) import {-# SOURCE #-} TysWiredIn ( runtimeRepTyCon, constraintKind , vecCountTyCon, vecElemTyCon, liftedTypeKind ) import {-# SOURCE #-} DataCon ( DataCon, dataConExTyVars, dataConFieldLabels ) @@ -367,6 +367,15 @@ See also: ************************************************************************ -} +{- Note [TyCon binders] +~~~~~~~~~~~~~~~~~~~~~~~ + +data TyConBinder = TCB TyVar TcConBinderVis + +data TyConBinderVis = NamedTCB VisiblityFlag + | AnonTCB +-} + -- | TyCons represent type constructors. Type constructors are introduced by -- things such as: -- @@ -811,7 +820,7 @@ data FamTyConFlav All TyCons have this group of fields tyConBinders :: [TyBinder] tyConResKind :: Kind - tyConKind :: Kind -- Cached = mkForAllTys tyConBinders tyConResKind + tyConKind :: Kind -- Cached = mkPiTys tyConBinders tyConResKind tyConArity :: Arity -- Cached = length tyConBinders They fit together like so: @@ -832,8 +841,8 @@ They fit together like so: considered saturated. Here we mean "applied to in the actual Type", not surface syntax; i.e. including implicit kind variables. -Note [tyConBinders and tyConTyVars] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Note [tyConTyVars and tyConBinders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider type App a (b :: k) = a b -- App :: forall {k}; (k->*) -> k -> * @@ -1238,7 +1247,7 @@ mkFunTyCon name binders rep_nm tyConName = name, tyConBinders = binders, tyConResKind = liftedTypeKind, - tyConKind = mkForAllTys binders liftedTypeKind, + tyConKind = mkPiTys binders liftedTypeKind, tyConArity = 2, tcRepName = rep_nm } @@ -1269,7 +1278,7 @@ mkAlgTyCon name binders res_kind tyvars roles cType stupid rhs parent is_rec gad tyConUnique = nameUnique name, tyConBinders = binders, tyConResKind = res_kind, - tyConKind = mkForAllTys binders res_kind, + tyConKind = mkPiTys binders res_kind, tyConArity = length tyvars, tyConTyVars = tyvars, tcRoles = roles, @@ -1306,7 +1315,7 @@ mkTupleTyCon name binders res_kind arity tyvars con sort parent tyConUnique = nameUnique name, tyConBinders = binders, tyConResKind = res_kind, - tyConKind = mkForAllTys binders res_kind, + tyConKind = mkPiTys binders res_kind, tyConArity = arity, tyConTyVars = tyvars, tcRoles = replicate arity Representational, @@ -1337,7 +1346,7 @@ mkTcTyCon name tvs binders res_kind unsat scoped_tvs , tyConTyVars = tvs , tyConBinders = binders , tyConResKind = res_kind - , tyConKind = mkForAllTys binders res_kind + , tyConKind = mkPiTys binders res_kind , tyConUnsat = unsat , tyConArity = length binders , tcTyConScopedTyVars = scoped_tvs } @@ -1376,7 +1385,7 @@ mkPrimTyCon' name binders res_kind roles is_unlifted rep_nm tyConUnique = nameUnique name, tyConBinders = binders, tyConResKind = res_kind, - tyConKind = mkForAllTys binders res_kind, + tyConKind = mkPiTys binders res_kind, tyConArity = length roles, tcRoles = roles, isUnlifted = is_unlifted, @@ -1392,7 +1401,7 @@ mkSynonymTyCon name binders res_kind tyvars roles rhs tyConUnique = nameUnique name, tyConBinders = binders, tyConResKind = res_kind, - tyConKind = mkForAllTys binders res_kind, + tyConKind = mkPiTys binders res_kind, tyConArity = length tyvars, tyConTyVars = tyvars, tcRoles = roles, @@ -1409,7 +1418,7 @@ mkFamilyTyCon name binders res_kind tyvars resVar flav parent inj , tyConName = name , tyConBinders = binders , tyConResKind = res_kind - , tyConKind = mkForAllTys binders res_kind + , tyConKind = mkPiTys binders res_kind , tyConArity = length tyvars , tyConTyVars = tyvars , famTcResVar = resVar @@ -1433,7 +1442,7 @@ mkPromotedDataCon con name rep_name binders res_kind roles rep_info tcRoles = roles, tyConBinders = binders, tyConResKind = res_kind, - tyConKind = mkForAllTys binders res_kind, + tyConKind = mkPiTys binders res_kind, dataCon = con, tcRepName = rep_name, promDcRepInfo = rep_info diff --git a/compiler/types/Type.hs b/compiler/types/Type.hs index 8ce60a50bb..c20a158cdb 100644 --- a/compiler/types/Type.hs +++ b/compiler/types/Type.hs @@ -15,7 +15,7 @@ module Type ( -- $representation_types TyThing(..), Type, VisibilityFlag(..), KindOrType, PredType, ThetaType, - Var, TyVar, isTyVar, TyCoVar, TyBinder, + Var, TyVar, isTyVar, TyCoVar, TyBinder, TyVarBinder, -- ** Constructing and deconstructing types mkTyVarTy, mkTyVarTys, getTyVar, getTyVar_maybe, repGetTyVar_maybe, @@ -35,12 +35,12 @@ module Type ( repSplitTyConApp_maybe, mkForAllTy, mkForAllTys, mkInvForAllTys, mkSpecForAllTys, - mkVisForAllTys, - mkNamedForAllTy, - splitForAllTy_maybe, splitForAllTys, splitForAllTy, - splitPiTy_maybe, splitPiTys, splitPiTy, - splitNamedPiTys, - mkPiType, mkPiTypes, mkTyBindersPreferAnon, + mkVisForAllTys, mkInvForAllTy, + splitForAllTys, splitForAllTyVarBndrs, + splitForAllTy_maybe, splitForAllTy, + splitPiTy_maybe, splitPiTy, splitPiTys, + mkPiTy, mkPiTys, mkTyBindersPreferAnon, + mkLamType, mkLamTypes, piResultTy, piResultTys, applyTysX, dropForAlls, @@ -82,13 +82,14 @@ module Type ( predTypeEqRel, -- ** Binders - sameVis, - mkNamedBinder, mkNamedBinders, - mkAnonBinder, isNamedBinder, isAnonBinder, - isIdLikeBinder, binderVisibility, binderVar_maybe, - binderVar, binderRelevantType_maybe, caseBinder, - partitionBinders, partitionBindersIntoBinders, - binderType, isVisibleBinder, isInvisibleBinder, + sameVis, mkNamedTyBinders, + mkTyVarBinder, mkTyVarBinders, + mkAnonBinder, mkNamedBinder, + isAnonTyBinder, isNamedTyBinder, + binderVar, binderType, binderVisibility, + tyBinderType, tyBinderVisibility, + binderRelevantType_maybe, caseBinder, + isVisible, isInvisible, isVisibleBinder, isInvisibleBinder, -- ** Common type constructors funTyCon, @@ -115,7 +116,8 @@ module Type ( liftedTypeKind, -- * Type free variables - tyCoVarsOfType, tyCoVarsOfTypes, tyCoFVsOfType, + tyCoFVsOfType, tyCoFVsBndr, + tyCoVarsOfType, tyCoVarsOfTypes, tyCoVarsOfTypeDSet, coVarsOfType, coVarsOfTypes, closeOverKinds, closeOverKindsList, @@ -172,7 +174,7 @@ module Type ( cloneTyVarBndr, cloneTyVarBndrs, lookupTyVar, -- * Pretty-printing - pprType, pprParendType, pprTypeApp, pprTyThingCategory, pprTyThing, + pprType, pprParendType, pprTypeApp, pprTyThingCategory, pprShortTyThing, pprTvBndr, pprTvBndrs, pprForAll, pprForAllImplicit, pprUserForAll, pprSigmaType, ppSuggestExplicitKinds, pprTheta, pprThetaArrowTy, pprClassPred, @@ -189,7 +191,7 @@ module Type ( tidyTyVarOcc, tidyTopType, tidyKind, - tidyTyBinder, tidyTyBinders + tidyTyVarBinder, tidyTyVarBinders ) where #include "HsVersions.h" @@ -353,11 +355,11 @@ expandTypeSynonyms ty go _ (LitTy l) = LitTy l go subst (TyVarTy tv) = substTyVar subst tv go subst (AppTy t1 t2) = mkAppTy (go subst t1) (go subst t2) - go subst (ForAllTy (Anon arg) res) + go subst (FunTy arg res) = mkFunTy (go subst arg) (go subst res) - go subst (ForAllTy (Named tv vis) t) + go subst (ForAllTy (TvBndr tv vis) t) = let (subst', tv') = substTyVarBndrCallback go subst tv in - ForAllTy (Named tv' vis) (go subst' t) + ForAllTy (TvBndr tv' vis) (go subst' t) go subst (CastTy ty co) = mkCastTy (go subst ty) (go_co subst co) go subst (CoercionTy co) = mkCoercionTy (go_co subst co) @@ -475,18 +477,18 @@ mapType mapper@(TyCoMapper { tcm_smart = smart, tcm_tyvar = tyvar go t@(TyConApp _ []) = return t -- avoid allocation in this exceedingly -- common case (mostly, for *) go (TyConApp tc tys) = mktyconapp tc <$> mapM go tys - go (ForAllTy (Anon arg) res) = mkfunty <$> go arg <*> go res - go (ForAllTy (Named tv vis) inner) + go (FunTy arg res) = FunTy <$> go arg <*> go res + go (ForAllTy (TvBndr tv vis) inner) = do { (env', tv') <- tybinder env tv vis ; inner' <- mapType mapper env' inner - ; return $ ForAllTy (Named tv' vis) inner' } - go ty@(LitTy {}) = return ty - go (CastTy ty co) = mkcastty <$> go ty <*> mapCoercion mapper env co + ; return $ ForAllTy (TvBndr tv' vis) inner' } + go ty@(LitTy {}) = return ty + go (CastTy ty co) = mkcastty <$> go ty <*> mapCoercion mapper env co go (CoercionTy co) = CoercionTy <$> mapCoercion mapper env co - (mktyconapp, mkappty, mkcastty, mkfunty) - | smart = (mkTyConApp, mkAppTy, mkCastTy, mkFunTy) - | otherwise = (TyConApp, AppTy, CastTy, ForAllTy . Anon) + (mktyconapp, mkappty, mkcastty) + | smart = (mkTyConApp, mkAppTy, mkCastTy) + | otherwise = (TyConApp, AppTy, CastTy) {-# INLINABLE mapCoercion #-} -- See Note [Specialising mappers] mapCoercion :: Monad m @@ -646,8 +648,7 @@ splitAppTy_maybe ty = repSplitAppTy_maybe ty repSplitAppTy_maybe :: Type -> Maybe (Type,Type) -- ^ Does the AppTy split as in 'splitAppTy_maybe', but assumes that -- any Core view stuff is already done -repSplitAppTy_maybe (ForAllTy (Anon ty1) ty2) - = Just (TyConApp funTyCon [ty1], ty2) +repSplitAppTy_maybe (FunTy ty1 ty2) = Just (TyConApp funTyCon [ty1], ty2) repSplitAppTy_maybe (AppTy ty1 ty2) = Just (ty1, ty2) repSplitAppTy_maybe (TyConApp tc tys) | mightBeUnsaturatedTyCon tc || tys `lengthExceeds` tyConArity tc @@ -661,7 +662,7 @@ repSplitAppTy_maybe _other = Nothing tcRepSplitAppTy_maybe :: Type -> Maybe (Type,Type) -- ^ Does the AppTy split as in 'tcSplitAppTy_maybe', but assumes that -- any coreView stuff is already done. Refuses to look through (c => t) -tcRepSplitAppTy_maybe (ForAllTy (Anon ty1) ty2) +tcRepSplitAppTy_maybe (FunTy ty1 ty2) | isConstraintKind (typeKind ty1) = Nothing -- See Note [Decomposing fat arrow c=>t] | otherwise = Just (TyConApp funTyCon [ty1], ty2) tcRepSplitAppTy_maybe (AppTy ty1 ty2) = Just (ty1, ty2) @@ -694,9 +695,9 @@ splitAppTys ty = split ty ty [] (tc_args1, tc_args2) = splitAt n tc_args in (TyConApp tc tc_args1, tc_args2 ++ args) - split _ (ForAllTy (Anon ty1) ty2) args = ASSERT( null args ) - (TyConApp funTyCon [], [ty1,ty2]) - split orig_ty _ args = (orig_ty, args) + split _ (FunTy ty1 ty2) args = ASSERT( null args ) + (TyConApp funTyCon [], [ty1,ty2]) + split orig_ty _ args = (orig_ty, args) -- | Like 'splitAppTys', but doesn't look through type synonyms repSplitAppTys :: Type -> (Type, [Type]) @@ -709,8 +710,8 @@ repSplitAppTys ty = split ty [] (tc_args1, tc_args2) = splitAt n tc_args in (TyConApp tc tc_args1, tc_args2 ++ args) - split (ForAllTy (Anon ty1) ty2) args = ASSERT( null args ) - (TyConApp funTyCon [], [ty1, ty2]) + split (FunTy ty1 ty2) args = ASSERT( null args ) + (TyConApp funTyCon [], [ty1, ty2]) split ty args = (ty, args) {- @@ -782,8 +783,6 @@ pprUserTypeErrorTy ty = --------------------------------------------------------------------- FunTy ~~~~~ - -Function types are represented with (ForAllTy (Anon ...) ...) -} isFunTy :: Type -> Bool @@ -793,33 +792,33 @@ splitFunTy :: Type -> (Type, Type) -- ^ Attempts to extract the argument and result types from a type, and -- panics if that is not possible. See also 'splitFunTy_maybe' splitFunTy ty | Just ty' <- coreView ty = splitFunTy ty' -splitFunTy (ForAllTy (Anon arg) res) = (arg, res) -splitFunTy other = pprPanic "splitFunTy" (ppr other) +splitFunTy (FunTy arg res) = (arg, res) +splitFunTy other = pprPanic "splitFunTy" (ppr other) splitFunTy_maybe :: Type -> Maybe (Type, Type) -- ^ Attempts to extract the argument and result types from a type splitFunTy_maybe ty | Just ty' <- coreView ty = splitFunTy_maybe ty' -splitFunTy_maybe (ForAllTy (Anon arg) res) = Just (arg, res) -splitFunTy_maybe _ = Nothing +splitFunTy_maybe (FunTy arg res) = Just (arg, res) +splitFunTy_maybe _ = Nothing splitFunTys :: Type -> ([Type], Type) splitFunTys ty = split [] ty ty where split args orig_ty ty | Just ty' <- coreView ty = split args orig_ty ty' - split args _ (ForAllTy (Anon arg) res) = split (arg:args) res res - split args orig_ty _ = (reverse args, orig_ty) + split args _ (FunTy arg res) = split (arg:args) res res + split args orig_ty _ = (reverse args, orig_ty) funResultTy :: Type -> Type -- ^ Extract the function result type and panic if that is not possible funResultTy ty | Just ty' <- coreView ty = funResultTy ty' -funResultTy (ForAllTy (Anon {}) res) = res -funResultTy ty = pprPanic "funResultTy" (ppr ty) +funResultTy (FunTy _ res) = res +funResultTy ty = pprPanic "funResultTy" (ppr ty) funArgTy :: Type -> Type -- ^ Extract the function argument type and panic if that is not possible funArgTy ty | Just ty' <- coreView ty = funArgTy ty' -funArgTy (ForAllTy (Anon arg) _res) = arg -funArgTy ty = pprPanic "funArgTy" (ppr ty) +funArgTy (FunTy arg _res) = arg +funArgTy ty = pprPanic "funArgTy" (ppr ty) piResultTy :: Type -> Type -> Type piResultTy ty arg = case piResultTy_maybe ty arg of @@ -834,13 +833,14 @@ piResultTy_maybe :: Type -> Type -> Maybe Type piResultTy_maybe ty arg | Just ty' <- coreView ty = piResultTy_maybe ty' arg - | ForAllTy bndr res <- ty - = case bndr of - Anon {} -> Just res - Named tv _ -> Just (substTy (extendTvSubst empty_subst tv arg) res) - where - empty_subst = mkEmptyTCvSubst $ mkInScopeSet $ - tyCoVarsOfTypes [arg,res] + | FunTy _ res <- ty + = Just res + + | ForAllTy (TvBndr tv _) res <- ty + = let empty_subst = mkEmptyTCvSubst $ mkInScopeSet $ + tyCoVarsOfTypes [arg,res] + in Just (substTy (extendTvSubst empty_subst tv arg) res) + | otherwise = Nothing @@ -871,10 +871,11 @@ piResultTys ty orig_args@(arg:args) | Just ty' <- coreView ty = piResultTys ty' orig_args - | ForAllTy bndr res <- ty - = case bndr of - Anon {} -> piResultTys res args - Named tv _ -> go (extendVarEnv emptyTvSubstEnv tv arg) res args + | FunTy _ res <- ty + = piResultTys res args + + | ForAllTy (TvBndr tv _) res <- ty + = go (extendVarEnv emptyTvSubstEnv tv arg) res args | otherwise = pprPanic "piResultTys1" (ppr ty $$ ppr orig_args) @@ -888,10 +889,11 @@ piResultTys ty orig_args@(arg:args) | Just ty' <- coreView ty = go tv_env ty' all_args - | ForAllTy bndr res <- ty - = case bndr of - Anon _ -> go tv_env res args - Named tv _ -> go (extendVarEnv tv_env tv arg) res args + | FunTy _ res <- ty + = go tv_env res args + + | ForAllTy (TvBndr tv _) res <- ty + = go (extendVarEnv tv_env tv arg) res args | TyVarTy tv <- ty , Just ty' <- lookupVarEnv tv_env tv @@ -924,7 +926,7 @@ applyTysX tvs body_ty arg_tys mkTyConApp :: TyCon -> [Type] -> Type mkTyConApp tycon tys | isFunTyCon tycon, [ty1,ty2] <- tys - = ForAllTy (Anon ty1) ty2 + = FunTy ty1 ty2 | otherwise = TyConApp tycon tys @@ -936,17 +938,17 @@ mkTyConApp tycon tys -- | Retrieve the tycon heading this type, if there is one. Does /not/ -- look through synonyms. tyConAppTyConPicky_maybe :: Type -> Maybe TyCon -tyConAppTyConPicky_maybe (TyConApp tc _) = Just tc -tyConAppTyConPicky_maybe (ForAllTy (Anon _) _) = Just funTyCon -tyConAppTyConPicky_maybe _ = Nothing +tyConAppTyConPicky_maybe (TyConApp tc _) = Just tc +tyConAppTyConPicky_maybe (FunTy {}) = Just funTyCon +tyConAppTyConPicky_maybe _ = Nothing -- | The same as @fst . splitTyConApp@ tyConAppTyCon_maybe :: Type -> Maybe TyCon tyConAppTyCon_maybe ty | Just ty' <- coreView ty = tyConAppTyCon_maybe ty' -tyConAppTyCon_maybe (TyConApp tc _) = Just tc -tyConAppTyCon_maybe (ForAllTy (Anon _) _) = Just funTyCon -tyConAppTyCon_maybe _ = Nothing +tyConAppTyCon_maybe (TyConApp tc _) = Just tc +tyConAppTyCon_maybe (FunTy {}) = Just funTyCon +tyConAppTyCon_maybe _ = Nothing tyConAppTyCon :: Type -> TyCon tyConAppTyCon ty = tyConAppTyCon_maybe ty `orElse` pprPanic "tyConAppTyCon" (ppr ty) @@ -954,9 +956,9 @@ tyConAppTyCon ty = tyConAppTyCon_maybe ty `orElse` pprPanic "tyConAppTyCon" (ppr -- | The same as @snd . splitTyConApp@ tyConAppArgs_maybe :: Type -> Maybe [Type] tyConAppArgs_maybe ty | Just ty' <- coreView ty = tyConAppArgs_maybe ty' -tyConAppArgs_maybe (TyConApp _ tys) = Just tys -tyConAppArgs_maybe (ForAllTy (Anon arg) res) = Just [arg,res] -tyConAppArgs_maybe _ = Nothing +tyConAppArgs_maybe (TyConApp _ tys) = Just tys +tyConAppArgs_maybe (FunTy arg res) = Just [arg,res] +tyConAppArgs_maybe _ = Nothing tyConAppArgs :: Type -> [Type] tyConAppArgs ty = tyConAppArgs_maybe ty `orElse` pprPanic "tyConAppArgs" (ppr ty) @@ -985,9 +987,9 @@ splitTyConApp_maybe ty = repSplitTyConApp_maybe ty -- | Like 'splitTyConApp_maybe', but doesn't look through synonyms. This -- assumes the synonyms have already been dealt with. repSplitTyConApp_maybe :: Type -> Maybe (TyCon, [Type]) -repSplitTyConApp_maybe (TyConApp tc tys) = Just (tc, tys) -repSplitTyConApp_maybe (ForAllTy (Anon arg) res) = Just (funTyCon, [arg,res]) -repSplitTyConApp_maybe _ = Nothing +repSplitTyConApp_maybe (TyConApp tc tys) = Just (tc, tys) +repSplitTyConApp_maybe (FunTy arg res) = Just (funTyCon, [arg,res]) +repSplitTyConApp_maybe _ = Nothing -- | Attempts to tease a list type apart and gives the type of the elements if -- successful (looks through type synonyms) @@ -1071,14 +1073,16 @@ mkCastTy ty co | isReflexiveCo co = ty -- in test dependent/should_compile/dynamic-paper. mkCastTy (CastTy ty co1) co2 = mkCastTy ty (co1 `mkTransCo` co2) --- See Note [Weird typing rule for ForAllTy] -mkCastTy outer_ty@(ForAllTy (Named tv vis) inner_ty) co - = -- have to make sure that pushing the co in doesn't capture the bound var - let fvs = tyCoVarsOfCo co `unionVarSet` tyCoVarsOfType outer_ty - empty_subst = mkEmptyTCvSubst (mkInScopeSet fvs) - (subst, tv') = substTyVarBndr empty_subst tv - in - ForAllTy (Named tv' vis) (substTy subst inner_ty `mkCastTy` co) + +mkCastTy outer_ty@(ForAllTy (TvBndr tv vis) inner_ty) co + = ForAllTy (TvBndr tv' vis) (substTy subst inner_ty `mkCastTy` co) + where + -- See Note [Weird typing rule for ForAllTy] + -- have to make sure that pushing the co in doesn't capture the bound var + fvs = tyCoVarsOfCo co `unionVarSet` tyCoVarsOfType outer_ty + empty_subst = mkEmptyTCvSubst (mkInScopeSet fvs) + (subst, tv') = substTyVarBndr empty_subst tv + mkCastTy ty co = -- NB: don't check if the coercion "from" type matches here; -- there may be unzonked variables about let result = split_apps [] ty co in @@ -1102,24 +1106,25 @@ mkCastTy ty co = -- NB: don't check if the coercion "from" type matches here; affix_co (fst $ splitPiTys $ typeKind saturated_tc) saturated_tc (decomp_args `chkAppend` args) co - split_apps args (ForAllTy (Anon arg) res) co + split_apps args (FunTy arg res) co = affix_co (tyConBinders funTyCon) (mkTyConTy funTyCon) (arg : res : args) co split_apps args ty co = affix_co (fst $ splitPiTys $ typeKind ty) ty args co - -- having broken everything apart, this figures out the point at which there + -- Having broken everything apart, this figures out the point at which there -- are no more dependent quantifications, and puts the cast there - affix_co _ ty [] co = no_double_casts ty co + affix_co _ ty [] co + = no_double_casts ty co affix_co bndrs ty args co -- if kind contains any dependent quantifications, we can't push. -- apply arguments until it doesn't - = let (no_dep_bndrs, some_dep_bndrs) = spanEnd isAnonBinder bndrs + = let (no_dep_bndrs, some_dep_bndrs) = spanEnd isAnonTyBinder bndrs (some_dep_args, rest_args) = splitAtList some_dep_bndrs args dep_subst = zipTyBinderSubst some_dep_bndrs some_dep_args used_no_dep_bndrs = takeList rest_args no_dep_bndrs - rest_arg_tys = substTys dep_subst (map binderType used_no_dep_bndrs) + rest_arg_tys = substTys dep_subst (map tyBinderType used_no_dep_bndrs) co' = mkFunCos Nominal (map (mkReflCo Nominal) rest_arg_tys) co @@ -1177,61 +1182,58 @@ interfaces. Notably this plays a role in tcTySigs in TcBinds.hs. ~~~~~~~~ -} -mkForAllTy :: TyBinder -> Type -> Type -mkForAllTy = ForAllTy - -- | Make a dependent forall. -mkNamedForAllTy :: TyVar -> VisibilityFlag -> Type -> Type -mkNamedForAllTy tv vis = ASSERT( isTyVar tv ) - ForAllTy (Named tv vis) +mkInvForAllTy :: TyVar -> Type -> Type +mkInvForAllTy tv ty = ASSERT( isTyVar tv ) + ForAllTy (TvBndr tv Invisible) ty -- | Like mkForAllTys, but assumes all variables are dependent and invisible, -- a common case mkInvForAllTys :: [TyVar] -> Type -> Type -mkInvForAllTys tvs = ASSERT( all isTyVar tvs ) - mkForAllTys (map (flip Named Invisible) tvs) +mkInvForAllTys tvs ty = ASSERT( all isTyVar tvs ) + foldr mkInvForAllTy ty tvs -- | Like mkForAllTys, but assumes all variables are dependent and specified, -- a common case mkSpecForAllTys :: [TyVar] -> Type -> Type mkSpecForAllTys tvs = ASSERT( all isTyVar tvs ) - mkForAllTys (map (flip Named Specified) tvs) + mkForAllTys [ TvBndr tv Specified | tv <- tvs ] -- | Like mkForAllTys, but assumes all variables are dependent and visible mkVisForAllTys :: [TyVar] -> Type -> Type mkVisForAllTys tvs = ASSERT( all isTyVar tvs ) - mkForAllTys (map (flip Named Visible) tvs) + mkForAllTys [ TvBndr tv Visible | tv <- tvs ] -mkPiType :: Var -> Type -> Type +mkLamType :: Var -> Type -> Type -- ^ Makes a @(->)@ type or an implicit forall type, depending -- on whether it is given a type variable or a term variable. -- This is used, for example, when producing the type of a lambda. -- Always uses Invisible binders. -mkPiTypes :: [Var] -> Type -> Type --- ^ 'mkPiType' for multiple type or value arguments +mkLamTypes :: [Var] -> Type -> Type +-- ^ 'mkLamType' for multiple type or value arguments -mkPiType v ty - | isTyVar v = mkForAllTy (Named v Invisible) ty - | otherwise = mkForAllTy (Anon (varType v)) ty +mkLamType v ty + | isTyVar v = ForAllTy (TvBndr v Invisible) ty + | otherwise = FunTy (varType v) ty -mkPiTypes vs ty = foldr mkPiType ty vs +mkLamTypes vs ty = foldr mkLamType ty vs -- | Given a list of type-level vars and a result type, makes TyBinders, preferring -- anonymous binders if the variable is, in fact, not dependent. -- All binders are /visible/. mkTyBindersPreferAnon :: [TyVar] -> Type -> [TyBinder] -mkTyBindersPreferAnon vars inner_ty = fst $ go vars inner_ty +mkTyBindersPreferAnon vars inner_ty = fst (go vars) where - go :: [TyVar] -> Type -> ([TyBinder], VarSet) -- also returns the free vars - go [] ty = ([], tyCoVarsOfType ty) - go (v:vs) ty | v `elemVarSet` fvs - = ( Named v Visible : binders - , fvs `delVarSet` v `unionVarSet` kind_vars ) - | otherwise - = ( Anon (tyVarKind v) : binders - , fvs `unionVarSet` kind_vars ) + go :: [TyVar] -> ([TyBinder], VarSet) -- also returns the free vars + go [] = ([], tyCoVarsOfType inner_ty) + go (v:vs) | v `elemVarSet` fvs + = ( Named (TvBndr v Visible) : binders + , fvs `delVarSet` v `unionVarSet` kind_vars ) + | otherwise + = ( Anon (tyVarKind v) : binders + , fvs `unionVarSet` kind_vars ) where - (binders, fvs) = go vs ty + (binders, fvs) = go vs kind_vars = tyCoVarsOfType $ tyVarKind v -- | Take a ForAllTy apart, returning the list of tyvars and the result type. @@ -1241,34 +1243,26 @@ splitForAllTys :: Type -> ([TyVar], Type) splitForAllTys ty = split ty ty [] where split orig_ty ty tvs | Just ty' <- coreView ty = split orig_ty ty' tvs - split _ (ForAllTy (Named tv _) ty) tvs = split ty ty (tv:tvs) - split orig_ty _ tvs = (reverse tvs, orig_ty) + split _ (ForAllTy (TvBndr tv _) ty) tvs = split ty ty (tv:tvs) + split orig_ty _ tvs = (reverse tvs, orig_ty) --- | Split off all TyBinders to a type, splitting both proper foralls --- and functions -splitPiTys :: Type -> ([TyBinder], Type) -splitPiTys ty = split ty ty [] +-- | Like 'splitPiTys' but split off only /named/ binders. +splitForAllTyVarBndrs :: Type -> ([TyVarBinder], Type) +splitForAllTyVarBndrs ty = split ty ty [] where split orig_ty ty bs | Just ty' <- coreView ty = split orig_ty ty' bs split _ (ForAllTy b res) bs = split res res (b:bs) split orig_ty _ bs = (reverse bs, orig_ty) --- | Like 'splitPiTys' but split off only /named/ binders. -splitNamedPiTys :: Type -> ([TyBinder], Type) -splitNamedPiTys ty = split ty ty [] - where - split orig_ty ty bs | Just ty' <- coreView ty = split orig_ty ty' bs - split _ (ForAllTy b@(Named {}) res) bs = split res res (b:bs) - split orig_ty _ bs = (reverse bs, orig_ty) - -- | Checks whether this is a proper forall (with a named binder) isForAllTy :: Type -> Bool -isForAllTy (ForAllTy (Named {}) _) = True -isForAllTy _ = False +isForAllTy (ForAllTy {}) = True +isForAllTy _ = False -- | Is this a function or forall? isPiTy :: Type -> Bool isPiTy (ForAllTy {}) = True +isPiTy (FunTy {}) = True isPiTy _ = False -- | Take a forall type apart, or panics if that is not possible. @@ -1277,14 +1271,22 @@ splitForAllTy ty | Just answer <- splitForAllTy_maybe ty = answer | otherwise = pprPanic "splitForAllTy" (ppr ty) +-- | Drops all ForAllTys +dropForAlls :: Type -> Type +dropForAlls ty = go ty + where + go ty | Just ty' <- coreView ty = go ty' + go (ForAllTy _ res) = go res + go res = res + -- | Attempts to take a forall type apart, but only if it's a proper forall, -- with a named binder splitForAllTy_maybe :: Type -> Maybe (TyVar, Type) -splitForAllTy_maybe ty = splitFAT_m ty +splitForAllTy_maybe ty = go ty where - splitFAT_m ty | Just ty' <- coreView ty = splitFAT_m ty' - splitFAT_m (ForAllTy (Named tv _) ty) = Just (tv, ty) - splitFAT_m _ = Nothing + go ty | Just ty' <- coreView ty = go ty' + go (ForAllTy (TvBndr tv _) ty) = Just (tv, ty) + go _ = Nothing -- | Attempts to take a forall type apart; works with proper foralls and -- functions @@ -1292,7 +1294,8 @@ splitPiTy_maybe :: Type -> Maybe (TyBinder, Type) splitPiTy_maybe ty = go ty where go ty | Just ty' <- coreView ty = go ty' - go (ForAllTy bndr ty) = Just (bndr, ty) + go (ForAllTy bndr ty) = Just (Named bndr, ty) + go (FunTy arg res) = Just (Anon arg, res) go _ = Nothing -- | Takes a forall type apart, or panics @@ -1301,13 +1304,27 @@ splitPiTy ty | Just answer <- splitPiTy_maybe ty = answer | otherwise = pprPanic "splitPiTy" (ppr ty) --- | Drops all non-anonymous ForAllTys -dropForAlls :: Type -> Type -dropForAlls ty | Just ty' <- coreView ty = dropForAlls ty' - | otherwise = go ty +-- | Split off all TyBinders to a type, splitting both proper foralls +-- and functions +splitPiTys :: Type -> ([TyBinder], Type) +splitPiTys ty = split ty ty [] where - go (ForAllTy (Named {}) res) = go res - go res = res + split orig_ty ty bs | Just ty' <- coreView ty = split orig_ty ty' bs + split _ (ForAllTy b res) bs = split res res (Named b : bs) + split _ (FunTy arg res) bs = split res res (Anon arg : bs) + split orig_ty _ bs = (reverse bs, orig_ty) + +-- Like splitPiTys, but returns only *invisible* binders, including constraints +-- Stops at the first visible binder +splitPiTysInvisible :: Type -> ([TyBinder], Type) +splitPiTysInvisible ty = split ty ty [] + where + split orig_ty ty bs | Just ty' <- coreView ty = split orig_ty ty' bs + split _ (ForAllTy b@(TvBndr _ vis) res) bs + | isInvisible vis = split res res (Named b : bs) + split _ (FunTy arg res) bs + | isPredTy arg = split res res (Anon arg : bs) + split orig_ty _ bs = (reverse bs, orig_ty) -- | Given a tycon and its arguments, filters out any invisible arguments filterOutInvisibleTypes :: TyCon -> [Type] -> [Type] @@ -1338,28 +1355,16 @@ partitionInvisibles :: TyCon -> (a -> Type) -> [a] -> ([a], [a]) partitionInvisibles tc get_ty = go emptyTCvSubst (tyConKind tc) where go _ _ [] = ([], []) - go subst (ForAllTy bndr res_ki) (x:xs) - | isVisibleBinder bndr = second (x :) (go subst' res_ki xs) - | otherwise = first (x :) (go subst' res_ki xs) + go subst (ForAllTy (TvBndr tv vis) res_ki) (x:xs) + | isVisible vis = second (x :) (go subst' res_ki xs) + | otherwise = first (x :) (go subst' res_ki xs) where - subst' = extendTvSubstBinder subst bndr (get_ty x) + subst' = extendTvSubst subst tv (get_ty x) go subst (TyVarTy tv) xs | Just ki <- lookupTyVar subst tv = go subst ki xs go _ _ xs = ([], xs) -- something is ill-kinded. But this can happen -- when printing errors. Assume everything is visible. --- like splitPiTys, but returns only *invisible* binders, including constraints -splitPiTysInvisible :: Type -> ([TyBinder], Type) -splitPiTysInvisible ty = split ty ty [] - where - split orig_ty ty bndrs - | Just ty' <- coreView ty = split orig_ty ty' bndrs - split _ (ForAllTy bndr ty) bndrs - | isInvisibleBinder bndr - = split ty ty (bndr:bndrs) - - split orig_ty _ bndrs - = (reverse bndrs, orig_ty) {- %************************************************************************ @@ -1370,45 +1375,46 @@ splitPiTysInvisible ty = split ty ty [] -} -- | Make a named binder -mkNamedBinder :: VisibilityFlag -> Var -> TyBinder -mkNamedBinder vis var = Named var vis +mkTyVarBinder :: VisibilityFlag -> Var -> TyVarBinder +mkTyVarBinder vis var = TvBndr var vis -- | Make many named binders -mkNamedBinders :: VisibilityFlag -> [TyVar] -> [TyBinder] -mkNamedBinders vis = map (mkNamedBinder vis) +mkTyVarBinders :: VisibilityFlag -> [TyVar] -> [TyVarBinder] +mkTyVarBinders vis = map (mkTyVarBinder vis) + +mkNamedTyBinders :: VisibilityFlag -> [TyVar] -> [TyBinder] +mkNamedTyBinders vis tvs + = map (mkNamedBinder . mkTyVarBinder vis) tvs -- | Make an anonymous binder mkAnonBinder :: Type -> TyBinder mkAnonBinder = Anon +-- | Make a Named TyBinder +mkNamedBinder :: TyVarBinder -> TyBinder +mkNamedBinder = Named + -- | Does this binder bind a variable that is /not/ erased? Returns -- 'True' for anonymous binders. -isIdLikeBinder :: TyBinder -> Bool -isIdLikeBinder (Named {}) = False -isIdLikeBinder (Anon {}) = True - --- | Does this type, when used to the left of an arrow, require --- a visible argument? This checks to see if the kind of the type --- is constraint. -isVisibleType :: Type -> Bool -isVisibleType = not . isPredTy - -binderVisibility :: TyBinder -> VisibilityFlag -binderVisibility (Named _ vis) = vis -binderVisibility (Anon ty) - | isVisibleType ty = Visible - | otherwise = Invisible - --- | Extract a bound variable in a binder, if any -binderVar_maybe :: TyBinder -> Maybe Var -binderVar_maybe (Named v _) = Just v -binderVar_maybe (Anon {}) = Nothing - --- | Extract a bound variable in a binder, or panics -binderVar :: String -- ^ printed if there is a panic - -> TyBinder -> Var -binderVar _ (Named v _) = v -binderVar e (Anon t) = pprPanic ("binderVar (" ++ e ++ ")") (ppr t) +isAnonTyBinder :: TyBinder -> Bool +isAnonTyBinder (Named {}) = False +isAnonTyBinder (Anon {}) = True + +isNamedTyBinder :: TyBinder -> Bool +isNamedTyBinder (Named {}) = True +isNamedTyBinder (Anon {}) = False + +tyBinderType :: TyBinder -> Type +-- Barely used +tyBinderType (Named tvb) = binderType tvb +tyBinderType (Anon ty) = ty + +tyBinderVisibility :: TyBinder -> VisibilityFlag +-- Barely used +tyBinderVisibility (Named tvb) = binderVisibility tvb +tyBinderVisibility (Anon ty) + | isPredTy ty = Invisible + | otherwise = Visible -- | Extract a relevant type, if there is one. binderRelevantType_maybe :: TyBinder -> Maybe Type @@ -1416,25 +1422,19 @@ binderRelevantType_maybe (Named {}) = Nothing binderRelevantType_maybe (Anon ty) = Just ty -- | Like 'maybe', but for binders. -caseBinder :: TyBinder -- ^ binder to scrutinize - -> (TyVar -> a) -- ^ named case - -> (Type -> a) -- ^ anonymous case +caseBinder :: TyBinder -- ^ binder to scrutinize + -> (TyVarBinder -> a) -- ^ named case + -> (Type -> a) -- ^ anonymous case -> a -caseBinder (Named v _) f _ = f v -caseBinder (Anon t) _ d = d t +caseBinder (Named v) f _ = f v +caseBinder (Anon t) _ d = d t --- | Break apart a list of binders into tyvars and anonymous types. -partitionBinders :: [TyBinder] -> ([TyVar], [Type]) -partitionBinders = partitionWith named_or_anon - where - named_or_anon bndr = caseBinder bndr Left Right - --- | Break apart a list of binders into a list of named binders and --- a list of anonymous types. -partitionBindersIntoBinders :: [TyBinder] -> ([TyBinder], [Type]) -partitionBindersIntoBinders = partitionWith named_or_anon - where - named_or_anon bndr = caseBinder bndr (\_ -> Left bndr) Right +-- | Create a TCvSubst combining the binders and types provided. +-- NB: It is specifically OK if the lists are of different lengths. +-- Barely used +zipTyBinderSubst :: [TyBinder] -> [Type] -> TCvSubst +zipTyBinderSubst bndrs tys + = mkTvSubstPrs [ (tv, ty) | (Named (TvBndr tv _), ty) <- zip bndrs tys ] {- %************************************************************************ @@ -1477,10 +1477,10 @@ isPredTy ty = go ty [] go (TyVarTy tv) args = go_k (tyVarKind tv) args go (TyConApp tc tys) args = ASSERT( null args ) -- TyConApp invariant go_tc tc tys - go (ForAllTy (Anon arg) res) [] + go (FunTy arg res) [] | isPredTy arg = isPredTy res -- (Eq a => C a) | otherwise = False -- (Int -> Bool) - go (ForAllTy (Named {}) ty) [] = go ty [] + go (ForAllTy _ ty) [] = go ty [] go (CastTy _ co) args = go_k (pSnd (coercionKind co)) args go _ _ = False @@ -1715,13 +1715,14 @@ predTypeEqRel ty -- are `eqType` may return different sizes. This is OK, because this -- function is used only in reporting, not decision-making. typeSize :: Type -> Int -typeSize (LitTy {}) = 1 -typeSize (TyVarTy {}) = 1 -typeSize (AppTy t1 t2) = typeSize t1 + typeSize t2 -typeSize (ForAllTy b t) = typeSize (binderType b) + typeSize t -typeSize (TyConApp _ ts) = 1 + sum (map typeSize ts) -typeSize (CastTy ty co) = typeSize ty + coercionSize co -typeSize (CoercionTy co) = coercionSize co +typeSize (LitTy {}) = 1 +typeSize (TyVarTy {}) = 1 +typeSize (AppTy t1 t2) = typeSize t1 + typeSize t2 +typeSize (FunTy t1 t2) = typeSize t1 + typeSize t2 +typeSize (ForAllTy (TvBndr tv _) t) = typeSize (tyVarKind tv) + typeSize t +typeSize (TyConApp _ ts) = 1 + sum (map typeSize ts) +typeSize (CastTy ty co) = typeSize ty + coercionSize co +typeSize (CoercionTy co) = coercionSize co {- ********************************************************************** @@ -1941,9 +1942,9 @@ isUnliftedType :: Type -> Bool -- construct them isUnliftedType ty | Just ty' <- coreView ty = isUnliftedType ty' -isUnliftedType (ForAllTy (Named {}) ty) = isUnliftedType ty -isUnliftedType (TyConApp tc _) = isUnliftedTyCon tc -isUnliftedType _ = False +isUnliftedType (ForAllTy _ ty) = isUnliftedType ty +isUnliftedType (TyConApp tc _) = isUnliftedTyCon tc +isUnliftedType _ = False -- | Extract the RuntimeRep classifier of a type. Panics if this is not possible. getRuntimeRep :: String -- ^ Printed in case of an error @@ -2015,13 +2016,14 @@ isPrimitiveType ty = case splitTyConApp_maybe ty of -} seqType :: Type -> () -seqType (LitTy n) = n `seq` () -seqType (TyVarTy tv) = tv `seq` () -seqType (AppTy t1 t2) = seqType t1 `seq` seqType t2 -seqType (TyConApp tc tys) = tc `seq` seqTypes tys -seqType (ForAllTy bndr ty) = seqType (binderType bndr) `seq` seqType ty -seqType (CastTy ty co) = seqType ty `seq` seqCo co -seqType (CoercionTy co) = seqCo co +seqType (LitTy n) = n `seq` () +seqType (TyVarTy tv) = tv `seq` () +seqType (AppTy t1 t2) = seqType t1 `seq` seqType t2 +seqType (FunTy t1 t2) = seqType t1 `seq` seqType t2 +seqType (TyConApp tc tys) = tc `seq` seqTypes tys +seqType (ForAllTy (TvBndr tv _) ty) = seqType (tyVarKind tv) `seq` seqType ty +seqType (CastTy ty co) = seqType ty `seq` seqCo co +seqType (CoercionTy co) = seqCo co seqTypes :: [Type] -> () seqTypes [] = () @@ -2160,7 +2162,7 @@ nonDetCmpTypeX env orig_t1 orig_t2 = go env (TyVarTy tv1) (TyVarTy tv2) = liftOrdering $ rnOccL env tv1 `nonDetCmpVar` rnOccR env tv2 - go env (ForAllTy (Named tv1 _) t1) (ForAllTy (Named tv2 _) t2) + go env (ForAllTy (TvBndr tv1 _) t1) (ForAllTy (TvBndr tv2 _) t2) = go env (tyVarKind tv1) (tyVarKind tv2) `thenCmpTy` go (rnBndr2 env tv1 tv2) t1 t2 -- See Note [Equality on AppTys] @@ -2170,7 +2172,7 @@ nonDetCmpTypeX env orig_t1 orig_t2 = go env ty1 (AppTy s2 t2) | Just (s1, t1) <- repSplitAppTy_maybe ty1 = go env s1 s2 `thenCmpTy` go env t1 t2 - go env (ForAllTy (Anon s1) t1) (ForAllTy (Anon s2) t2) + go env (FunTy s1 t1) (FunTy s2 t2) = go env s1 s2 `thenCmpTy` go env t1 t2 go env (TyConApp tc1 tys1) (TyConApp tc2 tys2) = liftOrdering (tc1 `nonDetCmpTc` tc2) `thenCmpTy` gos env tys1 tys2 @@ -2185,13 +2187,13 @@ nonDetCmpTypeX env orig_t1 orig_t2 = where get_rank :: Type -> Int get_rank (CastTy {}) = pprPanic "nonDetCmpTypeX.get_rank" (ppr [ty1,ty2]) - get_rank (TyVarTy {}) = 0 - get_rank (CoercionTy {}) = 1 - get_rank (AppTy {}) = 3 - get_rank (LitTy {}) = 4 - get_rank (TyConApp {}) = 5 - get_rank (ForAllTy (Anon {}) _) = 6 - get_rank (ForAllTy (Named {}) _) = 7 + get_rank (TyVarTy {}) = 0 + get_rank (CoercionTy {}) = 1 + get_rank (AppTy {}) = 3 + get_rank (LitTy {}) = 4 + get_rank (TyConApp {}) = 5 + get_rank (FunTy {}) = 6 + get_rank (ForAllTy {}) = 7 gos :: RnEnv2 -> [Type] -> [Type] -> TypeOrdering gos _ [] [] = TEQ @@ -2232,7 +2234,7 @@ typeKind :: Type -> Kind typeKind (TyConApp tc tys) = piResultTys (tyConKind tc) tys typeKind (AppTy fun arg) = piResultTy (typeKind fun) arg typeKind (LitTy l) = typeLiteralKind l -typeKind (ForAllTy (Anon _) _) = liftedTypeKind +typeKind (FunTy {}) = liftedTypeKind typeKind (ForAllTy _ ty) = typeKind ty typeKind (TyVarTy tyvar) = tyVarKind tyvar typeKind (CastTy _ty co) = pSnd $ coercionKind co @@ -2265,14 +2267,14 @@ tyConsOfType ty where go :: Type -> NameEnv TyCon -- The NameEnv does duplicate elim go ty | Just ty' <- coreView ty = go ty' - go (TyVarTy {}) = emptyNameEnv - go (LitTy {}) = emptyNameEnv - go (TyConApp tc tys) = go_tc tc `plusNameEnv` go_s tys - go (AppTy a b) = go a `plusNameEnv` go b - go (ForAllTy (Anon a) b) = go a `plusNameEnv` go b `plusNameEnv` go_tc funTyCon - go (ForAllTy (Named tv _) ty) = go ty `plusNameEnv` go (tyVarKind tv) - go (CastTy ty co) = go ty `plusNameEnv` go_co co - go (CoercionTy co) = go_co co + go (TyVarTy {}) = emptyNameEnv + go (LitTy {}) = emptyNameEnv + go (TyConApp tc tys) = go_tc tc `plusNameEnv` go_s tys + go (AppTy a b) = go a `plusNameEnv` go b + go (FunTy a b) = go a `plusNameEnv` go b `plusNameEnv` go_tc funTyCon + go (ForAllTy (TvBndr tv _) ty) = go ty `plusNameEnv` go (tyVarKind tv) + go (CastTy ty co) = go ty `plusNameEnv` go_co co + go (CoercionTy co) = go_co co go_co (Refl _ ty) = go ty go_co (TyConAppCo _ tc args) = go_tc tc `plusNameEnv` go_cos args @@ -2321,11 +2323,11 @@ splitVisVarsOfType orig_ty = Pair invis_vars vis_vars Pair invis_vars1 vis_vars = go orig_ty invis_vars = invis_vars1 `minusVarSet` vis_vars - go (TyVarTy tv) = Pair (tyCoVarsOfType $ tyVarKind tv) (unitVarSet tv) - go (AppTy t1 t2) = go t1 `mappend` go t2 + go (TyVarTy tv) = Pair (tyCoVarsOfType $ tyVarKind tv) (unitVarSet tv) + go (AppTy t1 t2) = go t1 `mappend` go t2 go (TyConApp tc tys) = go_tc tc tys - go (ForAllTy (Anon t1) t2) = go t1 `mappend` go t2 - go (ForAllTy (Named tv _) ty) + go (FunTy t1 t2) = go t1 `mappend` go t2 + go (ForAllTy (TvBndr tv _) ty) = ((`delVarSet` tv) <$> go ty) `mappend` (invisible (tyCoVarsOfType $ tyVarKind tv)) go (LitTy {}) = mempty diff --git a/compiler/types/Type.hs-boot b/compiler/types/Type.hs-boot index 7c16bc08cc..9436d195cc 100644 --- a/compiler/types/Type.hs-boot +++ b/compiler/types/Type.hs-boot @@ -3,7 +3,7 @@ import TyCon import Var ( TyVar ) import {-# SOURCE #-} TyCoRep( Type, Kind ) -isPredTy :: Type -> Bool +isPredTy :: Type -> Bool isCoercionTy :: Type -> Bool mkAppTy :: Type -> Type -> Type diff --git a/compiler/types/Unify.hs b/compiler/types/Unify.hs index 859403d2b3..3993369a30 100644 --- a/compiler/types/Unify.hs +++ b/compiler/types/Unify.hs @@ -753,7 +753,7 @@ unify_ty ty1 (AppTy ty2a ty2b) _kco unify_ty (LitTy x) (LitTy y) _kco | x == y = return () -unify_ty (ForAllTy (Named tv1 _) ty1) (ForAllTy (Named tv2 _) ty2) kco +unify_ty (ForAllTy (TvBndr tv1 _) ty1) (ForAllTy (TvBndr tv2 _) ty2) kco = do { unify_ty (tyVarKind tv1) (tyVarKind tv2) (mkNomReflCo liftedTypeKind) ; umRnBndr2 tv1 tv2 $ unify_ty ty1 ty2 kco } @@ -1194,10 +1194,10 @@ ty_co_match menv subst ty1 (AppCo co2 arg2) _lkco _rkco ty_co_match menv subst (TyConApp tc1 tys) (TyConAppCo _ tc2 cos) _lkco _rkco = ty_co_match_tc menv subst tc1 tys tc2 cos -ty_co_match menv subst (ForAllTy (Anon ty1) ty2) (TyConAppCo _ tc cos) _lkco _rkco +ty_co_match menv subst (FunTy ty1 ty2) (TyConAppCo _ tc cos) _lkco _rkco = ty_co_match_tc menv subst funTyCon [ty1, ty2] tc cos -ty_co_match menv subst (ForAllTy (Named tv1 _) ty1) +ty_co_match menv subst (ForAllTy (TvBndr tv1 _) ty1) (ForAllCo tv2 kind_co2 co2) lkco rkco = do { subst1 <- ty_co_match menv subst (tyVarKind tv1) kind_co2 @@ -1258,11 +1258,11 @@ ty_co_match_args _ _ _ _ _ _ = Nothing pushRefl :: Coercion -> Maybe Coercion pushRefl (Refl Nominal (AppTy ty1 ty2)) = Just (AppCo (Refl Nominal ty1) (mkNomReflCo ty2)) -pushRefl (Refl r (ForAllTy (Anon ty1) ty2)) +pushRefl (Refl r (FunTy ty1 ty2)) = Just (TyConAppCo r funTyCon [mkReflCo r ty1, mkReflCo r ty2]) pushRefl (Refl r (TyConApp tc tys)) = Just (TyConAppCo r tc (zipWith mkReflCo (tyConRolesX r tc) tys)) -pushRefl (Refl r (ForAllTy (Named tv _) ty)) +pushRefl (Refl r (ForAllTy (TvBndr tv _) ty)) = Just (mkHomoForAllCos_NoRefl [tv] (Refl r ty)) -- NB: NoRefl variant. Otherwise, we get a loop! pushRefl (Refl r (CastTy ty co)) = Just (castCoercionKind (Refl r ty) co co) diff --git a/compiler/vectorise/Vectorise/Convert.hs b/compiler/vectorise/Vectorise/Convert.hs index af807c8fd7..b3b70986e5 100644 --- a/compiler/vectorise/Vectorise/Convert.hs +++ b/compiler/vectorise/Vectorise/Convert.hs @@ -44,7 +44,7 @@ fromVect ty expr -- For each function constructor in the original type we add an outer -- lambda to bind the parameter variable, and an inner application of it. -fromVect (ForAllTy (Anon arg_ty) res_ty) expr +fromVect (FunTy arg_ty res_ty) expr = do arg <- newLocalVar (fsLit "x") arg_ty varg <- toVect arg_ty (Var arg) @@ -84,6 +84,7 @@ identityConv (TyConApp tycon tys) identityConv (LitTy {}) = noV $ text "identityConv: not sure about literal types under vectorisation" identityConv (TyVarTy {}) = noV $ text "identityConv: type variable changes under vectorisation" identityConv (AppTy {}) = noV $ text "identityConv: type appl. changes under vectorisation" +identityConv (FunTy {}) = noV $ text "identityConv: function type changes under vectorisation" identityConv (ForAllTy {}) = noV $ text "identityConv: quantified type changes under vectorisation" identityConv (CastTy {}) = noV $ text "identityConv: not sure about casted types under vectorisation" identityConv (CoercionTy {}) = noV $ text "identityConv: not sure about coercions under vectorisation" diff --git a/compiler/vectorise/Vectorise/Generic/PData.hs b/compiler/vectorise/Vectorise/Generic/PData.hs index 2c403bf82a..23cd0a2cb0 100644 --- a/compiler/vectorise/Vectorise/Generic/PData.hs +++ b/compiler/vectorise/Vectorise/Generic/PData.hs @@ -85,8 +85,8 @@ buildPDataDataCon orig_name vect_tc repr_tc repr (map (const no_bang) comp_tys) (Just $ map (const HsLazy) comp_tys) [] -- no field labels - tvs (mkNamedBinders Specified tvs) - [] [] -- no existentials + tvs (map (mkNamedBinder . mkTyVarBinder Specified) tvs) + [] -- no existentials [] -- no eq spec [] -- no context comp_tys @@ -129,8 +129,8 @@ buildPDatasDataCon orig_name vect_tc repr_tc repr (map (const no_bang) comp_tys) (Just $ map (const HsLazy) comp_tys) [] -- no field labels - tvs (mkNamedBinders Specified tvs) - [] [] -- no existentials + tvs (map (mkNamedBinder . mkTyVarBinder Specified) tvs) + [] -- no existentials [] -- no eq spec [] -- no context comp_tys diff --git a/compiler/vectorise/Vectorise/Type/TyConDecl.hs b/compiler/vectorise/Vectorise/Type/TyConDecl.hs index 4bf6515826..052eced404 100644 --- a/compiler/vectorise/Vectorise/Type/TyConDecl.hs +++ b/compiler/vectorise/Vectorise/Type/TyConDecl.hs @@ -192,7 +192,7 @@ vectDataCon dc (Just $ dataConImplBangs dc) [] -- no labelled fields for now univ_tvs univ_bndrs -- universally quantified vars - [] [] -- no existential tvs for now + [] -- no existential tvs for now [] -- no equalities for now [] -- no context for now arg_tys -- argument types @@ -204,4 +204,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 = dataConUnivTyBinders dc + univ_bndrs = map mkNamedBinder (dataConUnivTyVarBinders dc) diff --git a/compiler/vectorise/Vectorise/Type/Type.hs b/compiler/vectorise/Vectorise/Type/Type.hs index 088269130f..88d3f565f3 100644 --- a/compiler/vectorise/Vectorise/Type/Type.hs +++ b/compiler/vectorise/Vectorise/Type/Type.hs @@ -58,7 +58,7 @@ vectType (TyVarTy tv) = return $ TyVarTy tv vectType (LitTy l) = return $ LitTy l vectType (AppTy ty1 ty2) = AppTy <$> vectType ty1 <*> vectType ty2 vectType (TyConApp tc tys) = TyConApp <$> vectTyCon tc <*> mapM vectType tys -vectType (ForAllTy (Anon ty1) ty2) +vectType (FunTy ty1 ty2) | isPredTy ty1 = mkFunTy <$> vectType ty1 <*> vectType ty2 -- don't build a closure for dictionary abstraction | otherwise diff --git a/compiler/vectorise/Vectorise/Utils/PADict.hs b/compiler/vectorise/Vectorise/Utils/PADict.hs index ca2006b91f..9cd740cf53 100644 --- a/compiler/vectorise/Vectorise/Utils/PADict.hs +++ b/compiler/vectorise/Vectorise/Utils/PADict.hs @@ -33,7 +33,7 @@ import Control.Monad paDictArgType :: TyVar -> VM (Maybe Type) paDictArgType tv = go (mkTyVarTy tv) (tyVarKind tv) where - go ty (ForAllTy (Anon k1) k2) + go ty (FunTy k1 k2) = do tv <- if isCoercionType k1 then newCoVar (fsLit "c") k1 @@ -42,7 +42,7 @@ paDictArgType tv = go (mkTyVarTy tv) (tyVarKind tv) case mty1 of Just ty1 -> do mty2 <- go (mkAppTy ty (mkTyVarTy tv)) k2 - return $ fmap (mkNamedForAllTy tv Invisible . mkFunTy ty1) mty2 + return $ fmap (mkInvForAllTy tv . mkFunTy ty1) mty2 Nothing -> go ty k2 go ty k diff --git a/libraries/Win32 b/libraries/Win32 -Subproject bb9469ece0b882017fa7f3b51e8db1d2985d672 +Subproject fec966e6d77a5e7f4a586de6096954137a1fe91 diff --git a/libraries/bytestring b/libraries/bytestring -Subproject 84253da85952765dd7631e467cc2b1d1bba03f2 +Subproject 3d6d0f60ac25736cc87a6f598886fe77e7b6ad9 diff --git a/libraries/hpc b/libraries/hpc -Subproject d8b5381bd5d03a3a75f4a1b91f1ede6fe0fd0ce +Subproject fbe2b7b9e163daa8fbe3c8f2dddc1132aa4e735 diff --git a/libraries/time b/libraries/time -Subproject 52e0f5e85ffbaab77b155d48720fb216021c8a7 +Subproject a73564c366b15f7057b614188662d7b7a8eaab1 diff --git a/libraries/vector b/libraries/vector -Subproject 224eccbac0125b7bd302f24063bbb473b2c2e1d +Subproject 6c17dd6fadc5e7e3e09f7892380ce1339f296ef diff --git a/nofib b/nofib -Subproject 35fc121fc8cc501ea2713c579a053be7ea65b16 +Subproject dfa9f9158943d2c441add8ccd4309c1b93fb347 diff --git a/testsuite/tests/dependent/should_fail/T11334b.stderr b/testsuite/tests/dependent/should_fail/T11334b.stderr index 4fcc593f80..8f4251b0cd 100644 --- a/testsuite/tests/dependent/should_fail/T11334b.stderr +++ b/testsuite/tests/dependent/should_fail/T11334b.stderr @@ -1,7 +1,7 @@ T11334b.hs:8:14: error: • Cannot default kind variable ‘f0’ - of kind: k10 -> * + of kind: k0 -> * Perhaps enable PolyKinds or add a kind signature • In an expression type signature: Proxy Compose In the expression: Proxy :: Proxy Compose @@ -9,7 +9,7 @@ T11334b.hs:8:14: error: T11334b.hs:8:14: error: • Cannot default kind variable ‘g0’ - of kind: k0 -> k10 + of kind: k10 -> k0 Perhaps enable PolyKinds or add a kind signature • In an expression type signature: Proxy Compose In the expression: Proxy :: Proxy Compose @@ -17,7 +17,7 @@ T11334b.hs:8:14: error: T11334b.hs:8:14: error: • Cannot default kind variable ‘a0’ - of kind: k0 + of kind: k10 Perhaps enable PolyKinds or add a kind signature • In an expression type signature: Proxy Compose In the expression: Proxy :: Proxy Compose diff --git a/testsuite/tests/ghci/scripts/T7587.stdout b/testsuite/tests/ghci/scripts/T7587.stdout index 975ad8f9a5..776eb6d223 100644 --- a/testsuite/tests/ghci/scripts/T7587.stdout +++ b/testsuite/tests/ghci/scripts/T7587.stdout @@ -1 +1 @@ -A :: k1 -> k -> * +A :: k -> k1 -> * diff --git a/testsuite/tests/ghci/scripts/T7730.stdout b/testsuite/tests/ghci/scripts/T7730.stdout index 94837b47cc..fcf9e4c1d2 100644 --- a/testsuite/tests/ghci/scripts/T7730.stdout +++ b/testsuite/tests/ghci/scripts/T7730.stdout @@ -1,7 +1,7 @@ type role A phantom phantom -data A (x :: k1) (y :: k) +data A (x :: k) (y :: k1) -- Defined at <interactive>:2:1 -A :: k1 -> k -> * +A :: k -> k1 -> * type role T phantom data T (a :: k) where MkT :: forall k (a :: k) a1. a1 -> T a diff --git a/testsuite/tests/partial-sigs/should_compile/T10403.stderr b/testsuite/tests/partial-sigs/should_compile/T10403.stderr index 753b983a15..3cebd8f92a 100644 --- a/testsuite/tests/partial-sigs/should_compile/T10403.stderr +++ b/testsuite/tests/partial-sigs/should_compile/T10403.stderr @@ -1,77 +1,82 @@ -
-T10403.hs:15:7: warning: [-Wpartial-type-signatures (in -Wdefault)]
- • Found type wildcard ‘_’ standing for ‘Functor f’
- Where: ‘f’ is a rigid type variable bound by
- the inferred type of h1 :: Functor f => (a -> b) -> f a -> H f
- at T10403.hs:17:1-41
- • In the type signature: h1 :: _ => _
-
-T10403.hs:15:12: warning: [-Wpartial-type-signatures (in -Wdefault)]
- • Found type wildcard ‘_’ standing for ‘(a -> b) -> f a -> H f’
- Where: ‘f’ is a rigid type variable bound by
- the inferred type of h1 :: Functor f => (a -> b) -> f a -> H f
- at T10403.hs:17:1-41
- ‘b’ is a rigid type variable bound by
- the inferred type of h1 :: Functor f => (a -> b) -> f a -> H f
- at T10403.hs:17:1-41
- ‘a’ is a rigid type variable bound by
- the inferred type of h1 :: Functor f => (a -> b) -> f a -> H f
- at T10403.hs:17:1-41
- • In the type signature: h1 :: _ => _
-
-T10403.hs:19:7: warning: [-Wpartial-type-signatures (in -Wdefault)]
- • Found type wildcard ‘_’ standing for ‘(a -> b) -> f0 a -> H f0’
- Where: ‘f0’ is an ambiguous type variable
- ‘b’ is a rigid type variable bound by
- the inferred type of h2 :: (a -> b) -> f0 a -> H f0
- at T10403.hs:22:1-41
- ‘a’ is a rigid type variable bound by
- the inferred type of h2 :: (a -> b) -> f0 a -> H f0
- at T10403.hs:22:1-41
- • In the type signature: h2 :: _
-
-T10403.hs:22:15: warning: [-Wdeferred-type-errors (in -Wdefault)]
- • Ambiguous type variable ‘f0’ arising from a use of ‘fmap’
- prevents the constraint ‘(Functor f0)’ from being solved.
- Relevant bindings include
- b :: f0 a (bound at T10403.hs:22:6)
- h2 :: (a -> b) -> f0 a -> H f0 (bound at T10403.hs:22:1)
- Probable fix: use a type annotation to specify what ‘f0’ should be.
- These potential instances exist:
- instance Functor IO -- Defined in ‘GHC.Base’
- instance Functor (B t) -- Defined at T10403.hs:10:10
- instance Functor I -- Defined at T10403.hs:6:10
- ...plus four others
- (use -fprint-potential-instances to see them all)
- • In the second argument of ‘(.)’, namely ‘fmap (const ())’
- In the expression: H . fmap (const ())
- In the expression: (H . fmap (const ())) (fmap f b)
-
-T10403.hs:28:8: warning: [-Wdeferred-type-errors (in -Wdefault)]
- • Couldn't match type ‘f0’ with ‘B t’
- because type variable ‘t’ would escape its scope
- This (rigid, skolem) type variable is bound by
- the type signature for:
- app2 :: H (B t)
- at T10403.hs:27:1-15
- Expected type: H (B t)
- Actual type: H f0
- • In the expression: h2 (H . I) (B ())
- In an equation for ‘app2’: app2 = h2 (H . I) (B ())
- • Relevant bindings include
- app2 :: H (B t) (bound at T10403.hs:28:1)
-
-T10403.hs:28:20: warning: [-Wdeferred-type-errors (in -Wdefault)]
- • Couldn't match type ‘f0’ with ‘B t’
- because type variable ‘t’ would escape its scope
- This (rigid, skolem) type variable is bound by
- the type signature for:
- app2 :: H (B t)
- at T10403.hs:27:1-15
- Expected type: f0 ()
- Actual type: B t ()
- • In the second argument of ‘h2’, namely ‘(B ())’
- In the expression: h2 (H . I) (B ())
- In an equation for ‘app2’: app2 = h2 (H . I) (B ())
- • Relevant bindings include
- app2 :: H (B t) (bound at T10403.hs:28:1)
+ +T10403.hs:15:7: warning: [-Wpartial-type-signatures (in -Wdefault)] + Found constraint wildcard ‘_’ standing for ‘Functor f’ + In the type signature: + h1 :: _ => _ + +T10403.hs:15:12: warning: [-Wpartial-type-signatures (in -Wdefault)] + • Found type wildcard ‘_’ standing for ‘(a -> b) -> f a -> H f’ + Where: ‘b’ is a rigid type variable bound by + the inferred type of h1 :: Functor f => (a -> b) -> f a -> H f + at T10403.hs:17:1 + ‘a’ is a rigid type variable bound by + the inferred type of h1 :: Functor f => (a -> b) -> f a -> H f + at T10403.hs:17:1 + ‘f’ is a rigid type variable bound by + the inferred type of h1 :: Functor f => (a -> b) -> f a -> H f + at T10403.hs:17:1 + • In the type signature: + h1 :: _ => _ + • Relevant bindings include + h1 :: (a -> b) -> f a -> H f (bound at T10403.hs:17:1) + +T10403.hs:19:7: warning: [-Wpartial-type-signatures (in -Wdefault)] + • Found type wildcard ‘_’ standing for ‘(a -> b) -> f0 a -> H f0’ + Where: ‘b’ is a rigid type variable bound by + the inferred type of h2 :: (a -> b) -> f0 a -> H f0 + at T10403.hs:22:1 + ‘a’ is a rigid type variable bound by + the inferred type of h2 :: (a -> b) -> f0 a -> H f0 + at T10403.hs:22:1 + ‘f0’ is an ambiguous type variable + • In the type signature: + h2 :: _ + • Relevant bindings include + h2 :: (a -> b) -> f0 a -> H f0 (bound at T10403.hs:22:1) + +T10403.hs:22:15: warning: [-Wdeferred-type-errors (in -Wdefault)] + • Ambiguous type variable ‘f0’ arising from a use of ‘fmap’ + prevents the constraint ‘(Functor f0)’ from being solved. + Relevant bindings include + b :: f0 a (bound at T10403.hs:22:6) + h2 :: (a -> b) -> f0 a -> H f0 (bound at T10403.hs:22:1) + Probable fix: use a type annotation to specify what ‘f0’ should be. + These potential instances exist: + instance Functor IO -- Defined in ‘GHC.Base’ + instance Functor (B t) -- Defined at T10403.hs:10:10 + instance Functor I -- Defined at T10403.hs:6:10 + ...plus four others + (use -fprint-potential-instances to see them all) + • In the second argument of ‘(.)’, namely ‘fmap (const ())’ + In the expression: H . fmap (const ()) + In the expression: (H . fmap (const ())) (fmap f b) + +T10403.hs:28:8: warning: [-Wdeferred-type-errors (in -Wdefault)] + • Couldn't match type ‘f0’ with ‘B t’ + because type variable ‘t’ would escape its scope + This (rigid, skolem) type variable is bound by + the type signature for: + app2 :: H (B t) + at T10403.hs:27:1-15 + Expected type: H (B t) + Actual type: H f0 + • In the expression: h2 (H . I) (B ()) + In an equation for ‘app2’: app2 = h2 (H . I) (B ()) + • Relevant bindings include + app2 :: H (B t) (bound at T10403.hs:28:1) + +T10403.hs:28:20: warning: [-Wdeferred-type-errors (in -Wdefault)] + • Couldn't match type ‘f0’ with ‘B t’ + because type variable ‘t’ would escape its scope + This (rigid, skolem) type variable is bound by + the type signature for: + app2 :: H (B t) + at T10403.hs:27:1-15 + Expected type: f0 () + Actual type: B t () + • In the second argument of ‘h2’, namely ‘(B ())’ + In the expression: h2 (H . I) (B ()) + In an equation for ‘app2’: app2 = h2 (H . I) (B ()) + • Relevant bindings include + app2 :: H (B t) (bound at T10403.hs:28:1) + diff --git a/testsuite/tests/partial-sigs/should_compile/T11192.stderr b/testsuite/tests/partial-sigs/should_compile/T11192.stderr index c2a9db5a96..c7420eb3d7 100644 --- a/testsuite/tests/partial-sigs/should_compile/T11192.stderr +++ b/testsuite/tests/partial-sigs/should_compile/T11192.stderr @@ -1,38 +1,45 @@ -
-T11192.hs:7:14: warning: [-Wpartial-type-signatures (in -Wdefault)]
- • Found type wildcard ‘_’ standing for ‘Int -> t -> t’
- Where: ‘t’ is a rigid type variable bound by
- the inferred type of go :: Int -> t -> t at T11192.hs:8:8-17
- • In the type signature: go :: _
- In the expression:
- let
- go :: _
- go 0 a = a
- in go (0 :: Int) undefined
- In an equation for ‘fails’:
- fails
- = let
- go :: _
- go 0 a = a
- in go (0 :: Int) undefined
- • Relevant bindings include fails :: a (bound at T11192.hs:6:1)
-
-T11192.hs:13:14: warning: [-Wpartial-type-signatures (in -Wdefault)]
- • Found type wildcard ‘_’ standing for ‘t1 -> t -> t’
- Where: ‘t’ is a rigid type variable bound by
- the inferred type of go :: t1 -> t -> t at T11192.hs:14:8-17
- ‘t1’ is a rigid type variable bound by
- the inferred type of go :: t1 -> t -> t at T11192.hs:14:8-17
- • In the type signature: go :: _
- In the expression:
- let
- go :: _
- go _ a = a
- in go (0 :: Int) undefined
- In an equation for ‘succeeds’:
- succeeds
- = let
- go :: _
- go _ a = a
- in go (0 :: Int) undefined
- • Relevant bindings include succeeds :: a (bound at T11192.hs:12:1)
+ +T11192.hs:7:14: warning: [-Wpartial-type-signatures (in -Wdefault)] + • Found type wildcard ‘_’ standing for ‘Int -> t -> t’ + Where: ‘t’ is a rigid type variable bound by + the inferred type of go :: Int -> t -> t at T11192.hs:8:8 + • In the type signature: + go :: _ + In the expression: + let + go :: _ + go 0 a = a + in go (0 :: Int) undefined + In an equation for ‘fails’: + fails + = let + go :: _ + go 0 a = a + in go (0 :: Int) undefined + • Relevant bindings include + go :: Int -> t -> t (bound at T11192.hs:8:8) + fails :: a (bound at T11192.hs:6:1) + +T11192.hs:13:14: warning: [-Wpartial-type-signatures (in -Wdefault)] + • Found type wildcard ‘_’ standing for ‘t -> t1 -> t1’ + Where: ‘t’ is a rigid type variable bound by + the inferred type of go :: t -> t1 -> t1 at T11192.hs:14:8 + ‘t1’ is a rigid type variable bound by + the inferred type of go :: t -> t1 -> t1 at T11192.hs:14:8 + • In the type signature: + go :: _ + In the expression: + let + go :: _ + go _ a = a + in go (0 :: Int) undefined + In an equation for ‘succeeds’: + succeeds + = let + go :: _ + go _ a = a + in go (0 :: Int) undefined + • Relevant bindings include + go :: t -> t1 -> t1 (bound at T11192.hs:14:8) + succeeds :: a (bound at T11192.hs:12:1) + diff --git a/testsuite/tests/partial-sigs/should_fail/T10045.stderr b/testsuite/tests/partial-sigs/should_fail/T10045.stderr index 74bfaae357..e9cac55e9e 100644 --- a/testsuite/tests/partial-sigs/should_fail/T10045.stderr +++ b/testsuite/tests/partial-sigs/should_fail/T10045.stderr @@ -1,23 +1,26 @@ -
-T10045.hs:6:18: error:
- • Found type wildcard ‘_’ standing for ‘t2 -> Bool -> t1’
- Where: ‘t1’ is a rigid type variable bound by
- the inferred type of copy :: t2 -> Bool -> t1 at T10045.hs:7:10-34
- ‘t2’ is a rigid type variable bound by
- the inferred type of copy :: t2 -> Bool -> t1 at T10045.hs:7:10-34
- To use the inferred type, enable PartialTypeSignatures
- • In the type signature: copy :: _
- In the expression:
- let
- copy :: _
- copy w from = copy w True
- in copy ws1 False
- In an equation for ‘foo’:
- foo (Meta ws1)
- = let
- copy :: _
- copy w from = copy w True
- in copy ws1 False
- • Relevant bindings include
- ws1 :: () (bound at T10045.hs:5:11)
- foo :: Meta -> t (bound at T10045.hs:5:1)
+ +T10045.hs:6:18: error: + • Found type wildcard ‘_’ standing for ‘t1 -> Bool -> t2’ + Where: ‘t1’ is a rigid type variable bound by + the inferred type of copy :: t1 -> Bool -> t2 at T10045.hs:7:10 + ‘t2’ is a rigid type variable bound by + the inferred type of copy :: t1 -> Bool -> t2 at T10045.hs:7:10 + To use the inferred type, enable PartialTypeSignatures + • In the type signature: + copy :: _ + In the expression: + let + copy :: _ + copy w from = copy w True + in copy ws1 False + In an equation for ‘foo’: + foo (Meta ws1) + = let + copy :: _ + copy w from = copy w True + in copy ws1 False + • Relevant bindings include + copy :: t1 -> Bool -> t2 (bound at T10045.hs:7:10) + ws1 :: () (bound at T10045.hs:5:11) + foo :: Meta -> t (bound at T10045.hs:5:1) + diff --git a/testsuite/tests/polykinds/T9017.stderr b/testsuite/tests/polykinds/T9017.stderr index 3e7f60e9b1..409e66ae6c 100644 --- a/testsuite/tests/polykinds/T9017.stderr +++ b/testsuite/tests/polykinds/T9017.stderr @@ -1,13 +1,14 @@ -
-T9017.hs:8:7: error:
- • Couldn't match kind ‘k1’ with ‘*’
- ‘k1’ is a rigid type variable bound by
- the type signature for:
- foo :: forall k k1 (a :: k1 -> k -> *) (b :: k1) (m :: k1 -> k).
- a b (m b)
- at T9017.hs:7:1-16
- When matching the kind of ‘a’
- • In the expression: arr return
- In an equation for ‘foo’: foo = arr return
- • Relevant bindings include
- foo :: a b (m b) (bound at T9017.hs:8:1)
+ +T9017.hs:8:7: error: + • Couldn't match kind ‘k1’ with ‘*’ + ‘k1’ is a rigid type variable bound by + the type signature for: + foo :: forall k k1 (a :: k -> k1 -> *) (b :: k) (m :: k -> k1). + a b (m b) + at T9017.hs:7:8 + When matching the kind of ‘a’ + • In the expression: arr return + In an equation for ‘foo’: foo = arr return + • Relevant bindings include + foo :: a b (m b) (bound at T9017.hs:8:1) + diff --git a/testsuite/tests/typecheck/should_fail/VtaFail.stderr b/testsuite/tests/typecheck/should_fail/VtaFail.stderr index ff1539850a..03671b0b04 100644 --- a/testsuite/tests/typecheck/should_fail/VtaFail.stderr +++ b/testsuite/tests/typecheck/should_fail/VtaFail.stderr @@ -1,6 +1,6 @@ VtaFail.hs:7:16: error: - • Cannot apply expression of type ‘t1 -> t0 -> (t1, t0)’ + • Cannot apply expression of type ‘t0 -> t1 -> (t0, t1)’ to a visible type argument ‘Int’ • In the expression: pairup_nosig @Int @Bool 5 True In an equation for ‘answer_nosig’: diff --git a/utils/haddock b/utils/haddock -Subproject 09054c2c6ac346b19d0dec9a43956fcea1c272f +Subproject f833ba8cdbe6ea9436f9f7bf79494a968e8394f |