diff options
| author | Simon Peyton Jones <simonpj@microsoft.com> | 2016-06-15 13:27:12 +0100 |
|---|---|---|
| committer | Simon Peyton Jones <simonpj@microsoft.com> | 2016-06-15 17:36:02 +0100 |
| commit | e368f3265b80aeb337fbac3f6a70ee54ab14edfd (patch) | |
| tree | c38b396e267a5f8172751daa8f985c22d6f92760 | |
| parent | 77bb09270c70455bbd547470c4e995707d19f37d (diff) | |
| download | haskell-e368f3265b80aeb337fbac3f6a70ee54ab14edfd.tar.gz | |
Major patch to introduce TyConBinder
Before this patch, following the TypeInType innovations,
each TyCon had two lists:
- tyConBinders :: [TyBinder]
- tyConTyVars :: [TyVar]
They were in 1-1 correspondence and contained
overlapping information. More broadly, there were many
places where we had to pass around this pair of lists,
instead of a single list.
This commit tidies all that up, by having just one list of
binders in a TyCon:
- tyConBinders :: [TyConBinder]
The new data types look like this:
Var.hs:
data TyVarBndr tyvar vis = TvBndr tyvar vis
data VisibilityFlag = Visible | Specified | Invisible
type TyVarBinder = TyVarBndr TyVar VisibilityFlag
TyCon.hs:
type TyConBinder = TyVarBndr TyVar TyConBndrVis
data TyConBndrVis
= NamedTCB VisibilityFlag
| AnonTCB
TyCoRep.hs:
data TyBinder
= Named TyVarBinder
| Anon Type
Note that Var.TyVarBdr has moved from TyCoRep and has been
made polymorphic in the tyvar and visiblity fields:
type TyVarBinder = TyVarBndr TyVar VisibilityFlag
-- Used in ForAllTy
type TyConBinder = TyVarBndr TyVar TyConBndrVis
-- Used in TyCon
type IfaceForAllBndr = TyVarBndr IfaceTvBndr VisibilityFlag
type IfaceTyConBinder = TyVarBndr IfaceTvBndr TyConBndrVis
-- Ditto, in interface files
There are a zillion knock-on changes, but everything
arises from these types. It was a bit fiddly to get the
module loops to work out right!
Some smaller points
~~~~~~~~~~~~~~~~~~~
* Nice new functions
TysPrim.mkTemplateKiTyVars
TysPrim.mkTemplateTyConBinders
which help you make the tyvar binders for dependently-typed
TyCons. See comments with their definition.
* The change showed up a bug in TcGenGenerics.tc_mkRepTy, where the code
was making an assumption about the order of the kind variables in the
kind of GHC.Generics.(:.:). I fixed this; see TcGenGenerics.mkComp.
104 files changed, 1475 insertions, 1378 deletions
diff --git a/compiler/basicTypes/DataCon.hs b/compiler/basicTypes/DataCon.hs index b5a22631ae..670754dea3 100644 --- a/compiler/basicTypes/DataCon.hs +++ b/compiler/basicTypes/DataCon.hs @@ -77,7 +77,9 @@ import BasicTypes import FastString import Module import Binary +import UniqSet import UniqFM +import Unique( mkAlphaTyVarUnique ) import qualified Data.Data as Data import Data.Char @@ -797,20 +799,50 @@ mkDataCon name declared_infix prom_info rep_ty = mkForAllTys univ_tvs $ mkForAllTys ex_tvs $ mkFunTys rep_arg_tys $ - mkTyConApp rep_tycon (mkTyVarTys (map binderVar univ_tvs)) + mkTyConApp rep_tycon (mkTyVarTys (binderVars univ_tvs)) -- See Note [Promoted data constructors] in TyCon - 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 + prom_tv_bndrs = [ mkNamedTyConBinder vis tv + | TvBndr tv vis <- filterEqSpec eq_spec univ_tvs ++ ex_tvs ] + + prom_arg_bndrs = mkCleanAnonTyConBinders prom_tv_bndrs (theta ++ orig_arg_tys) + prom_res_kind = orig_res_ty + promoted = mkPromotedDataCon con name prom_info + (prom_tv_bndrs ++ prom_arg_bndrs) + prom_res_kind roles rep_info roles = map (const Nominal) (univ_tvs ++ ex_tvs) ++ map (const Representational) orig_arg_tys +mkCleanAnonTyConBinders :: [TyConBinder] -> [Type] -> [TyConBinder] +-- Make sure that the "anonymous" tyvars don't clash in +-- name or unique with the universal/existential ones. +-- Tiresome! And unnecessary because these tyvars are never looked at +mkCleanAnonTyConBinders tc_bndrs tys + = [ mkAnonTyConBinder (mkTyVar name ty) + | (name, ty) <- fresh_names `zip` tys ] + where + fresh_names = freshNames (map getName (binderVars tc_bndrs)) + +freshNames :: [Name] -> [Name] +-- Make names whose Uniques and OccNames differ from +-- those in the 'avoid' list +freshNames avoids + = [ mkSystemName uniq occ + | n <- [0..] + , let uniq = mkAlphaTyVarUnique n + occ = mkTyVarOccFS (mkFastString ('x' : show n)) + + , not (uniq `elementOfUniqSet` avoid_uniqs) + , not (occ `elemOccSet` avoid_occs) ] + + where + avoid_uniqs :: UniqSet Unique + avoid_uniqs = mkUniqSet (map getUnique avoids) + + avoid_occs :: OccSet + avoid_occs = mkOccSet (map getOccName avoids) + -- | The 'Name' of the 'DataCon', giving it a unique, rooted identification dataConName :: DataCon -> Name dataConName = dcName @@ -842,7 +874,7 @@ dataConIsInfix = dcInfix -- | The universally-quantified type variables of the constructor dataConUnivTyVars :: DataCon -> [TyVar] -dataConUnivTyVars (MkData { dcUnivTyVars = tvbs }) = map binderVar tvbs +dataConUnivTyVars (MkData { dcUnivTyVars = tvbs }) = binderVars tvbs -- | 'TyBinder's for the universally-quantified type variables dataConUnivTyVarBinders :: DataCon -> [TyVarBinder] @@ -850,7 +882,7 @@ dataConUnivTyVarBinders = dcUnivTyVars -- | The existentially-quantified type variables of the constructor dataConExTyVars :: DataCon -> [TyVar] -dataConExTyVars (MkData { dcExTyVars = tvbs }) = map binderVar tvbs +dataConExTyVars (MkData { dcExTyVars = tvbs }) = binderVars tvbs -- | 'TyBinder's for the existentially-quantified type variables dataConExTyVarBinders :: DataCon -> [TyVarBinder] @@ -859,7 +891,7 @@ dataConExTyVarBinders = dcExTyVars -- | Both the universal and existentiatial type variables of the constructor dataConAllTyVars :: DataCon -> [TyVar] dataConAllTyVars (MkData { dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs }) - = map binderVar (univ_tvs ++ ex_tvs) + = binderVars (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 @@ -1014,9 +1046,9 @@ dataConInstSig (MkData { dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs , substTheta subst (eqSpecPreds eq_spec ++ theta) , substTys subst arg_tys) where - univ_subst = zipTvSubst (map binderVar univ_tvs) univ_tys + univ_subst = zipTvSubst (binderVars univ_tvs) univ_tys (subst, ex_tvs') = mapAccumL Type.substTyVarBndr univ_subst $ - map binderVar ex_tvs + binderVars ex_tvs -- | The \"full signature\" of the 'DataCon' returns, in order: @@ -1038,7 +1070,7 @@ dataConFullSig :: DataCon dataConFullSig (MkData {dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs, dcEqSpec = eq_spec, dcOtherTheta = theta, dcOrigArgTys = arg_tys, dcOrigResTy = res_ty}) - = (map binderVar univ_tvs, map binderVar ex_tvs, eq_spec, theta, arg_tys, res_ty) + = (binderVars univ_tvs, binderVars ex_tvs, eq_spec, theta, arg_tys, res_ty) dataConOrigResTy :: DataCon -> Type dataConOrigResTy dc = dcOrigResTy dc @@ -1086,7 +1118,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 (map binderVar univ_tvs) inst_tys) (dataConRepArgTys dc) + map (substTyWith (binderVars univ_tvs) inst_tys) (dataConRepArgTys dc) -- | Returns just the instantiated /value/ argument types of a 'DataCon', -- (excluding dictionary args) @@ -1104,7 +1136,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 = map binderVar (univ_tvs ++ ex_tvs) + tyvars = binderVars (univ_tvs ++ ex_tvs) -- | Returns the argument types of the wrapper, excluding all dictionary arguments -- and without substituting for any type variables @@ -1265,7 +1297,7 @@ buildAlgTyCon :: Name buildAlgTyCon tc_name ktvs roles cType stupid_theta rhs is_rec gadt_syn parent - = mkAlgTyCon tc_name binders liftedTypeKind ktvs roles cType stupid_theta + = mkAlgTyCon tc_name binders liftedTypeKind roles cType stupid_theta rhs parent is_rec gadt_syn where - binders = mkTyBindersPreferAnon ktvs liftedTypeKind + binders = mkTyConBindersPreferAnon ktvs liftedTypeKind diff --git a/compiler/basicTypes/DataCon.hs-boot b/compiler/basicTypes/DataCon.hs-boot index 6de1f2707c..7f512c2b42 100644 --- a/compiler/basicTypes/DataCon.hs-boot +++ b/compiler/basicTypes/DataCon.hs-boot @@ -1,12 +1,12 @@ module DataCon where -import Var( TyVar ) +import Var( TyVar, TyVarBinder ) import Name( Name, NamedThing ) import {-# SOURCE #-} TyCon( TyCon ) import FieldLabel ( FieldLabel ) import Unique ( Uniquable ) import Outputable ( Outputable, OutputableBndr ) import BasicTypes (Arity) -import {-# SOURCE #-} TyCoRep (Type, ThetaType, TyVarBinder) +import {-# SOURCE #-} TyCoRep ( Type, ThetaType ) data DataCon data DataConRep diff --git a/compiler/basicTypes/MkId.hs b/compiler/basicTypes/MkId.hs index 1ac5597d3e..e146c66c47 100644 --- a/compiler/basicTypes/MkId.hs +++ b/compiler/basicTypes/MkId.hs @@ -280,7 +280,7 @@ mkDictSelId name clas val_index = assoc "MkId.mkDictSelId" (sel_names `zip` [0..]) name sel_ty = mkForAllTys tyvars $ - mkFunTy (mkClassPred clas (mkTyVarTys (map binderVar tyvars))) $ + mkFunTy (mkClassPred clas (mkTyVarTys (binderVars tyvars))) $ getNth arg_tys val_index base_info = noCafIdInfo @@ -1066,22 +1066,17 @@ dollarId = pcMiscPrelId dollarName ty App (Var f) (Var x) ------------------------------------------------ --- proxy# :: forall a. Proxy# a proxyHashId :: Id proxyHashId = pcMiscPrelId proxyName ty (noCafIdInfo `setUnfoldingInfo` evaldUnfolding) -- Note [evaldUnfoldings] where - ty = mkSpecForAllTys [kv, tv] (mkProxyPrimTy k t) - kv = kKiVar - k = mkTyVarTy kv - [tv] = mkTemplateTyVars [k] - t = mkTyVarTy tv + -- proxy# :: forall k (a:k). Proxy# k a + bndrs = mkTemplateKiTyVars [liftedTypeKind] (\ks -> ks) + [k,t] = mkTyVarTys bndrs + ty = mkSpecForAllTys bndrs (mkProxyPrimTy k t) ------------------------------------------------ --- unsafeCoerce# :: forall (r1 :: RuntimeRep) (r2 :: RuntimeRep) --- (a :: TYPE r1) (b :: TYPE r2). --- a -> b unsafeCoerceId :: Id unsafeCoerceId = pcMiscPrelId unsafeCoerceName ty info @@ -1089,14 +1084,19 @@ unsafeCoerceId info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma `setUnfoldingInfo` mkCompulsoryUnfolding rhs - tvs = [ runtimeRep1TyVar, runtimeRep2TyVar - , openAlphaTyVar, openBetaTyVar ] + -- unsafeCoerce# :: forall (r1 :: RuntimeRep) (r2 :: RuntimeRep) + -- (a :: TYPE r1) (b :: TYPE r2). + -- a -> b + bndrs = mkTemplateKiTyVars [runtimeRepTy, runtimeRepTy] + (\ks -> map tYPE ks) - ty = mkSpecForAllTys tvs $ mkFunTy openAlphaTy openBetaTy + [_, _, a, b] = mkTyVarTys bndrs - [x] = mkTemplateLocals [openAlphaTy] - rhs = mkLams (tvs ++ [x]) $ - Cast (Var x) (mkUnsafeCo Representational openAlphaTy openBetaTy) + ty = mkSpecForAllTys bndrs (mkFunTy a b) + + [x] = mkTemplateLocals [a] + rhs = mkLams (bndrs ++ [x]) $ + Cast (Var x) (mkUnsafeCo Representational a b) ------------------------------------------------ nullAddrId :: Id diff --git a/compiler/basicTypes/PatSyn.hs b/compiler/basicTypes/PatSyn.hs index 2510d71ec0..3b514526f1 100644 --- a/compiler/basicTypes/PatSyn.hs +++ b/compiler/basicTypes/PatSyn.hs @@ -359,7 +359,7 @@ patSynUnivTyVarBinders :: PatSyn -> [TyVarBinder] patSynUnivTyVarBinders = psUnivTyVars patSynExTyVars :: PatSyn -> [TyVar] -patSynExTyVars ps = map binderVar (psExTyVars ps) +patSynExTyVars ps = binderVars (psExTyVars ps) patSynExTyVarBinders :: PatSyn -> [TyVarBinder] patSynExTyVarBinders = psExTyVars @@ -368,7 +368,7 @@ 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 }) - = (map binderVar univ_tvs, req, map binderVar ex_tvs, prov, arg_tys, res_ty) + = (binderVars univ_tvs, req, binderVars ex_tvs, prov, arg_tys, res_ty) patSynMatcher :: PatSyn -> (Id,Bool) patSynMatcher = psMatcher @@ -397,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 = map binderVar (univ_tvs ++ ex_tvs) + tyvars = binderVars (univ_tvs ++ ex_tvs) patSynInstResTy :: PatSyn -> [Type] -> Type -- Return the type of whole pattern @@ -410,7 +410,7 @@ 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 (map binderVar univ_tvs) inst_tys res_ty + substTyWith (binderVars univ_tvs) inst_tys res_ty -- | Print the type of a pattern synonym. The foralls are printed explicitly pprPatSynType :: PatSyn -> SDoc diff --git a/compiler/basicTypes/Var.hs b/compiler/basicTypes/Var.hs index 8d308ad3e7..a9912d320c 100644 --- a/compiler/basicTypes/Var.hs +++ b/compiler/basicTypes/Var.hs @@ -5,7 +5,7 @@ \section{@Vars@: Variables} -} -{-# LANGUAGE CPP, MultiWayIf #-} +{-# LANGUAGE CPP, MultiWayIf, FlexibleInstances, DeriveDataTypeable #-} -- | -- #name_types# @@ -56,7 +56,12 @@ module Var ( isGlobalId, isExportedId, mustHaveLocalBinding, - -- ** Constructing 'TyVar's + -- * TyVar's + TyVarBndr(..), VisibilityFlag(..), TyVarBinder, + binderVar, binderVars, binderVisibility, binderKind, + isVisible, isInvisible, sameVis, + + -- ** Constructing TyVar's mkTyVar, mkTcTyVar, -- ** Taking 'TyVar's apart @@ -77,12 +82,13 @@ import {-# SOURCE #-} TcType( TcTyVarDetails, pprTcTyVarDetails, vanillaSkolem import {-# SOURCE #-} IdInfo( IdDetails, IdInfo, coVarDetails, isCoVarDetails, vanillaIdInfo, pprIdDetails ) import Name hiding (varName) -import Unique +import Unique ( Uniquable, Unique, getKey, getUnique + , mkUniqueGrimily, nonDetCmpUnique ) import Util +import Binary import DynFlags import Outputable -import Unique (nonDetCmpUnique) import Data.Data {- @@ -309,10 +315,69 @@ updateVarTypeM :: Monad m => (Type -> m Type) -> Id -> m Id updateVarTypeM f id = do { ty' <- f (varType id) ; return (id { varType = ty' }) } +{- ********************************************************************* +* * +* VisibilityFlag +* * +********************************************************************* -} + +-- | Is something required to appear in source Haskell ('Visible'), +-- permitted by request ('Specified') (visible type application), or +-- prohibited entirely from appearing in source Haskell ('Invisible')? +-- See Note [TyBinders and VisibilityFlags] in TyCoRep +data VisibilityFlag = Visible | Specified | Invisible + deriving (Eq, Data) + +isVisible :: VisibilityFlag -> Bool +isVisible Visible = True +isVisible _ = False + +isInvisible :: VisibilityFlag -> Bool +isInvisible v = not (isVisible v) + +-- | Do these denote the same level of visibility? Except that +-- 'Specified' and 'Invisible' are considered the same. Used +-- for printing. +sameVis :: VisibilityFlag -> VisibilityFlag -> Bool +sameVis Visible Visible = True +sameVis Visible _ = False +sameVis _ Visible = False +sameVis _ _ = True + + +{- ********************************************************************* +* * +* TyVarBndr, TyVarBinder +* * +********************************************************************* -} + +-- TyVarBndr is polymorphic in both tyvar and visiblity fields: +-- * tyvar can be TyVar or IfaceTv +-- * vis can be VisibilityFlag or TyConBndrVis +data TyVarBndr tyvar vis = TvBndr tyvar vis + deriving( Data ) + +-- | A `TyVarBinder` is the binder of a ForAllTy +-- It's convenient to define this synonym here rather its natural +-- home in TyCoRep, because it's used in DataCon.hs-boot +type TyVarBinder = TyVarBndr TyVar VisibilityFlag + +binderVar :: TyVarBndr tv vis -> tv +binderVar (TvBndr v _) = v + +binderVars :: [TyVarBndr tv vis] -> [tv] +binderVars tvbs = map binderVar tvbs + +binderVisibility :: TyVarBndr tv vis -> vis +binderVisibility (TvBndr _ vis) = vis + +binderKind :: TyVarBndr TyVar vis -> Kind +binderKind (TvBndr tv _) = tyVarKind tv + {- ************************************************************************ * * -\subsection{Type and kind variables} +* Type and kind variables * * * ************************************************************************ -} @@ -363,6 +428,35 @@ tcTyVarDetails var = pprPanic "tcTyVarDetails" (ppr var <+> dcolon <+> pprKind ( setTcTyVarDetails :: TyVar -> TcTyVarDetails -> TyVar setTcTyVarDetails tv details = tv { tc_tv_details = details } +------------------------------------- +instance Outputable tv => Outputable (TyVarBndr tv VisibilityFlag) where + ppr (TvBndr v Visible) = ppr v + ppr (TvBndr v Specified) = char '@' <> ppr v + ppr (TvBndr v Invisible) = braces (ppr v) + +instance Outputable VisibilityFlag where + ppr Visible = text "[vis]" + ppr Specified = text "[spec]" + ppr Invisible = text "[invis]" + +instance (Binary tv, Binary vis) => Binary (TyVarBndr tv vis) where + put_ bh (TvBndr tv vis) = do { put_ bh tv; put_ bh vis } + + get bh = do { tv <- get bh; vis <- get bh; return (TvBndr tv vis) } + + +instance Binary VisibilityFlag where + put_ bh Visible = putByte bh 0 + put_ bh Specified = putByte bh 1 + put_ bh Invisible = putByte bh 2 + + get bh = do + h <- getByte bh + case h of + 0 -> return Visible + 1 -> return Specified + _ -> return Invisible + {- %************************************************************************ %* * diff --git a/compiler/coreSyn/CoreFVs.hs b/compiler/coreSyn/CoreFVs.hs index 09ef7f8866..bab7f5fd41 100644 --- a/compiler/coreSyn/CoreFVs.hs +++ b/compiler/coreSyn/CoreFVs.hs @@ -352,7 +352,7 @@ orphNamesOfType (TyVarTy _) = emptyNameSet orphNamesOfType (LitTy {}) = emptyNameSet orphNamesOfType (TyConApp tycon tys) = orphNamesOfTyCon tycon `unionNameSet` orphNamesOfTypes tys -orphNamesOfType (ForAllTy bndr res) = orphNamesOfType (binderType bndr) +orphNamesOfType (ForAllTy bndr res) = orphNamesOfType (binderKind bndr) `unionNameSet` orphNamesOfType res orphNamesOfType (FunTy arg res) = unitNameSet funTyConName -- NB! See Trac #8535 `unionNameSet` orphNamesOfType arg diff --git a/compiler/iface/BuildTyCl.hs b/compiler/iface/BuildTyCl.hs index c20a5ee9e2..df52b44126 100644 --- a/compiler/iface/BuildTyCl.hs +++ b/compiler/iface/BuildTyCl.hs @@ -6,7 +6,7 @@ {-# LANGUAGE CPP #-} module BuildTyCl ( - buildDataCon, + buildDataCon, mkDataConUnivTyVarBinders, buildPatSyn, TcMethInfo, buildClass, distinctAbstractTyConRhs, totallyAbstractTyConRhs, @@ -29,7 +29,6 @@ import MkId import Class import TyCon import Type -import TyCoRep( TyBinder(..), TyVarBinder(..) ) import Id import TcType @@ -112,8 +111,8 @@ buildDataCon :: FamInstEnvs -> Maybe [HsImplBang] -- See Note [Bangs on imported data constructors] in MkId -> [FieldLabel] -- Field labels - -> [TyVar] -> [TyBinder] -- Universals - -> [TyVarBinder] -- existentials + -> [TyVarBinder] -- Universals + -> [TyVarBinder] -- Existentials -> [EqSpec] -- Equality spec -> ThetaType -- Does not include the "stupid theta" -- or the GADT equalities @@ -126,7 +125,7 @@ buildDataCon :: FamInstEnvs -- allocating its unique (hence monadic) -- 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 eq_spec ctxt arg_tys res_ty rep_tycon + univ_tvs 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 @@ -136,11 +135,10 @@ 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 = mkDataConUnivTyVarBinders univ_tvs univ_bndrs - stupid_ctxt = mkDataConStupidTheta rep_tycon arg_tys univ_tvs + ; let stupid_ctxt = mkDataConStupidTheta rep_tycon arg_tys univ_tvs data_con = mkDataCon src_name declared_infix prom_info src_bangs field_lbls - dc_bndrs ex_tvs eq_spec ctxt + univ_tvs ex_tvs eq_spec ctxt arg_tys res_ty NoRRI rep_tycon stupid_ctxt dc_wrk dc_rep dc_wrk = mkDataConWorkId work_name data_con @@ -155,12 +153,13 @@ buildDataCon fam_envs src_name declared_infix prom_info src_bangs impl_bangs fie -- the type variables mentioned in the arg_tys -- ToDo: Or functionally dependent on? -- This whole stupid theta thing is, well, stupid. -mkDataConStupidTheta :: TyCon -> [Type] -> [TyVar] -> [PredType] +mkDataConStupidTheta :: TyCon -> [Type] -> [TyVarBinder] -> [PredType] mkDataConStupidTheta tycon arg_tys univ_tvs | null stupid_theta = [] -- The common case | otherwise = filter in_arg_tys stupid_theta where - tc_subst = zipTvSubst (tyConTyVars tycon) (mkTyVarTys univ_tvs) + tc_subst = zipTvSubst (tyConTyVars tycon) + (mkTyVarTys (binderVars univ_tvs)) stupid_theta = substTheta tc_subst (tyConStupidTheta tycon) -- Start by instantiating the master copy of the -- stupid theta, taken from the TyCon @@ -170,18 +169,18 @@ mkDataConStupidTheta tycon arg_tys univ_tvs tyCoVarsOfType pred `intersectVarSet` arg_tyvars -mkDataConUnivTyVarBinders :: [TyVar] -> [TyBinder] -- From the TyCon - -> [TyVarBinder] -- For the DataCon +mkDataConUnivTyVarBinders :: [TyConBinder] -- From the TyCon + -> [TyVarBinder] -- For the DataCon -- See Note [Building the TyBinders for a DataCon] -mkDataConUnivTyVarBinders tvs bndrs - = zipWith mk_binder tvs bndrs +mkDataConUnivTyVarBinders tc_bndrs + = map mk_binder tc_bndrs where - mk_binder tv bndr = mkTyVarBinder vis tv + mk_binder (TvBndr tv tc_vis) = mkTyVarBinder vis tv where - vis = case bndr of - Anon _ -> Specified - Named (TvBndr _ Visible) -> Specified - Named (TvBndr _ vis) -> vis + vis = case tc_vis of + AnonTCB -> Specified + NamedTCB Visible -> Specified + NamedTCB vis -> vis {- Note [Building the TyBinders for a DataCon] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -272,7 +271,7 @@ buildPatSyn src_name declared_infix matcher@(matcher_id,_) builder (arg_tys1, _) = tcSplitFunTys cont_tau twiddle = char '~' subst = zipTvSubst (univ_tvs1 ++ ex_tvs1) - (mkTyVarTys (map binderVar (univ_tvs ++ ex_tvs))) + (mkTyVarTys (binderVars (univ_tvs ++ ex_tvs))) ------------------------------------------------------ type TcMethInfo = (Name, Type, Maybe (DefMethSpec Type)) @@ -280,8 +279,8 @@ type TcMethInfo = (Name, Type, Maybe (DefMethSpec Type)) -- tcClassSigs and buildClass. buildClass :: Name -- Name of the class/tycon (they have the same Name) - -> [TyVar] -> [Role] -> ThetaType - -> [TyBinder] -- of the tycon + -> [TyConBinder] -- Of the tycon + -> [Role] -> ThetaType -> [FunDep TyVar] -- Functional dependencies -> [ClassATItem] -- Associated types -> [TcMethInfo] -- Method info @@ -289,7 +288,7 @@ buildClass :: Name -- Name of the class/tycon (they have the same Name) -> RecFlag -- Info for type constructor -> TcRnIf m n Class -buildClass tycon_name tvs roles sc_theta binders +buildClass tycon_name binders roles sc_theta fds at_items sig_stuff mindef tc_isrec = fixM $ \ rec_clas -> -- Only name generation inside loop do { traceIf (text "buildClass") @@ -325,11 +324,13 @@ buildClass tycon_name tvs roles sc_theta binders -- That means that in the case of -- class C a => D a -- we don't get a newtype with no arguments! - args = sc_sel_names ++ op_names - op_tys = [ty | (_,ty,_) <- sig_stuff] - op_names = [op | (op,_,_) <- sig_stuff] - arg_tys = sc_theta ++ op_tys - rec_tycon = classTyCon rec_clas + args = sc_sel_names ++ op_names + op_tys = [ty | (_,ty,_) <- sig_stuff] + op_names = [op | (op,_,_) <- sig_stuff] + arg_tys = sc_theta ++ op_tys + rec_tycon = classTyCon rec_clas + univ_bndrs = mkDataConUnivTyVarBinders binders + univ_tvs = binderVars univ_bndrs ; rep_nm <- newTyConRepName datacon_name ; dict_con <- buildDataCon (panic "buildClass: FamInstEnvs") @@ -339,12 +340,12 @@ buildClass tycon_name tvs roles sc_theta binders (map (const no_bang) args) (Just (map (const HsLazy) args)) [{- No fields -}] - tvs binders + univ_bndrs [{- no existentials -}] [{- No GADT equalities -}] [{- No theta -}] arg_tys - (mkTyConApp rec_tycon (mkTyVarTys tvs)) + (mkTyConApp rec_tycon (mkTyVarTys univ_tvs)) rec_tycon ; rhs <- if use_newtype @@ -354,7 +355,7 @@ buildClass tycon_name tvs roles sc_theta binders , tup_sort = ConstraintTuple }) else return (mkDataTyConRhs [dict_con]) - ; let { tycon = mkClassTyCon tycon_name binders tvs roles + ; let { tycon = mkClassTyCon tycon_name binders roles rhs rec_clas tc_isrec tc_rep_name -- A class can be recursive, and in the case of newtypes -- this matters. For example @@ -365,7 +366,7 @@ buildClass tycon_name tvs roles sc_theta binders -- newtype like a synonym, but that will lead to an infinite -- type] - ; result = mkClass tvs fds + ; result = mkClass tycon_name univ_tvs fds sc_theta sc_sel_ids at_items op_items mindef tycon } diff --git a/compiler/iface/IfaceSyn.hs b/compiler/iface/IfaceSyn.hs index 0ad4b0f5db..283da53e87 100644 --- a/compiler/iface/IfaceSyn.hs +++ b/compiler/iface/IfaceSyn.hs @@ -57,6 +57,7 @@ import SrcLoc import Fingerprint import Binary import BooleanFormula ( BooleanFormula, pprBooleanFormula, isTrue ) +import Var( TyVarBndr(..) ) import TyCon ( Role (..), Injectivity(..) ) import StaticFlags (opt_PprStyle_Debug) import Util( filterOut, filterByList ) @@ -972,7 +973,7 @@ ppr_rough Nothing = dot ppr_rough (Just tc) = ppr tc tv_to_forall_bndr :: IfaceTvBndr -> IfaceForAllBndr -tv_to_forall_bndr tv = IfaceTv tv Specified +tv_to_forall_bndr tv = TvBndr tv Specified {- Note [Result type of a data family GADT] @@ -1158,22 +1159,22 @@ freeNamesIfDecl (IfaceId _s t d i) = freeNamesIfIdInfo i &&& freeNamesIfIdDetails d freeNamesIfDecl d@IfaceData{} = - freeNamesIfTyBinders (ifBinders d) &&& + freeNamesIfTyVarBndrs (ifBinders d) &&& freeNamesIfType (ifResKind d) &&& freeNamesIfaceTyConParent (ifParent d) &&& freeNamesIfContext (ifCtxt d) &&& freeNamesIfConDecls (ifCons d) freeNamesIfDecl d@IfaceSynonym{} = freeNamesIfType (ifSynRhs d) &&& - freeNamesIfTyBinders (ifBinders d) &&& + freeNamesIfTyVarBndrs (ifBinders d) &&& freeNamesIfKind (ifResKind d) freeNamesIfDecl d@IfaceFamily{} = freeNamesIfFamFlav (ifFamFlav d) &&& - freeNamesIfTyBinders (ifBinders d) &&& + freeNamesIfTyVarBndrs (ifBinders d) &&& freeNamesIfKind (ifResKind d) freeNamesIfDecl d@IfaceClass{} = freeNamesIfContext (ifCtxt d) &&& - freeNamesIfTyBinders (ifBinders d) &&& + freeNamesIfTyVarBndrs (ifBinders d) &&& fnList freeNamesIfAT (ifATs d) &&& fnList freeNamesIfClsSig (ifSigs d) freeNamesIfDecl d@IfaceAxiom{} = @@ -1182,8 +1183,8 @@ freeNamesIfDecl d@IfaceAxiom{} = freeNamesIfDecl d@IfacePatSyn{} = unitNameSet (fst (ifPatMatcher d)) &&& maybe emptyNameSet (unitNameSet . fst) (ifPatBuilder d) &&& - fnList freeNamesIfForAllBndr (ifPatUnivBndrs d) &&& - fnList freeNamesIfForAllBndr (ifPatExBndrs d) &&& + freeNamesIfTyVarBndrs (ifPatUnivBndrs d) &&& + freeNamesIfTyVarBndrs (ifPatExBndrs d) &&& freeNamesIfContext (ifPatProvCtxt d) &&& freeNamesIfContext (ifPatReqCtxt d) &&& fnList freeNamesIfType (ifPatArgs d) &&& @@ -1194,11 +1195,11 @@ freeNamesIfAxBranch :: IfaceAxBranch -> NameSet freeNamesIfAxBranch (IfaceAxBranch { ifaxbTyVars = tyvars , ifaxbCoVars = covars , ifaxbLHS = lhs - , ifaxbRHS = rhs }) = - freeNamesIfTvBndrs tyvars &&& - fnList freeNamesIfIdBndr covars &&& - freeNamesIfTcArgs lhs &&& - freeNamesIfType rhs + , ifaxbRHS = rhs }) + = fnList freeNamesIfTvBndr tyvars &&& + fnList freeNamesIfIdBndr covars &&& + freeNamesIfTcArgs lhs &&& + freeNamesIfType rhs freeNamesIfIdDetails :: IfaceIdDetails -> NameSet freeNamesIfIdDetails (IfRecSelId tc _) = @@ -1239,7 +1240,7 @@ freeNamesIfConDecls _ = emptyNameSet freeNamesIfConDecl :: IfaceConDecl -> NameSet freeNamesIfConDecl c - = fnList freeNamesIfForAllBndr (ifConExTvs c) &&& + = freeNamesIfTyVarBndrs (ifConExTvs c) &&& freeNamesIfContext (ifConCtxt c) &&& fnList freeNamesIfType (ifConArgTys c) &&& fnList freeNamesIfType (map snd (ifConEqSpec c)) -- equality constraints @@ -1258,8 +1259,7 @@ freeNamesIfType (IfaceAppTy s t) = freeNamesIfType s &&& freeNamesIfType t freeNamesIfType (IfaceTyConApp tc ts) = freeNamesIfTc tc &&& freeNamesIfTcArgs ts freeNamesIfType (IfaceTupleTy _ _ ts) = freeNamesIfTcArgs ts freeNamesIfType (IfaceLitTy _) = emptyNameSet -freeNamesIfType (IfaceForAllTy tv t) = - freeNamesIfForAllBndr tv &&& freeNamesIfType t +freeNamesIfType (IfaceForAllTy tv t) = freeNamesIfTyVarBndr tv &&& freeNamesIfType t freeNamesIfType (IfaceFunTy s t) = freeNamesIfType s &&& freeNamesIfType t freeNamesIfType (IfaceDFunTy s t) = freeNamesIfType s &&& freeNamesIfType t freeNamesIfType (IfaceCastTy t c) = freeNamesIfType t &&& freeNamesIfCoercion c @@ -1307,18 +1307,11 @@ freeNamesIfProv (IfacePhantomProv co) = freeNamesIfCoercion co freeNamesIfProv (IfaceProofIrrelProv co) = freeNamesIfCoercion co freeNamesIfProv (IfacePluginProv _) = emptyNameSet -freeNamesIfTvBndrs :: [IfaceTvBndr] -> NameSet -freeNamesIfTvBndrs = fnList freeNamesIfTvBndr +freeNamesIfTyVarBndr :: TyVarBndr IfaceTvBndr vis -> NameSet +freeNamesIfTyVarBndr (TvBndr tv _) = freeNamesIfTvBndr tv -freeNamesIfForAllBndr :: IfaceForAllBndr -> NameSet -freeNamesIfForAllBndr (IfaceTv tv _) = freeNamesIfTvBndr tv - -freeNamesIfTyBinder :: IfaceTyConBinder -> NameSet -freeNamesIfTyBinder (IfaceAnon b) = freeNamesIfTvBndr b -freeNamesIfTyBinder (IfaceNamed b) = freeNamesIfForAllBndr b - -freeNamesIfTyBinders :: [IfaceTyConBinder] -> NameSet -freeNamesIfTyBinders = fnList freeNamesIfTyBinder +freeNamesIfTyVarBndrs :: [TyVarBndr IfaceTvBndr vis] -> NameSet +freeNamesIfTyVarBndrs = fnList freeNamesIfTyVarBndr freeNamesIfBndr :: IfaceBndr -> NameSet freeNamesIfBndr (IfaceIdBndr b) = freeNamesIfIdBndr b diff --git a/compiler/iface/IfaceType.hs b/compiler/iface/IfaceType.hs index fb2b3df1cc..5a4e03684e 100644 --- a/compiler/iface/IfaceType.hs +++ b/compiler/iface/IfaceType.hs @@ -17,8 +17,8 @@ module IfaceType ( IfaceTyCon(..), IfaceTyConInfo(..), IfaceTyLit(..), IfaceTcArgs(..), IfaceContext, IfaceBndr(..), IfaceOneShot(..), IfaceLamBndr, - IfaceTvBndr, IfaceIdBndr, IfaceTyConBinder(..), - IfaceForAllBndr(..), VisibilityFlag(..), + IfaceTvBndr, IfaceIdBndr, IfaceTyConBinder, + IfaceForAllBndr, VisibilityFlag(..), ifConstraintKind, ifTyConBinderTyVar, ifTyConBinderName, @@ -30,9 +30,8 @@ module IfaceType ( toIfaceType, toIfaceTypes, toIfaceKind, toIfaceTyVar, toIfaceContext, toIfaceBndr, toIfaceIdBndr, toIfaceTyCon, toIfaceTyCon_name, - toIfaceTcArgs, toIfaceTvBndrs, - zipIfaceBinders, toDegenerateBinders, - binderToIfaceForAllBndr, + toIfaceTcArgs, toIfaceTvBndr, toIfaceTvBndrs, + toIfaceForAllBndr, -- Conversion from IfaceTcArgs -> IfaceType tcArgsIfaceTypes, @@ -146,13 +145,8 @@ data IfaceTyLit | IfaceStrTyLit FastString deriving (Eq) -data IfaceForAllBndr - = IfaceTv IfaceTvBndr VisibilityFlag - -data IfaceTyConBinder - = IfaceAnon IfaceTvBndr -- Like Anon, but it includes a name from - -- which to produce a tyConTyVar - | IfaceNamed IfaceForAllBndr +type IfaceTyConBinder = TyVarBndr IfaceTvBndr TyConBndrVis +type IfaceForAllBndr = TyVarBndr IfaceTvBndr VisibilityFlag -- See Note [Suppressing invisible arguments] -- We use a new list type (rather than [(IfaceType,Bool)], because @@ -254,23 +248,17 @@ suppressIfaceInvisibles dflags tys xs suppress _ [] = [] suppress [] a = a suppress (k:ks) a@(_:xs) - | isIfaceInvisBndr k = suppress ks xs - | otherwise = a + | isInvisibleTyConBinder k = suppress ks xs + | otherwise = a stripIfaceInvisVars :: DynFlags -> [IfaceTyConBinder] -> [IfaceTyConBinder] stripIfaceInvisVars dflags tyvars | gopt Opt_PrintExplicitKinds dflags = tyvars - | otherwise = filterOut isIfaceInvisBndr tyvars - -isIfaceInvisBndr :: IfaceTyConBinder -> Bool -isIfaceInvisBndr (IfaceNamed (IfaceTv _ Invisible)) = True -isIfaceInvisBndr (IfaceNamed (IfaceTv _ Specified)) = True -isIfaceInvisBndr _ = False + | otherwise = filterOut isInvisibleTyConBinder tyvars -- | Extract a IfaceTvBndr from a IfaceTyConBinder ifTyConBinderTyVar :: IfaceTyConBinder -> IfaceTvBndr -ifTyConBinderTyVar (IfaceAnon tv) = tv -ifTyConBinderTyVar (IfaceNamed (IfaceTv tv _)) = tv +ifTyConBinderTyVar = binderVar -- | Extract the variable name from a IfaceTyConBinder ifTyConBinderName :: IfaceTyConBinder -> IfLclName @@ -299,7 +287,7 @@ ifTyVarsOfType ty ifTyVarsOfForAllBndr :: IfaceForAllBndr -> ( UniqSet IfLclName -- names used free in the binder , [IfLclName] ) -- names bound by this binder -ifTyVarsOfForAllBndr (IfaceTv (name, kind) _) = (ifTyVarsOfType kind, [name]) +ifTyVarsOfForAllBndr (TvBndr (name, kind) _) = (ifTyVarsOfType kind, [name]) ifTyVarsOfArgs :: IfaceTcArgs -> UniqSet IfLclName ifTyVarsOfArgs args = argv emptyUniqSet args @@ -484,7 +472,7 @@ eqIfaceTypes env tys1 tys2 = and (zipWith (eqIfaceType env) tys1 tys2) eqIfaceForAllBndr :: IfRnEnv2 -> IfaceForAllBndr -> IfaceForAllBndr -> (IfRnEnv2 -> Bool) -- continuation -> Bool -eqIfaceForAllBndr env (IfaceTv (tv1, k1) vis1) (IfaceTv (tv2, k2) vis2) k +eqIfaceForAllBndr env (TvBndr (tv1, k1) vis1) (TvBndr (tv2, k2) vis2) k = eqIfaceType env k1 k2 && vis1 == vis2 && k (extendIfRnEnv2 env tv1 tv2) @@ -725,7 +713,7 @@ ppr_iface_forall_part show_foralls_unconditionally tvs ctxt sdoc -- | Render the "forall ... ." or "forall ... ->" bit of a type. pprIfaceForAll :: [IfaceForAllBndr] -> SDoc pprIfaceForAll [] = empty -pprIfaceForAll bndrs@(IfaceTv _ vis : _) +pprIfaceForAll bndrs@(TvBndr _ vis : _) = add_separator (text "forall" <+> doc) <+> pprIfaceForAll bndrs' where (bndrs', doc) = ppr_itv_bndrs bndrs vis @@ -741,7 +729,7 @@ pprIfaceForAll bndrs@(IfaceTv _ vis : _) ppr_itv_bndrs :: [IfaceForAllBndr] -> VisibilityFlag -- ^ visibility of the first binder in the list -> ([IfaceForAllBndr], SDoc) -ppr_itv_bndrs all_bndrs@(bndr@(IfaceTv _ vis) : bndrs) vis1 +ppr_itv_bndrs all_bndrs@(bndr@(TvBndr _ vis) : bndrs) vis1 | vis `sameVis` vis1 = let (bndrs', doc) = ppr_itv_bndrs bndrs vis1 in (bndrs', pprIfaceForAllBndr bndr <+> doc) | otherwise = (all_bndrs, empty) @@ -755,11 +743,11 @@ pprIfaceForAllCoBndrs :: [(IfLclName, IfaceCoercion)] -> SDoc pprIfaceForAllCoBndrs bndrs = hsep $ map pprIfaceForAllCoBndr bndrs pprIfaceForAllBndr :: IfaceForAllBndr -> SDoc -pprIfaceForAllBndr (IfaceTv tv Invisible) = sdocWithDynFlags $ \dflags -> - if gopt Opt_PrintExplicitForalls dflags - then braces $ pprIfaceTvBndr tv - else pprIfaceTvBndr tv -pprIfaceForAllBndr (IfaceTv tv _) = pprIfaceTvBndr tv +pprIfaceForAllBndr (TvBndr tv Invisible) = sdocWithDynFlags $ \dflags -> + if gopt Opt_PrintExplicitForalls dflags + then braces $ pprIfaceTvBndr tv + else pprIfaceTvBndr tv +pprIfaceForAllBndr (TvBndr tv _) = pprIfaceTvBndr tv pprIfaceForAllCoBndr :: (IfLclName, IfaceCoercion) -> SDoc pprIfaceForAllCoBndr (tv, kind_co) @@ -996,30 +984,6 @@ instance Binary IfaceTyLit where ; return (IfaceStrTyLit n) } _ -> panic ("get IfaceTyLit " ++ show tag) -instance Binary IfaceForAllBndr where - put_ bh (IfaceTv tv vis) = do - put_ bh tv - put_ bh vis - - get bh = do - tv <- get bh - vis <- get bh - return (IfaceTv tv vis) - -instance Binary IfaceTyConBinder where - 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 - b <- get bh - return $! IfaceAnon b - _ -> do - b <- get bh - return $! IfaceNamed b - instance Binary IfaceTcArgs where put_ bh tk = case tk of @@ -1340,11 +1304,7 @@ toIfaceCoVar :: CoVar -> FastString toIfaceCoVar = occNameFS . getOccName toIfaceForAllBndr :: TyVarBinder -> IfaceForAllBndr -toIfaceForAllBndr (TvBndr v vis) - = IfaceTv (toIfaceTvBndr v) vis - -binderToIfaceForAllBndr :: TyVarBinder -> IfaceForAllBndr -binderToIfaceForAllBndr (TvBndr v vis) = IfaceTv (toIfaceTvBndr v) vis +toIfaceForAllBndr (TvBndr v vis) = TvBndr (toIfaceTvBndr v) vis ---------------- toIfaceTyCon :: TyCon -> IfaceTyCon @@ -1412,21 +1372,3 @@ toIfaceUnivCoProv (PhantomProv co) = IfacePhantomProv (toIfaceCoercion co) toIfaceUnivCoProv (ProofIrrelProv co) = IfaceProofIrrelProv (toIfaceCoercion co) toIfaceUnivCoProv (PluginProv str) = IfacePluginProv str toIfaceUnivCoProv (HoleProv h) = pprPanic "toIfaceUnivCoProv hit a hole" (ppr h) - ----------------------- --- | Zip together tidied tyConTyVars with tyConBinders to make IfaceTyConBinders -zipIfaceBinders :: [TyVar] -> [TyBinder] -> [IfaceTyConBinder] -zipIfaceBinders = zipWith go - where - 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 tvb) = IfaceNamed (toIfaceForAllBndr tvb) diff --git a/compiler/iface/MkIface.hs b/compiler/iface/MkIface.hs index aedec424ae..537d9601b7 100644 --- a/compiler/iface/MkIface.hs +++ b/compiler/iface/MkIface.hs @@ -1311,8 +1311,8 @@ patSynToIfaceDecl ps , ifPatMatcher = to_if_pr (patSynMatcher ps) , ifPatBuilder = fmap to_if_pr (patSynBuilder ps) , ifPatIsInfix = patSynIsInfix ps - , ifPatUnivBndrs = map binderToIfaceForAllBndr univ_bndrs' - , ifPatExBndrs = map binderToIfaceForAllBndr ex_bndrs' + , ifPatUnivBndrs = map toIfaceForAllBndr univ_bndrs' + , ifPatExBndrs = map toIfaceForAllBndr ex_bndrs' , ifPatProvCtxt = tidyToIfaceContext env2 prov_theta , ifPatReqCtxt = tidyToIfaceContext env2 req_theta , ifPatArgs = map (tidyToIfaceType env2) args @@ -1361,15 +1361,14 @@ coAxBranchToIfaceBranch' :: TyCon -> CoAxBranch -> IfaceAxBranch coAxBranchToIfaceBranch' tc (CoAxBranch { cab_tvs = tvs, cab_cvs = cvs , cab_lhs = lhs , cab_roles = roles, cab_rhs = rhs }) - = IfaceAxBranch { ifaxbTyVars = toIfaceTvBndrs tv_bndrs + = IfaceAxBranch { ifaxbTyVars = toIfaceTvBndrs tidy_tvs , ifaxbCoVars = map toIfaceIdBndr cvs , ifaxbLHS = tidyToIfaceTcArgs env1 tc lhs , ifaxbRoles = roles , ifaxbRHS = tidyToIfaceType env1 rhs , ifaxbIncomps = [] } where - - (env1, tv_bndrs) = tidyTyClTyCoVarBndrs emptyTidyEnv tvs + (env1, tidy_tvs) = tidyTyCoVarBndrs emptyTidyEnv tvs -- Don't re-bind in-scope tyvars -- See Note [CoAxBranch type variables] in CoAxiom @@ -1420,10 +1419,8 @@ tyConToIfaceDecl env tycon -- to put them into interface files = ( env , IfaceData { ifName = getOccName tycon, - ifBinders = if_degenerate_binders, - ifResKind = if_degenerate_res_kind, - -- FunTyCon, PrimTyCon etc don't have - -- `tyConTyVars`, hence "degenerate" + ifBinders = if_binders, + ifResKind = if_res_kind, ifCType = Nothing, ifRoles = tyConRoles tycon, ifCtxt = [], @@ -1435,18 +1432,13 @@ tyConToIfaceDecl env tycon -- NOTE: Not all TyCons have `tyConTyVars` field. Forcing this when `tycon` -- is one of these TyCons (FunTyCon, PrimTyCon, PromotedDataCon) will cause -- an error. - (tc_env1, tc_tyvars) = tidyTyClTyCoVarBndrs env (tyConTyVars tycon) - if_binders = zipIfaceBinders tc_tyvars (tyConBinders tycon) - if_res_kind = tidyToIfaceType tc_env1 (tyConResKind tycon) + (tc_env1, tc_binders) = tidyTyConBinders env (tyConBinders tycon) + tc_tyvars = binderVars tc_binders + if_binders = toIfaceTyVarBinders tc_binders + if_res_kind = tidyToIfaceType tc_env1 (tyConResKind 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 - (degenerate_binders, degenerate_res_kind) - = splitPiTys (tidyType env (tyConKind tycon)) - if_degenerate_binders = toDegenerateBinders degenerate_binders - if_degenerate_res_kind = toIfaceType degenerate_res_kind - parent = case tyConFamInstSig_maybe tycon of Just (tc, ty, ax) -> IfDataInstance (coAxiomName ax) (toIfaceTyCon tc) @@ -1482,7 +1474,7 @@ tyConToIfaceDecl env tycon = IfCon { ifConOcc = getOccName (dataConName data_con), ifConInfix = dataConIsInfix data_con, ifConWrapper = isJust (dataConWrapId_maybe data_con), - ifConExTvs = map binderToIfaceForAllBndr ex_bndrs', + ifConExTvs = map toIfaceForAllBndr ex_bndrs', ifConEqSpec = map (to_eq_spec . eqSpecPair) eq_spec, ifConCtxt = tidyToIfaceContext con_env2 theta, ifConArgTys = map (tidyToIfaceType con_env2) arg_tys, @@ -1508,7 +1500,7 @@ tyConToIfaceDecl env tycon -- A bit grimy, perhaps, but it's simple! (con_env2, ex_bndrs') = tidyTyVarBinders con_env1 ex_bndrs - to_eq_spec (tv,ty) = (toIfaceTyVar (tidyTyVar con_env2 tv), tidyToIfaceType con_env2 ty) + to_eq_spec (tv,ty) = (tidyTyVar con_env2 tv, tidyToIfaceType con_env2 ty) ifaceOverloaded flds = case dFsEnvElts flds of fl:_ -> flIsOverloaded fl @@ -1530,19 +1522,18 @@ classToIfaceDecl env clas , IfaceClass { ifCtxt = tidyToIfaceContext env1 sc_theta, ifName = getOccName tycon, ifRoles = tyConRoles (classTyCon clas), - ifBinders = binders, + ifBinders = toIfaceTyVarBinders tc_binders, ifFDs = map toIfaceFD clas_fds, ifATs = map toIfaceAT clas_ats, ifSigs = map toIfaceClassOp op_stuff, ifMinDef = fmap getOccFS (classMinimalDef clas), ifRec = boolToRecFlag (isRecursiveTyCon tycon) }) where - (clas_tyvars, clas_fds, sc_theta, _, clas_ats, op_stuff) + (_, clas_fds, sc_theta, _, clas_ats, op_stuff) = classExtraBigSig clas tycon = classTyCon clas - (env1, clas_tyvars') = tidyTyCoVarBndrs env clas_tyvars - binders = zipIfaceBinders clas_tyvars' (tyConBinders tycon) + (env1, tc_binders) = tidyTyConBinders env (tyConBinders tycon) toIfaceAT :: ClassATItem -> IfaceAT toIfaceAT (ATI tc def) @@ -1551,7 +1542,7 @@ classToIfaceDecl env clas (env2, if_decl) = tyConToIfaceDecl env1 tc toIfaceClassOp (sel_id, def_meth) - = ASSERT(sel_tyvars == clas_tyvars) + = ASSERT( sel_tyvars == binderVars tc_binders ) IfaceClassOp (getOccName sel_id) (tidyToIfaceType env1 op_ty) (fmap toDmSpec def_meth) @@ -1568,8 +1559,8 @@ classToIfaceDecl env clas toDmSpec (_, VanillaDM) = VanillaDM toDmSpec (_, GenericDM dm_ty) = GenericDM (tidyToIfaceType env1 dm_ty) - toIfaceFD (tvs1, tvs2) = (map (getOccFS . tidyTyVar env1) tvs1, - map (getOccFS . tidyTyVar env1) tvs2) + toIfaceFD (tvs1, tvs2) = (map (tidyTyVar env1) tvs1 + ,map (tidyTyVar env1) tvs2) -------------------------- tidyToIfaceType :: TidyEnv -> Type -> IfaceType @@ -1581,20 +1572,26 @@ tidyToIfaceTcArgs env tc tys = toIfaceTcArgs tc (tidyTypes env tys) tidyToIfaceContext :: TidyEnv -> ThetaType -> IfaceContext tidyToIfaceContext env theta = map (tidyToIfaceType env) theta -tidyTyClTyCoVarBndrs :: TidyEnv -> [TyCoVar] -> (TidyEnv, [TyCoVar]) -tidyTyClTyCoVarBndrs env tvs = mapAccumL tidyTyClTyCoVarBndr env tvs +toIfaceTyVarBinder :: TyVarBndr TyVar vis -> TyVarBndr IfaceTvBndr vis +toIfaceTyVarBinder (TvBndr tv vis) = TvBndr (toIfaceTvBndr tv) vis -tidyTyClTyCoVarBndr :: TidyEnv -> TyCoVar -> (TidyEnv, TyCoVar) +toIfaceTyVarBinders :: [TyVarBndr TyVar vis] -> [TyVarBndr IfaceTvBndr vis] +toIfaceTyVarBinders = map toIfaceTyVarBinder + +tidyTyConBinder :: TidyEnv -> TyConBinder -> (TidyEnv, TyConBinder) -- If the type variable "binder" is in scope, don't re-bind it -- In a class decl, for example, the ATD binders mention -- (amd must mention) the class tyvars -tidyTyClTyCoVarBndr env@(_, subst) tv - | Just tv' <- lookupVarEnv subst tv = (env, tv') - | otherwise = tidyTyCoVarBndr env tv +tidyTyConBinder env@(_, subst) tvb@(TvBndr tv vis) + = case lookupVarEnv subst tv of + Just tv' -> (env, TvBndr tv' vis) + Nothing -> tidyTyVarBinder env tvb + +tidyTyConBinders :: TidyEnv -> [TyConBinder] -> (TidyEnv, [TyConBinder]) +tidyTyConBinders = mapAccumL tidyTyConBinder -tidyTyVar :: TidyEnv -> TyVar -> TyVar -tidyTyVar (_, subst) tv = lookupVarEnv subst tv `orElse` tv - -- TcType.tidyTyVarOcc messes around with FlatSkols +tidyTyVar :: TidyEnv -> TyVar -> FastString +tidyTyVar (_, subst) tv = toIfaceTyVar (lookupVarEnv subst tv `orElse` tv) -------------------------- instanceToIfaceInst :: ClsInst -> IfaceClsInst diff --git a/compiler/iface/TcIface.hs b/compiler/iface/TcIface.hs index 35d83259aa..2d592bc0db 100644 --- a/compiler/iface/TcIface.hs +++ b/compiler/iface/TcIface.hs @@ -49,7 +49,7 @@ import DataCon import PrelNames import TysWiredIn import Literal -import qualified Var +import Var import VarEnv import VarSet import Name @@ -321,16 +321,17 @@ tc_iface_decl _ _ (IfaceData {ifName = occ_name, ifCtxt = ctxt, ifGadtSyntax = gadt_syn, ifCons = rdr_cons, ifRec = is_rec, ifParent = mb_parent }) - = bindIfaceTyConBinders_AT binders $ \ tyvars binders' -> do + = bindIfaceTyConBinders_AT binders $ \ binders' -> do { tc_name <- lookupIfaceTop occ_name ; res_kind' <- tcIfaceType res_kind ; tycon <- fixM $ \ tycon -> do { stupid_theta <- tcIfaceCtxt ctxt ; parent' <- tc_parent tc_name mb_parent - ; cons <- tcIfaceDataCons tc_name tycon tyvars binders' rdr_cons - ; return (mkAlgTyCon tc_name binders' res_kind' tyvars roles cType stupid_theta - cons parent' is_rec gadt_syn) } + ; cons <- tcIfaceDataCons tc_name tycon binders' rdr_cons + ; return (mkAlgTyCon tc_name binders' res_kind' + roles cType stupid_theta + cons parent' is_rec gadt_syn) } ; traceIf (text "tcIfaceDecl4" <+> ppr tycon) ; return (ATyCon tycon) } where @@ -350,12 +351,12 @@ tc_iface_decl _ _ (IfaceSynonym {ifName = occ_name, ifSynRhs = rhs_ty, ifBinders = binders, ifResKind = res_kind }) - = bindIfaceTyConBinders_AT binders $ \ tyvars binders' -> do + = bindIfaceTyConBinders_AT binders $ \ binders' -> do { tc_name <- lookupIfaceTop occ_name ; res_kind' <- tcIfaceType res_kind -- Note [Synonym kind loop] ; rhs <- forkM (mk_doc tc_name) $ tcIfaceType rhs_ty - ; let tycon = mkSynonymTyCon tc_name binders' res_kind' tyvars roles rhs + ; let tycon = mkSynonymTyCon tc_name binders' res_kind' roles rhs ; return (ATyCon tycon) } where mk_doc n = text "Type synonym" <+> ppr n @@ -365,13 +366,13 @@ tc_iface_decl parent _ (IfaceFamily {ifName = occ_name, ifBinders = binders, ifResKind = res_kind, ifResVar = res, ifFamInj = inj }) - = bindIfaceTyConBinders_AT binders $ \ tyvars binders' -> do + = bindIfaceTyConBinders_AT binders $ \ binders' -> do { tc_name <- lookupIfaceTop occ_name ; res_kind' <- tcIfaceType res_kind -- Note [Synonym kind loop] ; rhs <- forkM (mk_doc tc_name) $ tc_fam_flav tc_name fam_flav ; res_name <- traverse (newIfaceName . mkTyVarOccFS) res - ; let tycon = mkFamilyTyCon tc_name binders' res_kind' tyvars res_name rhs parent inj + ; let tycon = mkFamilyTyCon tc_name binders' res_kind' res_name rhs parent inj ; return (ATyCon tycon) } where mk_doc n = text "Type synonym" <+> ppr n @@ -399,7 +400,7 @@ tc_iface_decl _parent ignore_prags ifMinDef = mindef_occ, ifRec = tc_isrec }) -- ToDo: in hs-boot files we should really treat abstract classes specially, -- as we do abstract tycons - = bindIfaceTyConBinders binders $ \ tyvars binders' -> do + = bindIfaceTyConBinders binders $ \ binders' -> do { tc_name <- lookupIfaceTop tc_occ ; traceIf (text "tc-iface-class1" <+> ppr tc_occ) ; ctxt <- mapM tc_sc rdr_ctxt @@ -411,7 +412,7 @@ tc_iface_decl _parent ignore_prags ; cls <- fixM $ \ cls -> do { ats <- mapM (tc_at cls) rdr_ats ; traceIf (text "tc-iface-class4" <+> ppr tc_occ) - ; buildClass tc_name tyvars roles ctxt binders' fds ats sigs mindef tc_isrec } + ; buildClass tc_name binders' roles ctxt fds ats sigs mindef tc_isrec } ; return (ATyCon (classTyCon cls)) } where tc_sc pred = forkM (mk_sc_doc pred) (tcIfaceType pred) @@ -520,13 +521,13 @@ tc_ax_branch prev_branches , ifaxbLHS = lhs, ifaxbRHS = rhs , ifaxbRoles = roles, ifaxbIncomps = incomps }) = bindIfaceTyConBinders_AT - (map (\b -> IfaceNamed (IfaceTv b Invisible)) tv_bndrs) $ \ tvs _ -> + (map (\b -> TvBndr b (NamedTCB Invisible)) tv_bndrs) $ \ tvs -> -- The _AT variant is needed here; see Note [CoAxBranch type variables] in CoAxiom bindIfaceIds cv_bndrs $ \ cvs -> do { tc_lhs <- tcIfaceTcArgs lhs ; tc_rhs <- tcIfaceType rhs ; let br = CoAxBranch { cab_loc = noSrcSpan - , cab_tvs = tvs + , cab_tvs = binderVars tvs , cab_cvs = cvs , cab_lhs = tc_lhs , cab_roles = roles @@ -534,8 +535,8 @@ tc_ax_branch prev_branches , cab_incomps = map (prev_branches `getNth`) incomps } ; return (prev_branches ++ [br]) } -tcIfaceDataCons :: Name -> TyCon -> [TyVar] -> [TyBinder] -> IfaceConDecls -> IfL AlgTyConRhs -tcIfaceDataCons tycon_name tycon tc_tyvars tc_tybinders if_cons +tcIfaceDataCons :: Name -> TyCon -> [TyConBinder] -> IfaceConDecls -> IfL AlgTyConRhs +tcIfaceDataCons tycon_name tycon tc_tybinders if_cons = case if_cons of IfAbstractTyCon dis -> return (AbstractTyCon dis) IfDataTyCon cons _ _ -> do { field_lbls <- mapM (traverse lookupIfaceTop) (ifaceConDeclFields if_cons) @@ -545,6 +546,9 @@ tcIfaceDataCons tycon_name tycon tc_tyvars tc_tybinders if_cons ; data_con <- tc_con_decl field_lbls con ; mkNewTyConRhs tycon_name tycon data_con } where + univ_tv_bndrs :: [TyVarBinder] + univ_tv_bndrs = mkDataConUnivTyVarBinders tc_tybinders + tc_con_decl field_lbls (IfCon { ifConInfix = is_infix, ifConExTvs = ex_bndrs, ifConOcc = occ, ifConCtxt = ctxt, ifConEqSpec = spec, @@ -553,7 +557,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 -> do + bindIfaceForAllBndrs ex_bndrs $ \ ex_tv_bndrs -> do { traceIf (text "Start interface-file tc_con_decl" <+> ppr occ) ; dc_name <- lookupIfaceTop occ @@ -581,7 +585,7 @@ tcIfaceDataCons tycon_name tycon tc_tyvars tc_tybinders if_cons -- Remember, tycon is the representation tycon ; let orig_res_ty = mkFamilyTyConApp tycon (substTyVars (mkTvSubstPrs (map eqSpecPair eq_spec)) - tc_tyvars) + (binderVars tc_tybinders)) ; prom_rep_name <- newTyConRepName dc_name @@ -595,7 +599,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 + univ_tv_bndrs ex_tv_bndrs eq_spec theta arg_tys orig_res_ty tycon ; traceIf (text "Done interface-file tc_con_decl" <+> ppr dc_name) @@ -1445,7 +1449,7 @@ bindIfaceForAllBndrs (bndr:bndrs) thing_inside thing_inside (mkTyVarBinder vis tv : bndrs') bindIfaceForAllBndr :: IfaceForAllBndr -> (TyVar -> VisibilityFlag -> IfL a) -> IfL a -bindIfaceForAllBndr (IfaceTv tv vis) thing_inside +bindIfaceForAllBndr (TvBndr tv vis) thing_inside = bindIfaceTyVar tv $ \tv' -> thing_inside tv' vis bindIfaceTyVar :: IfaceTvBndr -> (TyVar -> IfL a) -> IfL a @@ -1460,25 +1464,25 @@ mk_iface_tyvar name ifKind ; return (Var.mkTyVar name kind) } bindIfaceTyConBinders :: [IfaceTyConBinder] - -> ([TyVar] -> [TyBinder] -> IfL a) -> IfL a -bindIfaceTyConBinders [] thing_inside = thing_inside [] [] + -> ([TyConBinder] -> IfL a) -> IfL a +bindIfaceTyConBinders [] thing_inside = thing_inside [] bindIfaceTyConBinders (b:bs) thing_inside - = bindIfaceTyConBinderX bindIfaceTyVar b $ \ tv' b' -> - bindIfaceTyConBinders bs $ \ tvs' bs' -> - thing_inside (tv':tvs') (b':bs') + = bindIfaceTyConBinderX bindIfaceTyVar b $ \ b' -> + bindIfaceTyConBinders bs $ \ bs' -> + thing_inside (b':bs') bindIfaceTyConBinders_AT :: [IfaceTyConBinder] - -> ([TyVar] -> [TyBinder] -> IfL a) -> IfL a + -> ([TyConBinder] -> IfL a) -> IfL a -- Used for type variable in nested associated data/type declarations -- where some of the type variables are already in scope -- class C a where { data T a b } -- Here 'a' is in scope when we look at the 'data T' bindIfaceTyConBinders_AT [] thing_inside - = thing_inside [] [] + = thing_inside [] bindIfaceTyConBinders_AT (b : bs) thing_inside - = bindIfaceTyConBinderX bind_tv b $ \tv' b' -> - bindIfaceTyConBinders_AT bs $ \tvs' bs' -> - thing_inside (tv':tvs') (b':bs') + = bindIfaceTyConBinderX bind_tv b $ \b' -> + bindIfaceTyConBinders_AT bs $ \bs' -> + thing_inside (b':bs') where bind_tv tv thing = do { mb_tv <- lookupIfaceTyVar tv @@ -1488,10 +1492,7 @@ bindIfaceTyConBinders_AT (b : bs) thing_inside bindIfaceTyConBinderX :: (IfaceTvBndr -> (TyVar -> IfL a) -> IfL a) -> IfaceTyConBinder - -> (TyVar -> TyBinder -> IfL a) -> IfL a -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 + -> (TyConBinder -> IfL a) -> IfL a +bindIfaceTyConBinderX bind_tv (TvBndr tv vis) thing_inside = bind_tv tv $ \tv' -> - thing_inside tv' (Named (mkTyVarBinder vis tv')) + thing_inside (TvBndr tv' vis) diff --git a/compiler/main/HscTypes.hs b/compiler/main/HscTypes.hs index 4529353ef3..200f642984 100644 --- a/compiler/main/HscTypes.hs +++ b/compiler/main/HscTypes.hs @@ -139,6 +139,7 @@ import ByteCodeTypes import InteractiveEvalTypes ( Resume ) import GHCi.Message ( Pipe ) import GHCi.RemoteTypes +import UniqFM #endif import HsSyn @@ -179,7 +180,6 @@ import Maybes import Outputable import SrcLoc import Unique -import UniqFM import UniqDFM import UniqSupply import FastString diff --git a/compiler/prelude/TysPrim.hs b/compiler/prelude/TysPrim.hs index e0be093420..376a0bbe43 100644 --- a/compiler/prelude/TysPrim.hs +++ b/compiler/prelude/TysPrim.hs @@ -12,12 +12,16 @@ module TysPrim( mkPrimTyConName, -- For implicit parameters in TysWiredIn only - mkTemplateTyVars, + mkTemplateKindVars, mkTemplateTyVars, mkTemplateTyVarsFrom, + mkTemplateKiTyVars, + + mkTemplateTyConBinders, mkTemplateKindTyConBinders, + mkTemplateAnonTyConBinders, + alphaTyVars, alphaTyVar, betaTyVar, gammaTyVar, deltaTyVar, alphaTys, alphaTy, betaTy, gammaTy, deltaTy, runtimeRep1TyVar, runtimeRep2TyVar, runtimeRep1Ty, runtimeRep2Ty, openAlphaTy, openBetaTy, openAlphaTyVar, openBetaTyVar, - kKiVar, -- Kind constructors... tYPETyConName, unliftedTypeKindTyConName, @@ -88,7 +92,7 @@ import {-# SOURCE #-} TysWiredIn , word32ElemRepDataConTy, word64ElemRepDataConTy, floatElemRepDataConTy , doubleElemRepDataConTy ) -import Var ( TyVar, KindVar, mkTyVar ) +import Var ( TyVar, mkTyVar ) import Name import TyCon import SrcLoc @@ -96,8 +100,8 @@ import Unique import PrelNames import FastString import Outputable -import TyCoRep -- doesn't need special access, but this is easier to avoid - -- import loops +import TyCoRep -- Doesn't need special access, but this is easier to avoid + -- import loops which show up if you import Type instead import Data.Char @@ -212,16 +216,76 @@ alphaTyVars is a list of type variables for use in templates: ["a", "b", ..., "z", "t1", "t2", ... ] -} +mkTemplateKindVars :: [Kind] -> [TyVar] +-- k0 with unique (mkAlphaTyVarUnique 0) +-- k1 with unique (mkAlphaTyVarUnique 1) +-- ... etc +mkTemplateKindVars kinds + = [ mkTyVar name kind + | (kind, u) <- kinds `zip` [0..] + , let occ = mkTyVarOccFS (mkFastString ('k' : show u)) + name = mkInternalName (mkAlphaTyVarUnique u) occ noSrcSpan + ] + +mkTemplateTyVarsFrom :: Int -> [Kind] -> [TyVar] +-- a with unique (mkAlphaTyVarUnique n) +-- b with unique (mkAlphaTyVarUnique n+1) +-- ... etc +-- Typically called as +-- mkTemplateTyVarsFrom (legth kv_bndrs) kinds +-- where kv_bndrs are the kind-level binders of a TyCon +mkTemplateTyVarsFrom n kinds + = [ mkTyVar name kind + | (kind, index) <- zip kinds [0..], + let ch_ord = index + ord 'a' + name_str | ch_ord <= ord 'z' = [chr ch_ord] + | otherwise = 't':show index + uniq = mkAlphaTyVarUnique (index + n) + name = mkInternalName uniq occ noSrcSpan + occ = mkTyVarOccFS (mkFastString name_str) + ] + mkTemplateTyVars :: [Kind] -> [TyVar] -mkTemplateTyVars kinds = - [ mkTyVar (mkInternalName (mkAlphaTyVarUnique u) - (mkTyVarOccFS (mkFastString name)) - noSrcSpan) k - | (k,u) <- zip kinds [2..], - let name | c <= 'z' = [c] - | otherwise = 't':show u - where c = chr (u-2 + ord 'a') - ] +mkTemplateTyVars = mkTemplateTyVarsFrom 1 + +mkTemplateTyConBinders + :: [Kind] -- [k1, .., kn] Kinds of kind-forall'd vars + -> ([Kind] -> [Kind]) -- Arg is [kv1:k1, ..., kvn:kn] + -- same length as first arg + -- Result is anon arg kinds + -> [TyConBinder] +mkTemplateTyConBinders kind_var_kinds mk_anon_arg_kinds + = kv_bndrs ++ tv_bndrs + where + kv_bndrs = mkTemplateKindTyConBinders kind_var_kinds + anon_kinds = mk_anon_arg_kinds (mkTyVarTys (binderVars kv_bndrs)) + tv_bndrs = mkTemplateAnonTyConBindersFrom (length kv_bndrs) anon_kinds + +mkTemplateKiTyVars + :: [Kind] -- [k1, .., kn] Kinds of kind-forall'd vars + -> ([Kind] -> [Kind]) -- Arg is [kv1:k1, ..., kvn:kn] + -- same length as first arg + -- Result is anon arg kinds [ak1, .., akm] + -> [TyVar] -- [kv1:k1, ..., kvn:kn, av1:ak1, ..., avm:akm] +-- Example: if you want the tyvars for +-- forall (r:RuntimeRep) (a:TYPE r) (b:*). blah +-- call mkTemplateKiTyVars [RuntimeRep] (\[r]. [TYPE r, *) +mkTemplateKiTyVars kind_var_kinds mk_arg_kinds + = kv_bndrs ++ tv_bndrs + where + kv_bndrs = mkTemplateKindVars kind_var_kinds + anon_kinds = mk_arg_kinds (mkTyVarTys kv_bndrs) + tv_bndrs = mkTemplateTyVarsFrom (length kv_bndrs) anon_kinds + +mkTemplateKindTyConBinders :: [Kind] -> [TyConBinder] +-- Makes named, Specified binders +mkTemplateKindTyConBinders kinds = [mkNamedTyConBinder Specified tv | tv <- mkTemplateKindVars kinds] + +mkTemplateAnonTyConBinders :: [Kind] -> [TyConBinder] +mkTemplateAnonTyConBinders kinds = map mkAnonTyConBinder (mkTemplateTyVars kinds) + +mkTemplateAnonTyConBindersFrom :: Int -> [Kind] -> [TyConBinder] +mkTemplateAnonTyConBindersFrom n kinds = map mkAnonTyConBinder (mkTemplateTyVarsFrom n kinds) alphaTyVars :: [TyVar] alphaTyVars = mkTemplateTyVars $ repeat liftedTypeKind @@ -250,10 +314,6 @@ openAlphaTy, openBetaTy :: Type openAlphaTy = mkTyVarTy openAlphaTyVar openBetaTy = mkTyVarTy openBetaTyVar -kKiVar :: KindVar -kKiVar = (mkTemplateTyVars $ repeat liftedTypeKind) !! 10 - -- the 10 selects the 11th letter in the alphabet: 'k' - {- ************************************************************************ * * @@ -266,9 +326,10 @@ funTyConName :: Name funTyConName = mkPrimTyConName (fsLit "(->)") funTyConKey funTyCon funTyCon :: TyCon -funTyCon = mkFunTyCon funTyConName (map Anon [liftedTypeKind, liftedTypeKind]) - tc_rep_nm +funTyCon = mkFunTyCon funTyConName tc_bndrs tc_rep_nm where + tc_bndrs = mkTemplateAnonTyConBinders [liftedTypeKind, liftedTypeKind] + -- You might think that (->) should have type (?? -> ? -> *), and you'd be right -- But if we do that we get kind errors when saying -- instance Control.Arrow (->) @@ -331,7 +392,7 @@ tYPETyCon, unliftedTypeKindTyCon :: TyCon tYPETyConName, unliftedTypeKindTyConName :: Name tYPETyCon = mkKindTyCon tYPETyConName - [Anon runtimeRepTy] + (mkTemplateAnonTyConBinders [runtimeRepTy]) liftedTypeKind [Nominal] (mkPrelTyConRepName tYPETyConName) @@ -340,8 +401,7 @@ tYPETyCon = mkKindTyCon tYPETyConName -- NB: unlifted is wired in because there is no way to parse it in -- Haskell. That's the only reason for wiring it in. unliftedTypeKindTyCon = mkSynonymTyCon unliftedTypeKindTyConName - [] liftedTypeKind - [] [] + [] liftedTypeKind [] (tYPE (TyConApp ptrRepUnliftedDataConTyCon [])) -------------------------- @@ -379,7 +439,7 @@ pcPrimTyCon :: Name -> [Role] -> PrimRep -> TyCon pcPrimTyCon name roles rep = mkPrimTyCon name binders result_kind roles where - binders = map (const (Anon liftedTypeKind)) roles + binders = mkTemplateAnonTyConBinders (map (const liftedTypeKind) roles) result_kind = tYPE rr rr = case rep of @@ -682,11 +742,10 @@ mkProxyPrimTy k ty = TyConApp proxyPrimTyCon [k, ty] proxyPrimTyCon :: TyCon proxyPrimTyCon = mkPrimTyCon proxyPrimTyConName binders res_kind [Nominal,Nominal] - where binders = [ Named (TvBndr kv Specified) - , Anon k ] - res_kind = tYPE voidRepDataConTy - kv = kKiVar - k = mkTyVarTy kv + where + -- Kind: forall k. k -> Void# + binders = mkTemplateTyConBinders [liftedTypeKind] (\ks-> ks) + res_kind = tYPE voidRepDataConTy {- ********************************************************************* @@ -699,46 +758,33 @@ 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 (TvBndr kv1 Specified) - , Named (TvBndr kv2 Specified) - , Anon k1 - , Anon k2 ] - res_kind = tYPE voidRepDataConTy - [kv1, kv2] = mkTemplateTyVars [liftedTypeKind, liftedTypeKind] - k1 = mkTyVarTy kv1 - k2 = mkTyVarTy kv2 - roles = [Nominal, Nominal, Nominal, Nominal] + where + -- Kind :: forall k1 k2. k1 -> k2 -> Void# + binders = mkTemplateTyConBinders [liftedTypeKind, liftedTypeKind] (\ks -> ks) + res_kind = tYPE voidRepDataConTy + roles = [Nominal, Nominal, Nominal, Nominal] -- like eqPrimTyCon, but the type for *Representational* coercions -- this should only ever appear as the type of a covar. Its role is -- interpreted in coercionRole eqReprPrimTyCon :: TyCon -- See Note [The equality types story] eqReprPrimTyCon = mkPrimTyCon eqReprPrimTyConName binders res_kind roles - where binders = [ Named (TvBndr kv1 Specified) - , Named (TvBndr kv2 Specified) - , Anon k1 - , Anon k2 ] - res_kind = tYPE voidRepDataConTy - [kv1, kv2] = mkTemplateTyVars [liftedTypeKind, liftedTypeKind] - k1 = mkTyVarTy kv1 - k2 = mkTyVarTy kv2 - roles = [Nominal, Nominal, Representational, Representational] + where + -- Kind :: forall k1 k2. k1 -> k2 -> Void# + binders = mkTemplateTyConBinders [liftedTypeKind, liftedTypeKind] (\ks -> ks) + res_kind = tYPE voidRepDataConTy + roles = [Nominal, Nominal, Representational, Representational] -- like eqPrimTyCon, but the type for *Phantom* coercions. -- This is only used to make higher-order equalities. Nothing -- should ever actually have this type! eqPhantPrimTyCon :: TyCon -eqPhantPrimTyCon = mkPrimTyCon eqPhantPrimTyConName binders res_kind - [Nominal, Nominal, Phantom, Phantom] - where binders = [ Named (TvBndr kv1 Specified) - , Named (TvBndr kv2 Specified) - , Anon k1 - , Anon k2 ] - res_kind = tYPE voidRepDataConTy - [kv1, kv2] = mkTemplateTyVars [liftedTypeKind, liftedTypeKind] - k1 = mkTyVarTy kv1 - k2 = mkTyVarTy kv2 - +eqPhantPrimTyCon = mkPrimTyCon eqPhantPrimTyConName binders res_kind roles + where + -- Kind :: forall k1 k2. k1 -> k2 -> Void# + binders = mkTemplateTyConBinders [liftedTypeKind, liftedTypeKind] (\ks -> ks) + res_kind = tYPE voidRepDataConTy + roles = [Nominal, Nominal, Phantom, Phantom] {- ********************************************************************* * * diff --git a/compiler/prelude/TysWiredIn.hs b/compiler/prelude/TysWiredIn.hs index 82c5bfb389..15cb7a1399 100644 --- a/compiler/prelude/TysWiredIn.hs +++ b/compiler/prelude/TysWiredIn.hs @@ -9,6 +9,14 @@ -- | This module is about types that can be defined in Haskell, but which -- must be wired into the compiler nonetheless. C.f module TysPrim module TysWiredIn ( + -- * Helper functions defined here + mkWiredInTyConName, -- This is used in TcTypeNats to define the + -- built-in functions for evaluation. + + mkWiredInIdName, -- used in MkId + + mkFunKind, mkForAllKind, + -- * All wired in things wiredInTyCons, isBuiltInOcc_maybe, @@ -50,7 +58,6 @@ module TysWiredIn ( nilDataCon, nilDataConName, nilDataConKey, consDataCon_RDR, consDataCon, consDataConName, promotedNilDataCon, promotedConsDataCon, - mkListTy, -- * Maybe @@ -86,11 +93,6 @@ module TysWiredIn ( heqTyCon, heqClass, heqDataCon, coercibleTyCon, coercibleDataCon, coercibleClass, - mkWiredInTyConName, -- This is used in TcTypeNats to define the - -- built-in functions for evaluation. - - mkWiredInIdName, -- used in MkId - -- * RuntimeRep and friends runtimeRepTyCon, vecCountTyCon, vecElemTyCon, @@ -347,13 +349,13 @@ anyTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Any") anyTyConKey anyTyCon anyTyCon :: TyCon -anyTyCon = mkFamilyTyCon anyTyConName binders res_kind [kKiVar] Nothing +anyTyCon = mkFamilyTyCon anyTyConName binders res_kind Nothing (ClosedSynFamilyTyCon Nothing) Nothing NotInjective where - binders = [mkNamedBinder (mkTyVarBinder Specified kKiVar)] - res_kind = mkTyVarTy kKiVar + binders@[kv] = mkTemplateKindTyConBinders [liftedTypeKind] + res_kind = mkTyVarTy (binderVar kv) anyTy :: Type anyTy = mkTyConTy anyTyCon @@ -453,9 +455,8 @@ pcNonRecDataTyCon = pcTyCon False NonRecursive pcTyCon :: Bool -> RecFlag -> Name -> Maybe CType -> [TyVar] -> [DataCon] -> TyCon pcTyCon is_enum is_rec name cType tyvars cons = mkAlgTyCon name - (map (mkAnonBinder . tyVarKind) tyvars) + (mkAnonTyConBinders tyvars) liftedTypeKind - tyvars (map (const Representational) tyvars) cType [] -- No stupid theta @@ -550,6 +551,14 @@ liftedTypeKind = tYPE ptrRepLiftedTy constraintKind = mkTyConApp constraintKindTyCon [] unboxedTupleKind = tYPE unboxedTupleRepDataConTy +-- mkFunKind and mkForAllKind are defined here +-- solely so that TyCon can use them via a SOURCE import +mkFunKind :: Kind -> Kind -> Kind +mkFunKind = mkFunTy + +mkForAllKind :: TyVar -> VisibilityFlag -> Kind -> Kind +mkForAllKind = mkForAllTy + {- ************************************************************************ * * @@ -729,50 +738,54 @@ boxedTupleArr = listArray (0,mAX_TUPLE_SIZE) [mk_tuple Boxed i | i <- [0..mA unboxedTupleArr = listArray (0,mAX_TUPLE_SIZE) [mk_tuple Unboxed i | i <- [0..mAX_TUPLE_SIZE]] mk_tuple :: Boxity -> Int -> (TyCon,DataCon) -mk_tuple boxity arity = (tycon, tuple_con) +mk_tuple Boxed arity = (tycon, tuple_con) + where + tycon = mkTupleTyCon tc_name tc_binders tc_res_kind tc_arity tuple_con + BoxedTuple flavour + + tc_binders = mkTemplateAnonTyConBinders (nOfThem arity liftedTypeKind) + tc_res_kind = liftedTypeKind + tc_arity = arity + flavour = VanillaAlgTyCon (mkPrelTyConRepName tc_name) + + dc_tvs = binderVars tc_binders + dc_arg_tys = mkTyVarTys dc_tvs + tuple_con = pcDataCon dc_name dc_tvs dc_arg_tys tycon + + boxity = Boxed + modu = gHC_TUPLE + tc_name = mkWiredInName modu (mkTupleOcc tcName boxity arity) tc_uniq + (ATyCon tycon) BuiltInSyntax + dc_name = mkWiredInName modu (mkTupleOcc dataName boxity arity) dc_uniq + (AConLike (RealDataCon tuple_con)) BuiltInSyntax + tc_uniq = mkTupleTyConUnique boxity arity + dc_uniq = mkTupleDataConUnique boxity arity + +mk_tuple Unboxed arity = (tycon, tuple_con) where - tycon = mkTupleTyCon tc_name tc_binders tc_res_kind tc_arity tyvars tuple_con - tup_sort flavour - - (tup_sort, modu, tc_binders, tc_res_kind, tc_arity, tyvars, tyvar_tys, flavour) - = case boxity of - Boxed -> - let boxed_tyvars = take arity alphaTyVars in - ( BoxedTuple - , gHC_TUPLE - , nOfThem arity (mkAnonBinder liftedTypeKind) - , liftedTypeKind - , arity - , boxed_tyvars - , mkTyVarTys boxed_tyvars - , VanillaAlgTyCon (mkPrelTyConRepName tc_name) - ) - -- See Note [Unboxed tuple RuntimeRep vars] in TyCon - Unboxed -> - let all_tvs = mkTemplateTyVars (replicate arity runtimeRepTy ++ - map (tYPE . mkTyVarTy) (take arity all_tvs)) - -- NB: This must be one call to mkTemplateTyVars, to make - -- sure that all the uniques are different - (rr_tvs, open_tvs) = splitAt arity all_tvs - in - ( UnboxedTuple - , gHC_PRIM - , map (mkNamedBinder . mkTyVarBinder Specified) rr_tvs ++ - map (mkAnonBinder . tyVarKind) open_tvs - , unboxedTupleKind - , arity * 2 - , all_tvs - , mkTyVarTys open_tvs - , UnboxedAlgTyCon - ) - - tc_name = mkWiredInName modu (mkTupleOcc tcName boxity arity) tc_uniq - (ATyCon tycon) BuiltInSyntax - tuple_con = pcDataCon dc_name tyvars tyvar_tys tycon - dc_name = mkWiredInName modu (mkTupleOcc dataName boxity arity) dc_uniq - (AConLike (RealDataCon tuple_con)) BuiltInSyntax - tc_uniq = mkTupleTyConUnique boxity arity - dc_uniq = mkTupleDataConUnique boxity arity + tycon = mkTupleTyCon tc_name tc_binders tc_res_kind tc_arity tuple_con + UnboxedTuple flavour + + -- See Note [Unboxed tuple RuntimeRep vars] in TyCon + -- Kind: forall (k1:RuntimeRep) (k2:RuntimeRep). TYPE k2 -> TYPE k2 -> # + tc_binders = mkTemplateTyConBinders (nOfThem arity runtimeRepTy) + (\ks -> map tYPE ks) + tc_res_kind = unboxedTupleKind + tc_arity = arity * 2 + flavour = UnboxedAlgTyCon + + dc_tvs = binderVars tc_binders + dc_arg_tys = mkTyVarTys (drop arity dc_tvs) + tuple_con = pcDataCon dc_name dc_tvs dc_arg_tys tycon + + boxity = Unboxed + modu = gHC_PRIM + tc_name = mkWiredInName modu (mkTupleOcc tcName boxity arity) tc_uniq + (ATyCon tycon) BuiltInSyntax + dc_name = mkWiredInName modu (mkTupleOcc dataName boxity arity) dc_uniq + (AConLike (RealDataCon tuple_con)) BuiltInSyntax + tc_uniq = mkTupleTyConUnique boxity arity + dc_uniq = mkTupleDataConUnique boxity arity unitTyCon :: TyCon unitTyCon = tupleTyCon Boxed 0 @@ -812,48 +825,43 @@ heqSCSelId, coercibleSCSelId :: Id (heqTyCon, heqClass, heqDataCon, heqSCSelId) = (tycon, klass, datacon, sc_sel_id) where - tycon = mkClassTyCon heqTyConName binders tvs roles + tycon = mkClassTyCon heqTyConName binders roles rhs klass NonRecursive (mkPrelTyConRepName heqTyConName) - klass = mkClass tvs [] [sc_pred] [sc_sel_id] [] [] (mkAnd []) tycon + klass = mk_class tycon sc_pred sc_sel_id datacon = pcDataCon heqDataConName tvs [sc_pred] tycon - binders = [ mkNamedBinder (mkTyVarBinder Specified kv1) - , mkNamedBinder (mkTyVarBinder Specified kv2) - , mkAnonBinder k1 - , mkAnonBinder k2 ] - kv1:kv2:_ = drop 9 alphaTyVars -- gets "j" and "k" - k1 = mkTyVarTy kv1 - k2 = mkTyVarTy kv2 - [av,bv] = mkTemplateTyVars [k1, k2] - tvs = [kv1, kv2, av, bv] + -- Kind: forall k1 k2. k1 -> k2 -> Constraint + binders = mkTemplateTyConBinders [liftedTypeKind, liftedTypeKind] (\ks -> ks) roles = [Nominal, Nominal, Nominal, Nominal] rhs = DataTyCon { data_cons = [datacon], is_enum = False } + tvs = binderVars binders sc_pred = mkTyConApp eqPrimTyCon (mkTyVarTys tvs) sc_sel_id = mkDictSelId heqSCSelIdName klass (coercibleTyCon, coercibleClass, coercibleDataCon, coercibleSCSelId) = (tycon, klass, datacon, sc_sel_id) where - tycon = mkClassTyCon coercibleTyConName binders tvs roles + tycon = mkClassTyCon coercibleTyConName binders roles rhs klass NonRecursive (mkPrelTyConRepName coercibleTyConName) - klass = mkClass tvs [] [sc_pred] [sc_sel_id] [] [] (mkAnd []) tycon + klass = mk_class tycon sc_pred sc_sel_id datacon = pcDataCon coercibleDataConName tvs [sc_pred] tycon - binders = [ mkNamedBinder (mkTyVarBinder Specified kKiVar) - , mkAnonBinder k - , mkAnonBinder k ] - k = mkTyVarTy kKiVar - [av,bv] = mkTemplateTyVars [k, k] - tvs = [kKiVar, av, bv] + -- Kind: forall k. k -> k -> Constraint + binders = mkTemplateTyConBinders [liftedTypeKind] (\[k] -> [k,k]) roles = [Nominal, Representational, Representational] rhs = DataTyCon { data_cons = [datacon], is_enum = False } - sc_pred = mkTyConApp eqReprPrimTyCon [k, k, mkTyVarTy av, mkTyVarTy bv] - sc_sel_id = mkDictSelId coercibleSCSelIdName klass + tvs@[k,a,b] = binderVars binders + sc_pred = mkTyConApp eqReprPrimTyCon (mkTyVarTys [k, k, a, b]) + sc_sel_id = mkDictSelId coercibleSCSelIdName klass +mk_class :: TyCon -> PredType -> Id -> Class +mk_class tycon sc_pred sc_sel_id + = mkClass (tyConName tycon) (tyConTyVars tycon) [] [sc_pred] [sc_sel_id] + [] [] (mkAnd []) tycon {- ********************************************************************* * * @@ -870,18 +878,15 @@ liftedTypeKindTyCon, starKindTyCon, unicodeStarKindTyCon :: TyCon -- See Note [TYPE] in TysPrim liftedTypeKindTyCon = mkSynonymTyCon liftedTypeKindTyConName - [] liftedTypeKind - [] [] + [] liftedTypeKind [] (tYPE ptrRepLiftedTy) starKindTyCon = mkSynonymTyCon starKindTyConName - [] liftedTypeKind - [] [] + [] liftedTypeKind [] (tYPE ptrRepLiftedTy) unicodeStarKindTyCon = mkSynonymTyCon unicodeStarKindTyConName - [] liftedTypeKind - [] [] + [] liftedTypeKind [] (tYPE ptrRepLiftedTy) runtimeRepTyCon :: TyCon diff --git a/compiler/prelude/TysWiredIn.hs-boot b/compiler/prelude/TysWiredIn.hs-boot index 0c8ed7e4da..d1debba7cd 100644 --- a/compiler/prelude/TysWiredIn.hs-boot +++ b/compiler/prelude/TysWiredIn.hs-boot @@ -1,9 +1,13 @@ module TysWiredIn where +import Var( TyVar, VisibilityFlag ) import {-# SOURCE #-} TyCon ( TyCon ) import {-# SOURCE #-} TyCoRep (Type, Kind) +mkFunKind :: Kind -> Kind -> Kind +mkForAllKind :: TyVar -> VisibilityFlag -> Kind -> Kind + listTyCon :: TyCon typeNatKind, typeSymbolKind :: Type mkBoxedTupleTy :: [Type] -> Type diff --git a/compiler/typecheck/Inst.hs b/compiler/typecheck/Inst.hs index 7ed98de881..a92c70933e 100644 --- a/compiler/typecheck/Inst.hs +++ b/compiler/typecheck/Inst.hs @@ -46,14 +46,14 @@ import CoreSyn ( isOrphan ) import FunDeps import TcMType import Type -import TyCoRep ( TyBinder(..), TyVarBinder(..) ) +import TyCoRep ( TyBinder(..) ) import TcType import HscTypes import Class( Class ) import MkId( mkDictFunId ) import Id import Name -import Var ( EvVar, mkTyVar ) +import Var ( EvVar, mkTyVar, TyVarBndr(..) ) import DataCon import TyCon import VarEnv diff --git a/compiler/typecheck/TcBinds.hs b/compiler/typecheck/TcBinds.hs index fb89416e04..20abdc3516 100644 --- a/compiler/typecheck/TcBinds.hs +++ b/compiler/typecheck/TcBinds.hs @@ -35,7 +35,7 @@ import FamInstEnv( normaliseType ) import FamInst( tcGetFamInstEnvs ) import TyCon import TcType -import Type( mkStrLitTy, tidyOpenType, TyVarBinder, mkTyVarBinder ) +import Type( mkStrLitTy, tidyOpenType, mkTyVarBinder ) import TysPrim import TysWiredIn( cTupleTyConName ) import Id diff --git a/compiler/typecheck/TcCanonical.hs b/compiler/typecheck/TcCanonical.hs index 3d05a554b2..256cf94354 100644 --- a/compiler/typecheck/TcCanonical.hs +++ b/compiler/typecheck/TcCanonical.hs @@ -607,7 +607,7 @@ can_eq_nc' _flat _rdr_env _envs ev eq_rel else do { traceTcS "Creating implication for polytype equality" $ ppr ev ; kind_cos <- zipWithM (unifyWanted loc Nominal) - (map binderType bndrs1) (map binderType bndrs2) + (map binderKind bndrs1) (map binderKind bndrs2) ; all_co <- deferTcSForAllEq (eqRelRole eq_rel) loc kind_cos (bndrs1,body1) (bndrs2,body2) ; setWantedEq orig_dest all_co @@ -1138,7 +1138,7 @@ canDecomposableTyConAppOK ev eq_rel tc tys1 tys2 -- in error messages bndrs = tyConBinders tc kind_loc = toKindLoc loc - is_kinds = map isNamedTyBinder bndrs + is_kinds = map isNamedTyConBinder bndrs new_locs | Just KindLevel <- ctLocTypeOrKind_maybe loc = repeat loc | otherwise diff --git a/compiler/typecheck/TcDeriv.hs b/compiler/typecheck/TcDeriv.hs index 2418517a12..16aecdca03 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 - | isNamedTyBinder bndr = KindLevel - | otherwise = TypeLevel + | isNamedTyConBinder 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/TcFlatten.hs b/compiler/typecheck/TcFlatten.hs index f31c122ff4..4e02e99299 100644 --- a/compiler/typecheck/TcFlatten.hs +++ b/compiler/typecheck/TcFlatten.hs @@ -986,7 +986,7 @@ flatten_one ty@(ForAllTy {}) -- We allow for-alls when, but only when, no type function -- applications inside the forall involve the bound type variables. = do { let (bndrs, rho) = splitForAllTyVarBndrs ty - tvs = map binderVar bndrs + tvs = binderVars 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 99838fe92a..02227c7ecb 100644 --- a/compiler/typecheck/TcForeign.hs +++ b/compiler/typecheck/TcForeign.hs @@ -131,7 +131,7 @@ normaliseFfiType' env ty0 = go initRecTc ty0 | (bndrs, inner_ty) <- splitForAllTyVarBndrs ty , not (null bndrs) = do (coi, nty1, gres1) <- go rec_nts inner_ty - return ( mkHomoForAllCos (map binderVar bndrs) coi + return ( mkHomoForAllCos (binderVars bndrs) coi , mkForAllTys bndrs nty1, gres1 ) | otherwise -- see Note [Don't recur in normaliseFfiType'] diff --git a/compiler/typecheck/TcGenGenerics.hs b/compiler/typecheck/TcGenGenerics.hs index 4443ed729c..a192357fb5 100644 --- a/compiler/typecheck/TcGenGenerics.hs +++ b/compiler/typecheck/TcGenGenerics.hs @@ -540,9 +540,6 @@ tc_mkRepTy gk_ tycon k = let mkSum' a b = mkTyConApp plus [k,a,b] mkProd a b = mkTyConApp times [k,a,b] - -- The second kind variable of (:.:) must always be *. - -- See Note [Handling kinds in a Rep instance] - mkComp a b = mkTyConApp comp [k,liftedTypeKind,a,b] mkRec0 a = mkBoxTy uAddr uChar uDouble uFloat uInt uWord rec0 k a mkRec1 a = mkTyConApp rec1 [k,a] mkPar1 = mkTyConTy par1 @@ -582,7 +579,7 @@ tc_mkRepTy gk_ tycon k = -- the presence of composition). argPar argVar = argTyFold argVar $ ArgTyAlg {ata_rec0 = mkRec0, ata_par1 = mkPar1, - ata_rec1 = mkRec1, ata_comp = mkComp} + ata_rec1 = mkRec1, ata_comp = mkComp comp k} tyConName_user = case tyConFamInst_maybe tycon of Just (ptycon, _) -> tyConName ptycon @@ -640,6 +637,21 @@ tc_mkRepTy gk_ tycon k = return (mkD tycon) +mkComp :: TyCon -> Kind -> Type -> Type -> Type +mkComp comp k f g + | k1_first = mkTyConApp comp [k,liftedTypeKind,f,g] + | otherwise = mkTyConApp comp [liftedTypeKind,k,f,g] + where + -- Which of these is the case? + -- newtype (:.:) {k1} {k2} (f :: k2->*) (g :: k1->k2) (p :: k1) = ... + -- or newtype (:.:) {k2} {k1} (f :: k2->*) (g :: k1->k2) (p :: k1) = ... + -- We want to instantiate with k1=k, and k2=* + -- Reason for k2=*: see Note [Handling kinds in a Rep instance] + -- But we need to know which way round! + k1_first = k_first == p_kind_var + [k_first,_,_,_,p] = tyConTyVars comp + Just p_kind_var = getTyVar_maybe (tyVarKind p) + -- Given the TyCons for each URec-related type synonym, check to see if the -- given type is an unlifted type that generics understands. If so, return -- its representation type. Otherwise, return Rec0. diff --git a/compiler/typecheck/TcHsSyn.hs b/compiler/typecheck/TcHsSyn.hs index 87f333bc92..a50cb4d306 100644 --- a/compiler/typecheck/TcHsSyn.hs +++ b/compiler/typecheck/TcHsSyn.hs @@ -26,10 +26,11 @@ module TcHsSyn ( -- | For a description of "zonking", see Note [What is zonking?] -- in TcMType zonkTopDecls, zonkTopExpr, zonkTopLExpr, - zonkTopBndrs, zonkTyBndrsX, zonkTyBinders, + zonkTopBndrs, zonkTyBndrsX, + zonkTyConBinders, emptyZonkEnv, mkEmptyZonkEnv, zonkTcTypeToType, zonkTcTypeToTypes, zonkTyVarOcc, - zonkCoToCo, zonkTcKindToKind, + zonkCoToCo, zonkEvBinds, -- * Validity checking @@ -48,7 +49,6 @@ import TcEvidence import TysPrim import TysWiredIn import Type -import TyCoRep ( TyBinder(..), TyVarBinder(..) ) import TyCon import Coercion import ConLike @@ -340,14 +340,13 @@ zonkTyBndrX env tv ; let tv' = mkTyVar (tyVarName tv) ki ; return (extendTyZonkEnv1 env tv', tv') } -zonkTyBinders :: ZonkEnv -> [TcTyBinder] -> TcM (ZonkEnv, [TyBinder]) -zonkTyBinders = mapAccumLM zonkTyBinder +zonkTyConBinders :: ZonkEnv -> [TyConBinder] -> TcM (ZonkEnv, [TyConBinder]) +zonkTyConBinders = mapAccumLM zonkTyConBinderX -zonkTyBinder :: ZonkEnv -> TcTyBinder -> TcM (ZonkEnv, TyBinder) -zonkTyBinder env (Anon ty) = (env, ) <$> (Anon <$> zonkTcTypeToType env ty) -zonkTyBinder env (Named (TvBndr tv vis)) +zonkTyConBinderX :: ZonkEnv -> TyConBinder -> TcM (ZonkEnv, TyConBinder) +zonkTyConBinderX env (TvBndr tv vis) = do { (env', tv') <- zonkTyBndrX env tv - ; return (env', Named (TvBndr tv' vis)) } + ; return (env', TvBndr tv' vis) } zonkTopExpr :: HsExpr TcId -> TcM (HsExpr Id) zonkTopExpr e = zonkExpr emptyZonkEnv e @@ -1576,14 +1575,6 @@ zonkTcTypeToType = mapType zonk_tycomapper zonkTcTypeToTypes :: ZonkEnv -> [TcType] -> TcM [Type] zonkTcTypeToTypes env tys = mapM (zonkTcTypeToType env) tys --- | Used during kind-checking in TcTyClsDecls, where it's more convenient --- to keep the binders and result kind separate. -zonkTcKindToKind :: [TcTyBinder] -> TcKind -> TcM ([TyBinder], Kind) -zonkTcKindToKind binders res_kind - = do { (env, binders') <- zonkTyBinders emptyZonkEnv binders - ; res_kind' <- zonkTcTypeToType env res_kind - ; return (binders', res_kind') } - zonkCoToCo :: ZonkEnv -> Coercion -> TcM Coercion zonkCoToCo = mapCoercion zonk_tycomapper diff --git a/compiler/typecheck/TcHsType.hs b/compiler/typecheck/TcHsType.hs index 7297066966..eba5e18949 100644 --- a/compiler/typecheck/TcHsType.hs +++ b/compiler/typecheck/TcHsType.hs @@ -741,14 +741,15 @@ bigConstraintTuple arity -- the visible ones. tcInferArgs :: Outputable fun => fun -- ^ the function - -> [TyBinder] -- ^ function kind's binders + -> [TyConBinder] -- ^ function kind's binders -> Maybe (VarEnv Kind) -- ^ possibly, kind info (see above) -> [LHsType Name] -- ^ args -> TcM (TCvSubst, [TyBinder], [TcType], [LHsType Name], Int) -- ^ (instantiating subst, un-insted leftover binders, -- typechecked args, untypechecked args, n) -tcInferArgs fun binders mb_kind_info args - = do { (subst, leftover_binders, args', leftovers, n) +tcInferArgs fun tc_binders mb_kind_info args + = do { let binders = tyConBindersTyBinders tc_binders -- UGH! + ; (subst, leftover_binders, args', leftovers, n) <- tc_infer_args typeLevelMode fun binders mb_kind_info args 1 -- now, we need to instantiate any remaining invisible arguments ; let (invis_bndrs, other_binders) = span isInvisibleBinder leftover_binders @@ -1241,14 +1242,15 @@ kcHsTyVarBndrs name cusk open_fam all_kind_vars = do { kv_kinds <- mk_kv_kinds ; let scoped_kvs = zipWith mk_skolem_tv kv_ns kv_kinds ; tcExtendTyVarEnv2 (kv_ns `zip` scoped_kvs) $ - do { (tvs, binders, res_kind, stuff) <- solveEqualities $ - bind_telescope hs_tvs thing_inside + do { (tc_binders, res_kind, stuff) <- solveEqualities $ + bind_telescope hs_tvs thing_inside -- Now, because we're in a CUSK, quantify over the mentioned -- kind vars, in dependency order. - ; binders <- mapM zonkTcTyBinder binders + ; tc_binders <- mapM zonkTyConBinder tc_binders ; res_kind <- zonkTcType res_kind - ; let qkvs = tyCoVarsOfTypeWellScoped (mkPiTys binders res_kind) + ; let tc_tvs = binderVars tc_binders + qkvs = tyCoVarsOfTypeWellScoped (mkTyConKind tc_binders res_kind) -- the visibility of tvs doesn't matter here; we just -- want the free variables not to include the tvs @@ -1256,41 +1258,40 @@ kcHsTyVarBndrs name cusk open_fam all_kind_vars -- 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) + report_non_cusk_tvs (qkvs ++ tc_tvs) - -- if any of the scoped_kvs aren't actually mentioned in a binder's + -- If any of the scoped_kvs aren't actually mentioned in a binder's -- kind (or the return kind), then we're in the CUSK case from -- Note [Free-floating kind vars] - ; let tycon_tyvars = good_tvs ++ tvs + ; let all_tc_tvs = good_tvs ++ tc_tvs all_mentioned_tvs = mapUnionVarSet (tyCoVarsOfType . tyVarKind) - tycon_tyvars + all_tc_tvs `unionVarSet` tyCoVarsOfType res_kind unmentioned_kvs = filterOut (`elemVarSet` all_mentioned_tvs) scoped_kvs - ; reportFloatingKvs name tycon_tyvars unmentioned_kvs - - ; let final_binders = mkNamedTyBinders Specified good_tvs ++ binders - mk_tctc unsat = mkTcTyCon name tycon_tyvars - final_binders res_kind - unsat (scoped_kvs ++ tvs) - -- the tvs contain the binders already - -- in scope from an enclosing class, but - -- re-adding tvs to the env't doesn't cause - -- harm + ; reportFloatingKvs name all_tc_tvs unmentioned_kvs + + ; let final_binders = map (mkNamedTyConBinder Specified) good_tvs + ++ tc_binders + mk_tctc unsat = mkTcTyCon name final_binders res_kind + unsat (scoped_kvs ++ tc_tvs) + -- the tvs contain the binders already + -- in scope from an enclosing class, but + -- re-adding tvs to the env't doesn't cause + -- harm ; return ( mk_tctc, stuff ) }} | otherwise = do { kv_kinds <- mk_kv_kinds ; scoped_kvs <- zipWithM newSigTyVar kv_ns kv_kinds -- the names must line up in splitTelescopeTvs - ; (tvs, binders, res_kind, stuff) + ; (binders, res_kind, stuff) <- tcExtendTyVarEnv2 (kv_ns `zip` scoped_kvs) $ bind_telescope hs_tvs thing_inside ; let -- NB: Don't add scoped_kvs to tyConTyVars, because they -- must remain lined up with the binders - mk_tctc unsat = mkTcTyCon name tvs - binders res_kind unsat - (scoped_kvs ++ tvs) + mk_tctc unsat = mkTcTyCon name binders res_kind unsat + (scoped_kvs ++ binderVars binders) ; return (mk_tctc, stuff) } where -- if -XNoTypeInType and we know all the implicits are kind vars, @@ -1306,24 +1307,23 @@ kcHsTyVarBndrs name cusk open_fam all_kind_vars -- to handle them one at a time. bind_telescope :: [LHsTyVarBndr Name] -> TcM (Kind, r) - -> TcM ([TcTyVar], [TyBinder], TcKind, r) + -> TcM ([TyConBinder], TcKind, r) bind_telescope [] thing = do { (res_kind, stuff) <- thing - ; return ([], [], res_kind, stuff) } + ; return ([], res_kind, stuff) } bind_telescope (L _ hs_tv : hs_tvs) thing = do { tv_pair@(tv, _) <- kc_hs_tv hs_tv -- NB: Bring all tvs into scope, even non-dependent ones, -- as they're needed in type synonyms, data constructors, etc. - ; (tvs, binders, res_kind, stuff) <- bind_unless_scoped tv_pair $ - bind_telescope hs_tvs $ - thing + ; (binders, res_kind, stuff) <- bind_unless_scoped tv_pair $ + bind_telescope hs_tvs $ + thing -- See Note [Dependent LHsQTyVars] ; let new_binder | hsTyVarName hs_tv `elemNameSet` dep_names - = mkNamedBinder (mkTyVarBinder Visible tv) + = mkNamedTyConBinder Visible tv | otherwise - = mkAnonBinder (tyVarKind tv) - ; return ( tv : tvs - , new_binder : binders + = mkAnonTyConBinder tv + ; return ( new_binder : binders , res_kind, stuff ) } -- | Bind the tyvar in the env't unless the bool is True @@ -1619,7 +1619,7 @@ kcTyClTyVars tycon_name thing_inside ; tcExtendTyVarEnv (tcTyConScopedTyVars tycon) $ thing_inside } tcTyClTyVars :: Name - -> ([TyVar] -> [TyBinder] -> Kind -> TcM a) -> TcM a + -> ([TyConBinder] -> Kind -> TcM a) -> TcM a -- ^ Used for the type variables of a type or class decl -- on the second full pass (type-checking/desugaring) in TcTyClDecls. -- This is *not* used in the initial-kind run, nor in the "kind-checking" pass. @@ -1640,9 +1640,7 @@ tcTyClTyVars tycon_name thing_inside = do { tycon <- kcLookupTcTyCon tycon_name ; let scoped_tvs = tcTyConScopedTyVars tycon - -- these are all zonked: - tkvs = tyConTyVars tycon binders = tyConBinders tycon res_kind = tyConResKind tycon @@ -1655,11 +1653,11 @@ tcTyClTyVars tycon_name thing_inside -- Add the *unzonked* tyvars to the env't, because those -- are the ones mentioned in the source. ; tcExtendTyVarEnv scoped_tvs $ - thing_inside tkvs binders res_kind } + thing_inside binders res_kind } where ----------------------------------- -tcDataKindSig :: Kind -> TcM ([TyVar], [TyBinder], Kind) +tcDataKindSig :: Kind -> TcM ([TyConBinder], Kind) -- GADT decls can have a (perhaps partial) kind signature -- e.g. data T :: * -> * -> * where ... -- This function makes up suitable (kinded) type variables for @@ -1679,21 +1677,24 @@ tcDataKindSig kind , isNothing (lookupLocalRdrOcc rdr_env occ) ] -- Note [Avoid name clashes for associated data types] - -- 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. - 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 ] + extra_bndrs = zipWith3 (mk_tc_bndr span) tv_bndrs occs uniqs - ; return (tvs, bndrs, res_kind) } + ; return (extra_bndrs, res_kind) } where - (bndrs, res_kind) = splitPiTys kind + (tv_bndrs, res_kind) = splitPiTys kind mk_tv loc uniq occ kind = mkTyVar (mkInternalName uniq occ loc) 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. + -- Ugh! + mk_tc_bndr loc tv_bndr occ uniq + = case tv_bndr of + Named (TvBndr tv vis) -> TvBndr tv (NamedTCB vis) + Anon kind -> TvBndr (mk_tv loc uniq occ kind) AnonTCB + + badKindSig :: Kind -> SDoc badKindSig kind = hang (text "Kind signature on data type declaration has non-* return kind") diff --git a/compiler/typecheck/TcInstDcls.hs b/compiler/typecheck/TcInstDcls.hs index 8c968df18c..27ccd5a4bf 100644 --- a/compiler/typecheck/TcInstDcls.hs +++ b/compiler/typecheck/TcInstDcls.hs @@ -649,10 +649,10 @@ tcDataFamInstDecl mb_clsinfo orig_res_ty = mkTyConApp fam_tc pats' ; (rep_tc, axiom) <- fixM $ \ ~(rec_rep_tc, _) -> - do { let ty_binders = mkTyBindersPreferAnon full_tvs liftedTypeKind + do { let ty_binders = mkTyConBindersPreferAnon full_tvs liftedTypeKind ; data_cons <- tcConDecls new_or_data rec_rep_tc - (full_tvs, ty_binders, orig_res_ty) cons + (ty_binders, orig_res_ty) cons ; tc_rhs <- case new_or_data of DataType -> return (mkDataTyConRhs data_cons) NewType -> ASSERT( not (null data_cons) ) @@ -668,7 +668,6 @@ tcDataFamInstDecl mb_clsinfo -- the end of Note [Data type families] in TyCon rep_tc = mkAlgTyCon rep_tc_name ty_binders liftedTypeKind - full_tvs (map (const Nominal) full_tvs) (fmap unLoc cType) stupid_theta tc_rhs parent diff --git a/compiler/typecheck/TcInteract.hs b/compiler/typecheck/TcInteract.hs index f6a59e1c9e..a9f7bc68ef 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 isNamedTyBinder used_bndrs && - all isAnonTyBinder leftover_bndrs + = all isNamedTyConBinder used_bndrs && + all (not . isNamedTyConBinder) leftover_bndrs where bndrs = tyConBinders tc (used_bndrs, leftover_bndrs) = splitAtList ks bndrs @@ -2052,9 +2052,10 @@ doTyApp clas ty f tk | isForAllTy (typeKind f) = return NoInstance -- We can't solve until we know the ctr. | otherwise - = return $ GenInst [mk_typeable_pred clas f, mk_typeable_pred clas tk] + = do { traceTcS "doTyApp" (ppr clas $$ ppr ty $$ ppr f $$ ppr tk) + ; return $ GenInst [mk_typeable_pred clas f, mk_typeable_pred clas tk] (\[t1,t2] -> EvTypeable ty $ EvTypeableTyApp t1 t2) - True + True } -- Emit a `Typeable` constraint for the given type. mk_typeable_pred :: Class -> Type -> PredType @@ -2073,13 +2074,13 @@ doTyLit kc t = do { kc_clas <- tcLookupClass kc {- Note [Typeable (T a b c)] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ For type applications we always decompose using binary application, -vai doTyApp, until we get to a *kind* instantiation. Exmaple +via doTyApp, until we get to a *kind* instantiation. Exmaple Proxy :: forall k. k -> * To solve Typeable (Proxy (* -> *) Maybe) we - First decompose with doTyApp, to get (Typeable (Proxy (* -> *))) and Typeable Maybe - - Then sovle (Typeable (Proxy (* -> *))) with doTyConApp + - Then solve (Typeable (Proxy (* -> *))) with doTyConApp If we attempt to short-cut by solving it all at once, via doTyCOnAPp diff --git a/compiler/typecheck/TcMType.hs b/compiler/typecheck/TcMType.hs index c2cf82edde..678661c56d 100644 --- a/compiler/typecheck/TcMType.hs +++ b/compiler/typecheck/TcMType.hs @@ -73,7 +73,8 @@ module TcMType ( zonkTcTypeAndSplitDepVars, zonkTcTypesAndSplitDepVars, zonkQuantifiedTyVar, quantifyTyVars, quantifyZonkedTyVars, - zonkTcTyCoVarBndr, zonkTcTyBinder, zonkTcType, zonkTcTypes, zonkCo, + zonkTcTyCoVarBndr, zonkTcTyBinder, zonkTyConBinder, + zonkTcType, zonkTcTypes, zonkCo, zonkTyCoVarKind, zonkTcTypeMapper, zonkEvVar, zonkWC, zonkSimples, zonkId, zonkCt, zonkSkolemInfo, @@ -87,6 +88,7 @@ module TcMType ( import TyCoRep import TcType import Type +import TyCon( TyConBinder ) import Kind import Coercion import Class @@ -1375,10 +1377,16 @@ zonkTcTyCoVarBndr tyvar -- | Zonk a TyBinder zonkTcTyBinder :: TcTyBinder -> TcM TcTyBinder -zonkTcTyBinder (Anon ty) = Anon <$> zonkTcType ty -zonkTcTyBinder (Named (TvBndr tv vis)) +zonkTcTyBinder (Anon ty) = Anon <$> zonkTcType ty +zonkTcTyBinder (Named tvb) = Named <$> zonkTyVarBinder tvb + +zonkTyConBinder :: TyConBinder -> TcM TyConBinder +zonkTyConBinder = zonkTyVarBinder + +zonkTyVarBinder :: TyVarBndr TyVar vis -> TcM (TyVarBndr TyVar vis) +zonkTyVarBinder (TvBndr tv vis) = do { tv' <- zonkTcTyCoVarBndr tv - ; return (Named (TvBndr tv' vis)) } + ; return (TvBndr tv' vis) } zonkTcTyVar :: TcTyVar -> TcM TcType -- Simply look through all Flexis diff --git a/compiler/typecheck/TcPatSyn.hs b/compiler/typecheck/TcPatSyn.hs index e2d26384e6..b9a6dec0a8 100644 --- a/compiler/typecheck/TcPatSyn.hs +++ b/compiler/typecheck/TcPatSyn.hs @@ -14,9 +14,8 @@ module TcPatSyn ( tcInferPatSynDecl, tcCheckPatSynDecl import HsSyn import TcPat -import Type( binderVar, mkNamedBinders, binderVisibility, mkEmptyTCvSubst - , tidyTyCoVarBndrs, tidyTypes, tidyType ) - , tcHsContext, tcHsLiftedType, tcHsOpenType, kindGeneralize ) +import Type( mkTyVarBinders, mkEmptyTCvSubst + , tidyTyVarBinders, tidyTypes, tidyType ) import TcRnMonad import TcSigs( emptyPragEnv, completeSigFromId ) import TcEnv @@ -133,14 +132,13 @@ tcCheckPatSynDecl psb@PSB{ psb_id = lname@(L _ name), psb_args = details <+> pprQuotedList bad_tvs) -- See Note [The pattern-synonym signature splitting rule] - ; let get_tv = binderVar "tcCheckPatSynDecl" - univ_fvs = closeOverKinds $ + ; let univ_fvs = closeOverKinds $ (tyCoVarsOfTypes (pat_ty : req_theta) `extendVarSetList` explicit_univ_tvs) - (extra_univ, extra_ex) = partition ((`elemVarSet` univ_fvs) . get_tv) implicit_tvs - univ_bndrs = extra_univ ++ mkNamedBinders Specified explicit_univ_tvs - ex_bndrs = extra_ex ++ mkNamedBinders Specified explicit_ex_tvs - univ_tvs = map get_tv univ_bndrs - ex_tvs = map get_tv ex_bndrs + (extra_univ, extra_ex) = partition ((`elemVarSet` univ_fvs) . binderVar) implicit_tvs + univ_bndrs = extra_univ ++ mkTyVarBinders Specified explicit_univ_tvs + ex_bndrs = extra_ex ++ mkTyVarBinders Specified explicit_ex_tvs + univ_tvs = binderVars univ_bndrs + ex_tvs = binderVars ex_bndrs -- Right! Let's check the pattern against the signature -- See Note [Checking against a pattern signature] @@ -323,8 +321,8 @@ tc_patsyn_finish lname dir is_infix lpat' -- Make the 'matcher' ; (matcher_id, matcher_bind) <- tcPatSynMatcher lname lpat' - (map binderVar univ_tvs, req_theta, req_ev_binds, req_dicts) - (map binderVar ex_tvs, ex_tys, prov_theta, prov_dicts) + (binderVars univ_tvs, req_theta, req_ev_binds, req_dicts) + (binderVars ex_tvs, ex_tys, prov_theta, prov_dicts) (args, arg_tys) pat_ty diff --git a/compiler/typecheck/TcRnTypes.hs b/compiler/typecheck/TcRnTypes.hs index 9ebb1d52ed..f6ecadf834 100644 --- a/compiler/typecheck/TcRnTypes.hs +++ b/compiler/typecheck/TcRnTypes.hs @@ -1304,7 +1304,7 @@ Here we get data TcPatSynInfo = TPSI { patsig_name :: Name, - patsig_implicit_bndrs :: [TyBinder], -- Implicitly-bound kind vars (Invisible) and + patsig_implicit_bndrs :: [TyVarBinder], -- Implicitly-bound kind vars (Invisible) and -- implicitly-bound type vars (Specified) -- See Note [The pattern-synonym signature splitting rule] in TcPatSyn patsig_univ_bndrs :: [TyVar], -- Bound by explicit user forall diff --git a/compiler/typecheck/TcSMonad.hs b/compiler/typecheck/TcSMonad.hs index 75506b99c3..fda039bbc0 100644 --- a/compiler/typecheck/TcSMonad.hs +++ b/compiler/typecheck/TcSMonad.hs @@ -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 bndrs1 - tvs2 = map binderVar bndrs2 + tvs1 = binderVars bndrs1 + tvs2 = binderVars bndrs2 diff --git a/compiler/typecheck/TcSigs.hs b/compiler/typecheck/TcSigs.hs index 62f4db8d62..5cb23663bc 100644 --- a/compiler/typecheck/TcSigs.hs +++ b/compiler/typecheck/TcSigs.hs @@ -34,7 +34,7 @@ import TcUnify( tcSkolemise, unifyType, noThing ) import Inst( topInstantiate ) import TcEnv( tcLookupId ) import TcEvidence( HsWrapper, (<.>) ) -import Type( mkNamedBinders ) +import Type( mkTyVarBinders ) import DynFlags import Var ( TyVar, tyVarName, tyVarKind ) diff --git a/compiler/typecheck/TcSplice.hs b/compiler/typecheck/TcSplice.hs index 4614b7034e..e0fa1cbf03 100644 --- a/compiler/typecheck/TcSplice.hs +++ b/compiler/typecheck/TcSplice.hs @@ -1781,7 +1781,7 @@ reify_tc_app tc tys isEmptyVarSet $ filterVarSet isTyVar $ tyCoVarsOfType $ - mkPiTys (dropList tys tc_binders) tc_res_kind + mkTyConKind (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 f8308e80d9..91746903d2 100644 --- a/compiler/typecheck/TcTyClsDecls.hs +++ b/compiler/typecheck/TcTyClsDecls.hs @@ -351,9 +351,10 @@ kcTyClGroup decls kc_binders = tyConBinders tc kc_res_kind = tyConResKind tc kc_tyvars = tyConTyVars tc - ; 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 + ; kvs <- kindGeneralize (mkTyConKind kc_binders kc_res_kind) + + ; (env, kc_binders') <- zonkTyConBinders emptyZonkEnv kc_binders + ; kc_res_kind' <- zonkTcTypeToType env kc_res_kind -- Make sure kc_kind' has the final, zonked kind variables ; traceTc "Generalise kind" $ @@ -361,8 +362,8 @@ kcTyClGroup decls , ppr kvs, ppr kc_binders', ppr kc_res_kind' , ppr kc_tyvars, ppr (tcTyConScopedTyVars tc)] - ; return (mkTcTyCon name (kvs ++ kc_tyvars) - (mkNamedTyBinders Invisible kvs ++ kc_binders') + ; return (mkTcTyCon name + (mkNamedTyConBinders Invisible kvs ++ kc_binders') kc_res_kind' (mightBeUnsaturatedTyCon tc) (tcTyConScopedTyVars tc)) } @@ -726,15 +727,15 @@ tcTyClDecl1 parent _rec_info (FamDecl { tcdFam = fd }) tcTyClDecl1 _parent rec_info (SynDecl { tcdLName = L _ tc_name, tcdRhs = rhs }) = ASSERT( isNothing _parent ) - tcTyClTyVars tc_name $ \ tkvs' binders res_kind -> - tcTySynRhs rec_info tc_name tkvs' binders res_kind rhs + tcTyClTyVars tc_name $ \ binders res_kind -> + tcTySynRhs rec_info tc_name binders res_kind rhs -- "data/newtype" declaration tcTyClDecl1 _parent rec_info (DataDecl { tcdLName = L _ tc_name, tcdDataDefn = defn }) = ASSERT( isNothing _parent ) - tcTyClTyVars tc_name $ \ tkvs' tycon_binders res_kind -> - tcDataDefn rec_info tc_name tkvs' tycon_binders res_kind defn + tcTyClTyVars tc_name $ \ tycon_binders res_kind -> + tcDataDefn rec_info tc_name tycon_binders res_kind defn tcTyClDecl1 _parent rec_info (ClassDecl { tcdLName = L _ class_name @@ -743,13 +744,12 @@ tcTyClDecl1 _parent rec_info , tcdATs = ats, tcdATDefs = at_defs }) = ASSERT( isNothing _parent ) do { clas <- fixM $ \ clas -> - tcTyClTyVars class_name $ \ tkvs' binders res_kind -> + tcTyClTyVars class_name $ \ binders res_kind -> do { MASSERT( isConstraintKind res_kind ) -- This little knot is just so we can get -- hold of the name of the class TyCon, which we -- need to look up its recursiveness - ; traceTc "tcClassDecl 1" (ppr class_name $$ ppr tkvs' $$ - ppr binders) + ; traceTc "tcClassDecl 1" (ppr class_name $$ ppr binders) ; let tycon_name = tyConName (classTyCon clas) tc_isrec = rti_is_rec rec_info tycon_name roles = rti_roles rec_info tycon_name @@ -762,10 +762,10 @@ tcTyClDecl1 _parent rec_info ; at_stuff <- tcClassATs class_name clas ats at_defs ; mindef <- tcClassMinimalDef class_name sigs sig_stuff ; clas <- buildClass - class_name tkvs' roles ctxt' binders + class_name binders roles ctxt' fds' at_stuff sig_stuff mindef tc_isrec - ; traceTc "tcClassDecl" (ppr fundeps $$ ppr tkvs' $$ + ; traceTc "tcClassDecl" (ppr fundeps $$ ppr binders $$ ppr fds') ; return clas } @@ -780,25 +780,24 @@ tcFamDecl1 parent (FamilyDecl { fdInfo = fam_info, fdLName = tc_lname@(L _ tc_na , fdTyVars = tvs, fdResultSig = L _ sig , fdInjectivityAnn = inj }) | DataFamily <- fam_info - = tcTyClTyVars tc_name $ \ tkvs' binders res_kind -> do + = tcTyClTyVars tc_name $ \ binders res_kind -> do { traceTc "data family:" (ppr tc_name) ; checkFamFlag tc_name - ; (extra_tvs, extra_binders, real_res_kind) <- tcDataKindSig res_kind + ; (extra_binders, real_res_kind) <- tcDataKindSig res_kind ; tc_rep_name <- newTyConRepName tc_name - ; let final_tvs = tkvs' `chkAppend` extra_tvs -- we may not need these - tycon = mkFamilyTyCon tc_name (binders `chkAppend` extra_binders) - real_res_kind final_tvs + ; let tycon = mkFamilyTyCon tc_name (binders `chkAppend` extra_binders) + real_res_kind (resultVariableName sig) (DataFamilyTyCon tc_rep_name) parent NotInjective ; return tycon } | OpenTypeFamily <- fam_info - = tcTyClTyVars tc_name $ \ tkvs' binders res_kind -> do + = tcTyClTyVars tc_name $ \ binders res_kind -> do { traceTc "open type family:" (ppr tc_name) ; checkFamFlag tc_name - ; inj' <- tcInjectivity tkvs' inj - ; let tycon = mkFamilyTyCon tc_name binders res_kind tkvs' + ; inj' <- tcInjectivity binders inj + ; let tycon = mkFamilyTyCon tc_name binders res_kind (resultVariableName sig) OpenSynFamilyTyCon parent inj' ; return tycon } @@ -809,11 +808,11 @@ tcFamDecl1 parent (FamilyDecl { fdInfo = fam_info, fdLName = tc_lname@(L _ tc_na do { traceTc "Closed type family:" (ppr tc_name) -- the variables in the header scope only over the injectivity -- declaration but this is not involved here - ; (tvs', inj', binders, res_kind) + ; (inj', binders, res_kind) <- tcTyClTyVars tc_name - $ \ tkvs' binders res_kind -> - do { inj' <- tcInjectivity tkvs' inj - ; return (tkvs', inj', binders, res_kind) } + $ \ binders res_kind -> + do { inj' <- tcInjectivity binders inj + ; return (inj', binders, res_kind) } ; checkFamFlag tc_name -- make sure we have -XTypeFamilies @@ -821,7 +820,7 @@ tcFamDecl1 parent (FamilyDecl { fdInfo = fam_info, fdLName = tc_lname@(L _ tc_na -- but eqns might be empty in the Just case as well ; case mb_eqns of Nothing -> - return $ mkFamilyTyCon tc_name binders res_kind tvs' + return $ mkFamilyTyCon tc_name binders res_kind (resultVariableName sig) AbstractClosedSynFamilyTyCon parent inj' @@ -850,7 +849,7 @@ tcFamDecl1 parent (FamilyDecl { fdInfo = fam_info, fdLName = tc_lname@(L _ tc_na | null eqns = Nothing -- mkBranchedCoAxiom fails on empty list | otherwise = Just (mkBranchedCoAxiom co_ax_name fam_tc branches) - fam_tc = mkFamilyTyCon tc_name binders res_kind tvs' (resultVariableName sig) + fam_tc = mkFamilyTyCon tc_name binders res_kind (resultVariableName sig) (ClosedSynFamilyTyCon mb_co_ax) parent inj' -- We check for instance validity later, when doing validity @@ -867,7 +866,7 @@ tcFamDecl1 parent (FamilyDecl { fdInfo = fam_info, fdLName = tc_lname@(L _ tc_na -- True on position -- N means that a function is injective in its Nth argument. False means it is -- not. -tcInjectivity :: [TyVar] -> Maybe (LInjectivityAnn Name) +tcInjectivity :: [TyConBinder] -> Maybe (LInjectivityAnn Name) -> TcM Injectivity tcInjectivity _ Nothing = return NotInjective @@ -890,9 +889,10 @@ tcInjectivity _ Nothing -- therefore we can always infer the result kind if we know the result type. -- But this does not seem to be useful in any way so we don't do it. (Another -- reason is that the implementation would not be straightforward.) -tcInjectivity tvs (Just (L loc (InjectivityAnn _ lInjNames))) +tcInjectivity tcbs (Just (L loc (InjectivityAnn _ lInjNames))) = setSrcSpan loc $ - do { dflags <- getDynFlags + do { let tvs = binderVars tcbs + ; dflags <- getDynFlags ; checkTc (xopt LangExt.TypeFamilyDependencies dflags) (text "Illegal injectivity annotation" $$ text "Use TypeFamilyDependencies to allow this") @@ -907,29 +907,28 @@ tcInjectivity tvs (Just (L loc (InjectivityAnn _ lInjNames))) tcTySynRhs :: RecTyInfo -> Name - -> [TyVar] -> [TyBinder] -> Kind + -> [TyConBinder] -> Kind -> LHsType Name -> TcM TyCon -tcTySynRhs rec_info tc_name tvs binders res_kind hs_ty +tcTySynRhs rec_info tc_name binders res_kind hs_ty = do { env <- getLclEnv ; traceTc "tc-syn" (ppr tc_name $$ ppr (tcl_env env)) ; rhs_ty <- solveEqualities $ tcCheckLHsType hs_ty res_kind ; rhs_ty <- zonkTcTypeToType emptyZonkEnv rhs_ty ; let roles = rti_roles rec_info tc_name - tycon = mkSynonymTyCon tc_name binders res_kind tvs roles rhs_ty + tycon = mkSynonymTyCon tc_name binders res_kind roles rhs_ty ; return tycon } tcDataDefn :: RecTyInfo -> Name - -> [TyVar] -> [TyBinder] -> Kind + -> [TyConBinder] -> Kind -> HsDataDefn Name -> TcM TyCon -- NB: not used for newtype/data instances (whether associated or not) tcDataDefn rec_info -- Knot-tied; don't look at this eagerly - tc_name tvs tycon_binders res_kind + tc_name tycon_binders res_kind (HsDataDefn { dd_ND = new_or_data, dd_cType = cType , dd_ctxt = ctxt, dd_kindSig = mb_ksig , dd_cons = cons }) - = do { (extra_tvs, extra_bndrs, real_res_kind) <- tcDataKindSig res_kind + = do { (extra_bndrs, real_res_kind) <- tcDataKindSig res_kind ; let final_bndrs = tycon_binders `chkAppend` extra_bndrs - final_tvs = tvs `chkAppend` extra_tvs roles = rti_roles rec_info tc_name ; stupid_tc_theta <- solveEqualities $ tcHsContext ctxt @@ -945,13 +944,15 @@ tcDataDefn rec_info -- Knot-tied; don't look at this eagerly ; gadt_syntax <- dataDeclChecks tc_name new_or_data stupid_theta cons ; tycon <- fixM $ \ tycon -> do - { let res_ty = mkTyConApp tycon (mkTyVarTys final_tvs) + { let res_ty = mkTyConApp tycon (mkTyVarTys (binderVars final_bndrs)) ; data_cons <- tcConDecls new_or_data tycon - (final_tvs, final_bndrs, res_ty) cons + (final_bndrs, res_ty) cons ; tc_rhs <- mk_tc_rhs is_boot tycon data_cons ; tc_rep_nm <- newTyConRepName tc_name - ; return (mkAlgTyCon tc_name (tycon_binders `chkAppend` extra_bndrs) - real_res_kind final_tvs roles + ; return (mkAlgTyCon tc_name + final_bndrs + real_res_kind + roles (fmap unLoc cType) stupid_theta tc_rhs (VanillaAlgTyCon tc_rep_nm) @@ -1187,7 +1188,7 @@ two bad things could happen: -} ----------------- -type FamTyConShape = (Name, Arity, [TyBinder], Kind) +type FamTyConShape = (Name, Arity, [TyConBinder], Kind) -- See Note [Type-checking type patterns] famTyConShape :: TyCon -> FamTyConShape @@ -1421,23 +1422,23 @@ consUseGadtSyntax _ = False -- All constructors have same shape ----------------------------------- -tcConDecls :: NewOrData -> TyCon -> ([TyVar], [TyBinder], Type) +tcConDecls :: NewOrData -> TyCon -> ([TyConBinder], Type) -> [LConDecl Name] -> TcM [DataCon] -- Why both the tycon tyvars and binders? Because the tyvars -- have all the names and the binders have the visibilities. -tcConDecls new_or_data rep_tycon (tmpl_tvs, tmpl_bndrs, res_tmpl) +tcConDecls new_or_data rep_tycon (tmpl_bndrs, res_tmpl) = concatMapM $ addLocM $ - tcConDecl new_or_data rep_tycon tmpl_tvs tmpl_bndrs res_tmpl + tcConDecl new_or_data rep_tycon tmpl_bndrs res_tmpl tcConDecl :: NewOrData -> TyCon -- Representation tycon. Knot-tied! - -> [TyVar] -> [TyBinder] -> Type + -> [TyConBinder] -> Type -- Return type template (with its template tyvars) -- (tvs, T tys), where T is the family TyCon -> ConDecl Name -> TcM [DataCon] -tcConDecl new_or_data rep_tycon tmpl_tvs tmpl_bndrs res_tmpl +tcConDecl new_or_data rep_tycon tmpl_bndrs res_tmpl (ConDeclH98 { con_name = name , con_qvars = hs_qvars, con_cxt = hs_ctxt , con_details = hs_details }) @@ -1478,7 +1479,7 @@ tcConDecl new_or_data rep_tycon tmpl_tvs tmpl_bndrs res_tmpl -- we're doing this to get the right behavior around removing -- any vars bound in exp_binders. - ; kvs <- quantifyZonkedTyVars (mkVarSet tmpl_tvs) vars + ; kvs <- quantifyZonkedTyVars (mkVarSet (binderVars tmpl_bndrs)) vars -- Zonk to Types ; (ze, qkvs) <- zonkTyBndrsX emptyZonkEnv kvs @@ -1499,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 + (mkDataConUnivTyVarBinders tmpl_bndrs) ex_tvs [{- no eq_preds -}] ctxt arg_tys res_tmpl rep_tycon @@ -1511,7 +1512,7 @@ tcConDecl new_or_data rep_tycon tmpl_tvs tmpl_bndrs res_tmpl ; mapM buildOneDataCon [name] } -tcConDecl _new_or_data rep_tycon tmpl_tvs _tmpl_bndrs res_tmpl +tcConDecl _new_or_data rep_tycon tmpl_bndrs res_tmpl (ConDeclGADT { con_names = names, con_type = ty }) = addErrCtxt (dataConCtxtName names) $ do { traceTc "tcConDecl 1" (ppr names) @@ -1531,13 +1532,13 @@ tcConDecl _new_or_data rep_tycon tmpl_tvs _tmpl_bndrs res_tmpl ; res_ty <- zonkTcTypeToType ze res_ty ; let (univ_tvs, ex_tvs, eq_preds, res_ty', arg_subst) - = rejigConRes tmpl_tvs res_tmpl qtkvs res_ty + = rejigConRes tmpl_bndrs res_tmpl qtkvs res_ty -- NB: this is a /lazy/ binding, so we pass five thunks to buildDataCon -- without yet forcing the guards in rejigConRes -- See Note [Checking GADT return types] -- See Note [Wrong visibility for GADTs] - univ_bndrs = mkNamedTyBinders Specified univ_tvs + univ_bndrs = mkTyVarBinders Specified univ_tvs ex_bndrs = mkTyVarBinders Specified ex_tvs ; fam_envs <- tcGetFamInstEnvs @@ -1552,7 +1553,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_bndrs eq_preds + univ_bndrs ex_bndrs eq_preds (substTys arg_subst ctxt) (substTys arg_subst arg_tys) (substTy arg_subst res_ty') @@ -1740,7 +1741,7 @@ errors reported in one pass. See Trac #7175, and #10836. -- TI :: forall b1 c1. (b1 ~ c1) => b1 -> :R7T b1 c1 -- In this case orig_res_ty = T (e,e) -rejigConRes :: [TyVar] -> Type -- Template for result type; e.g. +rejigConRes :: [TyConBinder] -> Type -- Template for result type; e.g. -- data instance T [a] b c = ... -- gives template ([a,b,c], T [a] b c) -- Type must be of kind *! @@ -1754,7 +1755,7 @@ rejigConRes :: [TyVar] -> Type -- Template for result type; e.g. -- We don't check that the TyCon given in the ResTy is -- the same as the parent tycon, because checkValidDataCon will do it -rejigConRes tmpl_tvs res_tmpl dc_tvs res_ty +rejigConRes tmpl_bndrs res_tmpl dc_tvs res_ty -- E.g. data T [a] b c where -- MkT :: forall x y z. T [(x,y)] z z -- The {a,b,c} are the tmpl_tvs, and the {x,y,z} are the dc_tvs @@ -1790,8 +1791,9 @@ rejigConRes tmpl_tvs res_tmpl dc_tvs res_ty -- bad-result-type error before seeing that the other fields look odd -- See Note [Checking GADT return types] = (tmpl_tvs, dc_tvs `minusList` tmpl_tvs, [], res_ty, emptyTCvSubst) - where + tmpl_tvs = binderVars tmpl_bndrs + {- Note [mkGADTVars] ~~~~~~~~~~~~~~~~~ diff --git a/compiler/typecheck/TcTyDecls.hs b/compiler/typecheck/TcTyDecls.hs index 025afc967f..c04c750bfe 100644 --- a/compiler/typecheck/TcTyDecls.hs +++ b/compiler/typecheck/TcTyDecls.hs @@ -48,7 +48,7 @@ import IdInfo import VarEnv import VarSet import NameSet ( NameSet, unitNameSet, emptyNameSet, unionNameSet - , extendNameSet, mkNameSet, nameSetElems, elemNameSet ) + , extendNameSet, mkNameSet, elemNameSet ) import Coercion ( ltRole ) import Digraph import BasicTypes @@ -609,7 +609,7 @@ initialRoleEnv1 is_boot annots_env tc | otherwise = pprPanic "initialRoleEnv1" (ppr tc) where name = tyConName tc bndrs = tyConBinders tc - visflags = map tyBinderVisibility $ take (tyConArity tc) bndrs + visflags = map tyConBinderVisibility bndrs num_exps = count (== Visible) visflags -- if the number of annotations in the role annotation decl diff --git a/compiler/typecheck/TcType.hs b/compiler/typecheck/TcType.hs index a307851f6f..f254225b46 100644 --- a/compiler/typecheck/TcType.hs +++ b/compiler/typecheck/TcType.hs @@ -135,7 +135,6 @@ module TcType ( mkTyConApp, mkAppTy, mkAppTys, mkTyConTy, mkTyVarTy, mkTyVarTys, - mkNamedBinder, isClassPred, isEqPred, isNomEqPred, isIPPred, mkClassPred, @@ -719,7 +718,7 @@ tcTyFamInsts (TyConApp tc tys) | isTypeFamilyTyCon tc = [(tc, take (tyConArity tc) tys)] | otherwise = concat (map tcTyFamInsts tys) tcTyFamInsts (LitTy {}) = [] -tcTyFamInsts (ForAllTy bndr ty) = tcTyFamInsts (binderType bndr) +tcTyFamInsts (ForAllTy bndr ty) = tcTyFamInsts (binderKind bndr) ++ tcTyFamInsts ty tcTyFamInsts (FunTy ty1 ty2) = tcTyFamInsts ty1 ++ tcTyFamInsts ty2 tcTyFamInsts (AppTy ty1 ty2) = tcTyFamInsts ty1 ++ tcTyFamInsts ty2 @@ -775,7 +774,7 @@ exactTyCoVarsOfType ty 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 (ForAllTy bndr ty) = delBinderVar (go ty) bndr `unionVarSet` go (binderKind bndr) go (CastTy ty co) = go ty `unionVarSet` goCo co go (CoercionTy co) = goCo co @@ -1514,7 +1513,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 tyBinderVisibility bndrs + viss = map tyConBinderVisibility bndrs tc_vis vis _ = repeat vis -- if we're not in a visible context, our args -- aren't either diff --git a/compiler/typecheck/TcTypeNats.hs b/compiler/typecheck/TcTypeNats.hs index e6a6c7ed70..cececff979 100644 --- a/compiler/typecheck/TcTypeNats.hs +++ b/compiler/typecheck/TcTypeNats.hs @@ -24,7 +24,7 @@ import TcRnTypes ( Xi ) import CoAxiom ( CoAxiomRule(..), BuiltInSynFamily(..), Eqn ) import Name ( Name, BuiltInSyntax(..) ) import TysWiredIn -import TysPrim ( mkTemplateTyVars ) +import TysPrim ( mkTemplateAnonTyConBinders ) import PrelNames ( gHC_TYPELITS , typeNatAddTyFamNameKey , typeNatMulTyFamNameKey @@ -100,9 +100,8 @@ typeNatExpTyCon = mkTypeNatFunTyCon2 name typeNatLeqTyCon :: TyCon typeNatLeqTyCon = mkFamilyTyCon name - (map mkAnonBinder [ typeNatKind, typeNatKind ]) + (mkTemplateAnonTyConBinders [ typeNatKind, typeNatKind ]) boolTy - (mkTemplateTyVars [ typeNatKind, typeNatKind ]) Nothing (BuiltInSynFamTyCon ops) Nothing @@ -120,9 +119,8 @@ typeNatLeqTyCon = typeNatCmpTyCon :: TyCon typeNatCmpTyCon = mkFamilyTyCon name - (map mkAnonBinder [ typeNatKind, typeNatKind ]) + (mkTemplateAnonTyConBinders [ typeNatKind, typeNatKind ]) orderingKind - (mkTemplateTyVars [ typeNatKind, typeNatKind ]) Nothing (BuiltInSynFamTyCon ops) Nothing @@ -140,9 +138,8 @@ typeNatCmpTyCon = typeSymbolCmpTyCon :: TyCon typeSymbolCmpTyCon = mkFamilyTyCon name - (map mkAnonBinder [ typeSymbolKind, typeSymbolKind ]) + (mkTemplateAnonTyConBinders [ typeSymbolKind, typeSymbolKind ]) orderingKind - (mkTemplateTyVars [ typeSymbolKind, typeSymbolKind ]) Nothing (BuiltInSynFamTyCon ops) Nothing @@ -165,9 +162,8 @@ typeSymbolCmpTyCon = mkTypeNatFunTyCon2 :: Name -> BuiltInSynFamily -> TyCon mkTypeNatFunTyCon2 op tcb = mkFamilyTyCon op - (map mkAnonBinder [ typeNatKind, typeNatKind ]) + (mkTemplateAnonTyConBinders [ typeNatKind, typeNatKind ]) typeNatKind - (mkTemplateTyVars [ typeNatKind, typeNatKind ]) Nothing (BuiltInSynFamTyCon tcb) Nothing diff --git a/compiler/typecheck/TcUnify.hs b/compiler/typecheck/TcUnify.hs index 3ca6aa3bfa..ca3347861b 100644 --- a/compiler/typecheck/TcUnify.hs +++ b/compiler/typecheck/TcUnify.hs @@ -381,8 +381,11 @@ matchExpectedTyConApp tc orig_ty -- because that'll make types that are utterly ill-kinded. -- This happened in Trac #7368 defer - = do { (_subst, args) <- tcInstBinders (tyConBinders tc) - ; co <- unifyType noThing (mkTyConApp tc args) orig_ty + = do { (_, arg_tvs) <- newMetaTyVars (tyConTyVars tc) + ; traceTc "mtca" (ppr tc $$ ppr (tyConTyVars tc) $$ ppr arg_tvs) + ; let args = mkTyVarTys arg_tvs + tc_template = mkTyConApp tc args + ; co <- unifyType noThing tc_template orig_ty ; return (co, args) } ---------------------- @@ -1458,7 +1461,7 @@ checkTauTvUpdate dflags origin t_or_k tv ty defer_me (TyVarTy tv') = tv == tv' || defer_me (tyVarKind tv') 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 + defer_me (ForAllTy bndr t) = defer_me (binderKind bndr) || defer_me t || not impredicative defer_me (FunTy fun arg) = defer_me fun || defer_me arg defer_me (AppTy fun arg) = defer_me fun || defer_me arg diff --git a/compiler/typecheck/TcValidity.hs b/compiler/typecheck/TcValidity.hs index 2c66f357a4..8b621876e2 100644 --- a/compiler/typecheck/TcValidity.hs +++ b/compiler/typecheck/TcValidity.hs @@ -50,7 +50,7 @@ import Name import VarEnv import VarSet import UniqFM -import Var ( mkTyVar ) +import Var ( TyVarBndr(..), mkTyVar ) import ErrUtils import DynFlags import Util @@ -1006,7 +1006,7 @@ tyConArityErr tc tks -- tc_type_arity = number of *type* args expected -- tc_type_args = number of *type* args encountered - tc_type_arity = count isVisibleBinder $ tyConBinders tc + tc_type_arity = count isVisibleTyConBinder (tyConBinders tc) tc_type_args = length vis_tks arityErr :: Outputable a => String -> a -> Int -> Int -> SDoc @@ -1667,7 +1667,7 @@ checkValidFamPats mb_clsinfo fam_tc tvs cvs ty_pats -- type instance F Int y = y -- because then the type (F Int) would be like (\y.y) checkTc (length ty_pats == fam_arity) $ - wrongNumberOfParmsErr (fam_arity - count isInvisibleBinder fam_bndrs) + wrongNumberOfParmsErr (fam_arity - count isInvisibleTyConBinder fam_bndrs) -- report only explicit arguments ; mapM_ checkValidTypePat ty_pats diff --git a/compiler/types/Class.hs b/compiler/types/Class.hs index 27afe4d05c..a8626db407 100644 --- a/compiler/types/Class.hs +++ b/compiler/types/Class.hs @@ -23,7 +23,7 @@ module Class ( #include "HsVersions.h" -import {-# SOURCE #-} TyCon ( TyCon, tyConName, tyConUnique ) +import {-# SOURCE #-} TyCon ( TyCon ) import {-# SOURCE #-} TyCoRep ( Type, PredType, pprType ) import Var import Name @@ -155,7 +155,7 @@ The @mkClass@ function fills in the indirect superclasses. The SrcSpan is for the entire original declaration. -} -mkClass :: [TyVar] +mkClass :: Name -> [TyVar] -> [([TyVar], [TyVar])] -> [PredType] -> [Id] -> [ClassATItem] @@ -164,10 +164,12 @@ mkClass :: [TyVar] -> TyCon -> Class -mkClass tyvars fds super_classes superdict_sels at_stuff +mkClass cls_name tyvars fds super_classes superdict_sels at_stuff op_stuff mindef tycon - = Class { classKey = tyConUnique tycon, - className = tyConName tycon, + = Class { classKey = nameUnique cls_name, + className = cls_name, + -- NB: tyConName tycon = cls_name, + -- But it takes a module loop to assert it here classTyVars = tyvars, classFunDeps = fds, classSCTheta = super_classes, @@ -238,8 +240,7 @@ classATItems :: Class -> [ClassATItem] classATItems = classATStuff classTvsFds :: Class -> ([TyVar], [FunDep TyVar]) -classTvsFds c - = (classTyVars c, classFunDeps c) +classTvsFds c = (classTyVars c, classFunDeps c) classHasFds :: Class -> Bool classHasFds (Class { classFunDeps = fds }) = not (null fds) diff --git a/compiler/types/TyCoRep.hs b/compiler/types/TyCoRep.hs index edacdad048..6b1b3419b7 100644 --- a/compiler/types/TyCoRep.hs +++ b/compiler/types/TyCoRep.hs @@ -22,7 +22,9 @@ Note [The Type-related module hierarchy] {-# LANGUAGE ImplicitParams #-} module TyCoRep ( - TyThing(..), + TyThing(..), pprTyThingCategory, pprShortTyThing, + + -- * Types Type(..), TyLit(..), KindOrType, Kind, @@ -44,8 +46,8 @@ module TyCoRep ( sameVis, -- * Functions over binders - TyBinder(..), TyVarBinder(..), - binderVar, binderType, binderVisibility, + TyBinder(..), TyVarBinder, + binderVar, binderVars, binderKind, binderVisibility, delBinderVar, isInvisible, isVisible, isInvisibleBinder, isVisibleBinder, @@ -55,7 +57,7 @@ module TyCoRep ( -- * Pretty-printing pprType, pprParendType, pprTypeApp, pprTvBndr, pprTvBndrs, - pprShortTyThing, pprTyThingCategory, pprSigmaType, + pprSigmaType, pprTheta, pprForAll, pprForAllImplicit, pprUserForAll, pprThetaArrowTy, pprClassPred, pprKind, pprParendKind, pprTyLit, @@ -169,6 +171,63 @@ import Data.IORef ( IORef ) -- for CoercionHole import GHC.Stack (CallStack) #endif +{- +%************************************************************************ +%* * + TyThing +%* * +%************************************************************************ + +Despite the fact that DataCon has to be imported via a hi-boot route, +this module seems the right place for TyThing, because it's needed for +funTyCon and all the types in TysPrim. + +It is also SOURCE-imported into Name.hs + + +Note [ATyCon for classes] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Both classes and type constructors are represented in the type environment +as ATyCon. You can tell the difference, and get to the class, with + isClassTyCon :: TyCon -> Bool + tyConClass_maybe :: TyCon -> Maybe Class +The Class and its associated TyCon have the same Name. +-} + +-- | A global typecheckable-thing, essentially anything that has a name. +-- Not to be confused with a 'TcTyThing', which is also a typecheckable +-- thing but in the *local* context. See 'TcEnv' for how to retrieve +-- a 'TyThing' given a 'Name'. +data TyThing + = AnId Id + | AConLike ConLike + | ATyCon TyCon -- TyCons and classes; see Note [ATyCon for classes] + | ACoAxiom (CoAxiom Branched) + +instance Outputable TyThing where + ppr = pprShortTyThing + +instance NamedThing TyThing where -- Can't put this with the type + getName (AnId id) = getName id -- decl, because the DataCon instance + getName (ATyCon tc) = getName tc -- isn't visible there + getName (ACoAxiom cc) = getName cc + getName (AConLike cl) = conLikeName cl + +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) + | isClassTyCon tc = text "Class" + | otherwise = text "Type constructor" +pprTyThingCategory (ACoAxiom _) = text "Coercion axiom" +pprTyThingCategory (AnId _) = text "Identifier" +pprTyThingCategory (AConLike (RealDataCon _)) = text "Data constructor" +pprTyThingCategory (AConLike (PatSynCon _)) = text "Pattern synonym" + + {- ********************************************************************** * * Type @@ -381,27 +440,6 @@ data TyBinder | Anon Type -- Visibility is determined by the type (Constraint vs. *) 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 --- prohibited entirely from appearing in source Haskell ('Invisible')? --- See Note [TyBinders and VisibilityFlags] -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 @@ -416,22 +454,6 @@ isInvisibleBinder (Anon ty) = isPredTy ty 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. -sameVis :: VisibilityFlag -> VisibilityFlag -> Bool -sameVis Visible Visible = True -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] ~~~~~~~~~~~~~~~~~~~ @@ -584,18 +606,6 @@ We could change this decision, but Visible, Named TyBinders are rare anyway. (Most are Anons.) -} -instance Binary VisibilityFlag where - put_ bh Visible = putByte bh 0 - put_ bh Specified = putByte bh 1 - put_ bh Invisible = putByte bh 2 - - get bh = do - h <- getByte bh - case h of - 0 -> return Visible - 1 -> return Specified - _ -> return Invisible - {- ********************************************************************** * * @@ -670,8 +680,8 @@ mkFunTy arg res = FunTy arg res mkFunTys :: [Type] -> Type -> Type mkFunTys tys ty = foldr mkFunTy ty tys -mkForAllTy :: TyVarBinder -> Type -> Type -mkForAllTy = ForAllTy +mkForAllTy :: TyVar -> VisibilityFlag -> Type -> Type +mkForAllTy tv vis ty = ForAllTy (TvBndr tv vis) ty -- | Wraps foralls over the type using the provided 'TyVar's from left to right mkForAllTys :: [TyVarBinder] -> Type -> Type @@ -1564,60 +1574,6 @@ closeOverKindsDSet = fvDVarSet . closeOverKindsFV . dVarSetElems {- %************************************************************************ %* * - TyThing -%* * -%************************************************************************ - -Despite the fact that DataCon has to be imported via a hi-boot route, -this module seems the right place for TyThing, because it's needed for -funTyCon and all the types in TysPrim. - -Note [ATyCon for classes] -~~~~~~~~~~~~~~~~~~~~~~~~~ -Both classes and type constructors are represented in the type environment -as ATyCon. You can tell the difference, and get to the class, with - isClassTyCon :: TyCon -> Bool - tyConClass_maybe :: TyCon -> Maybe Class -The Class and its associated TyCon have the same Name. --} - --- | A global typecheckable-thing, essentially anything that has a name. --- Not to be confused with a 'TcTyThing', which is also a typecheckable --- thing but in the *local* context. See 'TcEnv' for how to retrieve --- a 'TyThing' given a 'Name'. -data TyThing - = AnId Id - | AConLike ConLike - | ATyCon TyCon -- TyCons and classes; see Note [ATyCon for classes] - | ACoAxiom (CoAxiom Branched) - -instance Outputable TyThing where - ppr = pprShortTyThing - -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) - | isClassTyCon tc = text "Class" - | otherwise = text "Type constructor" -pprTyThingCategory (ACoAxiom _) = text "Coercion axiom" -pprTyThingCategory (AnId _) = text "Identifier" -pprTyThingCategory (AConLike (RealDataCon _)) = text "Data constructor" -pprTyThingCategory (AConLike (PatSynCon _)) = text "Pattern synonym" - - -instance NamedThing TyThing where -- Can't put this with the type - getName (AnId id) = getName id -- decl, because the DataCon instance - getName (ATyCon tc) = getName tc -- isn't visible there - getName (ACoAxiom cc) = getName cc - getName (AConLike cl) = conLikeName cl - -{- -%************************************************************************ -%* * Substitutions Data type defined here to avoid unnecessary mutual recursion %* * @@ -2773,7 +2729,7 @@ pprUserForAll bndrs pprForAll bndrs where bndr_has_kind_var bndr - = not (isEmptyVarSet (tyCoVarsOfType (binderType bndr))) + = not (isEmptyVarSet (tyCoVarsOfType (binderKind bndr))) pprForAllImplicit :: [TyVar] -> SDoc pprForAllImplicit tvs = pprForAll [ TvBndr tv Specified | tv <- tvs ] @@ -2826,19 +2782,11 @@ 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 tvb) = ppr tvb - ppr (Anon ty) = text "[anon]" <+> ppr ty - -instance Outputable VisibilityFlag where - ppr Visible = text "[vis]" - ppr Specified = text "[spec]" - ppr Invisible = text "[invis]" + ppr (Anon ty) = text "[anon]" <+> ppr ty + ppr (Named (TvBndr v Visible)) = ppr v + ppr (Named (TvBndr v Specified)) = char '@' <> ppr v + ppr (Named (TvBndr v Invisible)) = braces (ppr v) ----------------- instance Outputable Coercion where -- defined here to avoid orphans @@ -3164,13 +3112,15 @@ tidyTyCoVarBndr tidy_env@(occ_env, subst) tyvar else mkVarOcc (occNameString occ ++ "0") | otherwise = occ -tidyTyVarBinder :: TidyEnv -> TyVarBinder -> (TidyEnv, TyVarBinder) +tidyTyVarBinder :: TidyEnv -> TyVarBndr TyVar vis + -> (TidyEnv, TyVarBndr TyVar vis) tidyTyVarBinder tidy_env (TvBndr tv vis) = (tidy_env', TvBndr tv' vis) where (tidy_env', tv') = tidyTyCoVarBndr tidy_env tv -tidyTyVarBinders :: TidyEnv -> [TyVarBinder] -> (TidyEnv, [TyVarBinder]) +tidyTyVarBinders :: TidyEnv -> [TyVarBndr TyVar vis] + -> (TidyEnv, [TyVarBndr TyVar vis]) tidyTyVarBinders = mapAccumL tidyTyVarBinder --------------- diff --git a/compiler/types/TyCoRep.hs-boot b/compiler/types/TyCoRep.hs-boot index 314eed15a4..df2dfd59a4 100644 --- a/compiler/types/TyCoRep.hs-boot +++ b/compiler/types/TyCoRep.hs-boot @@ -4,16 +4,12 @@ import Outputable ( SDoc ) import Data.Data ( Data ) data Type -data TyBinder -data TyVarBinder data TyThing data Coercion data LeftOrRight data UnivCoProvenance data TCvSubst -mkPiTys :: [TyBinder] -> Type -> Type - type PredType = Type type Kind = Type type ThetaType = [PredType] diff --git a/compiler/types/TyCon.hs b/compiler/types/TyCon.hs index c7c225d454..ae97e34d8e 100644 --- a/compiler/types/TyCon.hs +++ b/compiler/types/TyCon.hs @@ -6,17 +6,22 @@ The @TyCon@ datatype -} -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP, FlexibleInstances #-} module TyCon( -- * Main TyCon data types - TyCon, - - AlgTyConRhs(..), visibleDataCons, + TyCon, AlgTyConRhs(..), visibleDataCons, AlgTyConFlav(..), isNoParent, FamTyConFlav(..), Role(..), Injectivity(..), RuntimeRepInfo(..), + -- * TyConBinder + TyConBinder, TyConBndrVis(..), + mkNamedTyConBinder, mkNamedTyConBinders, + mkAnonTyConBinder, mkAnonTyConBinders, + tyConBinderVisibility, isNamedTyConBinder, + isVisibleTyConBinder, isInvisibleTyConBinder, + -- ** Field labels tyConFieldLabels, tyConFieldLabelEnv, @@ -91,7 +96,7 @@ module TyCon( expandSynTyCon_maybe, makeTyConAbstract, newTyConCo, newTyConCo_maybe, - pprPromotionQuote, + pprPromotionQuote, mkTyConKind, -- * Runtime type representation TyConRepName, tyConRepName_maybe, @@ -111,9 +116,10 @@ module TyCon( #include "HsVersions.h" -import {-# SOURCE #-} TyCoRep ( Kind, Type, PredType, TyBinder, pprType, mkPiTys ) +import {-# SOURCE #-} TyCoRep ( Kind, Type, PredType, pprType ) import {-# SOURCE #-} TysWiredIn ( runtimeRepTyCon, constraintKind - , vecCountTyCon, vecElemTyCon, liftedTypeKind ) + , vecCountTyCon, vecElemTyCon, liftedTypeKind + , mkFunKind, mkForAllKind ) import {-# SOURCE #-} DataCon ( DataCon, dataConExTyVars, dataConFieldLabels ) import Binary @@ -359,23 +365,130 @@ See also: * [Verifying injectivity annotation] in FamInstEnv * [Type inference for type families with injectivity] in TcInteract - ************************************************************************ * * -\subsection{The data type} + TyConBinder * * ************************************************************************ -} -{- Note [TyCon binders] -~~~~~~~~~~~~~~~~~~~~~~~ +type TyConBinder = TyVarBndr TyVar TyConBndrVis + +data TyConBndrVis + = NamedTCB VisibilityFlag + | AnonTCB + +mkAnonTyConBinder :: TyVar -> TyConBinder +mkAnonTyConBinder tv = TvBndr tv AnonTCB + +mkAnonTyConBinders :: [TyVar] -> [TyConBinder] +mkAnonTyConBinders tvs = map mkAnonTyConBinder tvs + +mkNamedTyConBinder :: VisibilityFlag -> TyVar -> TyConBinder +-- The odd argument order supports currying +mkNamedTyConBinder vis tv = TvBndr tv (NamedTCB vis) + +mkNamedTyConBinders :: VisibilityFlag -> [TyVar] -> [TyConBinder] +-- The odd argument order supports currying +mkNamedTyConBinders vis tvs = map (mkNamedTyConBinder vis) tvs + +tyConBinderVisibility :: TyConBinder -> VisibilityFlag +tyConBinderVisibility (TvBndr _ (NamedTCB vis)) = vis +tyConBinderVisibility (TvBndr _ AnonTCB) = Visible + +isNamedTyConBinder :: TyConBinder -> Bool +isNamedTyConBinder (TvBndr _ (NamedTCB {})) = True +isNamedTyConBinder _ = False + +isVisibleTyConBinder :: TyVarBndr tv TyConBndrVis -> Bool +-- Works for IfaceTyConBinder too +isVisibleTyConBinder (TvBndr _ (NamedTCB vis)) = isVisible vis +isVisibleTyConBinder (TvBndr _ AnonTCB) = True + +isInvisibleTyConBinder :: TyVarBndr tv TyConBndrVis -> Bool +-- Works for IfaceTyConBinder too +isInvisibleTyConBinder tcb = not (isVisibleTyConBinder tcb) + +mkTyConKind :: [TyConBinder] -> Kind -> Kind +mkTyConKind bndrs res_kind = foldr mk res_kind bndrs + where + mk :: TyConBinder -> Kind -> Kind + mk (TvBndr tv AnonTCB) k = mkFunKind (tyVarKind tv) k + mk (TvBndr tv (NamedTCB vis)) k = mkForAllKind tv vis k + +{- Note [The binders/kind/arity fields of a TyCon] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +All TyCons have this group of fields + tyConBinders :: [TyConBinder] + tyConResKind :: Kind + tyConTyVars :: [TyVra] -- Cached = binderVars tyConBinders + tyConKind :: Kind -- Cached = mkTyConKind tyConBinders tyConResKind + tyConArity :: Arity -- Cached = length tyConBinders + +They fit together like so: + +* tyConBinders gives the telescope of type variables on the LHS of the + type declaration. For example: + + type App a (b :: k) = a b + + tyConBinders = [ TvBndr (k::*) (NamedTCB Invisible) + , TvBndr (a:k->*) AnonTCB + , TvBndr (b:k) AnonTCB ] + + Note that that are three binders here, including the + kind variable k. + + See Note [TyBinders and VisibilityFlags] in TyConRep for what + the visibility flag means. + +* Each TyConBinder tyConBinders has a TyVar, and that TyVar may + scope over some other part of the TyCon's definition. Eg + type T a = a->a + we have + tyConBinders = [ TvBndr (a:*) AnonTCB ] + synTcRhs = a->a + So the 'a' scopes over the synTcRhs + +* From the tyConBinders and tyConResKind we can get the tyConKind + E.g for our App example: + App :: forall k. (k->*) -> k -> * + + We get a 'forall' in the kind for each NamedTCB, and an arrow + for each AnonTCB + + tyConKind is the full kind of the TyCon, not just the result kind + +* tyConArity is the arguments this TyCon must be applied to, to be + considered saturated. Here we mean "applied to in the actual Type", + not surface syntax; i.e. including implicit kind variables. + So it's just (length tyConBinders) +-} + +instance Outputable tv => Outputable (TyVarBndr tv TyConBndrVis) where + ppr (TvBndr v AnonTCB) = ppr v + ppr (TvBndr v (NamedTCB Visible)) = ppr v + ppr (TvBndr v (NamedTCB Specified)) = char '@' <> ppr v + ppr (TvBndr v (NamedTCB Invisible)) = braces (ppr v) + +instance Binary TyConBndrVis where + put_ bh AnonTCB = putByte bh 0 + put_ bh (NamedTCB vis) = do { putByte bh 1; put_ bh vis } -data TyConBinder = TCB TyVar TcConBinderVis + get bh = do { h <- getByte bh + ; case h of + 0 -> return AnonTCB + _ -> do { vis <- get bh; return (NamedTCB vis) } } -data TyConBinderVis = NamedTCB VisiblityFlag - | AnonTCB + +{- ********************************************************************* +* * + The TyCon type +* * +************************************************************************ -} + -- | TyCons represent type constructors. Type constructors are introduced by -- things such as: -- @@ -405,10 +518,10 @@ data TyCon tyConName :: Name, -- ^ Name of the constructor -- See Note [The binders/kind/arity fields of a TyCon] - tyConBinders :: [TyBinder], -- ^ The TyBinders for this TyCon's kind. - tyConResKind :: Kind, -- ^ Result kind - tyConKind :: Kind, -- ^ Kind of this TyCon - tyConArity :: Arity, -- ^ Arity + tyConBinders :: [TyConBinder], -- ^ Full binders + tyConResKind :: Kind, -- ^ Result kind + tyConKind :: Kind, -- ^ Kind of this TyCon + tyConArity :: Arity, -- ^ Arity tcRepName :: TyConRepName } @@ -434,23 +547,20 @@ data TyCon tyConName :: Name, -- ^ Name of the constructor -- See Note [The binders/kind/arity fields of a TyCon] - tyConBinders :: [TyBinder], -- ^ The TyBinders for this TyCon's kind. - tyConResKind :: Kind, -- ^ Result kind - tyConKind :: Kind, -- ^ Kind of this TyCon - tyConArity :: Arity, -- ^ Arity - - -- See Note [tyConTyVars and tyConBinders] - tyConTyVars :: [TyVar], -- ^ The kind and type variables used in the - -- type constructor. - -- Invariant: length tyConTyVars = tyConArity - -- Precisely, this list scopes over: - -- - -- 1. The 'algTcStupidTheta' - -- 2. The cached types in algTyConRhs.NewTyCon - -- 3. The family instance types if present - -- - -- Note that it does /not/ scope over the data - -- constructors. + tyConBinders :: [TyConBinder], -- ^ Full binders + tyConTyVars :: [TyVar], -- ^ TyVar binders + tyConResKind :: Kind, -- ^ Result kind + tyConKind :: Kind, -- ^ Kind of this TyCon + tyConArity :: Arity, -- ^ Arity + + -- The tyConTyVars scope over: + -- + -- 1. The 'algTcStupidTheta' + -- 2. The cached types in algTyConRhs.NewTyCon + -- 3. The family instance types if present + -- + -- Note that it does /not/ scope over the data + -- constructors. tcRoles :: [Role], -- ^ The role for each type variable -- This list has length = tyConArity @@ -497,15 +607,12 @@ data TyCon tyConName :: Name, -- ^ Name of the constructor -- See Note [The binders/kind/arity fields of a TyCon] - tyConBinders :: [TyBinder], -- ^ The TyBinders for this TyCon's kind. - tyConResKind :: Kind, -- ^ Result kind - tyConKind :: Kind, -- ^ Kind of this TyCon - tyConArity :: Arity, -- ^ Arity - - -- See Note [tyConTyVars and tyConBinders] - tyConTyVars :: [TyVar], -- ^ List of type and kind variables in this - -- TyCon. Includes implicit kind variables. - -- Scopes over: synTcRhs + tyConBinders :: [TyConBinder], -- ^ Full binders + tyConTyVars :: [TyVar], -- ^ TyVar binders + tyConResKind :: Kind, -- ^ Result kind + tyConKind :: Kind, -- ^ Kind of this TyCon + tyConArity :: Arity, -- ^ Arity + -- tyConTyVars scope over: synTcRhs tcRoles :: [Role], -- ^ The role for each type variable -- This list has length = tyConArity @@ -525,16 +632,12 @@ data TyCon tyConName :: Name, -- ^ Name of the constructor -- See Note [The binders/kind/arity fields of a TyCon] - tyConBinders :: [TyBinder], -- ^ The TyBinders for this TyCon's kind. - tyConResKind :: Kind, -- ^ Result kind - tyConKind :: Kind, -- ^ Kind of this TyCon - tyConArity :: Arity, -- ^ Arity - - -- See Note [tyConTyVars and tyConBinders] - tyConTyVars :: [TyVar], -- ^ The kind and type variables used in the - -- type constructor. - -- Invariant: length tyvars = arity - -- Needed to connect an associated family TyCon + tyConBinders :: [TyConBinder], -- ^ Full binders + tyConTyVars :: [TyVar], -- ^ TyVar binders + tyConResKind :: Kind, -- ^ Result kind + tyConKind :: Kind, -- ^ Kind of this TyCon + tyConArity :: Arity, -- ^ Arity + -- tyConTyVars connect an associated family TyCon -- with its parent class; see TcValidity.checkConsistentFamInst famTcResVar :: Maybe Name, -- ^ Name of result type variable, used @@ -566,10 +669,10 @@ data TyCon tyConName :: Name, -- ^ Name of the constructor -- See Note [The binders/kind/arity fields of a TyCon] - tyConBinders :: [TyBinder], -- ^ The TyBinders for this TyCon's kind. - tyConResKind :: Kind, -- ^ Result kind - tyConKind :: Kind, -- ^ Kind of this TyCon - tyConArity :: Arity, -- ^ Arity + tyConBinders :: [TyConBinder], -- ^ Full binders + tyConResKind :: Kind, -- ^ Result kind + tyConKind :: Kind, -- ^ Kind of this TyCon + tyConArity :: Arity, -- ^ Arity tcRoles :: [Role], -- ^ The role for each type variable -- This list has length = tyConArity @@ -590,10 +693,10 @@ data TyCon tyConName :: Name, -- ^ Same Name as the data constructor -- See Note [The binders/kind/arity fields of a TyCon] - tyConBinders :: [TyBinder], -- ^ The TyBinders for this TyCon's kind. - tyConResKind :: Kind, -- ^ Result kind - tyConKind :: Kind, -- ^ Kind of this TyCon - tyConArity :: Arity, -- ^ Arity + tyConBinders :: [TyConBinder], -- ^ Full binders + tyConResKind :: Kind, -- ^ Result kind + tyConKind :: Kind, -- ^ Kind of this TyCon + tyConArity :: Arity, -- ^ Arity tcRoles :: [Role], -- ^ Roles: N for kind vars, R for type vars dataCon :: DataCon, -- ^ Corresponding data constructor @@ -608,11 +711,11 @@ data TyCon tyConUnsat :: Bool, -- ^ can this tycon be unsaturated? -- See Note [The binders/kind/arity fields of a TyCon] - tyConTyVars :: [TyVar], -- ^ The TyCon's parameterised tyvars - tyConBinders :: [TyBinder], -- ^ The TyBinders for this TyCon's kind. - tyConResKind :: Kind, -- ^ Result kind - tyConKind :: Kind, -- ^ Kind of this TyCon - tyConArity :: Arity, -- ^ Arity + tyConBinders :: [TyConBinder], -- ^ Full binders + tyConTyVars :: [TyVar], -- ^ TyVar binders + tyConResKind :: Kind, -- ^ Result kind + tyConKind :: Kind, -- ^ Kind of this TyCon + tyConArity :: Arity, -- ^ Arity tcTyConScopedTyVars :: [TyVar] -- ^ Scoped tyvars over the -- tycon's body. See Note [TcTyCon] @@ -815,51 +918,8 @@ data FamTyConFlav -- | Built-in type family used by the TypeNats solver | BuiltInSynFamTyCon BuiltInSynFamily -{- Note [The binders/kind/arity fields of a TyCon] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -All TyCons have this group of fields - tyConBinders :: [TyBinder] - tyConResKind :: Kind - tyConKind :: Kind -- Cached = mkPiTys tyConBinders tyConResKind - tyConArity :: Arity -- Cached = length tyConBinders - -They fit together like so: - -* tyConBinders gives the telescope of Named (forall'd) - Anon (ordinary ->) binders - -* Note that tyConBinders /includes/ Anon arguments. For example: - type App a (b :: k) = a b - -- App :: forall {k}; (k->*) -> k -> * - we get - tyConTyBinders = [ Named (k :: *) Invisible, Anon (k->*), Anon k ] - -* tyConKind is the full kind of the TyCon, - not just the result kind - -* tyConArity is the arguments this TyCon must be applied to, to be - considered saturated. Here we mean "applied to in the actual Type", - not surface syntax; i.e. including implicit kind variables. - -Note [tyConTyVars and tyConBinders] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - type App a (b :: k) = a b - -- App :: forall {k}; (k->*) -> k -> * - -For App we get: - tyConTyVars = [ k:*, a:k->*, b:k] - tyConTyBinders = [ Named (k :: *) Invisible, Anon (k->*), Anon k ] - -The tyConBinder field is used to construct the kind of App, namely - App :: forall {k}; (k->*) -> k -> * -The tyConTyVars field always corresponds 1-1 with tyConBinders, and -records the names of the binders. That is important for type synonyms, -etc, where those names scope over some other field in the TyCon. In -this case, 'a' and 'b' are mentioned in the RHS. - -Note [Closed type families] -~~~~~~~~~~~~~~~~~~~~~~~~~ +{- Note [Closed type families] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ * In an open type family you can add new instances later. This is the usual case. @@ -1240,14 +1300,14 @@ So we compromise, and move their Kind calculation to the call site. -- | Given the name of the function type constructor and it's kind, create the -- corresponding 'TyCon'. It is reccomended to use 'TyCoRep.funTyCon' if you want -- this functionality -mkFunTyCon :: Name -> [TyBinder] -> Name -> TyCon +mkFunTyCon :: Name -> [TyConBinder] -> Name -> TyCon mkFunTyCon name binders rep_nm = FunTyCon { tyConUnique = nameUnique name, tyConName = name, tyConBinders = binders, tyConResKind = liftedTypeKind, - tyConKind = mkPiTys binders liftedTypeKind, + tyConKind = mkTyConKind binders liftedTypeKind, tyConArity = 2, tcRepName = rep_nm } @@ -1257,11 +1317,8 @@ mkFunTyCon name binders rep_nm -- type constructor - you can get hold of it easily (see Generics -- module) mkAlgTyCon :: Name - -> [TyBinder] -- ^ Binders of the resulting 'TyCon' + -> [TyConBinder] -- ^ Binders of the 'TyCon' -> Kind -- ^ Result kind - -> [TyVar] -- ^ 'TyVar's scoped over: see 'tyConTyVars'. - -- Arity is inferred from the length of this - -- list -> [Role] -- ^ The roles for each TyVar -> Maybe CType -- ^ The C type this type corresponds to -- when using the CAPI FFI @@ -1272,15 +1329,15 @@ mkAlgTyCon :: Name -> RecFlag -- ^ Is the 'TyCon' recursive? -> Bool -- ^ Was the 'TyCon' declared with GADT syntax? -> TyCon -mkAlgTyCon name binders res_kind tyvars roles cType stupid rhs parent is_rec gadt_syn +mkAlgTyCon name binders res_kind roles cType stupid rhs parent is_rec gadt_syn = AlgTyCon { tyConName = name, tyConUnique = nameUnique name, tyConBinders = binders, tyConResKind = res_kind, - tyConKind = mkPiTys binders res_kind, - tyConArity = length tyvars, - tyConTyVars = tyvars, + tyConKind = mkTyConKind binders res_kind, + tyConArity = length binders, + tyConTyVars = binderVars binders, tcRoles = roles, tyConCType = cType, algTcStupidTheta = stupid, @@ -1292,32 +1349,31 @@ mkAlgTyCon name binders res_kind tyvars roles cType stupid rhs parent is_rec gad } -- | Simpler specialization of 'mkAlgTyCon' for classes -mkClassTyCon :: Name -> [TyBinder] - -> [TyVar] -> [Role] -> AlgTyConRhs -> Class +mkClassTyCon :: Name -> [TyConBinder] + -> [Role] -> AlgTyConRhs -> Class -> RecFlag -> Name -> TyCon -mkClassTyCon name binders tyvars roles rhs clas is_rec tc_rep_name - = mkAlgTyCon name binders constraintKind tyvars roles Nothing [] rhs +mkClassTyCon name binders roles rhs clas is_rec tc_rep_name + = mkAlgTyCon name binders constraintKind roles Nothing [] rhs (ClassTyCon clas tc_rep_name) is_rec False mkTupleTyCon :: Name - -> [TyBinder] + -> [TyConBinder] -> Kind -- ^ Result kind of the 'TyCon' -> Arity -- ^ Arity of the tuple - -> [TyVar] -- ^ 'TyVar's scoped over: see 'tyConTyVars' -> DataCon -> TupleSort -- ^ Whether the tuple is boxed or unboxed -> AlgTyConFlav -> TyCon -mkTupleTyCon name binders res_kind arity tyvars con sort parent +mkTupleTyCon name binders res_kind arity con sort parent = AlgTyCon { tyConName = name, tyConUnique = nameUnique name, tyConBinders = binders, tyConResKind = res_kind, - tyConKind = mkPiTys binders res_kind, + tyConKind = mkTyConKind binders res_kind, tyConArity = arity, - tyConTyVars = tyvars, + tyConTyVars = binderVars binders, tcRoles = replicate arity Representational, tyConCType = Nothing, algTcStupidTheta = [], @@ -1335,31 +1391,32 @@ mkTupleTyCon name binders res_kind arity tyvars con sort parent -- TcErrors sometimes calls typeKind. -- See also Note [Kind checking recursive type and class declarations] -- in TcTyClsDecls. -mkTcTyCon :: Name -> [TyVar] - -> [TyBinder] -> Kind -- ^ /result/ kind only +mkTcTyCon :: Name + -> [TyConBinder] + -> Kind -- ^ /result/ kind only -> Bool -- ^ Can this be unsaturated? -> [TyVar] -- ^ Scoped type variables, see Note [TcTyCon] -> TyCon -mkTcTyCon name tvs binders res_kind unsat scoped_tvs +mkTcTyCon name binders res_kind unsat scoped_tvs = TcTyCon { tyConUnique = getUnique name , tyConName = name - , tyConTyVars = tvs + , tyConTyVars = binderVars binders , tyConBinders = binders , tyConResKind = res_kind - , tyConKind = mkPiTys binders res_kind + , tyConKind = mkTyConKind binders res_kind , tyConUnsat = unsat , tyConArity = length binders , tcTyConScopedTyVars = scoped_tvs } -- | Create an unlifted primitive 'TyCon', such as @Int#@ -mkPrimTyCon :: Name -> [TyBinder] +mkPrimTyCon :: Name -> [TyConBinder] -> Kind -- ^ /result/ kind -> [Role] -> TyCon mkPrimTyCon name binders res_kind roles = mkPrimTyCon' name binders res_kind roles True (Just $ mkPrelTyConRepName name) -- | Kind constructors -mkKindTyCon :: Name -> [TyBinder] +mkKindTyCon :: Name -> [TyConBinder] -> Kind -- ^ /result/ kind -> [Role] -> Name -> TyCon mkKindTyCon name binders res_kind roles rep_nm @@ -1368,14 +1425,14 @@ mkKindTyCon name binders res_kind roles rep_nm tc = mkPrimTyCon' name binders res_kind roles False (Just rep_nm) -- | Create a lifted primitive 'TyCon' such as @RealWorld@ -mkLiftedPrimTyCon :: Name -> [TyBinder] +mkLiftedPrimTyCon :: Name -> [TyConBinder] -> Kind -- ^ /result/ kind -> [Role] -> TyCon mkLiftedPrimTyCon name binders res_kind roles = mkPrimTyCon' name binders res_kind roles False (Just rep_nm) where rep_nm = mkPrelTyConRepName name -mkPrimTyCon' :: Name -> [TyBinder] +mkPrimTyCon' :: Name -> [TyConBinder] -> Kind -- ^ /result/ kind -> [Role] -> Bool -> Maybe TyConRepName -> TyCon @@ -1385,7 +1442,7 @@ mkPrimTyCon' name binders res_kind roles is_unlifted rep_nm tyConUnique = nameUnique name, tyConBinders = binders, tyConResKind = res_kind, - tyConKind = mkPiTys binders res_kind, + tyConKind = mkTyConKind binders res_kind, tyConArity = length roles, tcRoles = roles, isUnlifted = is_unlifted, @@ -1393,34 +1450,34 @@ mkPrimTyCon' name binders res_kind roles is_unlifted rep_nm } -- | Create a type synonym 'TyCon' -mkSynonymTyCon :: Name -> [TyBinder] -> Kind -- ^ /result/ kind - -> [TyVar] -> [Role] -> Type -> TyCon -mkSynonymTyCon name binders res_kind tyvars roles rhs +mkSynonymTyCon :: Name -> [TyConBinder] -> Kind -- ^ /result/ kind + -> [Role] -> Type -> TyCon +mkSynonymTyCon name binders res_kind roles rhs = SynonymTyCon { tyConName = name, tyConUnique = nameUnique name, tyConBinders = binders, tyConResKind = res_kind, - tyConKind = mkPiTys binders res_kind, - tyConArity = length tyvars, - tyConTyVars = tyvars, + tyConKind = mkTyConKind binders res_kind, + tyConArity = length binders, + tyConTyVars = binderVars binders, tcRoles = roles, synTcRhs = rhs } -- | Create a type family 'TyCon' -mkFamilyTyCon :: Name -> [TyBinder] -> Kind -- ^ /result/ kind - -> [TyVar] -> Maybe Name -> FamTyConFlav +mkFamilyTyCon :: Name -> [TyConBinder] -> Kind -- ^ /result/ kind + -> Maybe Name -> FamTyConFlav -> Maybe Class -> Injectivity -> TyCon -mkFamilyTyCon name binders res_kind tyvars resVar flav parent inj +mkFamilyTyCon name binders res_kind resVar flav parent inj = FamilyTyCon { tyConUnique = nameUnique name , tyConName = name , tyConBinders = binders , tyConResKind = res_kind - , tyConKind = mkPiTys binders res_kind - , tyConArity = length tyvars - , tyConTyVars = tyvars + , tyConKind = mkTyConKind binders res_kind + , tyConArity = length binders + , tyConTyVars = binderVars binders , famTcResVar = resVar , famTcFlav = flav , famTcParent = parent @@ -1432,23 +1489,22 @@ mkFamilyTyCon name binders res_kind tyvars resVar flav parent inj -- Somewhat dodgily, we give it the same Name -- as the data constructor itself; when we pretty-print -- the TyCon we add a quote; see the Outputable TyCon instance -mkPromotedDataCon :: DataCon -> Name -> TyConRepName -> [TyBinder] -> Kind -> [Role] +mkPromotedDataCon :: DataCon -> Name -> TyConRepName + -> [TyConBinder] -> Kind -> [Role] -> RuntimeRepInfo -> TyCon mkPromotedDataCon con name rep_name binders res_kind roles rep_info = PromotedDataCon { tyConUnique = nameUnique name, tyConName = name, - tyConArity = arity, + tyConArity = length roles, tcRoles = roles, tyConBinders = binders, tyConResKind = res_kind, - tyConKind = mkPiTys binders res_kind, + tyConKind = mkTyConKind binders res_kind, dataCon = con, tcRepName = rep_name, promDcRepInfo = rep_info } - where - arity = length roles isFunTyCon :: TyCon -> Bool isFunTyCon (FunTyCon {}) = True @@ -1463,7 +1519,7 @@ isAbstractTyCon _ = False -- Used when recovering from errors makeTyConAbstract :: TyCon -> TyCon makeTyConAbstract tc - = mkTcTyCon (tyConName tc) (tyConTyVars tc) + = mkTcTyCon (tyConName tc) (tyConBinders tc) (tyConResKind tc) (mightBeUnsaturatedTyCon tc) [{- no scoped vars -}] diff --git a/compiler/types/TyCon.hs-boot b/compiler/types/TyCon.hs-boot index 5d27fa0bc9..d77ed8a172 100644 --- a/compiler/types/TyCon.hs-boot +++ b/compiler/types/TyCon.hs-boot @@ -1,12 +1,7 @@ module TyCon where -import Name (Name) -import Unique (Unique) - data TyCon -tyConName :: TyCon -> Name -tyConUnique :: TyCon -> Unique isTupleTyCon :: TyCon -> Bool isUnboxedTupleTyCon :: TyCon -> Bool isFunTyCon :: TyCon -> Bool diff --git a/compiler/types/Type.hs b/compiler/types/Type.hs index c20a158cdb..93161b7f7f 100644 --- a/compiler/types/Type.hs +++ b/compiler/types/Type.hs @@ -39,7 +39,7 @@ module Type ( splitForAllTys, splitForAllTyVarBndrs, splitForAllTy_maybe, splitForAllTy, splitPiTy_maybe, splitPiTy, splitPiTys, - mkPiTy, mkPiTys, mkTyBindersPreferAnon, + mkPiTy, mkPiTys, mkTyConBindersPreferAnon, mkLamType, mkLamTypes, piResultTy, piResultTys, applyTysX, dropForAlls, @@ -82,14 +82,15 @@ module Type ( predTypeEqRel, -- ** Binders - sameVis, mkNamedTyBinders, + sameVis, mkTyVarBinder, mkTyVarBinders, - mkAnonBinder, mkNamedBinder, + mkAnonBinder, isAnonTyBinder, isNamedTyBinder, - binderVar, binderType, binderVisibility, - tyBinderType, tyBinderVisibility, + binderVar, binderVars, binderKind, binderVisibility, + tyBinderType, binderRelevantType_maybe, caseBinder, isVisible, isInvisible, isVisibleBinder, isInvisibleBinder, + tyConBindersTyBinders, -- ** Common type constructors funTyCon, @@ -880,10 +881,10 @@ piResultTys ty orig_args@(arg:args) | otherwise = pprPanic "piResultTys1" (ppr ty $$ ppr orig_args) where + in_scope = mkInScopeSet (tyCoVarsOfTypes (ty:orig_args)) + go :: TvSubstEnv -> Type -> [Type] -> Type go tv_env ty [] = substTy (mkTvSubst in_scope tv_env) ty - where - in_scope = mkInScopeSet (tyCoVarsOfTypes (ty:orig_args)) go tv_env ty all_args@(arg:args) | Just ty' <- coreView ty @@ -1098,7 +1099,7 @@ mkCastTy ty co = -- NB: don't check if the coercion "from" type matches here; = split_apps (t2:args) t1 co split_apps args (TyConApp tc tc_args) co | mightBeUnsaturatedTyCon tc - = affix_co (tyConBinders tc) (mkTyConTy tc) (tc_args `chkAppend` args) co + = affix_co (tyConTyBinders tc) (mkTyConTy tc) (tc_args `chkAppend` args) co | otherwise -- not decomposable... but it may still be oversaturated = let (non_decomp_args, decomp_args) = splitAt (tyConArity tc) tc_args saturated_tc = mkTyConApp tc non_decomp_args @@ -1107,7 +1108,7 @@ mkCastTy ty co = -- NB: don't check if the coercion "from" type matches here; saturated_tc (decomp_args `chkAppend` args) co split_apps args (FunTy arg res) co - = affix_co (tyConBinders funTyCon) (mkTyConTy funTyCon) + = affix_co (tyConTyBinders funTyCon) (mkTyConTy funTyCon) (arg : res : args) co split_apps args ty co = affix_co (fst $ splitPiTys $ typeKind ty) @@ -1134,6 +1135,17 @@ mkCastTy ty co = -- NB: don't check if the coercion "from" type matches here; no_double_casts (CastTy ty co1) co2 = CastTy ty (co1 `mkTransCo` co2) no_double_casts ty co = CastTy ty co +tyConTyBinders :: TyCon -> [TyBinder] +-- Return the tyConBinders in TyBinder form +tyConTyBinders tycon = tyConBindersTyBinders (tyConBinders tycon) + +tyConBindersTyBinders :: [TyConBinder] -> [TyBinder] +-- Return the tyConBinders in TyBinder form +tyConBindersTyBinders = map to_tyb + where + to_tyb (TvBndr tv (NamedTCB vis)) = Named (TvBndr tv vis) + to_tyb (TvBndr tv AnonTCB) = Anon (tyVarKind tv) + {- -------------------------------------------------------------------- CoercionTy @@ -1221,16 +1233,16 @@ 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) +mkTyConBindersPreferAnon :: [TyVar] -> Type -> [TyConBinder] +mkTyConBindersPreferAnon vars inner_ty = fst (go vars) where - go :: [TyVar] -> ([TyBinder], VarSet) -- also returns the free vars + go :: [TyVar] -> ([TyConBinder], VarSet) -- also returns the free vars go [] = ([], tyCoVarsOfType inner_ty) go (v:vs) | v `elemVarSet` fvs - = ( Named (TvBndr v Visible) : binders + = ( TvBndr v (NamedTCB Visible) : binders , fvs `delVarSet` v `unionVarSet` kind_vars ) | otherwise - = ( Anon (tyVarKind v) : binders + = ( TvBndr v AnonTCB : binders , fvs `unionVarSet` kind_vars ) where (binders, fvs) = go vs @@ -1382,18 +1394,10 @@ mkTyVarBinder vis var = TvBndr var 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. isAnonTyBinder :: TyBinder -> Bool @@ -1406,16 +1410,9 @@ isNamedTyBinder (Anon {}) = False tyBinderType :: TyBinder -> Type -- Barely used -tyBinderType (Named tvb) = binderType tvb +tyBinderType (Named tvb) = binderKind 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 binderRelevantType_maybe (Named {}) = Nothing @@ -1764,7 +1761,7 @@ repType ty | Just ty' <- coreView ty = go rec_nts ty' - go rec_nts (ForAllTy (Named {}) ty2) -- Drop type foralls + go rec_nts (ForAllTy _ ty2) -- Drop type foralls = go rec_nts ty2 go rec_nts (TyConApp tc tys) -- Expand newtypes @@ -1821,8 +1818,7 @@ kindPrimRep ki = WARN( True typeRepArity :: Arity -> Type -> RepArity typeRepArity 0 _ = 0 typeRepArity n ty = case repType ty of - UnaryRep (ForAllTy bndr ty) -> length (flattenRepType (repType (binderType bndr))) - + typeRepArity (n - 1) ty + UnaryRep (FunTy arg res) -> length (flattenRepType (repType arg)) + typeRepArity (n - 1) res _ -> pprPanic "typeRepArity: arity greater than type can handle" (ppr (n, ty, repType ty)) isVoidTy :: Type -> Bool diff --git a/compiler/types/Type.hs-boot b/compiler/types/Type.hs-boot index 9436d195cc..f4c7939a19 100644 --- a/compiler/types/Type.hs-boot +++ b/compiler/types/Type.hs-boot @@ -19,3 +19,4 @@ partitionInvisibles :: TyCon -> (a -> Type) -> [a] -> ([a], [a]) coreView :: Type -> Maybe Type tyCoVarsOfTypesWellScoped :: [Type] -> [TyVar] + diff --git a/compiler/vectorise/Vectorise/Generic/PData.hs b/compiler/vectorise/Vectorise/Generic/PData.hs index 23cd0a2cb0..9fbe1283f2 100644 --- a/compiler/vectorise/Vectorise/Generic/PData.hs +++ b/compiler/vectorise/Vectorise/Generic/PData.hs @@ -51,9 +51,8 @@ buildDataFamInst name' fam_tc vect_tc rhs rep_ty = mkTyConApp rep_tc tys' pat_tys = [mkTyConApp vect_tc tys'] rep_tc = mkAlgTyCon name' - (mkTyBindersPreferAnon tyvars' liftedTypeKind) + (mkTyConBindersPreferAnon tyvars' liftedTypeKind) liftedTypeKind - tyvars' (map (const Nominal) tyvars') Nothing [] -- no stupid theta @@ -85,7 +84,7 @@ buildPDataDataCon orig_name vect_tc repr_tc repr (map (const no_bang) comp_tys) (Just $ map (const HsLazy) comp_tys) [] -- no field labels - tvs (map (mkNamedBinder . mkTyVarBinder Specified) tvs) + (mkTyVarBinders Specified tvs) [] -- no existentials [] -- no eq spec [] -- no context @@ -129,7 +128,7 @@ buildPDatasDataCon orig_name vect_tc repr_tc repr (map (const no_bang) comp_tys) (Just $ map (const HsLazy) comp_tys) [] -- no field labels - tvs (map (mkNamedBinder . mkTyVarBinder Specified) tvs) + (mkTyVarBinders Specified tvs) [] -- no existentials [] -- no eq spec [] -- no context diff --git a/compiler/vectorise/Vectorise/Type/Env.hs b/compiler/vectorise/Vectorise/Type/Env.hs index 0bcdf0c4a8..b6c8bec3fc 100644 --- a/compiler/vectorise/Vectorise/Type/Env.hs +++ b/compiler/vectorise/Vectorise/Type/Env.hs @@ -360,7 +360,7 @@ vectTypeEnv tycons vectTypeDecls vectClassDecls origName = tyConName origTyCon vectName = tyConName vectTyCon - mkSyn canonName ty = mkSynonymTyCon canonName [] (typeKind ty) [] [] ty + mkSyn canonName ty = mkSynonymTyCon canonName [] (typeKind ty) [] ty defDataCons | isAbstract = return () diff --git a/compiler/vectorise/Vectorise/Type/TyConDecl.hs b/compiler/vectorise/Vectorise/Type/TyConDecl.hs index 052eced404..3085beb183 100644 --- a/compiler/vectorise/Vectorise/Type/TyConDecl.hs +++ b/compiler/vectorise/Vectorise/Type/TyConDecl.hs @@ -61,10 +61,9 @@ vectTyConDecl tycon name' ; cls' <- liftDs $ buildClass name' -- new name: "V:Class" - (tyConTyVars tycon) -- keep original type vars + (tyConBinders tycon) -- keep original kind (map (const Nominal) (tyConRoles tycon)) -- all role are N for safety theta' -- superclasses - (tyConBinders tycon) -- keep original kind (snd . classTvsFds $ cls) -- keep the original functional dependencies [] -- no associated types (for the moment) methods' -- method info @@ -105,7 +104,6 @@ vectTyConDecl tycon name' name' -- new name (tyConBinders tycon) (tyConResKind tycon) -- keep original kind - (tyConTyVars tycon) -- keep original type vars (map (const Nominal) (tyConRoles tycon)) -- all roles are N for safety Nothing [] -- no stupid theta @@ -191,7 +189,7 @@ vectDataCon dc (dataConSrcBangs dc) -- strictness as original constructor (Just $ dataConImplBangs dc) [] -- no labelled fields for now - univ_tvs univ_bndrs -- universally quantified vars + univ_bndrs -- universally quantified vars [] -- no existential tvs for now [] -- no equalities for now [] -- no context for now @@ -204,4 +202,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 = map mkNamedBinder (dataConUnivTyVarBinders dc) + univ_bndrs = dataConUnivTyVarBinders dc diff --git a/testsuite/tests/ado/ado002.stderr b/testsuite/tests/ado/ado002.stderr index 9e7eba0a67..fe730f6c91 100644 --- a/testsuite/tests/ado/ado002.stderr +++ b/testsuite/tests/ado/ado002.stderr @@ -1,6 +1,6 @@ ado002.hs:8:8: error: - • Couldn't match expected type ‘Char -> IO t1’ + • Couldn't match expected type ‘Char -> IO b0’ with actual type ‘IO Char’ • The function ‘getChar’ is applied to one argument, but its type ‘IO Char’ has none diff --git a/testsuite/tests/driver/werror.stderr b/testsuite/tests/driver/werror.stderr index 8f2e6035db..ae18bb62f0 100644 --- a/testsuite/tests/driver/werror.stderr +++ b/testsuite/tests/driver/werror.stderr @@ -18,7 +18,7 @@ werror.hs:10:1: warning: [-Wunused-top-binds (in -Wextra, -Wunused-binds)] werror.hs:10:1: warning: [-Wmissing-signatures (in -Wall)] Top-level binding with no type signature: - f :: forall t t1. [t1] -> [t] + f :: forall a a1. [a1] -> [a] werror.hs:10:1: warning: [-Wincomplete-patterns (in -Wextra)] Pattern match(es) are non-exhaustive diff --git a/testsuite/tests/gadt/gadt13.stderr b/testsuite/tests/gadt/gadt13.stderr index 06b1f9c720..e304430b51 100644 --- a/testsuite/tests/gadt/gadt13.stderr +++ b/testsuite/tests/gadt/gadt13.stderr @@ -1,17 +1,17 @@ -
-gadt13.hs:15:13: error:
- • Couldn't match expected type ‘t’
- with actual type ‘String -> [Char]’
- ‘t’ is untouchable
- inside the constraints: t1 ~ Int
- bound by a pattern with constructor: I :: Int -> Term Int,
- in an equation for ‘shw’
- at gadt13.hs:15:6-8
- ‘t’ is a rigid type variable bound by
- the inferred type of shw :: Term t1 -> t at gadt13.hs:15:1-30
- Possible fix: add a type signature for ‘shw’
- • Possible cause: ‘(.)’ is applied to too many arguments
- In the expression: ("I " ++) . shows t
- In an equation for ‘shw’: shw (I t) = ("I " ++) . shows t
- • Relevant bindings include
- shw :: Term t1 -> t (bound at gadt13.hs:15:1)
+ +gadt13.hs:15:13: error: + • Couldn't match expected type ‘t’ + with actual type ‘String -> [Char]’ + ‘t’ is untouchable + inside the constraints: a ~ Int + bound by a pattern with constructor: I :: Int -> Term Int, + in an equation for ‘shw’ + at gadt13.hs:15:6-8 + ‘t’ is a rigid type variable bound by + the inferred type of shw :: Term a -> t at gadt13.hs:15:1-30 + Possible fix: add a type signature for ‘shw’ + • Possible cause: ‘(.)’ is applied to too many arguments + In the expression: ("I " ++) . shows t + In an equation for ‘shw’: shw (I t) = ("I " ++) . shows t + • Relevant bindings include + shw :: Term a -> t (bound at gadt13.hs:15:1) diff --git a/testsuite/tests/gadt/gadt7.stderr b/testsuite/tests/gadt/gadt7.stderr index 6e1effa067..e66226eaea 100644 --- a/testsuite/tests/gadt/gadt7.stderr +++ b/testsuite/tests/gadt/gadt7.stderr @@ -1,20 +1,20 @@ -
-gadt7.hs:16:38: error:
- • Couldn't match expected type ‘t’ with actual type ‘t1’
- ‘t’ is untouchable
- inside the constraints: t2 ~ Int
- bound by a pattern with constructor: K :: T Int,
- in a case alternative
- at gadt7.hs:16:33
- ‘t’ is a rigid type variable bound by
- the inferred type of i1b :: T t2 -> t1 -> t at gadt7.hs:16:1-44
- ‘t1’ is a rigid type variable bound by
- the inferred type of i1b :: T t2 -> t1 -> t at gadt7.hs:16:1-44
- Possible fix: add a type signature for ‘i1b’
- • In the expression: y1
- In a case alternative: K -> y1
- In the expression: case t1 of { K -> y1 }
- • Relevant bindings include
- y1 :: t1 (bound at gadt7.hs:16:16)
- y :: t1 (bound at gadt7.hs:16:7)
- i1b :: T t2 -> t1 -> t (bound at gadt7.hs:16:1)
+ +gadt7.hs:16:38: error: + • Couldn't match expected type ‘t’ with actual type ‘t1’ + ‘t’ is untouchable + inside the constraints: a ~ Int + bound by a pattern with constructor: K :: T Int, + in a case alternative + at gadt7.hs:16:33 + ‘t’ is a rigid type variable bound by + the inferred type of i1b :: T a -> t1 -> t at gadt7.hs:16:1-44 + ‘t1’ is a rigid type variable bound by + the inferred type of i1b :: T a -> t1 -> t at gadt7.hs:16:1-44 + Possible fix: add a type signature for ‘i1b’ + • In the expression: y1 + In a case alternative: K -> y1 + In the expression: case t1 of { K -> y1 } + • Relevant bindings include + y1 :: t1 (bound at gadt7.hs:16:16) + y :: t1 (bound at gadt7.hs:16:7) + i1b :: T a -> t1 -> t (bound at gadt7.hs:16:1) diff --git a/testsuite/tests/generics/T10604/T10604_deriving.stderr b/testsuite/tests/generics/T10604/T10604_deriving.stderr index b4168d1bdd..cecb2ce308 100644 --- a/testsuite/tests/generics/T10604/T10604_deriving.stderr +++ b/testsuite/tests/generics/T10604/T10604_deriving.stderr @@ -303,8 +303,8 @@ GHC.Generics representation types: 'GHC.Generics.NoSourceStrictness 'GHC.Generics.DecidedLazy) ((GHC.Generics.:.:) - (k -> GHC.Types.*) * + (k -> GHC.Types.*) (T10604_deriving.Proxy *) (GHC.Generics.Rec1 (k -> GHC.Types.*) diff --git a/testsuite/tests/ghci.debugger/scripts/break003.stderr b/testsuite/tests/ghci.debugger/scripts/break003.stderr index d069493986..36398dfda1 100644 --- a/testsuite/tests/ghci.debugger/scripts/break003.stderr +++ b/testsuite/tests/ghci.debugger/scripts/break003.stderr @@ -1,5 +1,5 @@ <interactive>:4:1: error: - • No instance for (Show (t1 -> t)) arising from a use of ‘print’ + • No instance for (Show (t -> a)) arising from a use of ‘print’ (maybe you haven't applied a function to enough arguments?) • In a stmt of an interactive GHCi command: print it diff --git a/testsuite/tests/ghci.debugger/scripts/break003.stdout b/testsuite/tests/ghci.debugger/scripts/break003.stdout index 1d0844c6cc..d510a476ff 100644 --- a/testsuite/tests/ghci.debugger/scripts/break003.stdout +++ b/testsuite/tests/ghci.debugger/scripts/break003.stdout @@ -1,6 +1,6 @@ Breakpoint 0 activated at ../Test3.hs:2:18-31 Stopped in Main.mymap, ../Test3.hs:2:18-31 -_result :: [t] = _ -f :: t1 -> t = _ -x :: t1 = _ -xs :: [t1] = [_] +_result :: [a] = _ +f :: t -> a = _ +x :: t = _ +xs :: [t] = [_] diff --git a/testsuite/tests/ghci.debugger/scripts/break005.stdout b/testsuite/tests/ghci.debugger/scripts/break005.stdout index 81eae63726..35e92d44f0 100644 --- a/testsuite/tests/ghci.debugger/scripts/break005.stdout +++ b/testsuite/tests/ghci.debugger/scripts/break005.stdout @@ -4,7 +4,7 @@ a :: Integer = 1 left :: [Integer] = _ right :: [Integer] = _ Stopped in QSort.qsort, ../QSort.hs:5:17-26 -_result :: [t] = _ -left :: [t] = _ +_result :: [a] = _ +left :: [a] = _ () left = [] diff --git a/testsuite/tests/ghci.debugger/scripts/break006.stderr b/testsuite/tests/ghci.debugger/scripts/break006.stderr index 463b66fcbf..7929e36cc2 100644 --- a/testsuite/tests/ghci.debugger/scripts/break006.stderr +++ b/testsuite/tests/ghci.debugger/scripts/break006.stderr @@ -1,9 +1,9 @@ <interactive>:4:1: error: - • No instance for (Show t) arising from a use of ‘print’ - Cannot resolve unknown runtime type ‘t’ + • No instance for (Show a) arising from a use of ‘print’ + Cannot resolve unknown runtime type ‘a’ Use :print or :force to determine these types - Relevant bindings include it :: t (bound at <interactive>:4:1) + Relevant bindings include it :: a (bound at <interactive>:4:1) These potential instances exist: instance (Show b, Show a) => Show (Either a b) -- Defined in ‘Data.Either’ @@ -15,10 +15,10 @@ • In a stmt of an interactive GHCi command: print it <interactive>:6:1: error: - • No instance for (Show t) arising from a use of ‘print’ - Cannot resolve unknown runtime type ‘t’ + • No instance for (Show a) arising from a use of ‘print’ + Cannot resolve unknown runtime type ‘a’ Use :print or :force to determine these types - Relevant bindings include it :: t (bound at <interactive>:6:1) + Relevant bindings include it :: a (bound at <interactive>:6:1) These potential instances exist: instance (Show b, Show a) => Show (Either a b) -- Defined in ‘Data.Either’ diff --git a/testsuite/tests/ghci.debugger/scripts/break006.stdout b/testsuite/tests/ghci.debugger/scripts/break006.stdout index d8f1b65864..35fa44564c 100644 --- a/testsuite/tests/ghci.debugger/scripts/break006.stdout +++ b/testsuite/tests/ghci.debugger/scripts/break006.stdout @@ -1,13 +1,13 @@ Stopped in Main.mymap, ../Test3.hs:2:18-31 -_result :: [t] = _ -f :: Integer -> t = _ +_result :: [a] = _ +f :: Integer -> a = _ x :: Integer = 1 xs :: [Integer] = [2,3] xs :: [Integer] = [2,3] x :: Integer = 1 -f :: Integer -> t = _ -_result :: [t] = _ -y = (_t1::t) +f :: Integer -> a = _ +_result :: [a] = _ +y = (_t1::a) y = 2 xs :: [Integer] = [2,3] x :: Integer = 1 diff --git a/testsuite/tests/ghci.debugger/scripts/hist001.stdout b/testsuite/tests/ghci.debugger/scripts/hist001.stdout index 7ef5dc1e8e..9ae5688cb0 100644 --- a/testsuite/tests/ghci.debugger/scripts/hist001.stdout +++ b/testsuite/tests/ghci.debugger/scripts/hist001.stdout @@ -9,25 +9,25 @@ _result :: [a] = _ -6 : mymap (../Test3.hs:2:18-31) <end of history> Logged breakpoint at ../Test3.hs:2:22-31 -_result :: [t] -f :: t1 -> t -xs :: [t1] -xs :: [t1] = [] -f :: t1 -> t = _ -_result :: [t] = _ +_result :: [a] +f :: t -> a +xs :: [t] +xs :: [t] = [] +f :: t -> a = _ +_result :: [a] = _ Logged breakpoint at ../Test3.hs:2:18-20 -_result :: t -f :: Integer -> t +_result :: a +f :: Integer -> a x :: Integer -xs :: [t1] = [] +xs :: [t] = [] x :: Integer = 2 -f :: Integer -> t = _ -_result :: t = _ +f :: Integer -> a = _ +_result :: a = _ _result = 3 Logged breakpoint at ../Test3.hs:2:18-31 -_result :: [t] -f :: Integer -> t +_result :: [a] +f :: Integer -> a x :: Integer xs :: [Integer] Logged breakpoint at ../Test3.hs:2:18-20 -_result :: t +_result :: a diff --git a/testsuite/tests/ghci/prog010/ghci.prog010.stdout b/testsuite/tests/ghci/prog010/ghci.prog010.stdout index 0cc49e23d5..8434b21e18 100644 --- a/testsuite/tests/ghci/prog010/ghci.prog010.stdout +++ b/testsuite/tests/ghci/prog010/ghci.prog010.stdout @@ -1,7 +1,7 @@ -f :: t -> [t] +f :: a -> [a] g :: a -> Maybe a -f :: t -> [t] -f :: t -> [t] +f :: a -> [a] +f :: a -> [a] g :: a -> Maybe a -f :: t -> [t] +f :: a -> [a] g :: a -> Maybe a diff --git a/testsuite/tests/ghci/scripts/T11524a.stdout b/testsuite/tests/ghci/scripts/T11524a.stdout index 0a9dddbaec..164e0cf256 100644 --- a/testsuite/tests/ghci/scripts/T11524a.stdout +++ b/testsuite/tests/ghci/scripts/T11524a.stdout @@ -3,11 +3,11 @@ without -fprint-explicit-foralls pattern P :: Bool -- Defined at <interactive>:16:1 pattern Pe :: a -> Ex -- Defined at <interactive>:17:1 pattern Pu :: t -> t -- Defined at <interactive>:18:1 -pattern Pue :: t -> a -> (t, Ex) -- Defined at <interactive>:19:1 +pattern Pue :: a -> a1 -> (a, Ex) -- Defined at <interactive>:19:1 pattern Pur :: (Num a, Eq a) => a -> [a] -- Defined at <interactive>:20:1 -pattern Purp :: (Num a, Eq a) => Show t => a - -> t -> ([a], UnivProv t) +pattern Purp :: (Num a1, Eq a1) => Show a => a1 + -> a -> ([a1], UnivProv a) -- Defined at <interactive>:21:1 pattern Pure :: (Num a, Eq a) => a -> a1 -> ([a], Ex) -- Defined at <interactive>:22:1 @@ -16,9 +16,9 @@ pattern Purep :: (Num a, Eq a) => Show a1 => a -- Defined at <interactive>:23:1 pattern Pep :: () => Show a => a -> ExProv -- Defined at <interactive>:24:1 -pattern Pup :: () => Show t => t -> UnivProv t +pattern Pup :: () => Show a => a -> UnivProv a -- Defined at <interactive>:25:1 -pattern Puep :: () => Show a => a -> t -> (ExProv, t) +pattern Puep :: () => Show a => a -> b -> (ExProv, b) -- Defined at <interactive>:26:1 with -fprint-explicit-foralls @@ -27,12 +27,12 @@ pattern P :: Bool -- Defined at <interactive>:16:1 pattern Pe :: () => forall {a}. a -> Ex -- Defined at <interactive>:17:1 pattern Pu :: forall {t}. t -> t -- Defined at <interactive>:18:1 -pattern Pue :: forall {t}. () => forall {a}. t -> a -> (t, Ex) +pattern Pue :: forall {a}. () => forall {a1}. a -> a1 -> (a, Ex) -- Defined at <interactive>:19:1 pattern Pur :: forall {a}. (Num a, Eq a) => a -> [a] -- Defined at <interactive>:20:1 -pattern Purp :: forall {t} {a}. (Num a, Eq a) => Show t => a - -> t -> ([a], UnivProv t) +pattern Purp :: forall {a} {a1}. (Num a1, Eq a1) => Show a => a1 + -> a -> ([a1], UnivProv a) -- Defined at <interactive>:21:1 pattern Pure :: forall {a}. (Num a, Eq a) => forall {a1}. a -> a1 -> ([a], Ex) @@ -42,8 +42,8 @@ pattern Purep :: forall {a}. (Num a, Eq a) => forall {a1}. Show -- Defined at <interactive>:23:1 pattern Pep :: () => forall {a}. Show a => a -> ExProv -- Defined at <interactive>:24:1 -pattern Pup :: forall {t}. () => Show t => t -> UnivProv t +pattern Pup :: forall {a}. () => Show a => a -> UnivProv a -- Defined at <interactive>:25:1 -pattern Puep :: forall {t}. () => forall {a}. Show a => a - -> t -> (ExProv, t) +pattern Puep :: forall {b}. () => forall {a}. Show a => a + -> b -> (ExProv, b) -- Defined at <interactive>:26:1 diff --git a/testsuite/tests/ghci/scripts/T6018ghcifail.stderr b/testsuite/tests/ghci/scripts/T6018ghcifail.stderr index f06760eed7..048f45d288 100644 --- a/testsuite/tests/ghci/scripts/T6018ghcifail.stderr +++ b/testsuite/tests/ghci/scripts/T6018ghcifail.stderr @@ -49,7 +49,7 @@ <interactive>:60:15: error: Type family equation violates injectivity annotation. - Kind variable ‘k’ cannot be inferred from the right-hand side. + Kind variable ‘k1’ cannot be inferred from the right-hand side. Use -fprint-explicit-kinds to see the kind arguments In the type family equation: PolyKindVars '[] = '[] -- Defined at <interactive>:60:15 diff --git a/testsuite/tests/ghci/scripts/T7627.stdout b/testsuite/tests/ghci/scripts/T7627.stdout index 81a360facb..2dfae3749f 100644 --- a/testsuite/tests/ghci/scripts/T7627.stdout +++ b/testsuite/tests/ghci/scripts/T7627.stdout @@ -25,9 +25,9 @@ instance Foldable ((,) a) -- Defined in ‘Data.Foldable’ instance Traversable ((,) a) -- Defined in ‘Data.Traversable’ instance (Monoid a, Monoid b) => Monoid (a, b) -- Defined in ‘GHC.Base’ -data (#,#) (c :: TYPE a) (d :: TYPE b) = (#,#) c d +data (#,#) (a :: TYPE k0) (b :: TYPE k1) = (#,#) a b -- Defined in ‘GHC.Prim’ (,) :: a -> b -> (a, b) -(#,#) :: c -> d -> (# c, d #) +(#,#) :: a -> b -> (# a, b #) ( , ) :: a -> b -> (a, b) -(# , #) :: c -> d -> (# c, d #) +(# , #) :: a -> b -> (# a, b #) diff --git a/testsuite/tests/ghci/scripts/T8535.stdout b/testsuite/tests/ghci/scripts/T8535.stdout index 6eb08cdfe4..2f35e23a77 100644 --- a/testsuite/tests/ghci/scripts/T8535.stdout +++ b/testsuite/tests/ghci/scripts/T8535.stdout @@ -1,4 +1,4 @@ -data (->) t1 t2 -- Defined in ‘GHC.Prim’ +data (->) a b -- Defined in ‘GHC.Prim’ infixr 0 `(->)` instance Monad ((->) r) -- Defined in ‘GHC.Base’ instance Functor ((->) r) -- Defined in ‘GHC.Base’ diff --git a/testsuite/tests/ghci/scripts/T8776.stdout b/testsuite/tests/ghci/scripts/T8776.stdout index d0d9bd5240..1fe5d797b6 100644 --- a/testsuite/tests/ghci/scripts/T8776.stdout +++ b/testsuite/tests/ghci/scripts/T8776.stdout @@ -1,2 +1,2 @@ -pattern P :: () => (Num t1, Eq t) => A t1 t +pattern P :: () => (Num x, Eq y) => A x y -- Defined at T8776.hs:6:1 diff --git a/testsuite/tests/ghci/scripts/ghci013.stdout b/testsuite/tests/ghci/scripts/ghci013.stdout index d6c3823fdd..695aaafc53 100644 --- a/testsuite/tests/ghci/scripts/ghci013.stdout +++ b/testsuite/tests/ghci/scripts/ghci013.stdout @@ -1 +1 @@ -f :: Monad m => (m a, t) -> m b +f :: Monad m => (m a, b) -> m b1 diff --git a/testsuite/tests/ghci/scripts/ghci020.stdout b/testsuite/tests/ghci/scripts/ghci020.stdout index 6eb08cdfe4..2f35e23a77 100644 --- a/testsuite/tests/ghci/scripts/ghci020.stdout +++ b/testsuite/tests/ghci/scripts/ghci020.stdout @@ -1,4 +1,4 @@ -data (->) t1 t2 -- Defined in ‘GHC.Prim’ +data (->) a b -- Defined in ‘GHC.Prim’ infixr 0 `(->)` instance Monad ((->) r) -- Defined in ‘GHC.Base’ instance Functor ((->) r) -- Defined in ‘GHC.Base’ diff --git a/testsuite/tests/ghci/scripts/ghci059.stdout b/testsuite/tests/ghci/scripts/ghci059.stdout index fac61163f4..3cb103c9f5 100644 --- a/testsuite/tests/ghci/scripts/ghci059.stdout +++ b/testsuite/tests/ghci/scripts/ghci059.stdout @@ -1,4 +1,4 @@ type role Coercible representational representational -class a ~R# b => Coercible (a :: k) (b :: k) +class a ~R# b => Coercible (a :: k0) (b :: k0) -- Defined in ‘GHC.Types’ coerce :: Coercible a b => a -> b -- Defined in ‘GHC.Prim’ diff --git a/testsuite/tests/ghci/should_run/T10145.stdout b/testsuite/tests/ghci/should_run/T10145.stdout index 6eb08cdfe4..2f35e23a77 100644 --- a/testsuite/tests/ghci/should_run/T10145.stdout +++ b/testsuite/tests/ghci/should_run/T10145.stdout @@ -1,4 +1,4 @@ -data (->) t1 t2 -- Defined in ‘GHC.Prim’ +data (->) a b -- Defined in ‘GHC.Prim’ infixr 0 `(->)` instance Monad ((->) r) -- Defined in ‘GHC.Base’ instance Functor ((->) r) -- Defined in ‘GHC.Base’ diff --git a/testsuite/tests/indexed-types/should_compile/T3017.stderr b/testsuite/tests/indexed-types/should_compile/T3017.stderr index a3489d23bd..29877bf2aa 100644 --- a/testsuite/tests/indexed-types/should_compile/T3017.stderr +++ b/testsuite/tests/indexed-types/should_compile/T3017.stderr @@ -4,7 +4,7 @@ TYPE SIGNATURES emptyL :: forall a. ListColl a insert :: forall c. Coll c => Elem c -> c -> c test2 :: - forall t t1 c. (Elem c ~ (t, t1), Coll c, Num t, Num t1) => c -> c + forall a b c. (Elem c ~ (a, b), Coll c, Num a, Num b) => c -> c TYPE CONSTRUCTORS class Coll c where type family Elem c :: * open diff --git a/testsuite/tests/indexed-types/should_fail/ExtraTcsUntch.stderr b/testsuite/tests/indexed-types/should_fail/ExtraTcsUntch.stderr index f8cd07d0f7..0a1b9d37a9 100644 --- a/testsuite/tests/indexed-types/should_fail/ExtraTcsUntch.stderr +++ b/testsuite/tests/indexed-types/should_fail/ExtraTcsUntch.stderr @@ -1,18 +1,18 @@ ExtraTcsUntch.hs:23:18: error: - Couldn't match expected type ‘F Int’ with actual type ‘[[t]]’ - In the first argument of ‘h’, namely ‘[x]’ - In the expression: h [x] - In an equation for ‘g1’: g1 _ = h [x] - Relevant bindings include - x :: [t] (bound at ExtraTcsUntch.hs:21:3) - f :: [t] -> ((), ((), ())) (bound at ExtraTcsUntch.hs:21:1) + • Couldn't match expected type ‘F Int’ with actual type ‘[[a]]’ + • In the first argument of ‘h’, namely ‘[x]’ + In the expression: h [x] + In an equation for ‘g1’: g1 _ = h [x] + • Relevant bindings include + x :: [a] (bound at ExtraTcsUntch.hs:21:3) + f :: [a] -> ((), ((), ())) (bound at ExtraTcsUntch.hs:21:1) ExtraTcsUntch.hs:25:38: error: - Couldn't match expected type ‘F Int’ with actual type ‘[[t]]’ - In the first argument of ‘h’, namely ‘[[undefined]]’ - In the expression: h [[undefined]] - In the expression: (h [[undefined]], op x [y]) - Relevant bindings include - x :: [t] (bound at ExtraTcsUntch.hs:21:3) - f :: [t] -> ((), ((), ())) (bound at ExtraTcsUntch.hs:21:1) + • Couldn't match expected type ‘F Int’ with actual type ‘[[a]]’ + • In the first argument of ‘h’, namely ‘[[undefined]]’ + In the expression: h [[undefined]] + In the expression: (h [[undefined]], op x [y]) + • Relevant bindings include + x :: [a] (bound at ExtraTcsUntch.hs:21:3) + f :: [a] -> ((), ((), ())) (bound at ExtraTcsUntch.hs:21:1) diff --git a/testsuite/tests/parser/should_fail/T7848.stderr b/testsuite/tests/parser/should_fail/T7848.stderr index e1a64e4668..f7617ee606 100644 --- a/testsuite/tests/parser/should_fail/T7848.stderr +++ b/testsuite/tests/parser/should_fail/T7848.stderr @@ -1,9 +1,9 @@ T7848.hs:6:1: error: • Occurs check: cannot construct the infinite type: - t ~ t2 -> t1 -> A -> A -> A -> A -> t0 -> t + t ~ t0 -> t1 -> A -> A -> A -> A -> t2 -> t • When checking that: - t2 -> t1 -> A -> A -> A -> A -> forall t4. t4 -> t + t0 -> t1 -> A -> A -> A -> A -> forall t2. t2 -> t is more polymorphic than: t • Relevant bindings include x :: t (bound at T7848.hs:6:1) diff --git a/testsuite/tests/partial-sigs/should_compile/T10403.stderr b/testsuite/tests/partial-sigs/should_compile/T10403.stderr index 3cebd8f92a..23c059e720 100644 --- a/testsuite/tests/partial-sigs/should_compile/T10403.stderr +++ b/testsuite/tests/partial-sigs/should_compile/T10403.stderr @@ -1,38 +1,34 @@ T10403.hs:15:7: warning: [-Wpartial-type-signatures (in -Wdefault)] - Found constraint wildcard ‘_’ standing for ‘Functor f’ - In the type signature: - h1 :: _ => _ + • 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: ‘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 + 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 + at T10403.hs:17:1-41 ‘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) + 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: ‘b’ is a rigid type variable bound by the inferred type of h2 :: (a -> b) -> f0 a -> H f0 - at T10403.hs:22:1 + 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 + at T10403.hs:22:1-41 ‘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) + • 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’ @@ -79,4 +75,3 @@ T10403.hs:28:20: warning: [-Wdeferred-type-errors (in -Wdefault)] 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 c7420eb3d7..7abf6e5845 100644 --- a/testsuite/tests/partial-sigs/should_compile/T11192.stderr +++ b/testsuite/tests/partial-sigs/should_compile/T11192.stderr @@ -2,9 +2,8 @@ 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 :: _ + the inferred type of go :: Int -> t -> t at T11192.hs:8:8-17 + • In the type signature: go :: _ In the expression: let go :: _ @@ -16,18 +15,15 @@ T11192.hs:7:14: warning: [-Wpartial-type-signatures (in -Wdefault)] 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) + • 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 ‘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 :: _ + • Found type wildcard ‘_’ standing for ‘t1 -> t -> t’ + Where: ‘t1’ is a rigid type variable bound by + the inferred type of go :: t1 -> t -> t at T11192.hs:14:8-17 + ‘t’ 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 :: _ @@ -39,7 +35,4 @@ T11192.hs:13:14: warning: [-Wpartial-type-signatures (in -Wdefault)] 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) - + • Relevant bindings include succeeds :: a (bound at T11192.hs:12:1) diff --git a/testsuite/tests/partial-sigs/should_compile/T12033.stderr b/testsuite/tests/partial-sigs/should_compile/T12033.stderr index 02a1233559..a3b293b0cc 100644 --- a/testsuite/tests/partial-sigs/should_compile/T12033.stderr +++ b/testsuite/tests/partial-sigs/should_compile/T12033.stderr @@ -1,24 +1,24 @@ -
-T12033.hs:12:22: warning: [-Wpartial-type-signatures (in -Wdefault)]
- • Found type wildcard ‘_’ standing for ‘v -> t’
- Where: ‘t’ is a rigid type variable bound by
- the inferred type of
- makeTuple :: v -> t
- makeExpression :: v -> t
- at T12033.hs:(11,4)-(13,39)
- ‘v’ is a rigid type variable bound by
- the type signature for:
- tripleStoreToRuleSet :: forall v. v -> v
- at T12033.hs:6:1-30
- • In the type signature: makeExpression :: _
- In an equation for ‘tripleStoreToRuleSet’:
- tripleStoreToRuleSet getAtom
- = makeTuple getAtom
- where
- makeRule v = makeExpression v
- makeTuple v = makeExpression v
- makeExpression :: _
- makeExpression v = makeTuple getAtom
- • Relevant bindings include
- getAtom :: v (bound at T12033.hs:7:22)
- tripleStoreToRuleSet :: v -> v (bound at T12033.hs:7:1)
+ +T12033.hs:12:22: warning: [-Wpartial-type-signatures (in -Wdefault)] + • Found type wildcard ‘_’ standing for ‘v -> t’ + Where: ‘v’ is a rigid type variable bound by + the type signature for: + tripleStoreToRuleSet :: forall v. v -> v + at T12033.hs:6:1-30 + ‘t’ is a rigid type variable bound by + the inferred type of + makeTuple :: v -> t + makeExpression :: v -> t + at T12033.hs:(11,4)-(13,39) + • In the type signature: makeExpression :: _ + In an equation for ‘tripleStoreToRuleSet’: + tripleStoreToRuleSet getAtom + = makeTuple getAtom + where + makeRule v = makeExpression v + makeTuple v = makeExpression v + makeExpression :: _ + makeExpression v = makeTuple getAtom + • Relevant bindings include + getAtom :: v (bound at T12033.hs:7:22) + tripleStoreToRuleSet :: v -> v (bound at T12033.hs:7:1) diff --git a/testsuite/tests/partial-sigs/should_compile/WarningWildcardInstantiations.stderr b/testsuite/tests/partial-sigs/should_compile/WarningWildcardInstantiations.stderr index 60b5b11bde..a69c59b0dc 100644 --- a/testsuite/tests/partial-sigs/should_compile/WarningWildcardInstantiations.stderr +++ b/testsuite/tests/partial-sigs/should_compile/WarningWildcardInstantiations.stderr @@ -1,50 +1,50 @@ -TYPE SIGNATURES
- bar :: forall w t. t -> (t -> w) -> w
- foo :: forall a. (Show a, Enum a) => a -> String
-TYPE CONSTRUCTORS
-COERCION AXIOMS
-Dependent modules: []
-Dependent packages: [base-4.9.0.0, ghc-prim-0.5.0.0,
- integer-gmp-1.0.0.1]
-
-WarningWildcardInstantiations.hs:5:14: warning: [-Wpartial-type-signatures (in -Wdefault)]
- • Found type wildcard ‘_a’ standing for ‘a’
- Where: ‘a’ is a rigid type variable bound by
- the inferred type of foo :: (Show a, Enum a) => a -> String
- at WarningWildcardInstantiations.hs:6:1-21
- • In the type signature: foo :: (Show _a, _) => _a -> _
-
-WarningWildcardInstantiations.hs:5:18: warning: [-Wpartial-type-signatures (in -Wdefault)]
- • Found type wildcard ‘_’ standing for ‘Enum a’
- Where: ‘a’ is a rigid type variable bound by
- the inferred type of foo :: (Show a, Enum a) => a -> String
- at WarningWildcardInstantiations.hs:6:1-21
- • In the type signature: foo :: (Show _a, _) => _a -> _
-
-WarningWildcardInstantiations.hs:5:30: warning: [-Wpartial-type-signatures (in -Wdefault)]
- • Found type wildcard ‘_’ standing for ‘String’
- • In the type signature: foo :: (Show _a, _) => _a -> _
-
-WarningWildcardInstantiations.hs:8:8: warning: [-Wpartial-type-signatures (in -Wdefault)]
- • Found type wildcard ‘_’ standing for ‘t’
- Where: ‘t’ is a rigid type variable bound by
- the inferred type of bar :: t -> (t -> w) -> w
- at WarningWildcardInstantiations.hs:9:1-13
- • In the type signature: bar :: _ -> _ -> _
-
-WarningWildcardInstantiations.hs:8:13: warning: [-Wpartial-type-signatures (in -Wdefault)]
- • Found type wildcard ‘_’ standing for ‘t -> w’
- Where: ‘w’ is a rigid type variable bound by
- the inferred type of bar :: t -> (t -> w) -> w
- at WarningWildcardInstantiations.hs:9:1-13
- ‘t’ is a rigid type variable bound by
- the inferred type of bar :: t -> (t -> w) -> w
- at WarningWildcardInstantiations.hs:9:1-13
- • In the type signature: bar :: _ -> _ -> _
-
-WarningWildcardInstantiations.hs:8:18: warning: [-Wpartial-type-signatures (in -Wdefault)]
- • Found type wildcard ‘_’ standing for ‘w’
- Where: ‘w’ is a rigid type variable bound by
- the inferred type of bar :: t -> (t -> w) -> w
- at WarningWildcardInstantiations.hs:9:1-13
- • In the type signature: bar :: _ -> _ -> _
+TYPE SIGNATURES + bar :: forall w t. t -> (t -> w) -> w + foo :: forall a. (Show a, Enum a) => a -> String +TYPE CONSTRUCTORS +COERCION AXIOMS +Dependent modules: [] +Dependent packages: [base-4.9.0.0, ghc-prim-0.5.0.0, + integer-gmp-1.0.0.1] + +WarningWildcardInstantiations.hs:5:14: warning: [-Wpartial-type-signatures (in -Wdefault)] + • Found type wildcard ‘_a’ standing for ‘a’ + Where: ‘a’ is a rigid type variable bound by + the inferred type of foo :: (Show a, Enum a) => a -> String + at WarningWildcardInstantiations.hs:6:1-21 + • In the type signature: foo :: (Show _a, _) => _a -> _ + +WarningWildcardInstantiations.hs:5:18: warning: [-Wpartial-type-signatures (in -Wdefault)] + • Found type wildcard ‘_’ standing for ‘Enum a’ + Where: ‘a’ is a rigid type variable bound by + the inferred type of foo :: (Show a, Enum a) => a -> String + at WarningWildcardInstantiations.hs:6:1-21 + • In the type signature: foo :: (Show _a, _) => _a -> _ + +WarningWildcardInstantiations.hs:5:30: warning: [-Wpartial-type-signatures (in -Wdefault)] + • Found type wildcard ‘_’ standing for ‘String’ + • In the type signature: foo :: (Show _a, _) => _a -> _ + +WarningWildcardInstantiations.hs:8:8: warning: [-Wpartial-type-signatures (in -Wdefault)] + • Found type wildcard ‘_’ standing for ‘t’ + Where: ‘t’ is a rigid type variable bound by + the inferred type of bar :: t -> (t -> w) -> w + at WarningWildcardInstantiations.hs:9:1-13 + • In the type signature: bar :: _ -> _ -> _ + +WarningWildcardInstantiations.hs:8:13: warning: [-Wpartial-type-signatures (in -Wdefault)] + • Found type wildcard ‘_’ standing for ‘t -> w’ + Where: ‘t’ is a rigid type variable bound by + the inferred type of bar :: t -> (t -> w) -> w + at WarningWildcardInstantiations.hs:9:1-13 + ‘w’ is a rigid type variable bound by + the inferred type of bar :: t -> (t -> w) -> w + at WarningWildcardInstantiations.hs:9:1-13 + • In the type signature: bar :: _ -> _ -> _ + +WarningWildcardInstantiations.hs:8:18: warning: [-Wpartial-type-signatures (in -Wdefault)] + • Found type wildcard ‘_’ standing for ‘w’ + Where: ‘w’ is a rigid type variable bound by + the inferred type of bar :: t -> (t -> w) -> w + at WarningWildcardInstantiations.hs:9:1-13 + • In the type signature: bar :: _ -> _ -> _ diff --git a/testsuite/tests/partial-sigs/should_fail/T10045.stderr b/testsuite/tests/partial-sigs/should_fail/T10045.stderr index e9cac55e9e..16a5bf876f 100644 --- a/testsuite/tests/partial-sigs/should_fail/T10045.stderr +++ b/testsuite/tests/partial-sigs/should_fail/T10045.stderr @@ -1,13 +1,12 @@ 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 + • Found type wildcard ‘_’ standing for ‘t2 -> Bool -> t1’ + Where: ‘t2’ is a rigid type variable bound by + the inferred type of copy :: t2 -> Bool -> t1 at T10045.hs:7:10-34 + ‘t1’ 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 type signature: copy :: _ In the expression: let copy :: _ @@ -20,7 +19,5 @@ T10045.hs:6:18: error: 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/partial-sigs/should_fail/WildcardInstantiations.stderr b/testsuite/tests/partial-sigs/should_fail/WildcardInstantiations.stderr index d026cbc70d..440d8722de 100644 --- a/testsuite/tests/partial-sigs/should_fail/WildcardInstantiations.stderr +++ b/testsuite/tests/partial-sigs/should_fail/WildcardInstantiations.stderr @@ -1,48 +1,48 @@ -
-WildcardInstantiations.hs:5:14: error:
- • Found type wildcard ‘_a’ standing for ‘a’
- Where: ‘a’ is a rigid type variable bound by
- the inferred type of foo :: (Show a, Enum a) => a -> String
- at WildcardInstantiations.hs:6:1-21
- To use the inferred type, enable PartialTypeSignatures
- • In the type signature: foo :: (Show _a, _) => _a -> _
-
-WildcardInstantiations.hs:5:18: error:
- • Found type wildcard ‘_’ standing for ‘Enum a’
- Where: ‘a’ is a rigid type variable bound by
- the inferred type of foo :: (Show a, Enum a) => a -> String
- at WildcardInstantiations.hs:6:1-21
- To use the inferred type, enable PartialTypeSignatures
- • In the type signature: foo :: (Show _a, _) => _a -> _
-
-WildcardInstantiations.hs:5:30: error:
- • Found type wildcard ‘_’ standing for ‘String’
- To use the inferred type, enable PartialTypeSignatures
- • In the type signature: foo :: (Show _a, _) => _a -> _
-
-WildcardInstantiations.hs:8:8: error:
- • Found type wildcard ‘_’ standing for ‘t’
- Where: ‘t’ is a rigid type variable bound by
- the inferred type of bar :: t -> (t -> w) -> w
- at WildcardInstantiations.hs:9:1-13
- To use the inferred type, enable PartialTypeSignatures
- • In the type signature: bar :: _ -> _ -> _
-
-WildcardInstantiations.hs:8:13: error:
- • Found type wildcard ‘_’ standing for ‘t -> w’
- Where: ‘w’ is a rigid type variable bound by
- the inferred type of bar :: t -> (t -> w) -> w
- at WildcardInstantiations.hs:9:1-13
- ‘t’ is a rigid type variable bound by
- the inferred type of bar :: t -> (t -> w) -> w
- at WildcardInstantiations.hs:9:1-13
- To use the inferred type, enable PartialTypeSignatures
- • In the type signature: bar :: _ -> _ -> _
-
-WildcardInstantiations.hs:8:18: error:
- • Found type wildcard ‘_’ standing for ‘w’
- Where: ‘w’ is a rigid type variable bound by
- the inferred type of bar :: t -> (t -> w) -> w
- at WildcardInstantiations.hs:9:1-13
- To use the inferred type, enable PartialTypeSignatures
- • In the type signature: bar :: _ -> _ -> _
+ +WildcardInstantiations.hs:5:14: error: + • Found type wildcard ‘_a’ standing for ‘a’ + Where: ‘a’ is a rigid type variable bound by + the inferred type of foo :: (Show a, Enum a) => a -> String + at WildcardInstantiations.hs:6:1-21 + To use the inferred type, enable PartialTypeSignatures + • In the type signature: foo :: (Show _a, _) => _a -> _ + +WildcardInstantiations.hs:5:18: error: + • Found type wildcard ‘_’ standing for ‘Enum a’ + Where: ‘a’ is a rigid type variable bound by + the inferred type of foo :: (Show a, Enum a) => a -> String + at WildcardInstantiations.hs:6:1-21 + To use the inferred type, enable PartialTypeSignatures + • In the type signature: foo :: (Show _a, _) => _a -> _ + +WildcardInstantiations.hs:5:30: error: + • Found type wildcard ‘_’ standing for ‘String’ + To use the inferred type, enable PartialTypeSignatures + • In the type signature: foo :: (Show _a, _) => _a -> _ + +WildcardInstantiations.hs:8:8: error: + • Found type wildcard ‘_’ standing for ‘t’ + Where: ‘t’ is a rigid type variable bound by + the inferred type of bar :: t -> (t -> w) -> w + at WildcardInstantiations.hs:9:1-13 + To use the inferred type, enable PartialTypeSignatures + • In the type signature: bar :: _ -> _ -> _ + +WildcardInstantiations.hs:8:13: error: + • Found type wildcard ‘_’ standing for ‘t -> w’ + Where: ‘t’ is a rigid type variable bound by + the inferred type of bar :: t -> (t -> w) -> w + at WildcardInstantiations.hs:9:1-13 + ‘w’ is a rigid type variable bound by + the inferred type of bar :: t -> (t -> w) -> w + at WildcardInstantiations.hs:9:1-13 + To use the inferred type, enable PartialTypeSignatures + • In the type signature: bar :: _ -> _ -> _ + +WildcardInstantiations.hs:8:18: error: + • Found type wildcard ‘_’ standing for ‘w’ + Where: ‘w’ is a rigid type variable bound by + the inferred type of bar :: t -> (t -> w) -> w + at WildcardInstantiations.hs:9:1-13 + To use the inferred type, enable PartialTypeSignatures + • In the type signature: bar :: _ -> _ -> _ diff --git a/testsuite/tests/patsyn/should_compile/T11213.stderr b/testsuite/tests/patsyn/should_compile/T11213.stderr index 7a0af54b67..72f67e3a26 100644 --- a/testsuite/tests/patsyn/should_compile/T11213.stderr +++ b/testsuite/tests/patsyn/should_compile/T11213.stderr @@ -11,7 +11,7 @@ T11213.hs:21:1: warning: [-Wmissing-pattern-synonym-signatures (in -Wall)] T11213.hs:22:1: warning: [-Wmissing-pattern-synonym-signatures (in -Wall)] Top-level binding with no type signature: - Pue :: forall t. () => forall a. t -> a -> (t, Ex) + Pue :: forall a. () => forall a1. a -> a1 -> (a, Ex) T11213.hs:23:1: warning: [-Wmissing-pattern-synonym-signatures (in -Wall)] Top-level binding with no type signature: @@ -19,9 +19,9 @@ T11213.hs:23:1: warning: [-Wmissing-pattern-synonym-signatures (in -Wall)] T11213.hs:24:1: warning: [-Wmissing-pattern-synonym-signatures (in -Wall)] Top-level binding with no type signature: - Purp :: forall t a. - (Num a, Eq a) => - Show t => a -> t -> ([a], UnivProv t) + Purp :: forall a a1. + (Num a1, Eq a1) => + Show a => a1 -> a -> ([a1], UnivProv a) T11213.hs:25:1: warning: [-Wmissing-pattern-synonym-signatures (in -Wall)] Top-level binding with no type signature: @@ -39,8 +39,8 @@ T11213.hs:27:1: warning: [-Wmissing-pattern-synonym-signatures (in -Wall)] T11213.hs:28:1: warning: [-Wmissing-pattern-synonym-signatures (in -Wall)] Top-level binding with no type signature: - Pup :: forall t. () => Show t => t -> UnivProv t + Pup :: forall a. () => Show a => a -> UnivProv a T11213.hs:29:1: warning: [-Wmissing-pattern-synonym-signatures (in -Wall)] Top-level binding with no type signature: - Puep :: forall t. () => forall a. Show a => a -> t -> (ExProv, t) + Puep :: forall b. () => forall a. Show a => a -> b -> (ExProv, b) diff --git a/testsuite/tests/patsyn/should_fail/T11053.stderr b/testsuite/tests/patsyn/should_fail/T11053.stderr index e583aa1b08..40dae30ba1 100644 --- a/testsuite/tests/patsyn/should_fail/T11053.stderr +++ b/testsuite/tests/patsyn/should_fail/T11053.stderr @@ -4,16 +4,16 @@ T11053.hs:7:1: warning: [-Wmissing-pattern-synonym-signatures (in -Wall)] T11053.hs:9:1: warning: [-Wmissing-pattern-synonym-signatures (in -Wall)] Top-level binding with no type signature: - J :: forall t. t -> Maybe t + J :: forall a. a -> Maybe a T11053.hs:11:1: warning: [-Wmissing-pattern-synonym-signatures (in -Wall)] Top-level binding with no type signature: - J1 :: forall t. t -> Maybe t + J1 :: forall a. a -> Maybe a T11053.hs:13:1: warning: [-Wmissing-pattern-synonym-signatures (in -Wall)] Top-level binding with no type signature: - J2 :: forall t. t -> Maybe t + J2 :: forall a. a -> Maybe a T11053.hs:15:1: warning: [-Wmissing-pattern-synonym-signatures (in -Wall)] Top-level binding with no type signature: - J3 :: forall t. t -> Maybe t + J3 :: forall a. a -> Maybe a diff --git a/testsuite/tests/patsyn/should_run/ghci.stdout b/testsuite/tests/patsyn/should_run/ghci.stdout index 3dcecbc7a6..d3e6c0edbf 100644 --- a/testsuite/tests/patsyn/should_run/ghci.stdout +++ b/testsuite/tests/patsyn/should_run/ghci.stdout @@ -1,3 +1,3 @@ -pattern Single :: t -> [t] -- Defined at <interactive>:3:1 +pattern Single :: a -> [a] -- Defined at <interactive>:3:1 foo :: [Bool] -> [Bool] [False] diff --git a/testsuite/tests/polykinds/T7328.stderr b/testsuite/tests/polykinds/T7328.stderr index 58e883e142..95b3a7782f 100644 --- a/testsuite/tests/polykinds/T7328.stderr +++ b/testsuite/tests/polykinds/T7328.stderr @@ -1,7 +1,6 @@ T7328.hs:8:34: error: - • Occurs check: cannot construct the infinite kind: k0 ~ k1 -> k0 + • Occurs check: cannot construct the infinite kind: k1 ~ k0 -> k1 • In the first argument of ‘Foo’, namely ‘f’ In the first argument of ‘Proxy’, namely ‘Foo f’ - In the type signature: - foo :: a ~ f i => Proxy (Foo f) + In the type signature: foo :: a ~ f i => Proxy (Foo f) diff --git a/testsuite/tests/polykinds/T7438.stderr b/testsuite/tests/polykinds/T7438.stderr index 31ac2a356e..9f8f62e25e 100644 --- a/testsuite/tests/polykinds/T7438.stderr +++ b/testsuite/tests/polykinds/T7438.stderr @@ -1,21 +1,19 @@ -
-T7438.hs:6:14: error:
- • Couldn't match expected type ‘t2’ with actual type ‘t3’
- ‘t2’ is untouchable
- inside the constraints: t ~ t1
- bound by a pattern with constructor:
- Nil :: forall k (a :: k). Thrist a a,
- in an equation for ‘go’
- at T7438.hs:6:4-6
- ‘t2’ is a rigid type variable bound by
- the inferred type of go :: Thrist t1 t -> t3 -> t2
- at T7438.hs:6:1-16
- ‘t3’ is a rigid type variable bound by
- the inferred type of go :: Thrist t1 t -> t3 -> t2
- at T7438.hs:6:1-16
- Possible fix: add a type signature for ‘go’
- • In the expression: acc
- In an equation for ‘go’: go Nil acc = acc
- • Relevant bindings include
- acc :: t3 (bound at T7438.hs:6:8)
- go :: Thrist t1 t -> t3 -> t2 (bound at T7438.hs:6:1)
+ +T7438.hs:6:14: error: + • Couldn't match expected type ‘t’ with actual type ‘t1’ + ‘t’ is untouchable + inside the constraints: b ~ a + bound by a pattern with constructor: + Nil :: forall k (a :: k). Thrist a a, + in an equation for ‘go’ + at T7438.hs:6:4-6 + ‘t’ is a rigid type variable bound by + the inferred type of go :: Thrist a b -> t1 -> t at T7438.hs:6:1-16 + ‘t1’ is a rigid type variable bound by + the inferred type of go :: Thrist a b -> t1 -> t at T7438.hs:6:1-16 + Possible fix: add a type signature for ‘go’ + • In the expression: acc + In an equation for ‘go’: go Nil acc = acc + • Relevant bindings include + acc :: t1 (bound at T7438.hs:6:8) + go :: Thrist a b -> t1 -> t (bound at T7438.hs:6:1) diff --git a/testsuite/tests/polykinds/T9017.stderr b/testsuite/tests/polykinds/T9017.stderr index 409e66ae6c..79a9a4617f 100644 --- a/testsuite/tests/polykinds/T9017.stderr +++ b/testsuite/tests/polykinds/T9017.stderr @@ -1,14 +1,13 @@ T9017.hs:8:7: error: - • Couldn't match kind ‘k1’ with ‘*’ - ‘k1’ is a rigid type variable bound by + • Couldn't match kind ‘k’ with ‘*’ + ‘k’ 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 + 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) - diff --git a/testsuite/tests/rebindable/rebindable6.stderr b/testsuite/tests/rebindable/rebindable6.stderr index 8667f318bf..241cf76962 100644 --- a/testsuite/tests/rebindable/rebindable6.stderr +++ b/testsuite/tests/rebindable/rebindable6.stderr @@ -25,7 +25,7 @@ rebindable6.hs:110:17: error: return b } rebindable6.hs:111:17: error: - • Ambiguous type variables ‘t0’, ‘t1’ arising from a do statement + • Ambiguous type variables ‘t1’, ‘t0’ arising from a do statement prevents the constraint ‘(HasBind (IO (Maybe b) -> (Maybe b -> t1) -> t0))’ from being solved. (maybe you haven't applied a function to enough arguments?) @@ -33,7 +33,7 @@ rebindable6.hs:111:17: error: g :: IO (Maybe b) (bound at rebindable6.hs:108:19) test_do :: IO a -> IO (Maybe b) -> IO b (bound at rebindable6.hs:108:9) - Probable fix: use a type annotation to specify what ‘t0’, ‘t1’ should be. + Probable fix: use a type annotation to specify what ‘t1’, ‘t0’ should be. These potential instance exist: instance HasBind (IO a -> (a -> IO b) -> IO b) -- Defined at rebindable6.hs:51:18 diff --git a/testsuite/tests/rename/should_fail/T10618.stderr b/testsuite/tests/rename/should_fail/T10618.stderr index 21c35471dd..8b4dc2c28d 100644 --- a/testsuite/tests/rename/should_fail/T10618.stderr +++ b/testsuite/tests/rename/should_fail/T10618.stderr @@ -1,6 +1,6 @@ T10618.hs:3:22: error: - • Variable not in scope: (<>) :: Maybe (Maybe a1) -> Maybe a0 -> t + • Variable not in scope: (<>) :: Maybe (Maybe a0) -> Maybe a1 -> t • Perhaps you meant one of these: ‘<$>’ (imported from Prelude), ‘*>’ (imported from Prelude), ‘<$’ (imported from Prelude) diff --git a/testsuite/tests/typecheck/should_compile/tc141.stderr b/testsuite/tests/typecheck/should_compile/tc141.stderr index ab778a0133..cf206a11ae 100644 --- a/testsuite/tests/typecheck/should_compile/tc141.stderr +++ b/testsuite/tests/typecheck/should_compile/tc141.stderr @@ -1,54 +1,54 @@ -
-tc141.hs:11:12: error:
- • You cannot bind scoped type variable ‘a’
- in a pattern binding signature
- • In the pattern: p :: a
- In the pattern: (p :: a, q :: a)
- In a pattern binding: (p :: a, q :: a) = x
-
-tc141.hs:11:31: error:
- • Couldn't match expected type ‘a1’ with actual type ‘a’
- because type variable ‘a1’ would escape its scope
- This (rigid, skolem) type variable is bound by
- an expression type signature:
- a1
- at tc141.hs:11:34
- • In the expression: q :: a
- In the expression: (q :: a, p)
- In the expression: let (p :: a, q :: a) = x in (q :: a, p)
- • Relevant bindings include
- p :: a (bound at tc141.hs:11:12)
- q :: a (bound at tc141.hs:11:17)
- x :: (a, a) (bound at tc141.hs:11:3)
- f :: (a, a) -> (t, a) (bound at tc141.hs:11:1)
-
-tc141.hs:13:13: error:
- • You cannot bind scoped type variable ‘a’
- in a pattern binding signature
- • In the pattern: y :: a
- In a pattern binding: y :: a = a
- In the expression:
- let y :: a = a in
- let
- v :: a
- v = b
- in v
-
-tc141.hs:15:18: error:
- • Couldn't match expected type ‘a1’ with actual type ‘t’
- because type variable ‘a1’ would escape its scope
- This (rigid, skolem) type variable is bound by
- the type signature for:
- v :: a1
- at tc141.hs:14:14-19
- • In the expression: b
- In an equation for ‘v’: v = b
- In the expression:
- let
- v :: a
- v = b
- in v
- • Relevant bindings include
- v :: a1 (bound at tc141.hs:15:14)
- b :: t (bound at tc141.hs:13:5)
- g :: t1 -> t -> forall a. a (bound at tc141.hs:13:1)
+ +tc141.hs:11:12: error: + • You cannot bind scoped type variable ‘a’ + in a pattern binding signature + • In the pattern: p :: a + In the pattern: (p :: a, q :: a) + In a pattern binding: (p :: a, q :: a) = x + +tc141.hs:11:31: error: + • Couldn't match expected type ‘a2’ with actual type ‘a1’ + because type variable ‘a2’ would escape its scope + This (rigid, skolem) type variable is bound by + an expression type signature: + a2 + at tc141.hs:11:34 + • In the expression: q :: a + In the expression: (q :: a, p) + In the expression: let (p :: a, q :: a) = x in (q :: a, p) + • Relevant bindings include + p :: a1 (bound at tc141.hs:11:12) + q :: a1 (bound at tc141.hs:11:17) + x :: (a1, a1) (bound at tc141.hs:11:3) + f :: (a1, a1) -> (a, a1) (bound at tc141.hs:11:1) + +tc141.hs:13:13: error: + • You cannot bind scoped type variable ‘a’ + in a pattern binding signature + • In the pattern: y :: a + In a pattern binding: y :: a = a + In the expression: + let y :: a = a in + let + v :: a + v = b + in v + +tc141.hs:15:18: error: + • Couldn't match expected type ‘a1’ with actual type ‘t’ + because type variable ‘a1’ would escape its scope + This (rigid, skolem) type variable is bound by + the type signature for: + v :: a1 + at tc141.hs:14:14-19 + • In the expression: b + In an equation for ‘v’: v = b + In the expression: + let + v :: a + v = b + in v + • Relevant bindings include + v :: a1 (bound at tc141.hs:15:14) + b :: t (bound at tc141.hs:13:5) + g :: t1 -> t -> forall a. a (bound at tc141.hs:13:1) diff --git a/testsuite/tests/typecheck/should_fail/FailDueToGivenOverlapping.stderr b/testsuite/tests/typecheck/should_fail/FailDueToGivenOverlapping.stderr index f30ceecff9..651aad6c57 100644 --- a/testsuite/tests/typecheck/should_fail/FailDueToGivenOverlapping.stderr +++ b/testsuite/tests/typecheck/should_fail/FailDueToGivenOverlapping.stderr @@ -1,6 +1,6 @@ FailDueToGivenOverlapping.hs:27:9: error: - • Overlapping instances for E [t0] arising from a use of ‘eop’ + • Overlapping instances for E [a0] arising from a use of ‘eop’ Matching givens (or their superclasses): E [Int] bound by the type signature for: @@ -8,6 +8,6 @@ FailDueToGivenOverlapping.hs:27:9: error: at FailDueToGivenOverlapping.hs:26:1-26 Matching instances: instance E [a] -- Defined at FailDueToGivenOverlapping.hs:21:10 - (The choice depends on the instantiation of ‘t0’) + (The choice depends on the instantiation of ‘a0’) • In the expression: eop [undefined] In an equation for ‘bar’: bar _ = eop [undefined] diff --git a/testsuite/tests/typecheck/should_fail/T10351.stderr b/testsuite/tests/typecheck/should_fail/T10351.stderr index b6a16d3723..782d6e39d8 100644 --- a/testsuite/tests/typecheck/should_fail/T10351.stderr +++ b/testsuite/tests/typecheck/should_fail/T10351.stderr @@ -1,6 +1,6 @@ T10351.hs:6:1: error: - • Non type-variable argument in the constraint: C [t] + • Non type-variable argument in the constraint: C [a] (Use FlexibleContexts to permit this) • When checking the inferred type - f :: forall t. C [t] => t -> () + f :: forall a. C [a] => a -> () diff --git a/testsuite/tests/typecheck/should_fail/T11355.stderr b/testsuite/tests/typecheck/should_fail/T11355.stderr index 6c649e4187..68375400a8 100644 --- a/testsuite/tests/typecheck/should_fail/T11355.stderr +++ b/testsuite/tests/typecheck/should_fail/T11355.stderr @@ -1,6 +1,6 @@ T11355.hs:5:7: error: - • Illegal polymorphic type: forall (a :: TYPE t1). a + • Illegal polymorphic type: forall (a :: TYPE t0). a GHC doesn't yet support impredicative polymorphism • In the expression: const @_ @((forall a. a) -> forall a. a) () (id @(forall a. a)) diff --git a/testsuite/tests/typecheck/should_fail/T5858.stderr b/testsuite/tests/typecheck/should_fail/T5858.stderr index 08de48888a..dc3ee90189 100644 --- a/testsuite/tests/typecheck/should_fail/T5858.stderr +++ b/testsuite/tests/typecheck/should_fail/T5858.stderr @@ -1,9 +1,9 @@ T5858.hs:11:7: error: - • Ambiguous type variables ‘t0’, ‘t1’ arising from a use of ‘infer’ + • Ambiguous type variables ‘a0’, ‘a1’ arising from a use of ‘infer’ prevents the constraint ‘(InferOverloaded - ([t0], [t1]))’ from being solved. - Probable fix: use a type annotation to specify what ‘t0’, ‘t1’ should be. + ([a0], [a1]))’ from being solved. + Probable fix: use a type annotation to specify what ‘a0’, ‘a1’ should be. These potential instance exist: instance t1 ~ String => InferOverloaded (t1, t1) -- Defined at T5858.hs:8:10 diff --git a/testsuite/tests/typecheck/should_fail/T6018fail.stderr b/testsuite/tests/typecheck/should_fail/T6018fail.stderr index 3bd6b40a82..758acfff05 100644 --- a/testsuite/tests/typecheck/should_fail/T6018fail.stderr +++ b/testsuite/tests/typecheck/should_fail/T6018fail.stderr @@ -69,7 +69,7 @@ T6018fail.hs:59:10: error: T6018fail.hs:62:15: error: Type family equation violates injectivity annotation. - Kind variable ‘k’ cannot be inferred from the right-hand side. + Kind variable ‘k1’ cannot be inferred from the right-hand side. Use -fprint-explicit-kinds to see the kind arguments In the type family equation: PolyKindVars '[] = '[] -- Defined at T6018fail.hs:62:15 diff --git a/testsuite/tests/typecheck/should_fail/T8142.stderr b/testsuite/tests/typecheck/should_fail/T8142.stderr index 53e6798a5e..4200268c24 100644 --- a/testsuite/tests/typecheck/should_fail/T8142.stderr +++ b/testsuite/tests/typecheck/should_fail/T8142.stderr @@ -1,14 +1,14 @@ T8142.hs:6:18: error: • Couldn't match type ‘Nu g0’ with ‘Nu g’ - Expected type: Nu ((,) t) -> Nu g - Actual type: Nu ((,) t0) -> Nu g0 + Expected type: Nu ((,) a) -> Nu g + Actual type: Nu ((,) a0) -> Nu g0 NB: ‘Nu’ is a type function, and may not be injective The type variable ‘g0’ is ambiguous • In the ambiguity check for the inferred type for ‘h’ To defer the ambiguity check to use sites, enable AllowAmbiguousTypes When checking the inferred type - h :: forall (g :: * -> *) t. Nu ((,) t) -> Nu g + h :: forall (g :: * -> *) a. Nu ((,) a) -> Nu g In an equation for ‘tracer’: tracer = h @@ -16,11 +16,11 @@ T8142.hs:6:18: error: h = (\ (_, b) -> ((outI . fmap h) b)) . out T8142.hs:6:57: error: - • Couldn't match type ‘Nu ((,) t)’ with ‘g (Nu ((,) t))’ - Expected type: Nu ((,) t) -> (t, g (Nu ((,) t))) - Actual type: Nu ((,) t) -> (t, Nu ((,) t)) + • Couldn't match type ‘Nu ((,) a)’ with ‘g (Nu ((,) a))’ + Expected type: Nu ((,) a) -> (a, g (Nu ((,) a))) + Actual type: Nu ((,) a) -> (a, Nu ((,) a)) • In the second argument of ‘(.)’, namely ‘out’ In the expression: (\ (_, b) -> ((outI . fmap h) b)) . out In an equation for ‘h’: h = (\ (_, b) -> ((outI . fmap h) b)) . out • Relevant bindings include - h :: Nu ((,) t) -> Nu g (bound at T8142.hs:6:18) + h :: Nu ((,) a) -> Nu g (bound at T8142.hs:6:18) diff --git a/testsuite/tests/typecheck/should_fail/T9109.stderr b/testsuite/tests/typecheck/should_fail/T9109.stderr index 996da6e534..ce1b09d51c 100644 --- a/testsuite/tests/typecheck/should_fail/T9109.stderr +++ b/testsuite/tests/typecheck/should_fail/T9109.stderr @@ -1,15 +1,14 @@ -
-T9109.hs:8:13: error:
- • Couldn't match expected type ‘t’ with actual type ‘Bool’
- ‘t’ is untouchable
- inside the constraints: t1 ~ Bool
- bound by a pattern with constructor: GBool :: G Bool,
- in an equation for ‘foo’
- at T9109.hs:8:5-9
- ‘t’ is a rigid type variable bound by
- the inferred type of foo :: G t1 -> t at T9109.hs:8:1-16
- Possible fix: add a type signature for ‘foo’
- • In the expression: True
- In an equation for ‘foo’: foo GBool = True
- • Relevant bindings include
- foo :: G t1 -> t (bound at T9109.hs:8:1)
+ +T9109.hs:8:13: error: + • Couldn't match expected type ‘t’ with actual type ‘Bool’ + ‘t’ is untouchable + inside the constraints: a ~ Bool + bound by a pattern with constructor: GBool :: G Bool, + in an equation for ‘foo’ + at T9109.hs:8:5-9 + ‘t’ is a rigid type variable bound by + the inferred type of foo :: G a -> t at T9109.hs:8:1-16 + Possible fix: add a type signature for ‘foo’ + • In the expression: True + In an equation for ‘foo’: foo GBool = True + • Relevant bindings include foo :: G a -> t (bound at T9109.hs:8:1) diff --git a/testsuite/tests/typecheck/should_fail/VtaFail.stderr b/testsuite/tests/typecheck/should_fail/VtaFail.stderr index 03671b0b04..ff90a738c9 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 ‘t0 -> t1 -> (t0, t1)’ + • Cannot apply expression of type ‘a0 -> b0 -> (a0, b0)’ to a visible type argument ‘Int’ • In the expression: pairup_nosig @Int @Bool 5 True In an equation for ‘answer_nosig’: diff --git a/testsuite/tests/typecheck/should_fail/tcfail001.stderr b/testsuite/tests/typecheck/should_fail/tcfail001.stderr index 61604469e5..56c28d98b5 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail001.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail001.stderr @@ -1,7 +1,7 @@ tcfail001.hs:9:2: error: • Couldn't match expected type ‘[a]’ - with actual type ‘[t1] -> [t0]’ + with actual type ‘[a0] -> [a1]’ • The equation(s) for ‘op’ have one argument, but its type ‘[a]’ has none In the instance declaration for ‘A [a]’ diff --git a/testsuite/tests/typecheck/should_fail/tcfail010.stderr b/testsuite/tests/typecheck/should_fail/tcfail010.stderr index c22a05e777..11e529084f 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail010.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail010.stderr @@ -1,6 +1,6 @@ tcfail010.hs:3:16: error: - • No instance for (Num [t0]) arising from a use of ‘+’ + • No instance for (Num [a0]) arising from a use of ‘+’ • In the expression: z + 2 In the expression: \ (y : z) -> z + 2 In an equation for ‘q’: q = \ (y : z) -> z + 2 diff --git a/testsuite/tests/typecheck/should_fail/tcfail012.stderr b/testsuite/tests/typecheck/should_fail/tcfail012.stderr index 572c7a677c..ea5a2a72cd 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail012.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail012.stderr @@ -1,5 +1,5 @@ -tcfail012.hs:3:8: - Couldn't match expected type ‘Bool’ with actual type ‘[t0]’ - In the expression: [] - In a pattern binding: True = [] +tcfail012.hs:3:8: error: + • Couldn't match expected type ‘Bool’ with actual type ‘[a0]’ + • In the expression: [] + In a pattern binding: True = [] diff --git a/testsuite/tests/typecheck/should_fail/tcfail013.stderr b/testsuite/tests/typecheck/should_fail/tcfail013.stderr index ff7702213c..f3e815bb6e 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail013.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail013.stderr @@ -1,7 +1,7 @@ tcfail013.hs:4:3: error: - • Couldn't match expected type ‘[t1]’ with actual type ‘Bool’ + • Couldn't match expected type ‘[a]’ with actual type ‘Bool’ • In the pattern: True In an equation for ‘f’: f True = 2 • Relevant bindings include - f :: [t1] -> t (bound at tcfail013.hs:3:1) + f :: [a] -> t (bound at tcfail013.hs:3:1) diff --git a/testsuite/tests/typecheck/should_fail/tcfail016.stderr b/testsuite/tests/typecheck/should_fail/tcfail016.stderr index 949cb65855..3430c2d830 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail016.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail016.stderr @@ -1,7 +1,7 @@ tcfail016.hs:8:1: error: - • Couldn't match type ‘(t, Expr t)’ with ‘Expr t’ - Expected type: AnnExpr t -> [[Char]] - Actual type: Expr t -> [[Char]] + • Couldn't match type ‘(a, Expr a)’ with ‘Expr a’ + Expected type: AnnExpr a -> [[Char]] + Actual type: Expr a -> [[Char]] • Relevant bindings include - g :: AnnExpr t -> [[Char]] (bound at tcfail016.hs:8:1) + g :: AnnExpr a -> [[Char]] (bound at tcfail016.hs:8:1) diff --git a/testsuite/tests/typecheck/should_fail/tcfail033.stderr b/testsuite/tests/typecheck/should_fail/tcfail033.stderr index e349ab1116..bc346c2aac 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail033.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail033.stderr @@ -1,10 +1,10 @@ tcfail033.hs:4:12: error: - • Occurs check: cannot construct the infinite type: t1 ~ (t1, t) + • Occurs check: cannot construct the infinite type: a ~ (a, b) • In the expression: x In the expression: [x | (x, y) <- buglet] In an equation for ‘buglet’: buglet = [x | (x, y) <- buglet] • Relevant bindings include - y :: t (bound at tcfail033.hs:4:19) - x :: t1 (bound at tcfail033.hs:4:17) - buglet :: [(t1, t)] (bound at tcfail033.hs:4:1) + y :: b (bound at tcfail033.hs:4:19) + x :: a (bound at tcfail033.hs:4:17) + buglet :: [(a, b)] (bound at tcfail033.hs:4:1) diff --git a/testsuite/tests/typecheck/should_fail/tcfail069.stderr b/testsuite/tests/typecheck/should_fail/tcfail069.stderr index 195119d26d..fcaf3e9542 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail069.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail069.stderr @@ -1,7 +1,7 @@ -tcfail069.hs:21:7: - Couldn't match expected type ‘([Int], [Int])’ - with actual type ‘[t0]’ - In the pattern: [] - In a case alternative: [] -> error "foo" - In the expression: case (list1, list2) of { [] -> error "foo" } +tcfail069.hs:21:7: error: + • Couldn't match expected type ‘([Int], [Int])’ + with actual type ‘[a0]’ + • In the pattern: [] + In a case alternative: [] -> error "foo" + In the expression: case (list1, list2) of { [] -> error "foo" } diff --git a/testsuite/tests/typecheck/should_fail/tcfail182.stderr b/testsuite/tests/typecheck/should_fail/tcfail182.stderr index 4103c3a0fa..6bd7b156ab 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail182.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail182.stderr @@ -1,10 +1,10 @@ tcfail182.hs:9:3: error: - Couldn't match expected type ‘Prelude.Maybe a’ - with actual type ‘Maybe t0’ - NB: ‘Maybe’ is defined at tcfail182.hs:6:1-18 - ‘Prelude.Maybe’ is defined in ‘GHC.Base’ in package ‘base-4.9.0.0’ - In the pattern: Foo - In an equation for ‘f’: f Foo = 3 - Relevant bindings include - f :: Prelude.Maybe a -> Int (bound at tcfail182.hs:9:1) + • Couldn't match expected type ‘Prelude.Maybe a’ + with actual type ‘Maybe a0’ + NB: ‘Maybe’ is defined at tcfail182.hs:6:1-18 + ‘Prelude.Maybe’ is defined in ‘GHC.Base’ in package ‘base-4.9.0.0’ + • In the pattern: Foo + In an equation for ‘f’: f Foo = 3 + • Relevant bindings include + f :: Prelude.Maybe a -> Int (bound at tcfail182.hs:9:1) diff --git a/testsuite/tests/typecheck/should_fail/tcfail201.stderr b/testsuite/tests/typecheck/should_fail/tcfail201.stderr index 9df11cafff..77349e29f4 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail201.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail201.stderr @@ -1,19 +1,19 @@ -
-tcfail201.hs:17:56: error:
- • Couldn't match type ‘a’ with ‘HsDoc t0’
- ‘a’ is a rigid type variable bound by
- the type signature for:
- gfoldl' :: forall (c :: * -> *) a.
- (forall a1 b. c (a1 -> b) -> a1 -> c b)
- -> (forall g. g -> c g) -> a -> c a
- at tcfail201.hs:15:1-85
- Expected type: c a
- Actual type: c (HsDoc t0)
- • In the expression: z DocEmpty
- In a case alternative: DocEmpty -> z DocEmpty
- In the expression: case hsDoc of { DocEmpty -> z DocEmpty }
- • Relevant bindings include
- hsDoc :: a (bound at tcfail201.hs:16:13)
- gfoldl' :: (forall a1 b. c (a1 -> b) -> a1 -> c b)
- -> (forall g. g -> c g) -> a -> c a
- (bound at tcfail201.hs:16:1)
+ +tcfail201.hs:17:56: error: + • Couldn't match type ‘a’ with ‘HsDoc id0’ + ‘a’ is a rigid type variable bound by + the type signature for: + gfoldl' :: forall (c :: * -> *) a. + (forall a1 b. c (a1 -> b) -> a1 -> c b) + -> (forall g. g -> c g) -> a -> c a + at tcfail201.hs:15:1-85 + Expected type: c a + Actual type: c (HsDoc id0) + • In the expression: z DocEmpty + In a case alternative: DocEmpty -> z DocEmpty + In the expression: case hsDoc of { DocEmpty -> z DocEmpty } + • Relevant bindings include + hsDoc :: a (bound at tcfail201.hs:16:13) + gfoldl' :: (forall a1 b. c (a1 -> b) -> a1 -> c b) + -> (forall g. g -> c g) -> a -> c a + (bound at tcfail201.hs:16:1) |