diff options
| author | Simon Peyton Jones <simonpj@microsoft.com> | 2016-05-27 15:26:46 +0100 |
|---|---|---|
| committer | Simon Peyton Jones <simonpj@microsoft.com> | 2016-06-15 14:41:49 +0100 |
| commit | 77bb09270c70455bbd547470c4e995707d19f37d (patch) | |
| tree | 3dbd57122d9931d2766fa32df0a4a29731f02d2a | |
| parent | e33ca0e54f3c20a8b233a3f7b38e4968a4955300 (diff) | |
| download | haskell-77bb09270c70455bbd547470c4e995707d19f37d.tar.gz | |
Re-add FunTy (big patch)
With TypeInType Richard combined ForAllTy and FunTy, but that was often
awkward, and yielded little benefit becuase in practice the two were
always treated separately. This patch re-introduces FunTy. Specfically
* New type
data TyVarBinder = TvBndr TyVar VisibilityFlag
This /always/ has a TyVar it. In many places that's just what
what we want, so there are /lots/ of TyBinder -> TyVarBinder changes
* TyBinder still exists:
data TyBinder = Named TyVarBinder | Anon Type
* data Type = ForAllTy TyVarBinder Type
| FunTy Type Type
| ....
There are a LOT of knock-on changes, but they are all routine.
The Haddock submodule needs to be updated too
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 |