diff options
124 files changed, 1616 insertions, 772 deletions
diff --git a/compiler/GHC/Builtin/Names/TH.hs b/compiler/GHC/Builtin/Names/TH.hs index 94407b51fb..3cd55b566d 100644 --- a/compiler/GHC/Builtin/Names/TH.hs +++ b/compiler/GHC/Builtin/Names/TH.hs @@ -105,6 +105,9 @@ templateHaskellNames = [ numTyLitName, strTyLitName, -- TyVarBndr plainTVName, kindedTVName, + plainInvisTVName, kindedInvisTVName, + -- Specificity + specifiedSpecName, inferredSpecName, -- Role nominalRName, representationalRName, phantomRName, inferRName, -- Kind @@ -152,7 +155,7 @@ templateHaskellNames = [ expQTyConName, fieldExpTyConName, predTyConName, stmtTyConName, decsTyConName, conTyConName, bangTypeTyConName, varBangTypeTyConName, typeQTyConName, expTyConName, decTyConName, - typeTyConName, tyVarBndrTyConName, clauseTyConName, + typeTyConName, tyVarBndrUnitTyConName, tyVarBndrSpecTyConName, clauseTyConName, patQTyConName, funDepTyConName, decsQTyConName, ruleBndrTyConName, tySynEqnTyConName, roleTyConName, tExpTyConName, injAnnTyConName, kindTyConName, @@ -471,6 +474,15 @@ plainTVName, kindedTVName :: Name plainTVName = libFun (fsLit "plainTV") plainTVIdKey kindedTVName = libFun (fsLit "kindedTV") kindedTVIdKey +plainInvisTVName, kindedInvisTVName :: Name +plainInvisTVName = libFun (fsLit "plainInvisTV") plainInvisTVIdKey +kindedInvisTVName = libFun (fsLit "kindedInvisTV") kindedInvisTVIdKey + +-- data Specificity = ... +specifiedSpecName, inferredSpecName :: Name +specifiedSpecName = libFun (fsLit "specifiedSpec") specifiedSpecKey +inferredSpecName = libFun (fsLit "inferredSpec") inferredSpecKey + -- data Role = ... nominalRName, representationalRName, phantomRName, inferRName :: Name nominalRName = libFun (fsLit "nominalR") nominalRIdKey @@ -546,7 +558,8 @@ patQTyConName, expQTyConName, stmtTyConName, conTyConName, bangTypeTyConName, varBangTypeTyConName, typeQTyConName, decsQTyConName, ruleBndrTyConName, tySynEqnTyConName, roleTyConName, - derivClauseTyConName, kindTyConName, tyVarBndrTyConName, + derivClauseTyConName, kindTyConName, + tyVarBndrUnitTyConName, tyVarBndrSpecTyConName, derivStrategyTyConName :: Name -- These are only used for the types of top-level splices expQTyConName = libTc (fsLit "ExpQ") expQTyConKey @@ -564,7 +577,8 @@ tySynEqnTyConName = thTc (fsLit "TySynEqn") tySynEqnTyConKey roleTyConName = libTc (fsLit "Role") roleTyConKey derivClauseTyConName = thTc (fsLit "DerivClause") derivClauseTyConKey kindTyConName = thTc (fsLit "Kind") kindTyConKey -tyVarBndrTyConName = thTc (fsLit "TyVarBndr") tyVarBndrTyConKey +tyVarBndrUnitTyConName = libTc (fsLit "TyVarBndrUnit") tyVarBndrUnitTyConKey +tyVarBndrSpecTyConName = libTc (fsLit "TyVarBndrSpec") tyVarBndrSpecTyConKey derivStrategyTyConName = thTc (fsLit "DerivStrategy") derivStrategyTyConKey -- quasiquoting @@ -628,7 +642,8 @@ quoteClassKey = mkPreludeClassUnique 201 expTyConKey, matchTyConKey, clauseTyConKey, qTyConKey, expQTyConKey, patTyConKey, stmtTyConKey, conTyConKey, typeQTyConKey, typeTyConKey, - tyVarBndrTyConKey, decTyConKey, bangTypeTyConKey, varBangTypeTyConKey, + tyVarBndrUnitTyConKey, tyVarBndrSpecTyConKey, + decTyConKey, bangTypeTyConKey, varBangTypeTyConKey, fieldExpTyConKey, fieldPatTyConKey, nameTyConKey, patQTyConKey, funDepTyConKey, predTyConKey, predQTyConKey, decsQTyConKey, ruleBndrTyConKey, tySynEqnTyConKey, @@ -655,7 +670,8 @@ patQTyConKey = mkPreludeTyConUnique 219 funDepTyConKey = mkPreludeTyConUnique 222 predTyConKey = mkPreludeTyConUnique 223 predQTyConKey = mkPreludeTyConUnique 224 -tyVarBndrTyConKey = mkPreludeTyConUnique 225 +tyVarBndrUnitTyConKey = mkPreludeTyConUnique 225 +tyVarBndrSpecTyConKey = mkPreludeTyConUnique 237 decsQTyConKey = mkPreludeTyConUnique 226 ruleBndrTyConKey = mkPreludeTyConUnique 227 tySynEqnTyConKey = mkPreludeTyConUnique 228 @@ -985,6 +1001,10 @@ plainTVIdKey, kindedTVIdKey :: Unique plainTVIdKey = mkPreludeMiscIdUnique 413 kindedTVIdKey = mkPreludeMiscIdUnique 414 +plainInvisTVIdKey, kindedInvisTVIdKey :: Unique +plainInvisTVIdKey = mkPreludeMiscIdUnique 482 +kindedInvisTVIdKey = mkPreludeMiscIdUnique 483 + -- data Role = ... nominalRIdKey, representationalRIdKey, phantomRIdKey, inferRIdKey :: Unique nominalRIdKey = mkPreludeMiscIdUnique 415 @@ -1060,6 +1080,11 @@ anyclassStrategyIdKey = mkPreludeDataConUnique 495 newtypeStrategyIdKey = mkPreludeDataConUnique 496 viaStrategyIdKey = mkPreludeDataConUnique 497 +-- data Specificity = ... +specifiedSpecKey, inferredSpecKey :: Unique +specifiedSpecKey = mkPreludeMiscIdUnique 498 +inferredSpecKey = mkPreludeMiscIdUnique 499 + {- ************************************************************************ * * diff --git a/compiler/GHC/Builtin/Types.hs b/compiler/GHC/Builtin/Types.hs index 0c0bab60ea..694d05869e 100644 --- a/compiler/GHC/Builtin/Types.hs +++ b/compiler/GHC/Builtin/Types.hs @@ -586,7 +586,7 @@ pcDataConWithFixity' declared_infix dc_name wrk_key rri (map (const no_bang) arg_tys) [] -- No labelled fields tyvars ex_tyvars - (mkTyCoVarBinders Specified user_tyvars) + (mkTyVarBinders SpecifiedSpec user_tyvars) [] -- No equality spec [] -- No theta arg_tys (mkTyConApp tycon (mkTyVarTys tyvars)) diff --git a/compiler/GHC/Core/Coercion.hs b/compiler/GHC/Core/Coercion.hs index 7294209730..9aa8ea5e2c 100644 --- a/compiler/GHC/Core/Coercion.hs +++ b/compiler/GHC/Core/Coercion.hs @@ -2284,7 +2284,7 @@ coercionRKind co go_forall subst (ForAllCo tv1 k_co co) -- See Note [Nested ForAllCos] | isTyVar tv1 - = mkInvForAllTy tv2 (go_forall subst' co) + = mkInfForAllTy tv2 (go_forall subst' co) where k2 = coercionRKind k_co tv2 = setTyVarKind tv1 (substTy subst k2) diff --git a/compiler/GHC/Core/ConLike.hs b/compiler/GHC/Core/ConLike.hs index ed247c9d81..c7f8f494eb 100644 --- a/compiler/GHC/Core/ConLike.hs +++ b/compiler/GHC/Core/ConLike.hs @@ -119,7 +119,7 @@ conLikeInstOrigArgTys (PatSynCon pat_syn) tys = -- followed by the existentially quantified type variables. For data -- constructors, the situation is slightly more complicated—see -- @Note [DataCon user type variable binders]@ in "GHC.Core.DataCon". -conLikeUserTyVarBinders :: ConLike -> [TyVarBinder] +conLikeUserTyVarBinders :: ConLike -> [InvisTVBinder] conLikeUserTyVarBinders (RealDataCon data_con) = dataConUserTyVarBinders data_con conLikeUserTyVarBinders (PatSynCon pat_syn) = diff --git a/compiler/GHC/Core/DataCon.hs b/compiler/GHC/Core/DataCon.hs index 5877ce35e0..ca486863a5 100644 --- a/compiler/GHC/Core/DataCon.hs +++ b/compiler/GHC/Core/DataCon.hs @@ -371,7 +371,7 @@ data DataCon -- of tyvars (*not* covars) of dcExTyCoVars unioned with the -- set of dcUnivTyVars whose tyvars do not appear in dcEqSpec -- See Note [DataCon user type variable binders] - dcUserTyVarBinders :: [TyVarBinder], + dcUserTyVarBinders :: [InvisTVBinder], dcEqSpec :: [EqSpec], -- Equalities derived from the result type, -- _as written by the programmer_. @@ -939,10 +939,10 @@ mkDataCon :: Name -- if it is a record, otherwise empty -> [TyVar] -- ^ Universals. -> [TyCoVar] -- ^ Existentials. - -> [TyVarBinder] -- ^ User-written 'TyVarBinder's. - -- These must be Inferred/Specified. - -- See @Note [TyVarBinders in DataCons]@ - -> [EqSpec] -- ^ GADT equalities + -> [InvisTVBinder] -- ^ User-written 'TyVarBinder's. + -- These must be Inferred/Specified. + -- See @Note [TyVarBinders in DataCons]@ + -> [EqSpec] -- ^ GADT equalities -> KnotTied ThetaType -- ^ Theta-type occurring before the arguments proper -> [KnotTied Type] -- ^ Original argument types -> KnotTied Type -- ^ Original result type @@ -1006,13 +1006,13 @@ mkDataCon name declared_infix prom_info NoDataConRep -> dataConUserType con -- If the DataCon has a wrapper, then the worker's type is never seen -- by the user. The visibilities we pick do not matter here. - DCR{} -> mkInvForAllTys univ_tvs $ mkTyCoInvForAllTys ex_tvs $ + DCR{} -> mkInfForAllTys univ_tvs $ mkTyCoInvForAllTys ex_tvs $ mkVisFunTys rep_arg_tys $ mkTyConApp rep_tycon (mkTyVarTys univ_tvs) -- See Note [Promoted data constructors] in GHC.Core.TyCon - prom_tv_bndrs = [ mkNamedTyConBinder vis tv - | Bndr tv vis <- user_tvbs ] + prom_tv_bndrs = [ mkNamedTyConBinder (Invisible spec) tv + | Bndr tv spec <- user_tvbs ] fresh_names = freshNames (map getName user_tvbs) -- fresh_names: make sure that the "anonymous" tyvars don't @@ -1102,9 +1102,9 @@ dataConUserTyVars :: DataCon -> [TyVar] dataConUserTyVars (MkData { dcUserTyVarBinders = tvbs }) = binderVars tvbs -- See Note [DataCon user type variable binders] --- | 'TyCoVarBinder's for the type variables of the constructor, in the order the +-- | 'InvisTVBinder's for the type variables of the constructor, in the order the -- user wrote them -dataConUserTyVarBinders :: DataCon -> [TyVarBinder] +dataConUserTyVarBinders :: DataCon -> [InvisTVBinder] dataConUserTyVarBinders = dcUserTyVarBinders -- | Equalities derived from the result type of the data constructor, as written @@ -1327,7 +1327,7 @@ dataConUserType :: DataCon -> Type dataConUserType (MkData { dcUserTyVarBinders = user_tvbs, dcOtherTheta = theta, dcOrigArgTys = arg_tys, dcOrigResTy = res_ty }) - = mkForAllTys user_tvbs $ + = mkInvisForAllTys user_tvbs $ mkInvisFunTys theta $ mkVisFunTys arg_tys $ res_ty diff --git a/compiler/GHC/Core/DataCon.hs-boot b/compiler/GHC/Core/DataCon.hs-boot index aa2b266b06..6520abbbe7 100644 --- a/compiler/GHC/Core/DataCon.hs-boot +++ b/compiler/GHC/Core/DataCon.hs-boot @@ -1,7 +1,7 @@ module GHC.Core.DataCon where import GHC.Prelude -import GHC.Types.Var( TyVar, TyCoVar, TyVarBinder ) +import GHC.Types.Var( TyVar, TyCoVar, InvisTVBinder ) import GHC.Types.Name( Name, NamedThing ) import {-# SOURCE #-} GHC.Core.TyCon( TyCon ) import GHC.Types.FieldLabel ( FieldLabel ) @@ -18,7 +18,7 @@ dataConName :: DataCon -> Name dataConTyCon :: DataCon -> TyCon dataConExTyCoVars :: DataCon -> [TyCoVar] dataConUserTyVars :: DataCon -> [TyVar] -dataConUserTyVarBinders :: DataCon -> [TyVarBinder] +dataConUserTyVarBinders :: DataCon -> [InvisTVBinder] dataConSourceArity :: DataCon -> Arity dataConFieldLabels :: DataCon -> [FieldLabel] dataConInstOrigArgTys :: DataCon -> [Type] -> [Type] diff --git a/compiler/GHC/Core/Opt/Simplify/Utils.hs b/compiler/GHC/Core/Opt/Simplify/Utils.hs index 87948ff6c1..882ab9f49b 100644 --- a/compiler/GHC/Core/Opt/Simplify/Utils.hs +++ b/compiler/GHC/Core/Opt/Simplify/Utils.hs @@ -1802,7 +1802,7 @@ abstractFloats dflags top_lvl main_tvs floats body mk_poly1 tvs_here var = do { uniq <- getUniqueM ; let poly_name = setNameUnique (idName var) uniq -- Keep same name - poly_ty = mkInvForAllTys tvs_here (idType var) -- But new type of course + poly_ty = mkInfForAllTys tvs_here (idType var) -- But new type of course poly_id = transferPolyIdInfo var tvs_here $ -- Note [transferPolyIdInfo] in GHC.Types.Id mkLocalId poly_name poly_ty ; return (poly_id, mkTyApps (Var poly_id) (mkTyVarTys tvs_here)) } diff --git a/compiler/GHC/Core/PatSyn.hs b/compiler/GHC/Core/PatSyn.hs index 6179cd600b..c518a6c94e 100644 --- a/compiler/GHC/Core/PatSyn.hs +++ b/compiler/GHC/Core/PatSyn.hs @@ -15,7 +15,8 @@ module GHC.Core.PatSyn ( patSynName, patSynArity, patSynIsInfix, patSynArgs, patSynMatcher, patSynBuilder, - patSynUnivTyVarBinders, patSynExTyVars, patSynExTyVarBinders, patSynSig, + patSynUnivTyVarBinders, patSynExTyVars, patSynExTyVarBinders, + patSynSig, patSynSigBndr, patSynInstArgTys, patSynInstResTy, patSynFieldLabels, patSynFieldType, @@ -67,13 +68,13 @@ data PatSyn -- psArgs -- Universally-quantified type variables - psUnivTyVars :: [TyVarBinder], + psUnivTyVars :: [InvisTVBinder], -- Required dictionaries (may mention psUnivTyVars) psReqTheta :: ThetaType, -- Existentially-quantified type vars - psExTyVars :: [TyVarBinder], + psExTyVars :: [InvisTVBinder], -- Provided dictionaries (may mention psUnivTyVars or psExTyVars) psProvTheta :: ThetaType, @@ -354,10 +355,10 @@ instance Data.Data PatSyn where -- | Build a new pattern synonym mkPatSyn :: Name -> Bool -- ^ Is the pattern synonym declared infix? - -> ([TyVarBinder], ThetaType) -- ^ Universially-quantified type - -- variables and required dicts - -> ([TyVarBinder], ThetaType) -- ^ Existentially-quantified type - -- variables and provided dicts + -> ([InvisTVBinder], ThetaType) -- ^ Universially-quantified type + -- variables and required dicts + -> ([InvisTVBinder], ThetaType) -- ^ Existentially-quantified type + -- variables and provided dicts -> [Type] -- ^ Original arguments -> Type -- ^ Original result type -> (Id, Bool) -- ^ Name of matcher @@ -411,20 +412,24 @@ patSynFieldType ps label Just (_, ty) -> ty Nothing -> pprPanic "dataConFieldType" (ppr ps <+> ppr label) -patSynUnivTyVarBinders :: PatSyn -> [TyVarBinder] +patSynUnivTyVarBinders :: PatSyn -> [InvisTVBinder] patSynUnivTyVarBinders = psUnivTyVars patSynExTyVars :: PatSyn -> [TyVar] patSynExTyVars ps = binderVars (psExTyVars ps) -patSynExTyVarBinders :: PatSyn -> [TyVarBinder] +patSynExTyVarBinders :: PatSyn -> [InvisTVBinder] patSynExTyVarBinders = psExTyVars -patSynSig :: PatSyn -> ([TyVar], ThetaType, [TyVar], ThetaType, [Type], Type) -patSynSig (MkPatSyn { psUnivTyVars = univ_tvs, psExTyVars = ex_tvs +patSynSigBndr :: PatSyn -> ([InvisTVBinder], ThetaType, [InvisTVBinder], ThetaType, [Type], Type) +patSynSigBndr (MkPatSyn { psUnivTyVars = univ_tvs, psExTyVars = ex_tvs , psProvTheta = prov, psReqTheta = req , psArgs = arg_tys, psResultTy = res_ty }) - = (binderVars univ_tvs, req, binderVars ex_tvs, prov, arg_tys, res_ty) + = (univ_tvs, req, ex_tvs, prov, arg_tys, res_ty) + +patSynSig :: PatSyn -> ([TyVar], ThetaType, [TyVar], ThetaType, [Type], Type) +patSynSig ps = let (u_tvs, req, e_tvs, prov, arg_tys, res_ty) = patSynSigBndr ps + in (binderVars u_tvs, req, binderVars e_tvs, prov, arg_tys, res_ty) patSynMatcher :: PatSyn -> (Id,Bool) patSynMatcher = psMatcher @@ -473,12 +478,12 @@ pprPatSynType :: PatSyn -> SDoc pprPatSynType (MkPatSyn { psUnivTyVars = univ_tvs, psReqTheta = req_theta , psExTyVars = ex_tvs, psProvTheta = prov_theta , psArgs = orig_args, psResultTy = orig_res_ty }) - = sep [ pprForAll univ_tvs + = sep [ pprForAll $ tyVarSpecToBinders univ_tvs , pprThetaArrowTy req_theta , ppWhen insert_empty_ctxt $ parens empty <+> darrow , pprType sigma_ty ] where - sigma_ty = mkForAllTys ex_tvs $ + sigma_ty = mkInvisForAllTys ex_tvs $ mkInvisFunTys prov_theta $ mkVisFunTys orig_args orig_res_ty insert_empty_ctxt = null req_theta && not (null prov_theta && null ex_tvs) diff --git a/compiler/GHC/Core/TyCo/Ppr.hs b/compiler/GHC/Core/TyCo/Ppr.hs index 71077bdb76..40f901dc53 100644 --- a/compiler/GHC/Core/TyCo/Ppr.hs +++ b/compiler/GHC/Core/TyCo/Ppr.hs @@ -283,7 +283,7 @@ pprDataConWithArgs :: DataCon -> SDoc pprDataConWithArgs dc = sep [forAllDoc, thetaDoc, ppr dc <+> argsDoc] where (_univ_tvs, _ex_tvs, _eq_spec, theta, arg_tys, _res_ty) = dataConFullSig dc - user_bndrs = dataConUserTyVarBinders dc + user_bndrs = tyVarSpecToBinders $ dataConUserTyVarBinders dc forAllDoc = pprUserForAll user_bndrs thetaDoc = pprThetaArrowTy theta argsDoc = hsep (fmap pprParendType arg_tys) diff --git a/compiler/GHC/Core/TyCo/Rep.hs b/compiler/GHC/Core/TyCo/Rep.hs index 46a6cdee01..d07c424974 100644 --- a/compiler/GHC/Core/TyCo/Rep.hs +++ b/compiler/GHC/Core/TyCo/Rep.hs @@ -47,7 +47,7 @@ module GHC.Core.TyCo.Rep ( mkTyConTy, mkTyVarTy, mkTyVarTys, mkTyCoVarTy, mkTyCoVarTys, mkFunTy, mkVisFunTy, mkInvisFunTy, mkVisFunTys, mkInvisFunTys, - mkForAllTy, mkForAllTys, + mkForAllTy, mkForAllTys, mkInvisForAllTys, mkPiTy, mkPiTys, -- * Functions over binders @@ -687,8 +687,10 @@ data TyCoBinder instance Outputable TyCoBinder where ppr (Anon af ty) = ppr af <+> ppr ty ppr (Named (Bndr v Required)) = ppr v - ppr (Named (Bndr v Specified)) = char '@' <> ppr v - ppr (Named (Bndr v Inferred)) = braces (ppr v) + -- See Note [Explicit Case Statement for Specificity] + ppr (Named (Bndr v (Invisible spec))) = case spec of + SpecifiedSpec -> char '@' <> ppr v + InferredSpec -> braces (ppr v) -- | 'TyBinder' is like 'TyCoBinder', but there can only be 'TyVarBinder' @@ -802,16 +804,22 @@ This table summarises the visibility rules: f3 :: forall a. a -> a; f3 x = x So f3 gets the type f3 :: forall a. a -> a, with 'a' Specified +* Inferred. Function defn, with signature (explicit forall), marked as inferred: + f4 :: forall {a}. a -> a; f4 x = x + So f4 gets the type f4 :: forall {a}. a -> a, with 'a' Inferred + It's Inferred because the user marked it as such, even though it does appear + in the user-written signature for f4 + * Inferred/Specified. Function signature with inferred kind polymorphism. - f4 :: a b -> Int - So 'f4' gets the type f4 :: forall {k} (a:k->*) (b:k). a b -> Int + f5 :: a b -> Int + So 'f5' gets the type f5 :: forall {k} (a:k->*) (b:k). a b -> Int Here 'k' is Inferred (it's not mentioned in the type), but 'a' and 'b' are Specified. * Specified. Function signature with explicit kind polymorphism - f5 :: a (b :: k) -> Int + f6 :: a (b :: k) -> Int This time 'k' is Specified, because it is mentioned explicitly, - so we get f5 :: forall (k:*) (a:k->*) (b:k). a b -> Int + so we get f6 :: forall (k:*) (a:k->*) (b:k). a b -> Int * Similarly pattern synonyms: Inferred - from inferred types (e.g. no pattern type signature) @@ -995,6 +1003,10 @@ mkForAllTy tv vis ty = ForAllTy (Bndr tv vis) ty mkForAllTys :: [TyCoVarBinder] -> Type -> Type mkForAllTys tyvars ty = foldr ForAllTy ty tyvars +-- | Wraps foralls over the type using the provided 'InvisTVBinder's from left to right +mkInvisForAllTys :: [InvisTVBinder] -> Type -> Type +mkInvisForAllTys tyvars ty = foldr ForAllTy ty $ tyVarSpecToBinders tyvars + mkPiTy:: TyCoBinder -> Type -> Type mkPiTy (Anon af ty1) ty2 = FunTy { ft_af = af, ft_arg = ty1, ft_res = ty2 } mkPiTy (Named (Bndr tv vis)) ty = mkForAllTy tv vis ty diff --git a/compiler/GHC/Core/TyCon.hs b/compiler/GHC/Core/TyCon.hs index 0f850f2278..fdff076567 100644 --- a/compiler/GHC/Core/TyCon.hs +++ b/compiler/GHC/Core/TyCon.hs @@ -100,7 +100,7 @@ module GHC.Core.TyCon( newTyConDataCon_maybe, algTcFields, tyConRuntimeRepInfo, - tyConBinders, tyConResKind, tyConTyVarBinders, + tyConBinders, tyConResKind, tyConInvisTVBinders, tcTyConScopedTyVars, tcTyConIsPoly, mkTyConTagMap, @@ -492,19 +492,19 @@ mkTyConKind bndrs res_kind = foldr mk res_kind bndrs mk (Bndr tv (AnonTCB af)) k = mkFunTy af (varType tv) k mk (Bndr tv (NamedTCB vis)) k = mkForAllTy tv vis k -tyConTyVarBinders :: [TyConBinder] -- From the TyCon - -> [TyVarBinder] -- Suitable for the foralls of a term function +tyConInvisTVBinders :: [TyConBinder] -- From the TyCon + -> [InvisTVBinder] -- Suitable for the foralls of a term function -- See Note [Building TyVarBinders from TyConBinders] -tyConTyVarBinders tc_bndrs +tyConInvisTVBinders tc_bndrs = map mk_binder tc_bndrs where mk_binder (Bndr tv tc_vis) = mkTyVarBinder vis tv where vis = case tc_vis of - AnonTCB VisArg -> Specified - AnonTCB InvisArg -> Inferred -- See Note [AnonTCB InvisArg] - NamedTCB Required -> Specified - NamedTCB vis -> vis + AnonTCB VisArg -> SpecifiedSpec + AnonTCB InvisArg -> InferredSpec -- See Note [AnonTCB InvisArg] + NamedTCB Required -> SpecifiedSpec + NamedTCB (Invisible vis) -> vis -- Returns only tyvars, as covars are always inferred tyConVisibleTyVars :: TyCon -> [TyVar] @@ -655,8 +655,10 @@ instance OutputableBndr tv => Outputable (VarBndr tv TyConBndrVis) where ppr_bi (AnonTCB VisArg) = text "anon-vis" ppr_bi (AnonTCB InvisArg) = text "anon-invis" ppr_bi (NamedTCB Required) = text "req" - ppr_bi (NamedTCB Specified) = text "spec" - ppr_bi (NamedTCB Inferred) = text "inf" + -- See Note [Explicit Case Statement for Specificity] + ppr_bi (NamedTCB (Invisible spec)) = case spec of + SpecifiedSpec -> text "spec" + InferredSpec -> text "inf" instance Binary TyConBndrVis where put_ bh (AnonTCB af) = do { putByte bh 0; put_ bh af } diff --git a/compiler/GHC/Core/Type.hs b/compiler/GHC/Core/Type.hs index 1118315269..f06ae70a4e 100644 --- a/compiler/GHC/Core/Type.hs +++ b/compiler/GHC/Core/Type.hs @@ -3,7 +3,7 @@ -- -- Type - public interface -{-# LANGUAGE CPP, FlexibleContexts #-} +{-# LANGUAGE CPP, FlexibleContexts, PatternSynonyms #-} {-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} @@ -16,6 +16,7 @@ module GHC.Core.Type ( -- $representation_types TyThing(..), Type, ArgFlag(..), AnonArgFlag(..), ForallVisFlag(..), + Specificity(..), KindOrType, PredType, ThetaType, Var, TyVar, isTyVar, TyCoVar, TyCoBinder, TyCoVarBinder, TyVarBinder, KnotTied, @@ -39,10 +40,10 @@ module GHC.Core.Type ( splitListTyConApp_maybe, repSplitTyConApp_maybe, - mkForAllTy, mkForAllTys, mkTyCoInvForAllTys, + mkForAllTy, mkForAllTys, mkInvisForAllTys, mkTyCoInvForAllTys, mkSpecForAllTy, mkSpecForAllTys, mkVisForAllTys, mkTyCoInvForAllTy, - mkInvForAllTy, mkInvForAllTys, + mkInfForAllTy, mkInfForAllTys, splitForAllTys, splitForAllTysSameVis, splitForAllVarBndrs, splitForAllTy_maybe, splitForAllTy, @@ -92,6 +93,7 @@ module GHC.Core.Type ( sameVis, mkTyCoVarBinder, mkTyCoVarBinders, mkTyVarBinders, + tyVarSpecToBinders, mkAnonBinder, isAnonTyCoBinder, binderVar, binderVars, binderType, binderArgFlag, @@ -1476,8 +1478,8 @@ mkTyCoInvForAllTy tv ty = ForAllTy (Bndr tv Inferred) ty -- | Like 'mkTyCoInvForAllTy', but tv should be a tyvar -mkInvForAllTy :: TyVar -> Type -> Type -mkInvForAllTy tv ty = ASSERT( isTyVar tv ) +mkInfForAllTy :: TyVar -> Type -> Type +mkInfForAllTy tv ty = ASSERT( isTyVar tv ) ForAllTy (Bndr tv Inferred) ty -- | Like 'mkForAllTys', but assumes all variables are dependent and @@ -1486,8 +1488,8 @@ mkTyCoInvForAllTys :: [TyCoVar] -> Type -> Type mkTyCoInvForAllTys tvs ty = foldr mkTyCoInvForAllTy ty tvs -- | Like 'mkTyCoInvForAllTys', but tvs should be a list of tyvar -mkInvForAllTys :: [TyVar] -> Type -> Type -mkInvForAllTys tvs ty = foldr mkInvForAllTy ty tvs +mkInfForAllTys :: [TyVar] -> Type -> Type +mkInfForAllTys tvs ty = foldr mkInfForAllTy ty tvs -- | Like 'mkForAllTy', but assumes the variable is dependent and 'Specified', -- a common case @@ -1600,12 +1602,13 @@ splitForAllTys ty = split ty ty [] -- @'sameVis' argf supplied_argf@ is 'True', where @argf@ is the visibility -- of the @ForAllTy@'s binder and @supplied_argf@ is the visibility provided -- as an argument to this function. -splitForAllTysSameVis :: ArgFlag -> Type -> ([TyCoVar], Type) +-- Furthermore, each returned tyvar is annotated with its argf. +splitForAllTysSameVis :: ArgFlag -> Type -> ([TyCoVarBinder], Type) splitForAllTysSameVis supplied_argf ty = split ty ty [] where split orig_ty ty tvs | Just ty' <- coreView ty = split orig_ty ty' tvs split _ (ForAllTy (Bndr tv argf) ty) tvs - | argf `sameVis` supplied_argf = split ty ty (tv:tvs) + | argf `sameVis` supplied_argf = split ty ty ((Bndr tv argf):tvs) split orig_ty _ tvs = (reverse tvs, orig_ty) -- | Like splitForAllTys, but split only for tyvars. @@ -3021,10 +3024,22 @@ tyConAppNeedsKindSig spec_inj_pos tc n_args _ -> emptyFV source_of_injectivity Required = True - source_of_injectivity Specified = spec_inj_pos - source_of_injectivity Inferred = False + -- See Note [Explicit Case Statement for Specificity] + source_of_injectivity (Invisible spec) = case spec of + SpecifiedSpec -> spec_inj_pos + InferredSpec -> False {- +Note [Explicit Case Statement for Specificity] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When pattern matching against an `ArgFlag`, you should not pattern match against +the pattern synonyms 'Specified' or 'Inferred', as this results in a +non-exhaustive pattern match warning. +Instead, pattern match against 'Invisible spec' and do another case analysis on +this specificity argument. +The issue has been fixed in GHC 8.10 (ticket #17876). This hack can thus be +dropped once version 8.10 is used as the minimum version for building GHC. + Note [When does a tycon application need an explicit kind signature?] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ There are a couple of places in GHC where we convert Core Types into forms that diff --git a/compiler/GHC/CoreToIface.hs b/compiler/GHC/CoreToIface.hs index 93c5ba5672..3e997e8df7 100644 --- a/compiler/GHC/CoreToIface.hs +++ b/compiler/GHC/CoreToIface.hs @@ -206,10 +206,10 @@ toIfaceTyVar = occNameFS . getOccName toIfaceCoVar :: CoVar -> FastString toIfaceCoVar = occNameFS . getOccName -toIfaceForAllBndr :: TyCoVarBinder -> IfaceForAllBndr +toIfaceForAllBndr :: (VarBndr TyCoVar flag) -> (VarBndr IfaceBndr flag) toIfaceForAllBndr = toIfaceForAllBndrX emptyVarSet -toIfaceForAllBndrX :: VarSet -> TyCoVarBinder -> IfaceForAllBndr +toIfaceForAllBndrX :: VarSet -> (VarBndr TyCoVar flag) -> (VarBndr IfaceBndr flag) toIfaceForAllBndrX fr (Bndr v vis) = Bndr (toIfaceBndrX fr v) vis ---------------- diff --git a/compiler/GHC/CoreToIface.hs-boot b/compiler/GHC/CoreToIface.hs-boot index 431d2b0aa5..a906414aaf 100644 --- a/compiler/GHC/CoreToIface.hs-boot +++ b/compiler/GHC/CoreToIface.hs-boot @@ -1,9 +1,9 @@ module GHC.CoreToIface where import {-# SOURCE #-} GHC.Core.TyCo.Rep ( Type, TyLit, Coercion ) -import {-# SOURCE #-} GHC.Iface.Type( IfaceType, IfaceTyCon, IfaceForAllBndr +import {-# SOURCE #-} GHC.Iface.Type( IfaceType, IfaceTyCon, IfaceBndr , IfaceCoercion, IfaceTyLit, IfaceAppArgs ) -import GHC.Types.Var ( TyCoVarBinder ) +import GHC.Types.Var ( VarBndr, TyCoVar ) import GHC.Types.Var.Env ( TidyEnv ) import GHC.Core.TyCon ( TyCon ) import GHC.Types.Var.Set( VarSet ) @@ -11,7 +11,7 @@ import GHC.Types.Var.Set( VarSet ) -- For GHC.Core.TyCo.Rep toIfaceTypeX :: VarSet -> Type -> IfaceType toIfaceTyLit :: TyLit -> IfaceTyLit -toIfaceForAllBndr :: TyCoVarBinder -> IfaceForAllBndr +toIfaceForAllBndr :: (VarBndr TyCoVar flag) -> (VarBndr IfaceBndr flag) toIfaceTyCon :: TyCon -> IfaceTyCon toIfaceTcArgs :: TyCon -> [Type] -> IfaceAppArgs toIfaceCoercionX :: VarSet -> Coercion -> IfaceCoercion diff --git a/compiler/GHC/Hs/Decls.hs b/compiler/GHC/Hs/Decls.hs index 8044b37cc4..6dfe75005e 100644 --- a/compiler/GHC/Hs/Decls.hs +++ b/compiler/GHC/Hs/Decls.hs @@ -108,6 +108,7 @@ import GHC.Types.Basic import GHC.Core.Coercion import GHC.Types.ForeignCall import GHC.Hs.Extension +import GHC.Types.Name import GHC.Types.Name.Set -- others: @@ -560,7 +561,7 @@ data TyClDecl pass , tcdTyVars :: LHsQTyVars pass -- ^ Type variables; for an -- associated type these -- include outer binders - , tcdFixity :: LexicalFixity -- ^ Fixity used in the declaration + , tcdFixity :: LexicalFixity -- ^ Fixity used in the declaration , tcdRhs :: LHsType pass } -- ^ RHS of type declaration | -- | @data@ declaration @@ -579,10 +580,10 @@ data TyClDecl pass , tcdFixity :: LexicalFixity -- ^ Fixity used in the declaration , tcdDataDefn :: HsDataDefn pass } - | ClassDecl { tcdCExt :: XClassDecl pass, -- ^ Post renamer, FVs - tcdCtxt :: LHsContext pass, -- ^ Context... - tcdLName :: Located (IdP pass), -- ^ Name of the class - tcdTyVars :: LHsQTyVars pass, -- ^ Class type variables + | ClassDecl { tcdCExt :: XClassDecl pass, -- ^ Post renamer, FVs + tcdCtxt :: LHsContext pass, -- ^ Context... + tcdLName :: Located (IdP pass), -- ^ Name of the class + tcdTyVars :: LHsQTyVars pass, -- ^ Class type variables tcdFixity :: LexicalFixity, -- ^ Fixity used in the declaration tcdFDs :: [LHsFunDep pass], -- ^ Functional deps tcdSigs :: [LSig pass], -- ^ Methods' signatures @@ -1056,7 +1057,7 @@ data FamilyResultSig pass = -- see Note [FamilyResultSig] -- For details on above see note [Api annotations] in GHC.Parser.Annotation - | TyVarSig (XTyVarSig pass) (LHsTyVarBndr pass) + | TyVarSig (XTyVarSig pass) (LHsTyVarBndr () pass) -- ^ - 'ApiAnnotation.AnnKeywordId' : -- 'ApiAnnotation.AnnOpenP','ApiAnnotation.AnnDcolon', -- 'ApiAnnotation.AnnCloseP', 'ApiAnnotation.AnnEqual' @@ -1138,8 +1139,8 @@ famResultKindSignature (NoSig _) = Nothing famResultKindSignature (KindSig _ ki) = Just ki famResultKindSignature (TyVarSig _ bndr) = case unLoc bndr of - UserTyVar _ _ -> Nothing - KindedTyVar _ _ ki -> Just ki + UserTyVar _ _ _ -> Nothing + KindedTyVar _ _ _ ki -> Just ki -- | Maybe return name of the result type variable resultVariableName :: FamilyResultSig (GhcPass a) -> Maybe (IdP (GhcPass a)) @@ -1386,7 +1387,7 @@ data ConDecl pass -- AnnForall and AnnDot. , con_forall :: Located Bool -- ^ True <=> explicit forall -- False => hsq_explicit is empty - , con_qvars :: LHsQTyVars pass + , con_qvars :: [LHsTyVarBndr Specificity pass] -- Whether or not there is an /explicit/ forall, we still -- need to capture the implicitly-bound type/kind variables @@ -1407,16 +1408,19 @@ data ConDecl pass -- e.g. data T a = forall b. MkT b (b->a) -- con_ex_tvs = {b} -- False => con_ex_tvs is empty - , con_ex_tvs :: [LHsTyVarBndr pass] -- ^ Existentials only - , con_mb_cxt :: Maybe (LHsContext pass) -- ^ User-written context (if any) - , con_args :: HsConDeclDetails pass -- ^ Arguments; can be InfixCon + , con_ex_tvs :: [LHsTyVarBndr Specificity pass] -- ^ Existentials only + , con_mb_cxt :: Maybe (LHsContext pass) -- ^ User-written context (if any) + , con_args :: HsConDeclDetails pass -- ^ Arguments; can be InfixCon , con_doc :: Maybe LHsDocString -- ^ A possible Haddock comment. } | XConDecl !(XXConDecl pass) -type instance XConDeclGADT (GhcPass _) = NoExtField +type instance XConDeclGADT GhcPs = NoExtField +type instance XConDeclGADT GhcRn = [Name] -- Implicitly bound type variables +type instance XConDeclGADT GhcTc = NoExtField + type instance XConDeclH98 (GhcPass _) = NoExtField type instance XXConDecl (GhcPass _) = NoExtCon @@ -1542,7 +1546,7 @@ pprConDecl (ConDeclGADT { con_names = cons, con_qvars = qvars , con_mb_cxt = mcxt, con_args = args , con_res_ty = res_ty, con_doc = doc }) = ppr_mbDoc doc <+> ppr_con_names cons <+> dcolon - <+> (sep [pprHsForAll ForallInvis (hsq_explicit qvars) cxt, + <+> (sep [pprHsForAll ForallInvis qvars cxt, ppr_arrow_chain (get_args args ++ [ppr res_ty]) ]) where get_args (PrefixCon args) = map ppr args @@ -1691,7 +1695,7 @@ data FamEqn pass rhs = FamEqn { feqn_ext :: XCFamEqn pass rhs , feqn_tycon :: Located (IdP pass) - , feqn_bndrs :: Maybe [LHsTyVarBndr pass] -- ^ Optional quantified type vars + , feqn_bndrs :: Maybe [LHsTyVarBndr () pass] -- ^ Optional quantified type vars , feqn_pats :: HsTyPats pass , feqn_fixity :: LexicalFixity -- ^ Fixity used in the declaration , feqn_rhs :: rhs @@ -1812,7 +1816,7 @@ pprDataFamInstFlavour (DataFamInstDecl { dfid_eqn = HsIB { hsib_body = pprHsFamInstLHS :: (OutputableBndrId p) => IdP (GhcPass p) - -> Maybe [LHsTyVarBndr (GhcPass p)] + -> Maybe [LHsTyVarBndr () (GhcPass p)] -> HsTyPats (GhcPass p) -> LexicalFixity -> LHsContext (GhcPass p) @@ -2209,7 +2213,7 @@ data RuleDecl pass , rd_name :: Located (SourceText,RuleName) -- ^ Note [Pragma source text] in GHC.Types.Basic , rd_act :: Activation - , rd_tyvs :: Maybe [LHsTyVarBndr (NoGhcTc pass)] + , rd_tyvs :: Maybe [LHsTyVarBndr () (NoGhcTc pass)] -- ^ Forall'd type vars , rd_tmvs :: [LRuleBndr pass] -- ^ Forall'd term vars, before typechecking; after typechecking diff --git a/compiler/GHC/Hs/Instances.hs b/compiler/GHC/Hs/Instances.hs index f30e07a50e..a003a6b885 100644 --- a/compiler/GHC/Hs/Instances.hs +++ b/compiler/GHC/Hs/Instances.hs @@ -392,9 +392,9 @@ deriving instance Data (HsPatSigType GhcRn) deriving instance Data (HsPatSigType GhcTc) -- deriving instance (DataIdLR p p) => Data (HsTyVarBndr p) -deriving instance Data (HsTyVarBndr GhcPs) -deriving instance Data (HsTyVarBndr GhcRn) -deriving instance Data (HsTyVarBndr GhcTc) +deriving instance (Data flag) => Data (HsTyVarBndr flag GhcPs) +deriving instance (Data flag) => Data (HsTyVarBndr flag GhcRn) +deriving instance (Data flag) => Data (HsTyVarBndr flag GhcTc) -- deriving instance (DataIdLR p p) => Data (HsType p) deriving instance Data (HsType GhcPs) diff --git a/compiler/GHC/Hs/Types.hs b/compiler/GHC/Hs/Types.hs index f7a595d0f0..2bb4d11240 100644 --- a/compiler/GHC/Hs/Types.hs +++ b/compiler/GHC/Hs/Types.hs @@ -31,6 +31,7 @@ module GHC.Hs.Types ( HsIPName(..), hsIPNameFS, HsArg(..), numVisibleArgs, LHsTypeArg, + OutputableBndrFlag, LBangType, BangType, HsSrcBang(..), HsImplBang(..), @@ -50,7 +51,7 @@ module GHC.Hs.Types ( mkHsImplicitBndrs, mkHsWildCardBndrs, mkHsPatSigType, hsImplicitBody, mkEmptyImplicitBndrs, mkEmptyWildCardBndrs, - mkHsQTvs, hsQTvExplicit, emptyLHsQTvs, isEmptyLHsQTvs, + mkHsQTvs, hsQTvExplicit, emptyLHsQTvs, isHsKindedTyVar, hsTvbAllKinded, isLHsForAllTy, hsScopedTvs, hsWcScopedTvs, dropWildCards, hsTyVarName, hsAllLTyVarNames, hsLTyVarLocNames, @@ -61,9 +62,9 @@ module GHC.Hs.Types ( splitHsFunType, hsTyGetAppHead_maybe, mkHsOpTy, mkHsAppTy, mkHsAppTys, mkHsAppKindTy, ignoreParens, hsSigType, hsSigWcType, hsPatSigType, - hsLTyVarBndrToType, hsLTyVarBndrsToTypes, hsTyKindSig, hsConDetailsArgs, + setHsTyVarBndrFlag, hsTyVarBndrFlag, -- Printing pprHsType, pprHsForAll, pprHsForAllExtra, pprHsExplicitForAll, @@ -328,14 +329,14 @@ type LHsKind pass = Located (HsKind pass) -- The explicitly-quantified binders in a data/type declaration -- | Located Haskell Type Variable Binder -type LHsTyVarBndr pass = Located (HsTyVarBndr pass) +type LHsTyVarBndr flag pass = Located (HsTyVarBndr flag pass) -- See Note [HsType binders] -- | Located Haskell Quantified Type Variables data LHsQTyVars pass -- See Note [HsType binders] = HsQTvs { hsq_ext :: XHsQTvs pass - , hsq_explicit :: [LHsTyVarBndr pass] + , hsq_explicit :: [LHsTyVarBndr () pass] -- Explicit variables, written by the user } | XLHsQTyVars !(XXLHsQTyVars pass) @@ -350,19 +351,15 @@ type instance XHsQTvs GhcTc = HsQTvsRn type instance XXLHsQTyVars (GhcPass _) = NoExtCon -mkHsQTvs :: [LHsTyVarBndr GhcPs] -> LHsQTyVars GhcPs +mkHsQTvs :: [LHsTyVarBndr () GhcPs] -> LHsQTyVars GhcPs mkHsQTvs tvs = HsQTvs { hsq_ext = noExtField, hsq_explicit = tvs } -hsQTvExplicit :: LHsQTyVars pass -> [LHsTyVarBndr pass] +hsQTvExplicit :: LHsQTyVars pass -> [LHsTyVarBndr () pass] hsQTvExplicit = hsq_explicit emptyLHsQTvs :: LHsQTyVars GhcRn emptyLHsQTvs = HsQTvs { hsq_ext = [], hsq_explicit = [] } -isEmptyLHsQTvs :: LHsQTyVars GhcRn -> Bool -isEmptyLHsQTvs (HsQTvs { hsq_ext = imp, hsq_explicit = exp }) - = null imp && null exp - ------------------------------------------------ -- HsImplicitBndrs -- Used to quantify the implicit binders of a type @@ -591,13 +588,18 @@ instance OutputableBndr HsIPName where -------------------------------------------------- -- | Haskell Type Variable Binder -data HsTyVarBndr pass +-- The flag annotates the binder. It is 'Specificity' in places where +-- explicit specificity is allowed (e.g. x :: forall {a} b. ...) or +-- '()' in other places. +data HsTyVarBndr flag pass = UserTyVar -- no explicit kinding (XUserTyVar pass) + flag (Located (IdP pass)) -- See Note [Located RdrNames] in GHC.Hs.Expr | KindedTyVar (XKindedTyVar pass) + flag (Located (IdP pass)) (LHsKind pass) -- The user-supplied kind signature -- ^ @@ -614,8 +616,19 @@ type instance XKindedTyVar (GhcPass _) = NoExtField type instance XXTyVarBndr (GhcPass _) = NoExtCon +-- | Return the attached flag +hsTyVarBndrFlag :: HsTyVarBndr flag (GhcPass pass) -> flag +hsTyVarBndrFlag (UserTyVar _ fl _) = fl +hsTyVarBndrFlag (KindedTyVar _ fl _ _) = fl + +-- | Set the attached flag +setHsTyVarBndrFlag :: flag -> HsTyVarBndr flag' (GhcPass pass) + -> HsTyVarBndr flag (GhcPass pass) +setHsTyVarBndrFlag f (UserTyVar x _ l) = UserTyVar x f l +setHsTyVarBndrFlag f (KindedTyVar x _ l k) = KindedTyVar x f l k + -- | Does this 'HsTyVarBndr' come with an explicit kind annotation? -isHsKindedTyVar :: HsTyVarBndr pass -> Bool +isHsKindedTyVar :: HsTyVarBndr flag pass -> Bool isHsKindedTyVar (UserTyVar {}) = False isHsKindedTyVar (KindedTyVar {}) = True isHsKindedTyVar (XTyVarBndr {}) = False @@ -624,9 +637,24 @@ isHsKindedTyVar (XTyVarBndr {}) = False hsTvbAllKinded :: LHsQTyVars pass -> Bool hsTvbAllKinded = all (isHsKindedTyVar . unLoc) . hsQTvExplicit -instance NamedThing (HsTyVarBndr GhcRn) where - getName (UserTyVar _ v) = unLoc v - getName (KindedTyVar _ v _) = unLoc v +instance NamedThing (HsTyVarBndr flag GhcRn) where + getName (UserTyVar _ _ v) = unLoc v + getName (KindedTyVar _ _ v _) = unLoc v + +{- Note [Specificity in HsForAllTy] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +All type variables in a `HsForAllTy` type are annotated with their +`Specificity`. The meaning of this `Specificity` depends on the visibility of +the binder `hst_fvf`: + +* In an invisible forall type, the `Specificity` denotes whether type variables + are `Specified` (`forall a. ...`) or `Inferred` (`forall {a}. ...`). For more + information, see Note [VarBndrs, TyCoVarBinders, TyConBinders, and visibility] + in GHC.Core.TyCo.Rep. + +* In a visible forall type, the `Specificity` has no particular meaning. We + uphold the convention that all visible forall types use `Specified` binders. +-} -- | Haskell Type data HsType pass @@ -634,9 +662,10 @@ data HsType pass { hst_xforall :: XForAllTy pass , hst_fvf :: ForallVisFlag -- Is this `forall a -> {...}` or -- `forall a. {...}`? - , hst_bndrs :: [LHsTyVarBndr pass] - -- Explicit, user-supplied 'forall a b c' - , hst_body :: LHsType pass -- body type + , hst_bndrs :: [LHsTyVarBndr Specificity pass] + -- Explicit, user-supplied 'forall a {b} c' + -- see Note [Specificity in HsForAllTy] + , hst_body :: LHsType pass -- body type } -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnForall', -- 'ApiAnnotation.AnnDot','ApiAnnotation.AnnDarrow' @@ -1123,14 +1152,14 @@ Bottom line: nip problems in the bud by matching on ForallInvis from the start. -} --------------------- -hsTyVarName :: HsTyVarBndr (GhcPass p) -> IdP (GhcPass p) -hsTyVarName (UserTyVar _ (L _ n)) = n -hsTyVarName (KindedTyVar _ (L _ n) _) = n +hsTyVarName :: HsTyVarBndr flag (GhcPass p) -> IdP (GhcPass p) +hsTyVarName (UserTyVar _ _ (L _ n)) = n +hsTyVarName (KindedTyVar _ _ (L _ n) _) = n -hsLTyVarName :: LHsTyVarBndr (GhcPass p) -> IdP (GhcPass p) +hsLTyVarName :: LHsTyVarBndr flag (GhcPass p) -> IdP (GhcPass p) hsLTyVarName = hsTyVarName . unLoc -hsLTyVarNames :: [LHsTyVarBndr (GhcPass p)] -> [IdP (GhcPass p)] +hsLTyVarNames :: [LHsTyVarBndr flag (GhcPass p)] -> [IdP (GhcPass p)] hsLTyVarNames = map hsLTyVarName hsExplicitLTyVarNames :: LHsQTyVars (GhcPass p) -> [IdP (GhcPass p)] @@ -1143,26 +1172,12 @@ hsAllLTyVarNames (HsQTvs { hsq_ext = kvs , hsq_explicit = tvs }) = kvs ++ hsLTyVarNames tvs -hsLTyVarLocName :: LHsTyVarBndr (GhcPass p) -> Located (IdP (GhcPass p)) +hsLTyVarLocName :: LHsTyVarBndr flag (GhcPass p) -> Located (IdP (GhcPass p)) hsLTyVarLocName = mapLoc hsTyVarName hsLTyVarLocNames :: LHsQTyVars (GhcPass p) -> [Located (IdP (GhcPass p))] hsLTyVarLocNames qtvs = map hsLTyVarLocName (hsQTvExplicit qtvs) --- | Convert a LHsTyVarBndr to an equivalent LHsType. -hsLTyVarBndrToType :: LHsTyVarBndr (GhcPass p) -> LHsType (GhcPass p) -hsLTyVarBndrToType = mapLoc cvt - where cvt :: HsTyVarBndr (GhcPass p) -> HsType (GhcPass p) - cvt (UserTyVar _ n) = HsTyVar noExtField NotPromoted n - cvt (KindedTyVar _ (L name_loc n) kind) - = HsKindSig noExtField - (L name_loc (HsTyVar noExtField NotPromoted (L name_loc n))) kind - --- | Convert a LHsTyVarBndrs to a list of types. --- Works on *type* variable only, no kind vars. -hsLTyVarBndrsToTypes :: LHsQTyVars (GhcPass p) -> [LHsType (GhcPass p)] -hsLTyVarBndrsToTypes (HsQTvs { hsq_explicit = tvbs }) = map hsLTyVarBndrToType tvbs - -- | Get the kind signature of a type, ignoring parentheses: -- -- hsTyKindSig `Maybe ` = Nothing @@ -1299,9 +1314,9 @@ The SrcSpan is the span of the original HsPar -- generally possible to take the returned types and reconstruct the original -- type (parentheses and all) from them. splitLHsPatSynTy :: LHsType pass - -> ( [LHsTyVarBndr pass] -- universals + -> ( [LHsTyVarBndr Specificity pass] -- universals , LHsContext pass -- required constraints - , [LHsTyVarBndr pass] -- existentials + , [LHsTyVarBndr Specificity pass] -- existentials , LHsContext pass -- provided constraints , LHsType pass) -- body type splitLHsPatSynTy ty = (univs, reqs, exis, provs, ty4) @@ -1312,9 +1327,9 @@ splitLHsPatSynTy ty = (univs, reqs, exis, provs, ty4) (provs, ty4) = splitLHsQualTy ty3 -- | Decompose a sigma type (of the form @forall <tvs>. context => body@) --- into its constituent parts. Note that only /invisible/ @forall@s --- (i.e., @forall a.@, with a dot) are split apart; /visible/ @forall@s --- (i.e., @forall a ->@, with an arrow) are left untouched. +-- into its constituent parts. +-- Only splits type variable binders that were +-- quantified invisibly (e.g., @forall a.@, with a dot). -- -- This function is used to split apart certain types, such as instance -- declaration types, which disallow visible @forall@s. For instance, if GHC @@ -1326,16 +1341,15 @@ splitLHsPatSynTy ty = (univs, reqs, exis, provs, ty4) -- generally possible to take the returned types and reconstruct the original -- type (parentheses and all) from them. splitLHsSigmaTyInvis :: LHsType pass - -> ([LHsTyVarBndr pass], LHsContext pass, LHsType pass) + -> ([LHsTyVarBndr Specificity pass], LHsContext pass, LHsType pass) splitLHsSigmaTyInvis ty | (tvs, ty1) <- splitLHsForAllTyInvis ty , (ctxt, ty2) <- splitLHsQualTy ty1 = (tvs, ctxt, ty2) -- | Decompose a type of the form @forall <tvs>. body@ into its constituent --- parts. Note that only /invisible/ @forall@s --- (i.e., @forall a.@, with a dot) are split apart; /visible/ @forall@s --- (i.e., @forall a ->@, with an arrow) are left untouched. +-- parts. Only splits type variable binders that +-- were quantified invisibly (e.g., @forall a.@, with a dot). -- -- This function is used to split apart certain types, such as instance -- declaration types, which disallow visible @forall@s. For instance, if GHC @@ -1346,7 +1360,7 @@ splitLHsSigmaTyInvis ty -- such as @(forall a. <...>)@. The downside to this is that it is not -- generally possible to take the returned types and reconstruct the original -- type (parentheses and all) from them. -splitLHsForAllTyInvis :: LHsType pass -> ([LHsTyVarBndr pass], LHsType pass) +splitLHsForAllTyInvis :: LHsType pass -> ([LHsTyVarBndr Specificity pass], LHsType pass) splitLHsForAllTyInvis lty@(L _ ty) = case ty of HsParTy _ ty' -> splitLHsForAllTyInvis ty' @@ -1494,6 +1508,19 @@ ambiguousFieldOcc (FieldOcc sel rdr) = Unambiguous sel rdr ************************************************************************ -} +class OutputableBndrFlag flag where + pprTyVarBndr :: OutputableBndrId p => HsTyVarBndr flag (GhcPass p) -> SDoc + +instance OutputableBndrFlag () where + pprTyVarBndr (UserTyVar _ _ n) = ppr n + pprTyVarBndr (KindedTyVar _ _ n k) = parens $ hsep [ppr n, dcolon, ppr k] + +instance OutputableBndrFlag Specificity where + pprTyVarBndr (UserTyVar _ SpecifiedSpec n) = ppr n + pprTyVarBndr (UserTyVar _ InferredSpec n) = braces $ ppr n + pprTyVarBndr (KindedTyVar _ SpecifiedSpec n k) = parens $ hsep [ppr n, dcolon, ppr k] + pprTyVarBndr (KindedTyVar _ InferredSpec n k) = braces $ hsep [ppr n, dcolon, ppr k] + instance OutputableBndrId p => Outputable (HsType (GhcPass p)) where ppr ty = pprHsType ty @@ -1504,10 +1531,9 @@ instance OutputableBndrId p => Outputable (LHsQTyVars (GhcPass p)) where ppr (HsQTvs { hsq_explicit = tvs }) = interppSP tvs -instance OutputableBndrId p - => Outputable (HsTyVarBndr (GhcPass p)) where - ppr (UserTyVar _ n) = ppr n - ppr (KindedTyVar _ n k) = parens $ hsep [ppr n, dcolon, ppr k] +instance (OutputableBndrId p, OutputableBndrFlag flag) + => Outputable (HsTyVarBndr flag (GhcPass p)) where + ppr = pprTyVarBndr instance Outputable thing => Outputable (HsImplicitBndrs (GhcPass p) thing) where @@ -1526,8 +1552,8 @@ pprAnonWildCard = char '_' -- | Prints a forall; When passed an empty list, prints @forall .@/@forall ->@ -- only when @-dppr-debug@ is enabled. -pprHsForAll :: (OutputableBndrId p) - => ForallVisFlag -> [LHsTyVarBndr (GhcPass p)] +pprHsForAll :: (OutputableBndrId p, OutputableBndrFlag flag) + => ForallVisFlag -> [LHsTyVarBndr flag (GhcPass p)] -> LHsContext (GhcPass p) -> SDoc pprHsForAll = pprHsForAllExtra Nothing @@ -1538,9 +1564,9 @@ pprHsForAll = pprHsForAllExtra Nothing -- function for this is needed, as the extra-constraints wildcard is removed -- from the actual context and type, and stored in a separate field, thus just -- printing the type will not print the extra-constraints wildcard. -pprHsForAllExtra :: (OutputableBndrId p) +pprHsForAllExtra :: (OutputableBndrId p, OutputableBndrFlag flag) => Maybe SrcSpan -> ForallVisFlag - -> [LHsTyVarBndr (GhcPass p)] + -> [LHsTyVarBndr flag (GhcPass p)] -> LHsContext (GhcPass p) -> SDoc pprHsForAllExtra extra fvf qtvs cxt = pp_forall <+> pprLHsContextExtra (isJust extra) cxt @@ -1554,7 +1580,7 @@ pprHsForAllExtra extra fvf qtvs cxt -- @forall.@ when passed @Just []@. Prints nothing if passed 'Nothing' pprHsExplicitForAll :: (OutputableBndrId p) => ForallVisFlag - -> Maybe [LHsTyVarBndr (GhcPass p)] -> SDoc + -> Maybe [LHsTyVarBndr () (GhcPass p)] -> SDoc pprHsExplicitForAll fvf (Just qtvs) = forAllLit <+> interppSP qtvs <> ppr_forall_separator fvf pprHsExplicitForAll _ Nothing = empty diff --git a/compiler/GHC/Hs/Utils.hs b/compiler/GHC/Hs/Utils.hs index 6e89b6844a..6301927b26 100644 --- a/compiler/GHC/Hs/Utils.hs +++ b/compiler/GHC/Hs/Utils.hs @@ -736,14 +736,23 @@ typeToLHsType ty foldl' (\f (arg, flag) -> let arg' = go arg in case flag of - Inferred -> f - Specified -> f `nlHsAppKindTy` arg' + -- See Note [Explicit Case Statement for Specificity] + Invisible spec -> case spec of + InferredSpec -> f + SpecifiedSpec -> f `nlHsAppKindTy` arg' Required -> f `nlHsAppTy` arg') head (zip args arg_flags) - go_tv :: TyVar -> LHsTyVarBndr GhcPs - go_tv tv = noLoc $ KindedTyVar noExtField (noLoc (getRdrName tv)) - (go (tyVarKind tv)) + argf_to_spec :: ArgFlag -> Specificity + argf_to_spec Required = SpecifiedSpec + -- see Note [Specificity in HsForAllTy] in GHC.Hs.Types + argf_to_spec (Invisible s) = s + + go_tv :: TyVarBinder -> LHsTyVarBndr Specificity GhcPs + go_tv (Bndr tv argf) = noLoc $ KindedTyVar noExtField + (argf_to_spec argf) + (noLoc (getRdrName tv)) + (go (tyVarKind tv)) {- Note [Kind signatures in typeToLHsType] diff --git a/compiler/GHC/HsToCore/Foreign/Call.hs b/compiler/GHC/HsToCore/Foreign/Call.hs index 9589c375e8..fbe9c424bc 100644 --- a/compiler/GHC/HsToCore/Foreign/Call.hs +++ b/compiler/GHC/HsToCore/Foreign/Call.hs @@ -127,7 +127,7 @@ mkFCall dflags uniq the_fcall val_args res_ty arg_tys = map exprType val_args body_ty = (mkVisFunTys arg_tys res_ty) tyvars = tyCoVarsOfTypeWellScoped body_ty - ty = mkInvForAllTys tyvars body_ty + ty = mkInfForAllTys tyvars body_ty the_fcall_id = mkFCallId dflags uniq the_fcall ty unboxArg :: CoreExpr -- The supplied argument, not levity-polymorphic diff --git a/compiler/GHC/HsToCore/Quote.hs b/compiler/GHC/HsToCore/Quote.hs index 395f1adfb0..e449b03a5d 100644 --- a/compiler/GHC/HsToCore/Quote.hs +++ b/compiler/GHC/HsToCore/Quote.hs @@ -4,6 +4,11 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE AllowAmbiguousTypes #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} @@ -106,7 +111,7 @@ mkMetaWrappers q@(QuoteWrapper quote_var_raw m_var) = do -- Only used for the defensive assertion that the selector has -- the expected type tyvars = dataConUserTyVarBinders (classDataCon cls) - expected_ty = mkForAllTys tyvars $ + expected_ty = mkInvisForAllTys tyvars $ mkInvisFunTy (mkClassPred cls (mkTyVarTys (binderVars tyvars))) (mkClassPred monad_cls (mkTyVarTys (binderVars tyvars))) @@ -464,7 +469,7 @@ repTyClD (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls, tcdSigs = sigs, tcdMeths = meth_binds, tcdATs = ats, tcdATDefs = atds })) = do { cls1 <- lookupLOcc cls -- See note [Binders and occurrences] - ; dec <- addTyVarBinds tvs $ \bndrs -> + ; dec <- addQTyVarBinds tvs $ \bndrs -> do { cxt1 <- repLContext cxt -- See Note [Scoped type variables in class and instance declarations] ; (ss, sigs_binds) <- rep_sigs_binds sigs meth_binds @@ -494,9 +499,9 @@ repKiSigD (L loc kisig) = ------------------------- repDataDefn :: Core TH.Name - -> Either (Core [(M TH.TyVarBndr)]) + -> Either (Core [(M (TH.TyVarBndr ()))]) -- the repTyClD case - (Core (Maybe [(M TH.TyVarBndr)]), Core (M TH.Type)) + (Core (Maybe [(M (TH.TyVarBndr ()))]), Core (M TH.Type)) -- the repDataFamInstD case -> HsDataDefn GhcRn -> MetaM (Core (M TH.Dec)) @@ -520,7 +525,7 @@ repDataDefn tc opts derivs1 } } -repSynDecl :: Core TH.Name -> Core [(M TH.TyVarBndr)] +repSynDecl :: Core TH.Name -> Core [(M (TH.TyVarBndr ()))] -> LHsType GhcRn -> MetaM (Core (M TH.Dec)) repSynDecl tc bndrs ty @@ -534,7 +539,7 @@ repFamilyDecl decl@(L loc (FamilyDecl { fdInfo = info , fdResultSig = L _ resultSig , fdInjectivityAnn = injectivity })) = do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences] - ; let mkHsQTvs :: [LHsTyVarBndr GhcRn] -> LHsQTyVars GhcRn + ; let mkHsQTvs :: [LHsTyVarBndr () GhcRn] -> LHsQTyVars GhcRn mkHsQTvs tvs = HsQTvs { hsq_ext = [] , hsq_explicit = tvs } resTyVar = case resultSig of @@ -681,7 +686,7 @@ repTyFamEqn (HsIB { hsib_ext = var_names ; let hs_tvs = HsQTvs { hsq_ext = var_names , hsq_explicit = fromMaybe [] mb_bndrs } ; addTyClTyVarBinds hs_tvs $ \ _ -> - do { mb_bndrs1 <- repMaybeListM tyVarBndrTyConName + do { mb_bndrs1 <- repMaybeListM tyVarBndrUnitTyConName repTyVarBndr mb_bndrs ; tys1 <- case fixity of @@ -718,7 +723,7 @@ repDataFamInstD (DataFamInstDecl { dfid_eqn = ; let hs_tvs = HsQTvs { hsq_ext = var_names , hsq_explicit = fromMaybe [] mb_bndrs } ; addTyClTyVarBinds hs_tvs $ \ _ -> - do { mb_bndrs1 <- repMaybeListM tyVarBndrTyConName + do { mb_bndrs1 <- repMaybeListM tyVarBndrUnitTyConName repTyVarBndr mb_bndrs ; tys1 <- case fixity of @@ -803,7 +808,7 @@ repRuleD (L loc (HsRule { rd_name = n do { let tm_bndr_names = concatMap ruleBndrNames tm_bndrs ; ss <- mkGenSyms tm_bndr_names ; rule <- addBinds ss $ - do { elt_ty <- wrapName tyVarBndrTyConName + do { elt_ty <- wrapName tyVarBndrUnitTyConName ; ty_bndrs' <- return $ case ty_bndrs of Nothing -> coreNothing' (mkListTy elt_ty) Just _ -> coreJust' (mkListTy elt_ty) ex_bndrs @@ -875,22 +880,23 @@ repC (L _ (ConDeclH98 { con_name = con } } -repC (L _ (ConDeclGADT { con_names = cons - , con_qvars = qtvs +repC (L _ (ConDeclGADT { con_g_ext = imp_tvs + , con_names = cons + , con_qvars = exp_tvs , con_mb_cxt = mcxt , con_args = args , con_res_ty = res_ty })) - | isEmptyLHsQTvs qtvs -- No implicit or explicit variables - , Nothing <- mcxt -- No context - -- ==> no need for a forall + | null imp_tvs && null exp_tvs -- No implicit or explicit variables + , Nothing <- mcxt -- No context + -- ==> no need for a forall = repGadtDataCons cons args res_ty | otherwise - = addTyVarBinds qtvs $ \ ex_bndrs -> + = addTyVarBinds exp_tvs imp_tvs $ \ ex_bndrs -> -- See Note [Don't quantify implicit type variables in quotes] do { c' <- repGadtDataCons cons args res_ty ; ctxt' <- repMbContext mcxt - ; if null (hsQTvExplicit qtvs) && isNothing mcxt + ; if null exp_tvs && isNothing mcxt then return c' else rep2 forallCName ([unC ex_bndrs, unC ctxt', unC c']) } @@ -995,7 +1001,7 @@ rep_ty_sig mk_sig loc sig_ty nm = do { nm1 <- lookupLOcc nm ; let rep_in_scope_tv tv = do { name <- lookupBinder (hsLTyVarName tv) ; repTyVarBndrWithKind tv name } - ; th_explicit_tvs <- repListM tyVarBndrTyConName rep_in_scope_tv + ; th_explicit_tvs <- repListM tyVarBndrSpecTyConName rep_in_scope_tv explicit_tvs -- NB: Don't pass any implicit type variables to repList above @@ -1023,8 +1029,8 @@ rep_patsyn_ty_sig loc sig_ty nm = do { nm1 <- lookupLOcc nm ; let rep_in_scope_tv tv = do { name <- lookupBinder (hsLTyVarName tv) ; repTyVarBndrWithKind tv name } - ; th_univs <- repListM tyVarBndrTyConName rep_in_scope_tv univs - ; th_exis <- repListM tyVarBndrTyConName rep_in_scope_tv exis + ; th_univs <- repListM tyVarBndrSpecTyConName rep_in_scope_tv univs + ; th_exis <- repListM tyVarBndrSpecTyConName rep_in_scope_tv exis -- NB: Don't pass any implicit type variables to repList above -- See Note [Don't quantify implicit type variables in quotes] @@ -1110,44 +1116,74 @@ rep_complete_sig (L _ cls) mty loc -- Types ------------------------------------------------------- -addSimpleTyVarBinds :: [Name] -- the binders to be added - -> MetaM (Core (M a)) -- action in the ext env +class RepTV flag flag' | flag -> flag' where + tyVarBndrName :: Name + repPlainTV :: Core TH.Name -> flag -> MetaM (Core (M (TH.TyVarBndr flag'))) + repKindedTV :: Core TH.Name -> flag -> Core (M TH.Kind) + -> MetaM (Core (M (TH.TyVarBndr flag'))) + +instance RepTV () () where + tyVarBndrName = tyVarBndrUnitTyConName + repPlainTV (MkC nm) () = rep2 plainTVName [nm] + repKindedTV (MkC nm) () (MkC ki) = rep2 kindedTVName [nm, ki] + +instance RepTV Specificity TH.Specificity where + tyVarBndrName = tyVarBndrSpecTyConName + repPlainTV (MkC nm) spec = do { (MkC spec') <- rep_flag spec + ; rep2 plainInvisTVName [nm, spec'] } + repKindedTV (MkC nm) spec (MkC ki) = do { (MkC spec') <- rep_flag spec + ; rep2 kindedInvisTVName [nm, spec', ki] } + +rep_flag :: Specificity -> MetaM (Core TH.Specificity) +rep_flag SpecifiedSpec = rep2_nw specifiedSpecName [] +rep_flag InferredSpec = rep2_nw inferredSpecName [] + +addSimpleTyVarBinds :: [Name] -- the binders to be added + -> MetaM (Core (M a)) -- action in the ext env -> MetaM (Core (M a)) addSimpleTyVarBinds names thing_inside = do { fresh_names <- mkGenSyms names ; term <- addBinds fresh_names thing_inside ; wrapGenSyms fresh_names term } -addHsTyVarBinds :: [LHsTyVarBndr GhcRn] -- the binders to be added - -> (Core [(M TH.TyVarBndr)] -> MetaM (Core (M a))) -- action in the ext env +addHsTyVarBinds :: forall flag flag' a. RepTV flag flag' + => [LHsTyVarBndr flag GhcRn] -- the binders to be added + -> (Core [(M (TH.TyVarBndr flag'))] -> MetaM (Core (M a))) -- action in the ext env -> MetaM (Core (M a)) addHsTyVarBinds exp_tvs thing_inside = do { fresh_exp_names <- mkGenSyms (hsLTyVarNames exp_tvs) ; term <- addBinds fresh_exp_names $ - do { kbs <- repListM tyVarBndrTyConName mk_tv_bndr + do { kbs <- repListM (tyVarBndrName @flag @flag') mk_tv_bndr (exp_tvs `zip` fresh_exp_names) ; thing_inside kbs } ; wrapGenSyms fresh_exp_names term } where mk_tv_bndr (tv, (_,v)) = repTyVarBndrWithKind tv (coreVar v) -addTyVarBinds :: LHsQTyVars GhcRn -- the binders to be added - -> (Core [(M TH.TyVarBndr)] -> MetaM (Core (M a))) -- action in the ext env +addQTyVarBinds :: LHsQTyVars GhcRn -- the binders to be added + -> (Core [(M (TH.TyVarBndr ()))] -> MetaM (Core (M a))) -- action in the ext env + -> MetaM (Core (M a)) +addQTyVarBinds (HsQTvs { hsq_ext = imp_tvs + , hsq_explicit = exp_tvs }) + thing_inside + = addTyVarBinds exp_tvs imp_tvs thing_inside + +addTyVarBinds :: RepTV flag flag' + => [LHsTyVarBndr flag GhcRn] -- the binders to be added + -> [Name] + -> (Core [(M (TH.TyVarBndr flag'))] -> MetaM (Core (M a))) -- action in the ext env -> MetaM (Core (M a)) -- gensym a list of type variables and enter them into the meta environment; -- the computations passed as the second argument is executed in that extended -- meta environment and gets the *new* names on Core-level as an argument -addTyVarBinds (HsQTvs { hsq_ext = imp_tvs - , hsq_explicit = exp_tvs }) - thing_inside +addTyVarBinds exp_tvs imp_tvs thing_inside = addSimpleTyVarBinds imp_tvs $ addHsTyVarBinds exp_tvs $ thing_inside addTyClTyVarBinds :: LHsQTyVars GhcRn - -> (Core [(M TH.TyVarBndr)] -> MetaM (Core (M a))) + -> (Core [(M (TH.TyVarBndr ()))] -> MetaM (Core (M a))) -> MetaM (Core (M a)) - -- Used for data/newtype declarations, and family instances, -- so that the nested type variables work right -- instance C (T a) where @@ -1161,34 +1197,36 @@ addTyClTyVarBinds tvs m -- This makes things work for family declarations ; term <- addBinds freshNames $ - do { kbs <- repListM tyVarBndrTyConName mk_tv_bndr + do { kbs <- repListM tyVarBndrUnitTyConName mk_tv_bndr (hsQTvExplicit tvs) ; m kbs } ; wrapGenSyms freshNames term } where - mk_tv_bndr :: LHsTyVarBndr GhcRn -> MetaM (Core (M TH.TyVarBndr)) + mk_tv_bndr :: LHsTyVarBndr () GhcRn -> MetaM (Core (M (TH.TyVarBndr ()))) mk_tv_bndr tv = do { v <- lookupBinder (hsLTyVarName tv) ; repTyVarBndrWithKind tv v } -- Produce kinded binder constructors from the Haskell tyvar binders -- -repTyVarBndrWithKind :: LHsTyVarBndr GhcRn - -> Core TH.Name -> MetaM (Core (M TH.TyVarBndr)) -repTyVarBndrWithKind (L _ (UserTyVar _ _)) nm - = repPlainTV nm -repTyVarBndrWithKind (L _ (KindedTyVar _ _ ki)) nm - = repLTy ki >>= repKindedTV nm +repTyVarBndrWithKind :: RepTV flag flag' => LHsTyVarBndr flag GhcRn + -> Core TH.Name -> MetaM (Core (M (TH.TyVarBndr flag'))) +repTyVarBndrWithKind (L _ (UserTyVar _ fl _)) nm + = repPlainTV nm fl +repTyVarBndrWithKind (L _ (KindedTyVar _ fl _ ki)) nm + = do { ki' <- repLTy ki + ; repKindedTV nm fl ki' } -- | Represent a type variable binder -repTyVarBndr :: LHsTyVarBndr GhcRn -> MetaM (Core (M TH.TyVarBndr)) -repTyVarBndr (L _ (UserTyVar _ (L _ nm)) ) +repTyVarBndr :: RepTV flag flag' + => LHsTyVarBndr flag GhcRn -> MetaM (Core (M (TH.TyVarBndr flag'))) +repTyVarBndr (L _ (UserTyVar _ fl (L _ nm)) ) = do { nm' <- lookupBinder nm - ; repPlainTV nm' } -repTyVarBndr (L _ (KindedTyVar _ (L _ nm) ki)) + ; repPlainTV nm' fl } +repTyVarBndr (L _ (KindedTyVar _ fl (L _ nm) ki)) = do { nm' <- lookupBinder nm ; ki' <- repLTy ki - ; repKindedTV nm' ki' } + ; repKindedTV nm' fl ki' } -- represent a type context -- @@ -1243,7 +1281,9 @@ repTy :: HsType GhcRn -> MetaM (Core (M TH.Type)) repTy ty@(HsForAllTy { hst_fvf = fvf, hst_bndrs = tvs, hst_body = body }) = case fvf of ForallInvis -> repForallT ty - ForallVis -> addHsTyVarBinds tvs $ \bndrs -> + ForallVis -> let tvs' = map ((<$>) (setHsTyVarBndrFlag ())) tvs + -- see Note [Specificity in HsForAllTy] in GHC.Hs.Types + in addHsTyVarBinds tvs' $ \bndrs -> do body1 <- repLTy body repTForallVis bndrs body1 repTy ty@(HsQualTy {}) = repForallT ty @@ -2332,8 +2372,8 @@ repFun :: Core TH.Name -> Core [(M TH.Clause)] -> MetaM (Core (M TH.Dec)) repFun (MkC nm) (MkC b) = rep2 funDName [nm, b] repData :: Core (M TH.Cxt) -> Core TH.Name - -> Either (Core [(M TH.TyVarBndr)]) - (Core (Maybe [(M TH.TyVarBndr)]), Core (M TH.Type)) + -> Either (Core [(M (TH.TyVarBndr ()))]) + (Core (Maybe [(M (TH.TyVarBndr ()))]), Core (M TH.Type)) -> Core (Maybe (M TH.Kind)) -> Core [(M TH.Con)] -> Core [M TH.DerivClause] -> MetaM (Core (M TH.Dec)) repData (MkC cxt) (MkC nm) (Left (MkC tvs)) (MkC ksig) (MkC cons) (MkC derivs) @@ -2343,8 +2383,8 @@ repData (MkC cxt) (MkC _) (Right (MkC mb_bndrs, MkC ty)) (MkC ksig) (MkC cons) = rep2 dataInstDName [cxt, mb_bndrs, ty, ksig, cons, derivs] repNewtype :: Core (M TH.Cxt) -> Core TH.Name - -> Either (Core [(M TH.TyVarBndr)]) - (Core (Maybe [(M TH.TyVarBndr)]), Core (M TH.Type)) + -> Either (Core [(M (TH.TyVarBndr ()))]) + (Core (Maybe [(M (TH.TyVarBndr ()))]), Core (M TH.Type)) -> Core (Maybe (M TH.Kind)) -> Core (M TH.Con) -> Core [M TH.DerivClause] -> MetaM (Core (M TH.Dec)) repNewtype (MkC cxt) (MkC nm) (Left (MkC tvs)) (MkC ksig) (MkC con) @@ -2354,7 +2394,7 @@ repNewtype (MkC cxt) (MkC _) (Right (MkC mb_bndrs, MkC ty)) (MkC ksig) (MkC con) (MkC derivs) = rep2 newtypeInstDName [cxt, mb_bndrs, ty, ksig, con, derivs] -repTySyn :: Core TH.Name -> Core [(M TH.TyVarBndr)] +repTySyn :: Core TH.Name -> Core [(M (TH.TyVarBndr ()))] -> Core (M TH.Type) -> MetaM (Core (M TH.Dec)) repTySyn (MkC nm) (MkC tvs) (MkC rhs) = rep2 tySynDName [nm, tvs, rhs] @@ -2409,7 +2449,7 @@ repOverlap mb = just = coreJust overlapTyConName -repClass :: Core (M TH.Cxt) -> Core TH.Name -> Core [(M TH.TyVarBndr)] +repClass :: Core (M TH.Cxt) -> Core TH.Name -> Core [(M (TH.TyVarBndr ()))] -> Core [TH.FunDep] -> Core [(M TH.Dec)] -> MetaM (Core (M TH.Dec)) repClass (MkC cxt) (MkC cls) (MkC tvs) (MkC fds) (MkC ds) @@ -2442,7 +2482,7 @@ repPragSpecInst (MkC ty) = rep2 pragSpecInstDName [ty] repPragComplete :: Core [TH.Name] -> Core (Maybe TH.Name) -> MetaM (Core (M TH.Dec)) repPragComplete (MkC cls) (MkC mty) = rep2 pragCompleteDName [cls, mty] -repPragRule :: Core String -> Core (Maybe [(M TH.TyVarBndr)]) +repPragRule :: Core String -> Core (Maybe [(M (TH.TyVarBndr ()))]) -> Core [(M TH.RuleBndr)] -> Core (M TH.Exp) -> Core (M TH.Exp) -> Core TH.Phases -> MetaM (Core (M TH.Dec)) repPragRule (MkC nm) (MkC ty_bndrs) (MkC tm_bndrs) (MkC lhs) (MkC rhs) (MkC phases) @@ -2455,13 +2495,13 @@ repTySynInst :: Core (M TH.TySynEqn) -> MetaM (Core (M TH.Dec)) repTySynInst (MkC eqn) = rep2 tySynInstDName [eqn] -repDataFamilyD :: Core TH.Name -> Core [(M TH.TyVarBndr)] +repDataFamilyD :: Core TH.Name -> Core [(M (TH.TyVarBndr ()))] -> Core (Maybe (M TH.Kind)) -> MetaM (Core (M TH.Dec)) repDataFamilyD (MkC nm) (MkC tvs) (MkC kind) = rep2 dataFamilyDName [nm, tvs, kind] repOpenFamilyD :: Core TH.Name - -> Core [(M TH.TyVarBndr)] + -> Core [(M (TH.TyVarBndr ()))] -> Core (M TH.FamilyResultSig) -> Core (Maybe TH.InjectivityAnn) -> MetaM (Core (M TH.Dec)) @@ -2469,7 +2509,7 @@ repOpenFamilyD (MkC nm) (MkC tvs) (MkC result) (MkC inj) = rep2 openTypeFamilyDName [nm, tvs, result, inj] repClosedFamilyD :: Core TH.Name - -> Core [(M TH.TyVarBndr)] + -> Core [(M (TH.TyVarBndr ()))] -> Core (M TH.FamilyResultSig) -> Core (Maybe TH.InjectivityAnn) -> Core [(M TH.TySynEqn)] @@ -2477,7 +2517,7 @@ repClosedFamilyD :: Core TH.Name repClosedFamilyD (MkC nm) (MkC tvs) (MkC res) (MkC inj) (MkC eqns) = rep2 closedTypeFamilyDName [nm, tvs, res, inj, eqns] -repTySynEqn :: Core (Maybe [(M TH.TyVarBndr)]) -> +repTySynEqn :: Core (Maybe [(M (TH.TyVarBndr ()))]) -> Core (M TH.Type) -> Core (M TH.Type) -> MetaM (Core (M TH.TySynEqn)) repTySynEqn (MkC mb_bndrs) (MkC lhs) (MkC rhs) = rep2 tySynEqnName [mb_bndrs, lhs, rhs] @@ -2560,12 +2600,12 @@ repConstr _ _ _ = ------------ Types ------------------- -repTForall :: Core [(M TH.TyVarBndr)] -> Core (M TH.Cxt) -> Core (M TH.Type) +repTForall :: Core [(M (TH.TyVarBndr TH.Specificity))] -> Core (M TH.Cxt) -> Core (M TH.Type) -> MetaM (Core (M TH.Type)) repTForall (MkC tvars) (MkC ctxt) (MkC ty) = rep2 forallTName [tvars, ctxt, ty] -repTForallVis :: Core [(M TH.TyVarBndr)] -> Core (M TH.Type) +repTForallVis :: Core [(M (TH.TyVarBndr ()))] -> Core (M TH.Type) -> MetaM (Core (M TH.Type)) repTForallVis (MkC tvars) (MkC ty) = rep2 forallVisTName [tvars, ty] @@ -2654,14 +2694,6 @@ repPromotedNilTyCon = rep2 promotedNilTName [] repPromotedConsTyCon :: MetaM (Core (M TH.Type)) repPromotedConsTyCon = rep2 promotedConsTName [] ------------- TyVarBndrs ------------------- - -repPlainTV :: Core TH.Name -> MetaM (Core (M TH.TyVarBndr)) -repPlainTV (MkC nm) = rep2 plainTVName [nm] - -repKindedTV :: Core TH.Name -> Core (M TH.Kind) -> MetaM (Core (M TH.TyVarBndr)) -repKindedTV (MkC nm) (MkC ki) = rep2 kindedTVName [nm, ki] - ---------------------------------------------------------- -- Type family result signature @@ -2671,7 +2703,7 @@ repNoSig = rep2 noSigName [] repKindSig :: Core (M TH.Kind) -> MetaM (Core (M TH.FamilyResultSig)) repKindSig (MkC ki) = rep2 kindSigName [ki] -repTyVarSig :: Core (M TH.TyVarBndr) -> MetaM (Core (M TH.FamilyResultSig)) +repTyVarSig :: Core (M (TH.TyVarBndr ())) -> MetaM (Core (M TH.FamilyResultSig)) repTyVarSig (MkC bndr) = rep2 tyVarSigName [bndr] ---------------------------------------------------------- diff --git a/compiler/GHC/Iface/Ext/Ast.hs b/compiler/GHC/Iface/Ext/Ast.hs index 6b469160e2..230ea6a884 100644 --- a/compiler/GHC/Iface/Ext/Ast.hs +++ b/compiler/GHC/Iface/Ext/Ast.hs @@ -394,8 +394,8 @@ patScopes rsp useScope patScope xs = tvScopes :: TyVarScope -> Scope - -> [LHsTyVarBndr a] - -> [TVScoped (LHsTyVarBndr a)] + -> [LHsTyVarBndr flag a] + -> [TVScoped (LHsTyVarBndr flag a)] tvScopes tvScope rhsScope xs = map (\(RS sc a)-> TVS tvScope sc a) $ listScopes rhsScope xs @@ -1395,10 +1395,11 @@ instance ToHie (Located OverlapMode) where instance ToHie (LConDecl GhcRn) where toHie (L span decl) = concatM $ makeNode decl span : case decl of - ConDeclGADT { con_names = names, con_qvars = qvars + ConDeclGADT { con_names = names, con_qvars = exp_vars, con_g_ext = imp_vars , con_mb_cxt = ctx, con_args = args, con_res_ty = typ } -> [ toHie $ map (C (Decl ConDec $ getRealSpan span)) names - , toHie $ TS (ResolvedScopes [ctxScope, rhsScope]) qvars + , concatM $ [ pure $ bindingsOnly bindings + , toHie $ tvScopes resScope NoScope exp_vars ] , toHie ctx , toHie args , toHie typ @@ -1408,6 +1409,8 @@ instance ToHie (LConDecl GhcRn) where ctxScope = maybe NoScope mkLScope ctx argsScope = condecl_scope args tyScope = mkLScope typ + resScope = ResolvedScopes [ctxScope, rhsScope] + bindings = map (C $ TyVarBind (mkScope (loc exp_vars)) resScope) imp_vars ConDeclH98 { con_name = name, con_ex_tvs = qvars , con_mb_cxt = ctx, con_args = dets } -> [ toHie $ C (Decl ConDec $ getRealSpan span) name @@ -1582,12 +1585,12 @@ instance (ToHie tm, ToHie ty) => ToHie (HsArg tm ty) where toHie (HsTypeArg _ ty) = toHie ty toHie (HsArgPar sp) = pure $ locOnly sp -instance ToHie (TVScoped (LHsTyVarBndr GhcRn)) where +instance Data flag => ToHie (TVScoped (LHsTyVarBndr flag GhcRn)) where toHie (TVS tsc sc (L span bndr)) = concatM $ makeNode bndr span : case bndr of - UserTyVar _ var -> + UserTyVar _ _ var -> [ toHie $ C (TyVarBind sc tsc) var ] - KindedTyVar _ var kind -> + KindedTyVar _ _ var kind -> [ toHie $ C (TyVarBind sc tsc) var , toHie kind ] diff --git a/compiler/GHC/Iface/Make.hs b/compiler/GHC/Iface/Make.hs index bb80d5d79b..e11ebd0dc7 100644 --- a/compiler/GHC/Iface/Make.hs +++ b/compiler/GHC/Iface/Make.hs @@ -574,7 +574,7 @@ tyConToIfaceDecl env tycon -- tidying produced. Therefore, tidying the user-written tyvars is a -- simple matter of looking up each variable in the substitution, -- which tidyTyCoVarOcc accomplishes. - tidyUserTyCoVarBinder :: TidyEnv -> TyCoVarBinder -> TyCoVarBinder + tidyUserTyCoVarBinder :: TidyEnv -> InvisTVBinder -> InvisTVBinder tidyUserTyCoVarBinder env (Bndr tv vis) = Bndr (tidyTyCoVarOcc env tv) vis diff --git a/compiler/GHC/Iface/Rename.hs b/compiler/GHC/Iface/Rename.hs index d7da10382c..b7d5895490 100644 --- a/compiler/GHC/Iface/Rename.hs +++ b/compiler/GHC/Iface/Rename.hs @@ -735,7 +735,7 @@ rnIfaceType (IfaceCoercionTy co) rnIfaceType (IfaceCastTy ty co) = IfaceCastTy <$> rnIfaceType ty <*> rnIfaceCo co -rnIfaceForAllBndr :: Rename IfaceForAllBndr +rnIfaceForAllBndr :: Rename (VarBndr IfaceBndr flag) rnIfaceForAllBndr (Bndr tv vis) = Bndr <$> rnIfaceBndr tv <*> pure vis rnIfaceAppArgs :: Rename IfaceAppArgs diff --git a/compiler/GHC/Iface/Syntax.hs b/compiler/GHC/Iface/Syntax.hs index e69e546a89..cfa34ab7bb 100644 --- a/compiler/GHC/Iface/Syntax.hs +++ b/compiler/GHC/Iface/Syntax.hs @@ -65,7 +65,7 @@ import GHC.Types.SrcLoc import GHC.Utils.Fingerprint import GHC.Utils.Binary import GHC.Data.BooleanFormula ( BooleanFormula, pprBooleanFormula, isTrue ) -import GHC.Types.Var( VarBndr(..), binderVar ) +import GHC.Types.Var( VarBndr(..), binderVar, tyVarSpecToBinders ) import GHC.Core.TyCon ( Role (..), Injectivity(..), tyConBndrVisArgFlag ) import GHC.Utils.Misc( dropList, filterByList, notNull, unzipWith, debugIsOn ) import GHC.Core.DataCon (SrcStrictness(..), SrcUnpackedness(..)) @@ -163,8 +163,8 @@ data IfaceDecl ifPatBuilder :: Maybe (IfExtName, Bool), -- Everything below is redundant, -- but needed to implement pprIfaceDecl - ifPatUnivBndrs :: [IfaceForAllBndr], - ifPatExBndrs :: [IfaceForAllBndr], + ifPatUnivBndrs :: [IfaceForAllSpecBndr], + ifPatExBndrs :: [IfaceForAllSpecBndr], ifPatProvCtxt :: IfaceContext, ifPatReqCtxt :: IfaceContext, ifPatArgs :: [IfaceType], @@ -248,7 +248,7 @@ data IfaceConDecl -- So this guarantee holds for IfaceConDecl, but *not* for DataCon ifConExTCvs :: [IfaceBndr], -- Existential ty/covars - ifConUserTvBinders :: [IfaceForAllBndr], + ifConUserTvBinders :: [IfaceForAllSpecBndr], -- The tyvars, in the order the user wrote them -- INVARIANT: the set of tyvars in ifConUserTvBinders is exactly the -- set of tyvars (*not* covars) of ifConExTCvs, unioned @@ -970,8 +970,8 @@ pprIfaceDecl _ (IfacePatSyn { ifName = name, , pprIfaceContextArr prov_ctxt , pprIfaceType $ foldr (IfaceFunTy VisArg) pat_ty arg_tys ]) where - univ_msg = pprUserIfaceForAll univ_bndrs - ex_msg = pprUserIfaceForAll ex_bndrs + univ_msg = pprUserIfaceForAll $ tyVarSpecToBinders univ_bndrs + ex_msg = pprUserIfaceForAll $ tyVarSpecToBinders ex_bndrs insert_empty_ctxt = null req_ctxt && not (null prov_ctxt && isEmpty sdocCtx ex_msg) @@ -1099,9 +1099,9 @@ pprIfaceConDecl ss gadt_style tycon tc_binders parent -- the visibilities of the existential tyvar binders, we can simply drop -- the universal tyvar binders from user_tvbs. ex_tvbs = dropList tc_binders user_tvbs - ppr_ex_quant = pprIfaceForAllPartMust ex_tvbs ctxt + ppr_ex_quant = pprIfaceForAllPartMust (ifaceForAllSpecToBndrs ex_tvbs) ctxt pp_gadt_res_ty = mk_user_con_res_ty eq_spec - ppr_gadt_ty = pprIfaceForAllPart user_tvbs ctxt pp_tau + ppr_gadt_ty = pprIfaceForAllPart (ifaceForAllSpecToBndrs user_tvbs) ctxt pp_tau -- A bit gruesome this, but we can't form the full con_tau, and ppr it, -- because we don't have a Name for the tycon, only an OccName diff --git a/compiler/GHC/Iface/Type.hs b/compiler/GHC/Iface/Type.hs index 40ba0d54a1..63b6b33734 100644 --- a/compiler/GHC/Iface/Type.hs +++ b/compiler/GHC/Iface/Type.hs @@ -6,11 +6,19 @@ This module defines interface types and binders -} -{-# LANGUAGE CPP, FlexibleInstances, BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} + -- FlexibleInstances for Binary (DefMethSpec IfaceType) +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE LambdaCase #-} - -- FlexibleInstances for Binary (DefMethSpec IfaceType) + +#if !MIN_VERSION_GLASGOW_HASKELL(8,10,0,0) +{-# OPTIONS_GHC -Wno-overlapping-patterns -Wno-incomplete-patterns #-} + -- N.B. This can be dropped once GHC 8.8 can be dropped as a + -- bootstrap compiler. +#endif module GHC.Iface.Type ( IfExtName, IfLclName, @@ -22,10 +30,12 @@ module GHC.Iface.Type ( IfaceTyLit(..), IfaceAppArgs(..), IfaceContext, IfaceBndr(..), IfaceOneShot(..), IfaceLamBndr, IfaceTvBndr, IfaceIdBndr, IfaceTyConBinder, + IfaceForAllSpecBndr, IfaceForAllBndr, ArgFlag(..), AnonArgFlag(..), ForallVisFlag(..), ShowForAllFlag(..), mkIfaceForAllTvBndr, mkIfaceTyConKind, + ifaceForAllSpecToBndrs, ifaceForAllSpecToBndr, ifForAllBndrVar, ifForAllBndrName, ifaceBndrName, ifTyConBinderVar, ifTyConBinderName, @@ -168,8 +178,9 @@ data IfaceTyLit | IfaceStrTyLit FastString deriving (Eq) -type IfaceTyConBinder = VarBndr IfaceBndr TyConBndrVis -type IfaceForAllBndr = VarBndr IfaceBndr ArgFlag +type IfaceTyConBinder = VarBndr IfaceBndr TyConBndrVis +type IfaceForAllBndr = VarBndr IfaceBndr ArgFlag +type IfaceForAllSpecBndr = VarBndr IfaceBndr Specificity -- | Make an 'IfaceForAllBndr' from an 'IfaceTvBndr'. mkIfaceForAllTvBndr :: ArgFlag -> IfaceTvBndr -> IfaceForAllBndr @@ -184,6 +195,12 @@ mkIfaceTyConKind bndrs res_kind = foldr mk res_kind bndrs mk (Bndr tv (AnonTCB af)) k = IfaceFunTy af (ifaceBndrType tv) k mk (Bndr tv (NamedTCB vis)) k = IfaceForAllTy (Bndr tv vis) k +ifaceForAllSpecToBndrs :: [IfaceForAllSpecBndr] -> [IfaceForAllBndr] +ifaceForAllSpecToBndrs = map ifaceForAllSpecToBndr + +ifaceForAllSpecToBndr :: IfaceForAllSpecBndr -> IfaceForAllBndr +ifaceForAllSpecToBndr (Bndr tv spec) = Bndr tv (Invisible spec) + -- | Stores the arguments in a type application as a list. -- See @Note [Suppressing invisible arguments]@. data IfaceAppArgs @@ -781,8 +798,10 @@ pprIfaceTyConBinders suppress_sig = sep . map go -- The above case is rare. (See Note [AnonTCB InvisArg] in GHC.Core.TyCon.) -- Should we print these differently? NamedTCB Required -> ppr_bndr (UseBndrParens True) - NamedTCB Specified -> char '@' <> ppr_bndr (UseBndrParens True) - NamedTCB Inferred -> char '@' <> braces (ppr_bndr (UseBndrParens False)) + -- See Note [Explicit Case Statement for Specificity] + NamedTCB (Invisible spec) -> case spec of + SpecifiedSpec -> char '@' <> ppr_bndr (UseBndrParens True) + InferredSpec -> char '@' <> braces (ppr_bndr (UseBndrParens False)) where ppr_bndr = pprIfaceTvBndr bndr suppress_sig diff --git a/compiler/GHC/Iface/Type.hs-boot b/compiler/GHC/Iface/Type.hs-boot index 3876cb0618..2d896350a2 100644 --- a/compiler/GHC/Iface/Type.hs-boot +++ b/compiler/GHC/Iface/Type.hs-boot @@ -1,10 +1,12 @@ module GHC.Iface.Type - ( IfaceType, IfaceTyCon, IfaceForAllBndr + ( IfaceType, IfaceTyCon, IfaceBndr , IfaceCoercion, IfaceTyLit, IfaceAppArgs ) where -import GHC.Types.Var (VarBndr, ArgFlag) +-- Empty import to influence the compilation ordering. +-- See note [Depend on GHC.Integer] in GHC.Base +import GHC.Base () data IfaceAppArgs @@ -13,4 +15,3 @@ data IfaceTyCon data IfaceTyLit data IfaceCoercion data IfaceBndr -type IfaceForAllBndr = VarBndr IfaceBndr ArgFlag diff --git a/compiler/GHC/IfaceToCore.hs b/compiler/GHC/IfaceToCore.hs index 0a78e28790..d1e3bfa4bd 100644 --- a/compiler/GHC/IfaceToCore.hs +++ b/compiler/GHC/IfaceToCore.hs @@ -894,7 +894,7 @@ tcIfaceDataCons tycon_name tycon tc_tybinders if_cons ; mkNewTyConRhs tycon_name tycon data_con } where univ_tvs :: [TyVar] - univ_tvs = binderVars (tyConTyVarBinders tc_tybinders) + univ_tvs = binderVars tc_tybinders tag_map :: NameEnv ConTag tag_map = mkTyConTagMap tycon @@ -1771,14 +1771,14 @@ bindIfaceBndrs (b:bs) thing_inside thing_inside (b':bs') ----------------------- -bindIfaceForAllBndrs :: [IfaceForAllBndr] -> ([TyCoVarBinder] -> IfL a) -> IfL a +bindIfaceForAllBndrs :: [VarBndr IfaceBndr vis] -> ([VarBndr TyCoVar vis] -> IfL a) -> IfL a bindIfaceForAllBndrs [] thing_inside = thing_inside [] bindIfaceForAllBndrs (bndr:bndrs) thing_inside = bindIfaceForAllBndr bndr $ \tv vis -> bindIfaceForAllBndrs bndrs $ \bndrs' -> - thing_inside (mkTyCoVarBinder vis tv : bndrs') + thing_inside (Bndr tv vis : bndrs') -bindIfaceForAllBndr :: IfaceForAllBndr -> (TyCoVar -> ArgFlag -> IfL a) -> IfL a +bindIfaceForAllBndr :: (VarBndr IfaceBndr vis) -> (TyCoVar -> vis -> IfL a) -> IfL a bindIfaceForAllBndr (Bndr (IfaceTvBndr tv) vis) thing_inside = bindIfaceTyVar tv $ \tv' -> thing_inside tv' vis bindIfaceForAllBndr (Bndr (IfaceIdBndr tv) vis) thing_inside diff --git a/compiler/GHC/Parser.y b/compiler/GHC/Parser.y index 7c0790da12..c9b5f1f893 100644 --- a/compiler/GHC/Parser.y +++ b/compiler/GHC/Parser.y @@ -74,7 +74,7 @@ import GHC.Unit.Module import GHC.Types.Basic import GHC.Types.ForeignCall -import GHC.Core.Type ( funTyCon ) +import GHC.Core.Type ( funTyCon, Specificity(..) ) import GHC.Core.Class ( FunDep ) -- compiler/parser @@ -1272,7 +1272,8 @@ ty_fam_inst_eqns :: { Located [LTyFamInstEqn GhcPs] } ty_fam_inst_eqn :: { Located ([AddAnn],TyFamInstEqn GhcPs) } : 'forall' tv_bndrs '.' type '=' ktype {% do { hintExplicitForall $1 - ; (eqn,ann) <- mkTyFamInstEqn (Just $2) $4 $6 + ; tvb <- fromSpecTyVarBndrs $2 + ; (eqn,ann) <- mkTyFamInstEqn (Just tvb) $4 $6 ; return (sLL $1 $> (mu AnnForall $1:mj AnnDot $3:mj AnnEqual $5:ann,eqn)) } } | type '=' ktype @@ -1374,16 +1375,18 @@ opt_datafam_kind_sig :: { Located ([AddAnn], LFamilyResultSig GhcPs) } opt_tyfam_kind_sig :: { Located ([AddAnn], LFamilyResultSig GhcPs) } : { noLoc ([] , noLoc (NoSig noExtField) )} | '::' kind { sLL $1 $> ([mu AnnDcolon $1], sLL $1 $> (KindSig noExtField $2))} - | '=' tv_bndr { sLL $1 $> ([mj AnnEqual $1] , sLL $1 $> (TyVarSig noExtField $2))} + | '=' tv_bndr {% do { tvb <- fromSpecTyVarBndr $2 + ; return $ sLL $1 $> ([mj AnnEqual $1] , sLL $1 $> (TyVarSig noExtField tvb))} } opt_at_kind_inj_sig :: { Located ([AddAnn], ( LFamilyResultSig GhcPs , Maybe (LInjectivityAnn GhcPs)))} : { noLoc ([], (noLoc (NoSig noExtField), Nothing)) } | '::' kind { sLL $1 $> ( [mu AnnDcolon $1] , (sLL $2 $> (KindSig noExtField $2), Nothing)) } - | '=' tv_bndr '|' injectivity_cond - { sLL $1 $> ([mj AnnEqual $1, mj AnnVbar $3] - , (sLL $1 $2 (TyVarSig noExtField $2), Just $4))} + | '=' tv_bndr_no_braces '|' injectivity_cond + {% do { tvb <- fromSpecTyVarBndr $2 + ; return $ sLL $1 $> ([mj AnnEqual $1, mj AnnVbar $3] + , (sLL $1 $2 (TyVarSig noExtField tvb), Just $4))} } -- tycl_hdr parses the header of a class or data type decl, -- which takes the form @@ -1398,17 +1401,19 @@ tycl_hdr :: { Located (Maybe (LHsContext GhcPs), LHsType GhcPs) } } | type { sL1 $1 (Nothing, $1) } -tycl_hdr_inst :: { Located ([AddAnn],(Maybe (LHsContext GhcPs), Maybe [LHsTyVarBndr GhcPs], LHsType GhcPs)) } +tycl_hdr_inst :: { Located ([AddAnn],(Maybe (LHsContext GhcPs), Maybe [LHsTyVarBndr () GhcPs], LHsType GhcPs)) } : 'forall' tv_bndrs '.' context '=>' type {% hintExplicitForall $1 - >> (addAnnotation (gl $4) (toUnicodeAnn AnnDarrow $5) (gl $5) - >> return (sLL $1 $> ([mu AnnForall $1, mj AnnDot $3] - , (Just $4, Just $2, $6))) + >> fromSpecTyVarBndrs $2 + >>= \tvbs -> (addAnnotation (gl $4) (toUnicodeAnn AnnDarrow $5) (gl $5) + >> return (sLL $1 $> ([mu AnnForall $1, mj AnnDot $3] + , (Just $4, Just tvbs, $6))) ) } - | 'forall' tv_bndrs '.' type {% hintExplicitForall $1 - >> return (sLL $1 $> ([mu AnnForall $1, mj AnnDot $3] - , (Nothing, Just $2, $4))) - } + | 'forall' tv_bndrs '.' type {% do { hintExplicitForall $1 + ; tvbs <- fromSpecTyVarBndrs $2 + ; return (sLL $1 $> ([mu AnnForall $1, mj AnnDot $3] + , (Nothing, Just tvbs, $4))) + } } | context '=>' type {% addAnnotation (gl $1) (toUnicodeAnn AnnDarrow $2) (gl $2) >> (return (sLL $1 $>([], (Just $1, Nothing, $3)))) } @@ -1702,7 +1707,7 @@ rule_explicit_activation :: { ([AddAnn] { ($2++[mos $1,mcs $3] ,NeverActive) } -rule_foralls :: { ([AddAnn], Maybe [LHsTyVarBndr GhcPs], [LRuleBndr GhcPs]) } +rule_foralls :: { ([AddAnn], Maybe [LHsTyVarBndr () GhcPs], [LRuleBndr GhcPs]) } : 'forall' rule_vars '.' 'forall' rule_vars '.' {% let tyvs = mkRuleTyVarBndrs $2 in hintExplicitForall $1 >> checkRuleTyVarBndrNames (mkRuleTyVarBndrs $2) @@ -2136,13 +2141,21 @@ bar_types2 :: { [LHsType GhcPs] } -- Two or more: ty|ty|ty | ktype '|' bar_types2 {% addAnnotation (gl $1) AnnVbar (gl $2) >> return ($1 : $3) } -tv_bndrs :: { [LHsTyVarBndr GhcPs] } +tv_bndrs :: { [LHsTyVarBndr Specificity GhcPs] } : tv_bndr tv_bndrs { $1 : $2 } | {- empty -} { [] } -tv_bndr :: { LHsTyVarBndr GhcPs } - : tyvar { sL1 $1 (UserTyVar noExtField $1) } - | '(' tyvar '::' kind ')' {% ams (sLL $1 $> (KindedTyVar noExtField $2 $4)) +tv_bndr :: { LHsTyVarBndr Specificity GhcPs } + : tv_bndr_no_braces { $1 } + | '{' tyvar '}' {% ams (sLL $1 $> (UserTyVar noExtField InferredSpec $2)) + [mop $1, mcp $3] } + | '{' tyvar '::' kind '}' {% ams (sLL $1 $> (KindedTyVar noExtField InferredSpec $2 $4)) + [mop $1,mu AnnDcolon $3 + ,mcp $5] } + +tv_bndr_no_braces :: { LHsTyVarBndr Specificity GhcPs } + : tyvar { sL1 $1 (UserTyVar noExtField SpecifiedSpec $1) } + | '(' tyvar '::' kind ')' {% ams (sLL $1 $> (KindedTyVar noExtField SpecifiedSpec $2 $4)) [mop $1,mu AnnDcolon $3 ,mcp $5] } @@ -2331,7 +2344,7 @@ constr :: { LConDecl GhcPs } ($1 `mplus` doc_prev)) (fst $ unLoc $2) } -forall :: { Located ([AddAnn], Maybe [LHsTyVarBndr GhcPs]) } +forall :: { Located ([AddAnn], Maybe [LHsTyVarBndr Specificity GhcPs]) } : 'forall' tv_bndrs '.' { sLL $1 $> ([mu AnnForall $1,mj AnnDot $3], Just $2) } | {- empty -} { noLoc ([], Nothing) } diff --git a/compiler/GHC/Parser/PostProcess.hs b/compiler/GHC/Parser/PostProcess.hs index b9bff61599..c0afde8242 100644 --- a/compiler/GHC/Parser/PostProcess.hs +++ b/compiler/GHC/Parser/PostProcess.hs @@ -36,6 +36,7 @@ module GHC.Parser.PostProcess ( mkRdrRecordCon, mkRdrRecordUpd, setRdrNameSpace, filterCTuple, + fromSpecTyVarBndr, fromSpecTyVarBndrs, cvBindGroup, cvBindsAndSigs, @@ -114,7 +115,7 @@ import GHC.Types.Name import GHC.Types.Basic import GHC.Parser.Lexer import GHC.Utils.Lexeme ( isLexCon ) -import GHC.Core.Type ( TyThing(..), funTyCon ) +import GHC.Core.Type ( TyThing(..), funTyCon, Specificity(..) ) import GHC.Builtin.Types( cTupleTyConName, tupleTyCon, tupleDataCon, nilDataConName, nilDataConKey, listTyConName, listTyConKey, eqTyCon_RDR, @@ -264,7 +265,7 @@ mkStandaloneKindSig loc lhs rhs = 2 (pprWithCommas ppr vs) , text "See https://gitlab.haskell.org/ghc/ghc/issues/16754 for details." ] -mkTyFamInstEqn :: Maybe [LHsTyVarBndr GhcPs] +mkTyFamInstEqn :: Maybe [LHsTyVarBndr () GhcPs] -> LHsType GhcPs -> LHsType GhcPs -> P (TyFamInstEqn GhcPs,[AddAnn]) @@ -282,7 +283,7 @@ mkTyFamInstEqn bndrs lhs rhs mkDataFamInst :: SrcSpan -> NewOrData -> Maybe (Located CType) - -> (Maybe ( LHsContext GhcPs), Maybe [LHsTyVarBndr GhcPs] + -> (Maybe ( LHsContext GhcPs), Maybe [LHsTyVarBndr () GhcPs] , LHsType GhcPs) -> Maybe (LHsKind GhcPs) -> [LConDecl GhcPs] @@ -382,6 +383,27 @@ mkRoleAnnotDecl loc tycon roles suggestions list = hang (text "Perhaps you meant one of these:") 2 (pprWithCommas (quotes . ppr) list) +-- | Converts a list of 'LHsTyVarBndr's annotated with their 'Specificity' to +-- binders without annotations. Only accepts specified variables, and errors if +-- any of the provided binders has an 'InferredSpec' annotation. +fromSpecTyVarBndrs :: [LHsTyVarBndr Specificity GhcPs] -> P [LHsTyVarBndr () GhcPs] +fromSpecTyVarBndrs = mapM fromSpecTyVarBndr + +-- | Converts 'LHsTyVarBndr' annotated with its 'Specificity' to one without +-- annotations. Only accepts specified variables, and errors if the provided +-- binder has an 'InferredSpec' annotation. +fromSpecTyVarBndr :: LHsTyVarBndr Specificity GhcPs -> P (LHsTyVarBndr () GhcPs) +fromSpecTyVarBndr bndr = case bndr of + (L loc (UserTyVar xtv flag idp)) -> (check_spec flag loc) + >> return (L loc $ UserTyVar xtv () idp) + (L loc (KindedTyVar xtv flag idp k)) -> (check_spec flag loc) + >> return (L loc $ KindedTyVar xtv () idp k) + where + check_spec :: Specificity -> SrcSpan -> P () + check_spec SpecifiedSpec _ = return () + check_spec InferredSpec loc = addFatalError loc + (text "Inferred type variables are not allowed here") + {- ********************************************************************** #cvBinds-etc# Converting to @HsBinds@, etc. @@ -650,7 +672,7 @@ recordPatSynErr loc pat = text "record syntax not supported for pattern synonym declarations:" $$ ppr pat -mkConDeclH98 :: Located RdrName -> Maybe [LHsTyVarBndr GhcPs] +mkConDeclH98 :: Located RdrName -> Maybe [LHsTyVarBndr Specificity GhcPs] -> Maybe (LHsContext GhcPs) -> HsConDeclDetails GhcPs -> ConDecl GhcPs @@ -670,7 +692,7 @@ mkGadtDecl names ty = (ConDeclGADT { con_g_ext = noExtField , con_names = names , con_forall = L l $ isLHsForAllTy ty' - , con_qvars = mkHsQTvs tvs + , con_qvars = tvs , con_mb_cxt = mcxt , con_args = args , con_res_ty = res_ty @@ -819,18 +841,18 @@ checkTyVars pp_what equals_or_where tc tparms <+> text "declaration for" <+> quotes (ppr tc)] -- Keep around an action for adjusting the annotations of extra parens chkParens :: [AddAnn] -> LHsType GhcPs - -> P (LHsTyVarBndr GhcPs, [AddAnn]) + -> P (LHsTyVarBndr () GhcPs, [AddAnn]) chkParens acc (L l (HsParTy _ ty)) = chkParens (mkParensApiAnn l ++ acc) ty chkParens acc ty = do tv <- chk ty return (tv, reverse acc) -- Check that the name space is correct! - chk :: LHsType GhcPs -> P (LHsTyVarBndr GhcPs) + chk :: LHsType GhcPs -> P (LHsTyVarBndr () GhcPs) chk (L l (HsKindSig _ (L lv (HsTyVar _ _ (L _ tv))) k)) - | isRdrTyVar tv = return (L l (KindedTyVar noExtField (L lv tv) k)) + | isRdrTyVar tv = return (L l (KindedTyVar noExtField () (L lv tv) k)) chk (L l (HsTyVar _ _ (L ltv tv))) - | isRdrTyVar tv = return (L l (UserTyVar noExtField (L ltv tv))) + | isRdrTyVar tv = return (L l (UserTyVar noExtField () (L ltv tv))) chk t@(L loc _) = addFatalError loc $ vcat [ text "Unexpected type" <+> quotes (ppr t) @@ -877,17 +899,18 @@ mkRuleBndrs = fmap (fmap cvt_one) RuleBndrSig noExtField v (mkHsPatSigType sig) -- turns RuleTyTmVars into HsTyVarBndrs - this is more interesting -mkRuleTyVarBndrs :: [LRuleTyTmVar] -> [LHsTyVarBndr GhcPs] +mkRuleTyVarBndrs :: [LRuleTyTmVar] -> [LHsTyVarBndr () GhcPs] mkRuleTyVarBndrs = fmap (fmap cvt_one) - where cvt_one (RuleTyTmVar v Nothing) = UserTyVar noExtField (fmap tm_to_ty v) + where cvt_one (RuleTyTmVar v Nothing) + = UserTyVar noExtField () (fmap tm_to_ty v) cvt_one (RuleTyTmVar v (Just sig)) - = KindedTyVar noExtField (fmap tm_to_ty v) sig + = KindedTyVar noExtField () (fmap tm_to_ty v) sig -- takes something in namespace 'varName' to something in namespace 'tvName' tm_to_ty (Unqual occ) = Unqual (setOccNameSpace tvName occ) tm_to_ty _ = panic "mkRuleTyVarBndrs" --- See note [Parsing explicit foralls in Rules] in GHC.Parser -checkRuleTyVarBndrNames :: [LHsTyVarBndr GhcPs] -> P () +-- See note [Parsing explicit foralls in Rules] in Parser.y +checkRuleTyVarBndrNames :: [LHsTyVarBndr flag GhcPs] -> P () checkRuleTyVarBndrNames = mapM_ (check . fmap hsTyVarName) where check (L loc (Unqual occ)) = do when ((occNameString occ ==) `any` ["forall","family","role"]) diff --git a/compiler/GHC/Rename/Bind.hs b/compiler/GHC/Rename/Bind.hs index a2566220b6..bb4a3c1b76 100644 --- a/compiler/GHC/Rename/Bind.hs +++ b/compiler/GHC/Rename/Bind.hs @@ -955,7 +955,7 @@ renameSig _ (IdSig _ x) renameSig ctxt sig@(TypeSig _ vs ty) = do { new_vs <- mapM (lookupSigOccRn ctxt sig) vs ; let doc = TypeSigCtx (ppr_sig_bndrs vs) - ; (new_ty, fvs) <- rnHsSigWcType doc ty + ; (new_ty, fvs) <- rnHsSigWcType doc Nothing ty ; return (TypeSig noExtField new_vs new_ty, fvs) } renameSig ctxt sig@(ClassOpSig _ is_deflt vs ty) @@ -963,16 +963,21 @@ renameSig ctxt sig@(ClassOpSig _ is_deflt vs ty) ; when (is_deflt && not defaultSigs_on) $ addErr (defaultSigErr sig) ; new_v <- mapM (lookupSigOccRn ctxt sig) vs - ; (new_ty, fvs) <- rnHsSigType ty_ctxt TypeLevel ty + ; (new_ty, fvs) <- rnHsSigType ty_ctxt TypeLevel inf_msg ty ; return (ClassOpSig noExtField is_deflt new_v new_ty, fvs) } where (v1:_) = vs ty_ctxt = GenericCtx (text "a class method signature for" <+> quotes (ppr v1)) + inf_msg = if is_deflt + then Just (text "A default type signature cannot contain inferred type variables") + else Nothing renameSig _ (SpecInstSig _ src ty) - = do { (new_ty, fvs) <- rnHsSigType SpecInstSigCtx TypeLevel ty + = do { (new_ty, fvs) <- rnHsSigType SpecInstSigCtx TypeLevel inf_msg ty ; return (SpecInstSig noExtField src new_ty,fvs) } + where + inf_msg = Just (text "Inferred type variables are not allowed") -- {-# SPECIALISE #-} pragmas can refer to imported Ids -- so, in the top-level case (when mb_names is Nothing) @@ -988,7 +993,7 @@ renameSig ctxt sig@(SpecSig _ v tys inl) ty_ctxt = GenericCtx (text "a SPECIALISE signature for" <+> quotes (ppr v)) do_one (tys,fvs) ty - = do { (new_ty, fvs_ty) <- rnHsSigType ty_ctxt TypeLevel ty + = do { (new_ty, fvs_ty) <- rnHsSigType ty_ctxt TypeLevel Nothing ty ; return ( new_ty:tys, fvs_ty `plusFV` fvs) } renameSig ctxt sig@(InlineSig _ v s) @@ -1005,7 +1010,7 @@ renameSig ctxt sig@(MinimalSig _ s (L l bf)) renameSig ctxt sig@(PatSynSig _ vs ty) = do { new_vs <- mapM (lookupSigOccRn ctxt sig) vs - ; (ty', fvs) <- rnHsSigType ty_ctxt TypeLevel ty + ; (ty', fvs) <- rnHsSigType ty_ctxt TypeLevel Nothing ty ; return (PatSynSig noExtField new_vs ty', fvs) } where ty_ctxt = GenericCtx (text "a pattern synonym signature for" diff --git a/compiler/GHC/Rename/Expr.hs b/compiler/GHC/Rename/Expr.hs index 5ac352b0d0..db05756067 100644 --- a/compiler/GHC/Rename/Expr.hs +++ b/compiler/GHC/Rename/Expr.hs @@ -316,7 +316,7 @@ rnExpr (RecordUpd { rupd_expr = expr, rupd_flds = rbinds }) , fvExpr `plusFV` fvRbinds) } rnExpr (ExprWithTySig _ expr pty) - = do { (pty', fvTy) <- rnHsSigWcType ExprWithTySigCtx pty + = do { (pty', fvTy) <- rnHsSigWcType ExprWithTySigCtx Nothing pty ; (expr', fvExpr) <- bindSigTyVarsFV (hsWcScopedTvs pty') $ rnLExpr expr ; return (ExprWithTySig noExtField expr' pty', fvExpr `plusFV` fvTy) } diff --git a/compiler/GHC/Rename/HsType.hs b/compiler/GHC/Rename/HsType.hs index f3727221a0..1b3b601e23 100644 --- a/compiler/GHC/Rename/HsType.hs +++ b/compiler/GHC/Rename/HsType.hs @@ -36,6 +36,7 @@ import GHC.Prelude import {-# SOURCE #-} GHC.Rename.Splice( rnSpliceType ) +import GHC.Core.Type import GHC.Driver.Session import GHC.Hs import GHC.Rename.Doc ( rnLHsDoc, rnMbLHsDoc ) @@ -64,7 +65,7 @@ import GHC.Data.FastString import GHC.Data.Maybe import qualified GHC.LanguageExtensions as LangExt -import Data.List ( nubBy, partition, (\\) ) +import Data.List ( nubBy, partition, (\\), find ) import Control.Monad ( unless, when ) #include "HsVersions.h" @@ -119,16 +120,21 @@ data HsSigWcTypeScoping -- See also @Note [Pattern signature binders and scoping]@ in -- "GHC.Hs.Types". -rnHsSigWcType :: HsDocContext -> LHsSigWcType GhcPs +rnHsSigWcType :: HsDocContext + -> Maybe SDoc + -- ^ The error msg if the signature is not allowed to contain + -- manually written inferred variables. + -> LHsSigWcType GhcPs -> RnM (LHsSigWcType GhcRn, FreeVars) -rnHsSigWcType doc (HsWC { hswc_body = HsIB { hsib_body = hs_ty }}) - = rn_hs_sig_wc_type BindUnlessForall doc hs_ty $ \nwcs imp_tvs body -> +rnHsSigWcType doc inf_err (HsWC { hswc_body = HsIB { hsib_body = hs_ty }}) + = rn_hs_sig_wc_type BindUnlessForall doc inf_err hs_ty $ \nwcs imp_tvs body -> let ib_ty = HsIB { hsib_ext = imp_tvs, hsib_body = body } wc_ty = HsWC { hswc_ext = nwcs, hswc_body = ib_ty } in pure (wc_ty, emptyFVs) rnHsPatSigType :: HsSigWcTypeScoping - -> HsDocContext -> HsPatSigType GhcPs + -> HsDocContext -> Maybe SDoc + -> HsPatSigType GhcPs -> (HsPatSigType GhcRn -> RnM (a, FreeVars)) -> RnM (a, FreeVars) -- Used for @@ -138,10 +144,10 @@ rnHsPatSigType :: HsSigWcTypeScoping -- Wildcards are allowed -- -- See Note [Pattern signature binders and scoping] in GHC.Hs.Types -rnHsPatSigType scoping ctx sig_ty thing_inside +rnHsPatSigType scoping ctx inf_err sig_ty thing_inside = do { ty_sig_okay <- xoptM LangExt.ScopedTypeVariables ; checkErr ty_sig_okay (unexpectedPatSigTypeErr sig_ty) - ; rn_hs_sig_wc_type scoping ctx (hsPatSigType sig_ty) $ + ; rn_hs_sig_wc_type scoping ctx inf_err (hsPatSigType sig_ty) $ \nwcs imp_tvs body -> do { let sig_names = HsPSRn { hsps_nwcs = nwcs, hsps_imp_tvs = imp_tvs } sig_ty' = HsPS { hsps_ext = sig_names, hsps_body = body } @@ -149,14 +155,16 @@ rnHsPatSigType scoping ctx sig_ty thing_inside } } -- The workhorse for rnHsSigWcType and rnHsPatSigType. -rn_hs_sig_wc_type :: HsSigWcTypeScoping -> HsDocContext -> LHsType GhcPs +rn_hs_sig_wc_type :: HsSigWcTypeScoping -> HsDocContext -> Maybe SDoc + -> LHsType GhcPs -> ([Name] -- Wildcard names -> [Name] -- Implicitly bound type variable names -> LHsType GhcRn -> RnM (a, FreeVars)) -> RnM (a, FreeVars) -rn_hs_sig_wc_type scoping ctxt hs_ty thing_inside - = do { free_vars <- extractFilteredRdrTyVarsDups hs_ty +rn_hs_sig_wc_type scoping ctxt inf_err hs_ty thing_inside + = do { check_inferred_vars ctxt inf_err hs_ty + ; free_vars <- extractFilteredRdrTyVarsDups hs_ty ; (nwc_rdrs', tv_rdrs) <- partition_nwcs free_vars ; let nwc_rdrs = nubL nwc_rdrs' implicit_bndrs = case scoping of @@ -323,13 +331,17 @@ of the HsWildCardBndrs structure, and we are done. rnHsSigType :: HsDocContext -> TypeOrKind + -> Maybe SDoc + -- ^ The error msg if the signature is not allowed to contain + -- manually written inferred variables. -> LHsSigType GhcPs -> RnM (LHsSigType GhcRn, FreeVars) -- Used for source-language type signatures -- that cannot have wildcards -rnHsSigType ctx level (HsIB { hsib_body = hs_ty }) +rnHsSigType ctx level inf_err (HsIB { hsib_body = hs_ty }) = do { traceRn "rnHsSigType" (ppr hs_ty) ; vars <- extractFilteredRdrTyVarsDups hs_ty + ; check_inferred_vars ctx inf_err hs_ty ; rnImplicitBndrs (forAllOrNothing (isLHsForAllTy hs_ty) vars) $ \ vars -> do { (body', fvs) <- rnLHsTyKi (mkTyKiEnv ctx level RnTypeBody) hs_ty @@ -383,6 +395,25 @@ rnImplicitBndrs implicit_vs_with_dups ; bindLocalNamesFV vars $ thing_inside vars } +check_inferred_vars :: HsDocContext + -> Maybe SDoc + -- ^ The error msg if the signature is not allowed to contain + -- manually written inferred variables. + -> LHsType GhcPs + -> RnM () +check_inferred_vars _ Nothing _ = return () +check_inferred_vars ctxt (Just msg) ty = + let bndrs = forallty_bndrs ty + in case find ((==) InferredSpec . hsTyVarBndrFlag) bndrs of + Nothing -> return () + Just _ -> addErr $ withHsDocContext ctxt msg + where + forallty_bndrs :: LHsType GhcPs -> [HsTyVarBndr Specificity GhcPs] + forallty_bndrs (L _ ty) = case ty of + HsParTy _ ty' -> forallty_bndrs ty' + HsForAllTy { hst_bndrs = tvs } -> map unLoc tvs + _ -> [] + {- ****************************************************** * * LHsType and HsType @@ -982,12 +1013,13 @@ So tvs is {k,a} and kvs is {k}. NB: we do this only at the binding site of 'tvs'. -} -bindLHsTyVarBndrs :: HsDocContext +bindLHsTyVarBndrs :: (OutputableBndrFlag flag) + => HsDocContext -> Maybe SDoc -- Just d => check for unused tvs -- d is a phrase like "in the type ..." -> Maybe a -- Just _ => an associated type decl - -> [LHsTyVarBndr GhcPs] -- User-written tyvars - -> ([LHsTyVarBndr GhcRn] -> RnM (b, FreeVars)) + -> [LHsTyVarBndr flag GhcPs] -- User-written tyvars + -> ([LHsTyVarBndr flag GhcRn] -> RnM (b, FreeVars)) -> RnM (b, FreeVars) bindLHsTyVarBndrs doc mb_in_doc mb_assoc tv_bndrs thing_inside = do { when (isNothing mb_assoc) (checkShadowedRdrNames tv_names_w_loc) @@ -1009,24 +1041,24 @@ bindLHsTyVarBndrs doc mb_in_doc mb_assoc tv_bndrs thing_inside bindLHsTyVarBndr :: HsDocContext -> Maybe a -- associated class - -> LHsTyVarBndr GhcPs - -> (LHsTyVarBndr GhcRn -> RnM (b, FreeVars)) + -> LHsTyVarBndr flag GhcPs + -> (LHsTyVarBndr flag GhcRn -> RnM (b, FreeVars)) -> RnM (b, FreeVars) bindLHsTyVarBndr _doc mb_assoc (L loc - (UserTyVar x + (UserTyVar x fl lrdr@(L lv _))) thing_inside = do { nm <- newTyVarNameRn mb_assoc lrdr ; bindLocalNamesFV [nm] $ - thing_inside (L loc (UserTyVar x (L lv nm))) } + thing_inside (L loc (UserTyVar x fl (L lv nm))) } -bindLHsTyVarBndr doc mb_assoc (L loc (KindedTyVar x lrdr@(L lv _) kind)) +bindLHsTyVarBndr doc mb_assoc (L loc (KindedTyVar x fl lrdr@(L lv _) kind)) thing_inside = do { sig_ok <- xoptM LangExt.KindSignatures ; unless sig_ok (badKindSigErr doc kind) ; (kind', fvs1) <- rnLHsKind doc kind ; tv_nm <- newTyVarNameRn mb_assoc lrdr ; (b, fvs2) <- bindLocalNamesFV [tv_nm] - $ thing_inside (L loc (KindedTyVar x (L lv tv_nm) kind')) + $ thing_inside (L loc (KindedTyVar x fl (L lv tv_nm) kind')) ; return (b, fvs1 `plusFV` fvs2) } newTyVarNameRn :: Maybe a -> Located RdrName -> RnM Name @@ -1448,7 +1480,7 @@ dataKindsErr env thing inTypeDoc :: HsType GhcPs -> SDoc inTypeDoc ty = text "In the type" <+> quotes (ppr ty) -warnUnusedForAll :: SDoc -> LHsTyVarBndr GhcRn -> FreeVars -> TcM () +warnUnusedForAll :: (OutputableBndrFlag flag) => SDoc -> LHsTyVarBndr flag GhcRn -> FreeVars -> TcM () warnUnusedForAll in_doc (L loc tv) used_names = whenWOptM Opt_WarnUnusedForalls $ unless (hsTyVarName tv `elemNameSet` used_names) $ @@ -1693,7 +1725,7 @@ extractHsTysRdrTyVarsDups tys -- However duplicates are removed -- E.g. given [k1, a:k1, b:k2] -- the function returns [k1,k2], even though k1 is bound here -extractHsTyVarBndrsKVs :: [LHsTyVarBndr GhcPs] -> FreeKiTyVarsNoDups +extractHsTyVarBndrsKVs :: [LHsTyVarBndr flag GhcPs] -> FreeKiTyVarsNoDups extractHsTyVarBndrsKVs tv_bndrs = nubL (extract_hs_tv_bndrs_kvs tv_bndrs) @@ -1702,8 +1734,8 @@ extractHsTyVarBndrsKVs tv_bndrs -- See Note [Ordering of implicit variables]. extractRdrKindSigVars :: LFamilyResultSig GhcPs -> [Located RdrName] extractRdrKindSigVars (L _ resultSig) = case resultSig of - KindSig _ k -> extractHsTyRdrTyVars k - TyVarSig _ (L _ (KindedTyVar _ _ k)) -> extractHsTyRdrTyVars k + KindSig _ k -> extractHsTyRdrTyVars k + TyVarSig _ (L _ (KindedTyVar _ _ _ k)) -> extractHsTyRdrTyVars k _ -> [] -- | Get type/kind variables mentioned in the kind signature, preserving @@ -1766,13 +1798,13 @@ extract_lty (L _ ty) acc -- We deal with these separately in rnLHsTypeWithWildCards HsWildCardTy {} -> acc -extractHsTvBndrs :: [LHsTyVarBndr GhcPs] +extractHsTvBndrs :: [LHsTyVarBndr flag GhcPs] -> FreeKiTyVarsWithDups -- Free in body -> FreeKiTyVarsWithDups -- Free in result extractHsTvBndrs tv_bndrs body_fvs = extract_hs_tv_bndrs tv_bndrs [] body_fvs -extract_hs_tv_bndrs :: [LHsTyVarBndr GhcPs] +extract_hs_tv_bndrs :: [LHsTyVarBndr flag GhcPs] -> FreeKiTyVarsWithDups -- Accumulator -> FreeKiTyVarsWithDups -- Free in body -> FreeKiTyVarsWithDups @@ -1789,7 +1821,7 @@ extract_hs_tv_bndrs tv_bndrs acc_vars body_vars bndr_vars = extract_hs_tv_bndrs_kvs tv_bndrs tv_bndr_rdrs = map hsLTyVarLocName tv_bndrs -extract_hs_tv_bndrs_kvs :: [LHsTyVarBndr GhcPs] -> FreeKiTyVarsWithDups +extract_hs_tv_bndrs_kvs :: [LHsTyVarBndr flag GhcPs] -> FreeKiTyVarsWithDups -- Returns the free kind variables of any explicitly-kinded binders, returning -- variable occurrences in left-to-right order. -- See Note [Ordering of implicit variables]. @@ -1799,7 +1831,7 @@ extract_hs_tv_bndrs_kvs :: [LHsTyVarBndr GhcPs] -> FreeKiTyVarsWithDups -- the function returns [k1,k2], even though k1 is bound here extract_hs_tv_bndrs_kvs tv_bndrs = foldr extract_lty [] - [k | L _ (KindedTyVar _ _ k) <- tv_bndrs] + [k | L _ (KindedTyVar _ _ _ k) <- tv_bndrs] extract_tv :: Located RdrName -> [Located RdrName] -> [Located RdrName] diff --git a/compiler/GHC/Rename/Module.hs b/compiler/GHC/Rename/Module.hs index f7a677504f..c7c648bd87 100644 --- a/compiler/GHC/Rename/Module.hs +++ b/compiler/GHC/Rename/Module.hs @@ -370,7 +370,7 @@ rnHsForeignDecl :: ForeignDecl GhcPs -> RnM (ForeignDecl GhcRn, FreeVars) rnHsForeignDecl (ForeignImport { fd_name = name, fd_sig_ty = ty, fd_fi = spec }) = do { topEnv :: HscEnv <- getTopEnv ; name' <- lookupLocatedTopBndrRn name - ; (ty', fvs) <- rnHsSigType (ForeignDeclCtx name) TypeLevel ty + ; (ty', fvs) <- rnHsSigType (ForeignDeclCtx name) TypeLevel Nothing ty -- Mark any PackageTarget style imports as coming from the current package ; let unitId = thisPackage $ hsc_dflags topEnv @@ -382,7 +382,7 @@ rnHsForeignDecl (ForeignImport { fd_name = name, fd_sig_ty = ty, fd_fi = spec }) rnHsForeignDecl (ForeignExport { fd_name = name, fd_sig_ty = ty, fd_fe = spec }) = do { name' <- lookupLocatedOccRn name - ; (ty', fvs) <- rnHsSigType (ForeignDeclCtx name) TypeLevel ty + ; (ty', fvs) <- rnHsSigType (ForeignDeclCtx name) TypeLevel Nothing ty ; return (ForeignExport { fd_e_ext = noExtField , fd_name = name', fd_sig_ty = ty' , fd_fe = spec } @@ -602,7 +602,7 @@ rnClsInstDecl (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = mbinds , cid_overlap_mode = oflag , cid_datafam_insts = adts }) = do { (inst_ty', inst_fvs) - <- rnHsSigType (GenericCtx $ text "an instance declaration") TypeLevel inst_ty + <- rnHsSigType (GenericCtx $ text "an instance declaration") TypeLevel inf_err inst_ty ; let (ktv_names, _, head_ty') = splitLHsInstDeclTy inst_ty' ; cls <- case hsTyGetAppHead_maybe head_ty' of @@ -659,6 +659,8 @@ rnClsInstDecl (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = mbinds -- the instance context after renaming. This is a bit -- strange, but should not matter (and it would be more work -- to remove the context). + where + inf_err = Just (text "Inferred type variables are not allowed") rnFamInstEqn :: HsDocContext -> AssocTyFamInfo @@ -957,10 +959,11 @@ rnSrcDerivDecl (DerivDecl _ ty mds overlap) ; unless standalone_deriv_ok (addErr standaloneDerivErr) ; (mds', ty', fvs) <- rnLDerivStrategy DerivDeclCtx mds $ - rnHsSigWcType DerivDeclCtx ty + rnHsSigWcType DerivDeclCtx inf_err ty ; warnNoDerivStrat mds' loc ; return (DerivDecl noExtField ty' mds' overlap, fvs) } where + inf_err = Just (text "Inferred type variables are not allowed") loc = getLoc $ hsib_body $ hswc_body ty standaloneDerivErr :: SDoc @@ -1028,7 +1031,7 @@ bindRuleTmVars doc tyvs vars names thing_inside go ((L l (RuleBndrSig _ (L loc _) bsig)) : vars) (n : ns) thing_inside - = rnHsPatSigType bind_free_tvs doc bsig $ \ bsig' -> + = rnHsPatSigType bind_free_tvs doc Nothing bsig $ \ bsig' -> go vars ns $ \ vars' -> thing_inside (L l (RuleBndrSig noExtField (L loc n) bsig') : vars') @@ -1038,8 +1041,8 @@ bindRuleTmVars doc tyvs vars names thing_inside bind_free_tvs = case tyvs of Nothing -> AlwaysBind Just _ -> NeverBind -bindRuleTyVars :: HsDocContext -> SDoc -> Maybe [LHsTyVarBndr GhcPs] - -> (Maybe [LHsTyVarBndr GhcRn] -> RnM (b, FreeVars)) +bindRuleTyVars :: HsDocContext -> SDoc -> Maybe [LHsTyVarBndr () GhcPs] + -> (Maybe [LHsTyVarBndr () GhcRn] -> RnM (b, FreeVars)) -> RnM (b, FreeVars) bindRuleTyVars doc in_doc (Just bndrs) thing_inside = bindLHsTyVarBndrs doc (Just in_doc) Nothing bndrs (thing_inside . Just) @@ -1368,7 +1371,7 @@ rnStandaloneKindSignature tc_names (StandaloneKindSig _ v ki) ; unless standalone_ki_sig_ok $ addErr standaloneKiSigErr ; new_v <- lookupSigCtxtOccRn (TopSigCtxt tc_names) (text "standalone kind signature") v ; let doc = StandaloneKindSigCtx (ppr v) - ; (new_ki, fvs) <- rnHsSigType doc KindLevel ki + ; (new_ki, fvs) <- rnHsSigType doc KindLevel Nothing ki ; return (StandaloneKindSig noExtField new_v new_ki, fvs) } where @@ -1767,12 +1770,14 @@ rnLHsDerivingClause doc , deriv_clause_strategy = dcs , deriv_clause_tys = L loc' dct })) = do { (dcs', dct', fvs) - <- rnLDerivStrategy doc dcs $ mapFvRn (rnHsSigType doc TypeLevel) dct + <- rnLDerivStrategy doc dcs $ mapFvRn (rnHsSigType doc TypeLevel inf_err) dct ; warnNoDerivStrat dcs' loc ; pure ( L loc (HsDerivingClause { deriv_clause_ext = noExtField , deriv_clause_strategy = dcs' , deriv_clause_tys = L loc' dct' }) , fvs ) } + where + inf_err = Just (text "Inferred type variables are not allowed") rnLDerivStrategy :: forall a. HsDocContext @@ -1805,7 +1810,7 @@ rnLDerivStrategy doc mds thing_inside AnyclassStrategy -> boring_case AnyclassStrategy NewtypeStrategy -> boring_case NewtypeStrategy ViaStrategy via_ty -> - do (via_ty', fvs1) <- rnHsSigType doc TypeLevel via_ty + do (via_ty', fvs1) <- rnHsSigType doc TypeLevel inf_err via_ty let HsIB { hsib_ext = via_imp_tvs , hsib_body = via_body } = via_ty' (via_exp_tv_bndrs, _, _) = splitLHsSigmaTyInvis via_body @@ -1814,6 +1819,8 @@ rnLDerivStrategy doc mds thing_inside (thing, fvs2) <- extendTyVarEnvFVRn via_tvs thing_inside pure (ViaStrategy via_ty', thing, fvs1 `plusFV` fvs2) + inf_err = Just (text "Inferred type variables are not allowed") + boring_case :: ds -> RnM (ds, a, FreeVars) boring_case ds = do (thing, fvs) <- thing_inside @@ -2072,7 +2079,7 @@ rnConDecl decl@(ConDeclH98 { con_name = name, con_ex_tvs = ex_tvs rnConDecl decl@(ConDeclGADT { con_names = names , con_forall = L _ explicit_forall - , con_qvars = qtvs + , con_qvars = explicit_tkvs , con_mb_cxt = mcxt , con_args = args , con_res_ty = res_ty @@ -2081,8 +2088,7 @@ rnConDecl decl@(ConDeclGADT { con_names = names ; new_names <- mapM lookupLocatedTopBndrRn names ; mb_doc' <- rnMbLHsDoc mb_doc - ; let explicit_tkvs = hsQTvExplicit qtvs - theta = hsConDeclTheta mcxt + ; let theta = hsConDeclTheta mcxt arg_tys = hsConDeclArgTys args -- We must ensure that we extract the free tkvs in left-to-right @@ -2113,12 +2119,9 @@ rnConDecl decl@(ConDeclGADT { con_names = names -- See Note [GADT abstract syntax] in GHC.Hs.Decls (PrefixCon arg_tys, final_res_ty) - new_qtvs = HsQTvs { hsq_ext = implicit_tkvs - , hsq_explicit = explicit_tkvs } - ; traceRn "rnConDecl2" (ppr names $$ ppr implicit_tkvs $$ ppr explicit_tkvs) - ; return (decl { con_g_ext = noExtField, con_names = new_names - , con_qvars = new_qtvs, con_mb_cxt = new_cxt + ; return (decl { con_g_ext = implicit_tkvs, con_names = new_names + , con_qvars = explicit_tkvs, con_mb_cxt = new_cxt , con_args = args', con_res_ty = res_ty' , con_doc = mb_doc' }, all_fvs) } } diff --git a/compiler/GHC/Rename/Pat.hs b/compiler/GHC/Rename/Pat.hs index 09e2ea8cbe..06619cd142 100644 --- a/compiler/GHC/Rename/Pat.hs +++ b/compiler/GHC/Rename/Pat.hs @@ -412,7 +412,7 @@ rnPatAndThen mk (SigPat x pat sig) ; return (SigPat x pat' sig' ) } where rnHsPatSigTypeAndThen :: HsPatSigType GhcPs -> CpsRn (HsPatSigType GhcRn) - rnHsPatSigTypeAndThen sig = CpsRn (rnHsPatSigType AlwaysBind PatCtx sig) + rnHsPatSigTypeAndThen sig = CpsRn (rnHsPatSigType AlwaysBind PatCtx Nothing sig) rnPatAndThen mk (LitPat x lit) | HsString src s <- lit diff --git a/compiler/GHC/Runtime/Heap/Inspect.hs b/compiler/GHC/Runtime/Heap/Inspect.hs index 5b2bf597d2..3077c48aaf 100644 --- a/compiler/GHC/Runtime/Heap/Inspect.hs +++ b/compiler/GHC/Runtime/Heap/Inspect.hs @@ -660,7 +660,7 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do -- as this is needed to be able to manipulate -- them properly let quant_old_ty@(old_tvs, old_tau) = quantifyType old_ty - sigma_old_ty = mkInvForAllTys old_tvs old_tau + sigma_old_ty = mkInfForAllTys old_tvs old_tau traceTR (text "Term reconstruction started with initial type " <> ppr old_ty) term <- if null old_tvs diff --git a/compiler/GHC/Tc/Errors/Hole.hs b/compiler/GHC/Tc/Errors/Hole.hs index c764d7d3e3..0639e79073 100644 --- a/compiler/GHC/Tc/Errors/Hole.hs +++ b/compiler/GHC/Tc/Errors/Hole.hs @@ -441,10 +441,12 @@ pprHoleFit (HFDC sWrp sWrpVars sTy sProv sMs) (HoleFit {..}) = where name = getName hfCand tyApp = sep $ zipWithEqual "pprHoleFit" pprArg vars hfWrap where pprArg b arg = case binderArgFlag b of - Specified -> text "@" <> pprParendType arg - -- Do not print type application for inferred - -- variables (#16456) - Inferred -> empty + -- See Note [Explicit Case Statement for Specificity] + (Invisible spec) -> case spec of + SpecifiedSpec -> text "@" <> pprParendType arg + -- Do not print type application for inferred + -- variables (#16456) + InferredSpec -> empty Required -> pprPanic "pprHoleFit: bad Required" (ppr b <+> ppr arg) tyAppVars = sep $ punctuate comma $ diff --git a/compiler/GHC/Tc/Gen/Arrow.hs b/compiler/GHC/Tc/Gen/Arrow.hs index 6ac42a76d0..ef60b3cea7 100644 --- a/compiler/GHC/Tc/Gen/Arrow.hs +++ b/compiler/GHC/Tc/Gen/Arrow.hs @@ -307,7 +307,7 @@ tc_cmd env cmd@(HsCmdArrForm x expr f fixity cmd_args) (cmd_stk, res_ty) = addErrCtxt (cmdCtxt cmd) $ do { (cmd_args', cmd_tys) <- mapAndUnzipM tc_cmd_arg cmd_args -- We use alphaTyVar for 'w' - ; let e_ty = mkInvForAllTy alphaTyVar $ + ; let e_ty = mkInfForAllTy alphaTyVar $ mkVisFunTys cmd_tys $ mkCmdArrTy env (mkPairTy alphaTy cmd_stk) res_ty ; expr' <- tcCheckExpr expr e_ty diff --git a/compiler/GHC/Tc/Gen/Bind.hs b/compiler/GHC/Tc/Gen/Bind.hs index c2af14b93d..1870531f60 100644 --- a/compiler/GHC/Tc/Gen/Bind.hs +++ b/compiler/GHC/Tc/Gen/Bind.hs @@ -907,7 +907,7 @@ mkInferredPolyId insoluble qtvs inferred_theta poly_name mb_sig_inst mono_ty ; (binders, theta') <- chooseInferredQuantifiers inferred_theta (tyCoVarsOfType mono_ty') qtvs mb_sig_inst - ; let inferred_poly_ty = mkForAllTys binders (mkPhiTy theta' mono_ty') + ; let inferred_poly_ty = mkInvisForAllTys binders (mkPhiTy theta' mono_ty') ; traceTc "mkInferredPolyId" (vcat [ppr poly_name, ppr qtvs, ppr theta' , ppr inferred_poly_ty]) @@ -926,13 +926,13 @@ chooseInferredQuantifiers :: TcThetaType -- inferred -> TcTyVarSet -- tvs free in tau type -> [TcTyVar] -- inferred quantified tvs -> Maybe TcIdSigInst - -> TcM ([TyVarBinder], TcThetaType) + -> TcM ([InvisTVBinder], TcThetaType) chooseInferredQuantifiers inferred_theta tau_tvs qtvs Nothing = -- No type signature (partial or complete) for this binder, do { let free_tvs = closeOverKinds (growThetaTyVars inferred_theta tau_tvs) -- Include kind variables! #7916 my_theta = pickCapturedPreds free_tvs inferred_theta - binders = [ mkTyVarBinder Inferred tv + binders = [ mkTyVarBinder InferredSpec tv | tv <- qtvs , tv `elemVarSet` free_tvs ] ; return (binders, my_theta) } @@ -943,7 +943,8 @@ chooseInferredQuantifiers inferred_theta tau_tvs qtvs , sig_inst_theta = annotated_theta , sig_inst_skols = annotated_tvs })) = -- Choose quantifiers for a partial type signature - do { psig_qtv_prs <- zonkTyVarTyVarPairs annotated_tvs + do { psig_qtvbndr_prs <- zonkTyVarTyVarPairs annotated_tvs + ; let psig_qtv_prs = mapSnd binderVar psig_qtvbndr_prs -- Check whether the quantified variables of the -- partial signature have been unified together @@ -957,7 +958,8 @@ chooseInferredQuantifiers inferred_theta tau_tvs qtvs ; mapM_ report_mono_sig_tv_err [ n | (n,tv) <- psig_qtv_prs , not (tv `elem` qtvs) ] - ; let psig_qtvs = mkVarSet (map snd psig_qtv_prs) + ; let psig_qtvbndrs = map snd psig_qtvbndr_prs + psig_qtvs = mkVarSet (map snd psig_qtv_prs) ; annotated_theta <- zonkTcTypes annotated_theta ; (free_tvs, my_theta) <- choose_psig_context psig_qtvs annotated_theta wcx @@ -966,8 +968,9 @@ chooseInferredQuantifiers inferred_theta tau_tvs qtvs final_qtvs = [ mkTyVarBinder vis tv | tv <- qtvs -- Pulling from qtvs maintains original order , tv `elemVarSet` keep_me - , let vis | tv `elemVarSet` psig_qtvs = Specified - | otherwise = Inferred ] + , let vis = case lookupVarBndr tv psig_qtvbndrs of + Just spec -> spec + Nothing -> InferredSpec ] ; return (final_qtvs, my_theta) } where @@ -1447,7 +1450,7 @@ tcExtendTyVarEnvFromSig :: TcIdSigInst -> TcM a -> TcM a tcExtendTyVarEnvFromSig sig_inst thing_inside | TISI { sig_inst_skols = skol_prs, sig_inst_wcs = wcs } <- sig_inst = tcExtendNameTyVarEnv wcs $ - tcExtendNameTyVarEnv skol_prs $ + tcExtendNameTyVarEnv (mapSnd binderVar skol_prs) $ thing_inside tcExtendIdBinderStackForRhs :: [MonoBindInfo] -> TcM a -> TcM a diff --git a/compiler/GHC/Tc/Gen/Expr.hs b/compiler/GHC/Tc/Gen/Expr.hs index 3a89daac0b..2d6b25df10 100644 --- a/compiler/GHC/Tc/Gen/Expr.hs +++ b/compiler/GHC/Tc/Gen/Expr.hs @@ -1709,7 +1709,7 @@ tcExprSig expr sig@(PartialSig { psig_name = name, sig_loc = loc }) do { (tclvl, wanted, (expr', sig_inst)) <- pushLevelAndCaptureConstraints $ do { sig_inst <- tcInstSig sig - ; expr' <- tcExtendNameTyVarEnv (sig_inst_skols sig_inst) $ + ; expr' <- tcExtendNameTyVarEnv (mapSnd binderVar $ sig_inst_skols sig_inst) $ tcExtendNameTyVarEnv (sig_inst_wcs sig_inst) $ tcCheckExprNC expr (sig_inst_tau sig_inst) ; return (expr', sig_inst) } @@ -1730,7 +1730,7 @@ tcExprSig expr sig@(PartialSig { psig_name = name, sig_loc = loc }) ; (binders, my_theta) <- chooseInferredQuantifiers inferred_theta tau_tvs qtvs (Just sig_inst) ; let inferred_sigma = mkInfSigmaTy qtvs inferred_theta tau - my_sigma = mkForAllTys binders (mkPhiTy my_theta tau) + my_sigma = mkInvisForAllTys binders (mkPhiTy my_theta tau) ; wrap <- if inferred_sigma `eqType` my_sigma -- NB: eqType ignores vis. then return idHsWrapper -- Fast path; also avoids complaint when we infer -- an ambiguous type and have AllowAmbiguousType diff --git a/compiler/GHC/Tc/Gen/HsType.hs b/compiler/GHC/Tc/Gen/HsType.hs index cd48e5416f..328ed43d65 100644 --- a/compiler/GHC/Tc/Gen/HsType.hs +++ b/compiler/GHC/Tc/Gen/HsType.hs @@ -304,7 +304,7 @@ tc_hs_sig_type skol_info hs_sig_type ctxt_kind ; emitResidualTvConstraint skol_info Nothing (kvs ++ spec_tkvs) tc_lvl wanted - ; return (insolubleWC wanted, mkInvForAllTys kvs ty1) } + ; return (insolubleWC wanted, mkInfForAllTys kvs ty1) } tcTopLHsType :: TcTyMode -> LHsSigType GhcRn -> ContextKind -> TcM Type -- tcTopLHsType is used for kind-checking top-level HsType where @@ -325,7 +325,7 @@ tcTopLHsType mode hs_sig_type ctxt_kind ; spec_tkvs <- zonkAndScopedSort spec_tkvs ; let ty1 = mkSpecForAllTys spec_tkvs ty ; kvs <- kindGeneralizeAll ty1 -- "All" because it's a top-level type - ; final_ty <- zonkTcTypeToType (mkInvForAllTys kvs ty1) + ; final_ty <- zonkTcTypeToType (mkInfForAllTys kvs ty1) ; traceTc "End tcTopLHsType }" (vcat [ppr hs_ty, ppr final_ty]) ; return final_ty} @@ -717,23 +717,35 @@ tc_hs_type mode (HsOpTy _ ty1 (L _ op) ty2) exp_kind --------- Foralls tc_hs_type mode forall@(HsForAllTy { hst_fvf = fvf, hst_bndrs = hs_tvs , hst_body = ty }) exp_kind - = do { (tclvl, wanted, (tvs', ty')) + = do { (tclvl, wanted, (inv_tv_bndrs, ty')) <- pushLevelAndCaptureConstraints $ bindExplicitTKBndrs_Skol hs_tvs $ tc_lhs_type mode ty exp_kind -- Do not kind-generalise here! See Note [Kind generalisation] -- Why exp_kind? See Note [Body kind of HsForAllTy] - ; let argf = case fvf of - ForallVis -> Required - ForallInvis -> Specified - bndrs = mkTyVarBinders argf tvs' - skol_info = ForAllSkol (ppr forall) + ; let skol_info = ForAllSkol (ppr forall) m_telescope = Just (sep (map ppr hs_tvs)) - ; emitResidualTvConstraint skol_info m_telescope tvs' tclvl wanted - -- See Note [Skolem escape and forall-types] + ; tv_bndrs <- mapM construct_bndr inv_tv_bndrs - ; return (mkForAllTys bndrs ty') } + ; emitResidualTvConstraint skol_info m_telescope (binderVars tv_bndrs) tclvl wanted + + ; return (mkForAllTys tv_bndrs ty') } + where + construct_bndr :: TcInvisTVBinder -> TcM TcTyVarBinder + construct_bndr (Bndr tv spec) = do { argf <- spec_to_argf spec + ; return $ mkTyVarBinder argf tv } + + -- See Note [Variable Specificity and Forall Visibility] + spec_to_argf :: Specificity -> TcM ArgFlag + spec_to_argf SpecifiedSpec = case fvf of + ForallVis -> return Required + ForallInvis -> return Specified + spec_to_argf InferredSpec = case fvf of + ForallVis -> do { addErrTc (hang (text "Unexpected inferred variable in visible forall binder:") + 2 (ppr forall)) + ; return Required } + ForallInvis -> return Inferred tc_hs_type mode (HsQualTy { hst_ctxt = ctxt, hst_body = rn_ty }) exp_kind | null (unLoc ctxt) @@ -865,6 +877,29 @@ tc_hs_type mode ty@(HsKindSig {}) ek = tc_infer_hs_type_ek mode ty ek tc_hs_type mode ty@(XHsType (NHsCoreTy{})) ek = tc_infer_hs_type_ek mode ty ek tc_hs_type _ wc@(HsWildCardTy _) ek = tcAnonWildCardOcc wc ek +{- +Note [Variable Specificity and Forall Visibility] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A HsForAllTy contains a ForAllVisFlag to denote the visibility of the forall +binder. Furthermore, each bound variable also has a Specificity. Together these +determine the variable binders (ArgFlag) for each variable in the generated +ForAllTy type. + +This table summarises this relation: +-------------------------------------------------------------------------- +| User-written type ForAllVisFlag Specificity ArgFlag +|------------------------------------------------------------------------- +| f :: forall a. type ForallInvis SpecifiedSpec Specified +| f :: forall {a}. type ForallInvis InferredSpec Inferred +| f :: forall a -> type ForallVis SpecifiedSpec Required +| f :: forall {a} -> type ForallVis InferredSpec / +| This last form is non-sensical and is thus rejected. +-------------------------------------------------------------------------- + +For more information regarding the interpretation of the resulting ArgFlag, see +Note [VarBndrs, TyCoVarBinders, TyConBinders, and visibility] in TyCoRep. +-} + ------------------------------------------ tc_fun_type :: TcTyMode -> LHsType GhcRn -> LHsType GhcRn -> TcKind -> TcM TcType @@ -2204,8 +2239,8 @@ kcCheckDeclHeader_sig kisig name flav check_zipped_binder (ZippedBinder _ Nothing) = return () check_zipped_binder (ZippedBinder tb (Just b)) = case unLoc b of - UserTyVar _ _ -> return () - KindedTyVar _ v v_hs_ki -> do + UserTyVar _ _ _ -> return () + KindedTyVar _ _ v v_hs_ki -> do v_ki <- tcLHsKindSig (TyVarBndrKindCtxt (unLoc v)) v_hs_ki discardResult $ -- See Note [discardResult in kcCheckDeclHeader_sig] unifyKind (Just (HsTyVar noExtField NotPromoted v)) @@ -2228,14 +2263,14 @@ kcCheckDeclHeader_sig kisig name flav -- A quantifier from a kind signature zipped with a user-written binder for it. data ZippedBinder = - ZippedBinder TyBinder (Maybe (LHsTyVarBndr GhcRn)) + ZippedBinder TyBinder (Maybe (LHsTyVarBndr () GhcRn)) -- See Note [Arity inference in kcCheckDeclHeader_sig] zipBinders :: Kind -- kind signature - -> [LHsTyVarBndr GhcRn] -- user-written binders + -> [LHsTyVarBndr () GhcRn] -- user-written binders -> ([ZippedBinder], -- zipped binders - [LHsTyVarBndr GhcRn], -- remaining user-written binders + [LHsTyVarBndr () GhcRn], -- remaining user-written binders Kind) -- remainder of the kind signature zipBinders = zip_binders [] where @@ -2249,15 +2284,14 @@ zipBinders = zip_binders [] | otherwise = (ZippedBinder tb Nothing, b:bs) zippable = case tb of - Named (Bndr _ Specified) -> False - Named (Bndr _ Inferred) -> False - Named (Bndr _ Required) -> True + Named (Bndr _ (Invisible _)) -> False + Named (Bndr _ Required) -> True Anon InvisArg _ -> False Anon VisArg _ -> True in zip_binders (zb:acc) ki' bs' -tooManyBindersErr :: Kind -> [LHsTyVarBndr GhcRn] -> SDoc +tooManyBindersErr :: Kind -> [LHsTyVarBndr () GhcRn] -> SDoc tooManyBindersErr ki bndrs = hang (text "Not a function kind:") 4 (ppr ki) $$ @@ -2664,9 +2698,10 @@ cloneFlexiKindedTyVarTyVar = newFlexiKindedTyVar cloneTyVarTyVar -------------------------------------- bindExplicitTKBndrs_Skol, bindExplicitTKBndrs_Tv - :: [LHsTyVarBndr GhcRn] + :: (OutputableBndrFlag flag) + => [LHsTyVarBndr flag GhcRn] -> TcM a - -> TcM ([TcTyVar], a) + -> TcM ([VarBndr TyVar flag], a) bindExplicitTKBndrs_Skol = bindExplicitTKBndrsX (tcHsTyVarBndr newSkolemTyVar) bindExplicitTKBndrs_Tv = bindExplicitTKBndrsX (tcHsTyVarBndr cloneTyVarTyVar) @@ -2675,21 +2710,30 @@ bindExplicitTKBndrs_Tv = bindExplicitTKBndrsX (tcHsTyVarBndr cloneTyVarTyVar) bindExplicitTKBndrs_Q_Skol, bindExplicitTKBndrs_Q_Tv :: ContextKind - -> [LHsTyVarBndr GhcRn] + -> [LHsTyVarBndr () GhcRn] -> TcM a -> TcM ([TcTyVar], a) -bindExplicitTKBndrs_Q_Skol ctxt_kind = bindExplicitTKBndrsX (tcHsQTyVarBndr ctxt_kind newSkolemTyVar) -bindExplicitTKBndrs_Q_Tv ctxt_kind = bindExplicitTKBndrsX (tcHsQTyVarBndr ctxt_kind newTyVarTyVar) +bindExplicitTKBndrs_Q_Skol ctxt_kind = bindExplicitTKBndrsX_Q (tcHsQTyVarBndr ctxt_kind newSkolemTyVar) +bindExplicitTKBndrs_Q_Tv ctxt_kind = bindExplicitTKBndrsX_Q (tcHsQTyVarBndr ctxt_kind newTyVarTyVar) -- See Note [Non-cloning for tyvar binders] - -bindExplicitTKBndrsX - :: (HsTyVarBndr GhcRn -> TcM TcTyVar) - -> [LHsTyVarBndr GhcRn] +bindExplicitTKBndrsX_Q + :: (HsTyVarBndr () GhcRn -> TcM TcTyVar) + -> [LHsTyVarBndr () GhcRn] -> TcM a -> TcM ([TcTyVar], a) -- Returned [TcTyVar] are in 1-1 correspondence -- with the passed-in [LHsTyVarBndr] +bindExplicitTKBndrsX_Q tc_tv hs_tvs thing_inside + = do { (tv_bndrs,res) <- bindExplicitTKBndrsX tc_tv hs_tvs thing_inside + ; return ((binderVars tv_bndrs),res) } + +bindExplicitTKBndrsX :: (OutputableBndrFlag flag) + => (HsTyVarBndr flag GhcRn -> TcM TcTyVar) + -> [LHsTyVarBndr flag GhcRn] + -> TcM a + -> TcM ([VarBndr TyVar flag], a) -- Returned [TcTyVar] are in 1-1 correspondence + -- with the passed-in [LHsTyVarBndr] bindExplicitTKBndrsX tc_tv hs_tvs thing_inside = do { traceTc "bindExplicTKBndrs" (ppr hs_tvs) ; go hs_tvs } @@ -2705,33 +2749,33 @@ bindExplicitTKBndrsX tc_tv hs_tvs thing_inside -- See GHC.Tc.Utils.TcMType Note [Cloning for tyvar binders] ; (tvs,res) <- tcExtendNameTyVarEnv [(hsTyVarName hs_tv, tv)] $ go hs_tvs - ; return (tv:tvs, res) } + ; return ((Bndr tv (hsTyVarBndrFlag hs_tv)):tvs, res) } ----------------- tcHsTyVarBndr :: (Name -> Kind -> TcM TyVar) - -> HsTyVarBndr GhcRn -> TcM TcTyVar -tcHsTyVarBndr new_tv (UserTyVar _ (L _ tv_nm)) + -> HsTyVarBndr flag GhcRn -> TcM TcTyVar +tcHsTyVarBndr new_tv (UserTyVar _ _ (L _ tv_nm)) = do { kind <- newMetaKindVar ; new_tv tv_nm kind } -tcHsTyVarBndr new_tv (KindedTyVar _ (L _ tv_nm) lhs_kind) +tcHsTyVarBndr new_tv (KindedTyVar _ _ (L _ tv_nm) lhs_kind) = do { kind <- tcLHsKindSig (TyVarBndrKindCtxt tv_nm) lhs_kind ; new_tv tv_nm kind } ----------------- tcHsQTyVarBndr :: ContextKind -> (Name -> Kind -> TcM TyVar) - -> HsTyVarBndr GhcRn -> TcM TcTyVar + -> HsTyVarBndr () GhcRn -> TcM TcTyVar -- Just like tcHsTyVarBndr, but also -- - uses the in-scope TyVar from class, if it exists -- - takes a ContextKind to use for the no-sig case -tcHsQTyVarBndr ctxt_kind new_tv (UserTyVar _ (L _ tv_nm)) +tcHsQTyVarBndr ctxt_kind new_tv (UserTyVar _ _ (L _ tv_nm)) = do { mb_tv <- tcLookupLcl_maybe tv_nm ; case mb_tv of Just (ATyVar _ tv) -> return tv _ -> do { kind <- newExpectedKind ctxt_kind ; new_tv tv_nm kind } } -tcHsQTyVarBndr _ new_tv (KindedTyVar _ (L _ tv_nm) lhs_kind) +tcHsQTyVarBndr _ new_tv (KindedTyVar _ _ (L _ tv_nm) lhs_kind) = do { kind <- tcLHsKindSig (TyVarBndrKindCtxt tv_nm) lhs_kind ; mb_tv <- tcLookupLcl_maybe tv_nm ; case mb_tv of @@ -3156,7 +3200,7 @@ tcHsPartialSigType -> LHsSigWcType GhcRn -- The type signature -> TcM ( [(Name, TcTyVar)] -- Wildcards , Maybe TcType -- Extra-constraints wildcard - , [(Name,TcTyVar)] -- Original tyvar names, in correspondence with + , [(Name,InvisTVBinder)] -- Original tyvar names, in correspondence with -- the implicitly and explicitly bound type variables , TcThetaType -- Theta part , TcType ) -- Tau part @@ -3167,7 +3211,7 @@ tcHsPartialSigType ctxt sig_ty , hsib_body = hs_ty } <- ib_ty , (explicit_hs_tvs, L _ hs_ctxt, hs_tau) <- splitLHsSigmaTyInvis hs_ty = addSigCtxt ctxt hs_ty $ - do { (implicit_tvs, (explicit_tvs, (wcs, wcx, theta, tau))) + do { (implicit_tvs, (explicit_tvbndrs, (wcs, wcx, theta, tau))) <- solveLocalEqualities "tcHsPartialSigType" $ -- This solveLocalEqualiltes fails fast if there are -- insoluble equalities. See GHC.Tc.Solver @@ -3183,9 +3227,11 @@ tcHsPartialSigType ctxt sig_ty ; return (wcs, wcx, theta, tau) } - -- No kind-generalization here, but perhaps some promotion - ; kindGeneralizeNone (mkSpecForAllTys implicit_tvs $ - mkSpecForAllTys explicit_tvs $ + ; let implicit_tvbndrs = map (mkTyVarBinder SpecifiedSpec) implicit_tvs + + -- No kind-generalization here: + ; kindGeneralizeNone (mkInvisForAllTys implicit_tvbndrs $ + mkInvisForAllTys explicit_tvbndrs $ mkPhiTy theta $ tau) @@ -3197,16 +3243,14 @@ tcHsPartialSigType ctxt sig_ty -- Zonk, so that any nested foralls can "see" their occurrences -- See Note [Checking partial type signatures], in -- the bullet on Nested foralls. - ; implicit_tvs <- mapM zonkTcTyVarToTyVar implicit_tvs - ; explicit_tvs <- mapM zonkTcTyVarToTyVar explicit_tvs ; theta <- mapM zonkTcType theta ; tau <- zonkTcType tau - -- We return a proper (Name,TyVar) environment, to be sure that + -- We return a proper (Name,InvisTVBinder) environment, to be sure that -- we bring the right name into scope in the function body. -- Test case: partial-sigs/should_compile/LocalDefinitionBug - ; let tv_prs = (implicit_hs_tvs `zip` implicit_tvs) - ++ (hsLTyVarNames explicit_hs_tvs `zip` explicit_tvs) + ; let tv_prs = (implicit_hs_tvs `zip` implicit_tvbndrs) + ++ (hsLTyVarNames explicit_hs_tvs `zip` explicit_tvbndrs) -- NB: checkValidType on the final inferred type will be -- done later by checkInferredPolyId. We can't do it diff --git a/compiler/GHC/Tc/Gen/Match.hs b/compiler/GHC/Tc/Gen/Match.hs index 857470b155..350be10236 100644 --- a/compiler/GHC/Tc/Gen/Match.hs +++ b/compiler/GHC/Tc/Gen/Match.hs @@ -513,7 +513,7 @@ tcLcStmt m_tc ctxt (TransStmt { trS_form = form, trS_stmts = stmts tup_ty = mkBigCoreVarTupTy bndr_ids poly_arg_ty = m_app alphaTy poly_res_ty = m_app (n_app alphaTy) - using_poly_ty = mkInvForAllTy alphaTyVar $ + using_poly_ty = mkInfForAllTy alphaTyVar $ by_arrow $ poly_arg_ty `mkVisFunTy` poly_res_ty @@ -654,7 +654,7 @@ tcMcStmt ctxt (TransStmt { trS_stmts = stmts, trS_bndrs = bindersMap using_arg_ty = m1_ty `mkAppTy` tup_ty poly_res_ty = m2_ty `mkAppTy` n_app alphaTy using_res_ty = m2_ty `mkAppTy` n_app tup_ty - using_poly_ty = mkInvForAllTy alphaTyVar $ + using_poly_ty = mkInfForAllTy alphaTyVar $ by_arrow $ poly_arg_ty `mkVisFunTy` poly_res_ty @@ -694,8 +694,8 @@ tcMcStmt ctxt (TransStmt { trS_stmts = stmts, trS_bndrs = bindersMap ; fmap_op' <- case form of ThenForm -> return noExpr _ -> fmap unLoc . tcCheckExpr (noLoc fmap_op) $ - mkInvForAllTy alphaTyVar $ - mkInvForAllTy betaTyVar $ + mkInfForAllTy alphaTyVar $ + mkInfForAllTy betaTyVar $ (alphaTy `mkVisFunTy` betaTy) `mkVisFunTy` (n_app alphaTy) `mkVisFunTy` (n_app betaTy) @@ -759,7 +759,7 @@ tcMcStmt ctxt (TransStmt { trS_stmts = stmts, trS_bndrs = bindersMap tcMcStmt ctxt (ParStmt _ bndr_stmts_s mzip_op bind_op) res_ty thing_inside = do { m_ty <- newFlexiTyVarTy typeToTypeKind - ; let mzip_ty = mkInvForAllTys [alphaTyVar, betaTyVar] $ + ; let mzip_ty = mkInfForAllTys [alphaTyVar, betaTyVar] $ (m_ty `mkAppTy` alphaTy) `mkVisFunTy` (m_ty `mkAppTy` betaTy) diff --git a/compiler/GHC/Tc/Gen/Rule.hs b/compiler/GHC/Tc/Gen/Rule.hs index 3ed75ac49b..c788f15437 100644 --- a/compiler/GHC/Tc/Gen/Rule.hs +++ b/compiler/GHC/Tc/Gen/Rule.hs @@ -180,7 +180,7 @@ tcRule (HsRule { rd_ext = ext , rd_lhs = mkHsDictLet lhs_binds lhs' , rd_rhs = mkHsDictLet rhs_binds rhs' } } -generateRuleConstraints :: Maybe [LHsTyVarBndr GhcRn] -> [LRuleBndr GhcRn] +generateRuleConstraints :: Maybe [LHsTyVarBndr () GhcRn] -> [LRuleBndr GhcRn] -> LHsExpr GhcRn -> LHsExpr GhcRn -> TcM ( [TcId] , LHsExpr GhcTc, WantedConstraints @@ -204,11 +204,12 @@ generateRuleConstraints ty_bndrs tm_bndrs lhs rhs ; return (id_bndrs, lhs', all_lhs_wanted, rhs', rhs_wanted, rule_ty) } } -- See Note [TcLevel in type checking rules] -tcRuleBndrs :: Maybe [LHsTyVarBndr GhcRn] -> [LRuleBndr GhcRn] +tcRuleBndrs :: Maybe [LHsTyVarBndr () GhcRn] -> [LRuleBndr GhcRn] -> TcM ([TcTyVar], [Id]) tcRuleBndrs (Just bndrs) xs - = do { (tys1,(tys2,tms)) <- bindExplicitTKBndrs_Skol bndrs $ - tcRuleTmBndrs xs + = do { (tybndrs1,(tys2,tms)) <- bindExplicitTKBndrs_Skol bndrs $ + tcRuleTmBndrs xs + ; let tys1 = binderVars tybndrs1 ; return (tys1 ++ tys2, tms) } tcRuleBndrs Nothing xs diff --git a/compiler/GHC/Tc/Gen/Sig.hs b/compiler/GHC/Tc/Gen/Sig.hs index 2c716f1826..fb313d9297 100644 --- a/compiler/GHC/Tc/Gen/Sig.hs +++ b/compiler/GHC/Tc/Gen/Sig.hs @@ -42,7 +42,7 @@ import GHC.Tc.Types.Evidence( HsWrapper, (<.>) ) import GHC.Core.Type ( mkTyVarBinders ) import GHC.Driver.Session -import GHC.Types.Var ( TyVar, tyVarKind ) +import GHC.Types.Var ( TyVar, Specificity(..), tyVarKind, binderVars ) import GHC.Types.Id ( Id, idName, idType, idInlinePragma, setInlinePragma, mkLocalId ) import GHC.Builtin.Names( mkUnboundName ) import GHC.Types.Basic @@ -293,11 +293,11 @@ no_anon_wc lty = go lty gos = all go -no_anon_wc_bndrs :: [LHsTyVarBndr GhcRn] -> Bool +no_anon_wc_bndrs :: [LHsTyVarBndr flag GhcRn] -> Bool no_anon_wc_bndrs ltvs = all (go . unLoc) ltvs where - go (UserTyVar _ _) = True - go (KindedTyVar _ _ ki) = no_anon_wc ki + go (UserTyVar _ _ _) = True + go (KindedTyVar _ _ _ ki) = no_anon_wc ki {- Note [Fail eagerly on bad signatures] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -374,15 +374,15 @@ tcPatSynSig :: Name -> LHsSigType GhcRn -> TcM TcPatSynInfo tcPatSynSig name sig_ty | HsIB { hsib_ext = implicit_hs_tvs , hsib_body = hs_ty } <- sig_ty - , (univ_hs_tvs, hs_req, hs_ty1) <- splitLHsSigmaTyInvis hs_ty - , (ex_hs_tvs, hs_prov, hs_body_ty) <- splitLHsSigmaTyInvis hs_ty1 + , (univ_hs_tvbndrs, hs_req, hs_ty1) <- splitLHsSigmaTyInvis hs_ty + , (ex_hs_tvbndrs, hs_prov, hs_body_ty) <- splitLHsSigmaTyInvis hs_ty1 = do { traceTc "tcPatSynSig 1" (ppr sig_ty) - ; (implicit_tvs, (univ_tvs, (ex_tvs, (req, prov, body_ty)))) + ; (implicit_tvs, (univ_tvbndrs, (ex_tvbndrs, (req, prov, body_ty)))) <- pushTcLevelM_ $ solveEqualities $ -- See Note [solveEqualities in tcPatSynSig] bindImplicitTKBndrs_Skol implicit_hs_tvs $ - bindExplicitTKBndrs_Skol univ_hs_tvs $ - bindExplicitTKBndrs_Skol ex_hs_tvs $ + bindExplicitTKBndrs_Skol univ_hs_tvbndrs $ + bindExplicitTKBndrs_Skol ex_hs_tvbndrs $ do { req <- tcHsContext hs_req ; prov <- tcHsContext hs_prov ; body_ty <- tcHsOpenType hs_body_ty @@ -390,8 +390,8 @@ tcPatSynSig name sig_ty -- e.g. pattern Zero <- 0# (#12094) ; return (req, prov, body_ty) } - ; let ungen_patsyn_ty = build_patsyn_type [] implicit_tvs univ_tvs - req ex_tvs prov body_ty + ; let ungen_patsyn_ty = build_patsyn_type [] implicit_tvs univ_tvbndrs + req ex_tvbndrs prov body_ty -- Kind generalisation ; kvs <- kindGeneralizeAll ungen_patsyn_ty @@ -401,8 +401,8 @@ tcPatSynSig name sig_ty -- unification variables. Do this after kindGeneralize which may -- default kind variables to *. ; implicit_tvs <- zonkAndScopedSort implicit_tvs - ; univ_tvs <- mapM zonkTyCoVarKind univ_tvs - ; ex_tvs <- mapM zonkTyCoVarKind ex_tvs + ; univ_tvbndrs <- mapM zonkTyCoVarKindBinder univ_tvbndrs + ; ex_tvbndrs <- mapM zonkTyCoVarKindBinder ex_tvbndrs ; req <- zonkTcTypes req ; prov <- zonkTcTypes prov ; body_ty <- zonkTcType body_ty @@ -421,15 +421,15 @@ tcPatSynSig name sig_ty body_ty' = substTy env3 body_ty -} ; let implicit_tvs' = implicit_tvs - univ_tvs' = univ_tvs - ex_tvs' = ex_tvs + univ_tvbndrs' = univ_tvbndrs + ex_tvbndrs' = ex_tvbndrs req' = req prov' = prov body_ty' = body_ty -- Now do validity checking ; checkValidType ctxt $ - build_patsyn_type kvs implicit_tvs' univ_tvs' req' ex_tvs' prov' body_ty' + build_patsyn_type kvs implicit_tvs' univ_tvbndrs' req' ex_tvbndrs' prov' body_ty' -- arguments become the types of binders. We thus cannot allow -- levity polymorphism here @@ -439,27 +439,28 @@ tcPatSynSig name sig_ty ; traceTc "tcTySig }" $ vcat [ text "implicit_tvs" <+> ppr_tvs implicit_tvs' , text "kvs" <+> ppr_tvs kvs - , text "univ_tvs" <+> ppr_tvs univ_tvs' + , text "univ_tvs" <+> ppr_tvs (binderVars univ_tvbndrs') , text "req" <+> ppr req' - , text "ex_tvs" <+> ppr_tvs ex_tvs' + , text "ex_tvs" <+> ppr_tvs (binderVars ex_tvbndrs') , text "prov" <+> ppr prov' , text "body_ty" <+> ppr body_ty' ] ; return (TPSI { patsig_name = name - , patsig_implicit_bndrs = mkTyVarBinders Inferred kvs ++ - mkTyVarBinders Specified implicit_tvs' - , patsig_univ_bndrs = univ_tvs' + , patsig_implicit_bndrs = mkTyVarBinders InferredSpec kvs ++ + mkTyVarBinders SpecifiedSpec implicit_tvs' + , patsig_univ_bndrs = univ_tvbndrs' , patsig_req = req' - , patsig_ex_bndrs = ex_tvs' + , patsig_ex_bndrs = ex_tvbndrs' , patsig_prov = prov' , patsig_body_ty = body_ty' }) } where ctxt = PatSynCtxt name - build_patsyn_type kvs imp univ req ex prov body - = mkInvForAllTys kvs $ - mkSpecForAllTys (imp ++ univ) $ + build_patsyn_type kvs imp univ_bndrs req ex_bndrs prov body + = mkInfForAllTys kvs $ + mkSpecForAllTys imp $ + mkInvisForAllTys univ_bndrs $ mkPhiTy req $ - mkSpecForAllTys ex $ + mkInvisForAllTys ex_bndrs $ mkPhiTy prov $ body @@ -479,7 +480,7 @@ tcInstSig :: TcIdSigInfo -> TcM TcIdSigInst -- Instantiate a type signature; only used with plan InferGen tcInstSig sig@(CompleteSig { sig_bndr = poly_id, sig_loc = loc }) = setSrcSpan loc $ -- Set the binding site of the tyvars - do { (tv_prs, theta, tau) <- tcInstType newMetaTyVarTyVars poly_id + do { (tv_prs, theta, tau) <- tcInstTypeBndrs newMetaTyVarTyVars poly_id -- See Note [Pattern bindings and complete signatures] ; return (TISI { sig_inst_sig = sig diff --git a/compiler/GHC/Tc/Gen/Splice.hs b/compiler/GHC/Tc/Gen/Splice.hs index 99806ff820..aa792ee6b7 100644 --- a/compiler/GHC/Tc/Gen/Splice.hs +++ b/compiler/GHC/Tc/Gen/Splice.hs @@ -15,6 +15,8 @@ {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TupleSections #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} {-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} @@ -1618,7 +1620,7 @@ reifyThing (AGlobal (AConLike (RealDataCon dc))) reifyThing (AGlobal (AConLike (PatSynCon ps))) = do { let name = reifyName ps - ; ty <- reifyPatSynType (patSynSig ps) + ; ty <- reifyPatSynType (patSynSigBndr ps) ; return (TH.PatSynI name ty) } reifyThing (ATcId {tct_id = id}) @@ -1673,7 +1675,7 @@ reifyTyCon tc Just name -> let thName = reifyName name injAnnot = tyConInjectivityInfo tc - sig = TH.TyVarSig (TH.KindedTV thName kind') + sig = TH.TyVarSig (TH.KindedTV thName () kind') inj = case injAnnot of NotInjective -> Nothing Injective ms -> @@ -1737,7 +1739,7 @@ reifyDataCon isGadtDataCon tys dc (ex_tvs, theta, arg_tys) = dataConInstSig dc tys -- used for GADTs data constructors - g_user_tvs' = dataConUserTyVars dc + g_user_tvs' = dataConUserTyVarBinders dc (g_univ_tvs, _, g_eq_spec, g_theta', g_arg_tys', g_res_ty') = dataConFullSig dc (srcUnpks, srcStricts) @@ -1753,7 +1755,7 @@ reifyDataCon isGadtDataCon tys dc -- See Note [Freshen reified GADT constructors' universal tyvars] <- freshenTyVarBndrs $ filterOut (`elemVarSet` eq_spec_tvs) g_univ_tvs - ; let (tvb_subst, g_user_tvs) = substTyVarBndrs univ_subst g_user_tvs' + ; let (tvb_subst, g_user_tvs) = subst_tv_binders univ_subst g_user_tvs' g_theta = substTys tvb_subst g_theta' g_arg_tys = substTys tvb_subst g_arg_tys' g_res_ty = substTy tvb_subst g_res_ty' @@ -1786,14 +1788,23 @@ reifyDataCon isGadtDataCon tys dc ; let (ex_tvs', theta') | isGadtDataCon = (g_user_tvs, g_theta) | otherwise = ASSERT( all isTyVar ex_tvs ) -- no covars for haskell syntax - (ex_tvs, theta) + (map mk_specified ex_tvs, theta) ret_con | null ex_tvs' && null theta' = return main_con | otherwise = do { cxt <- reifyCxt theta' - ; ex_tvs'' <- reifyTyVars ex_tvs' + ; ex_tvs'' <- reifyTyVarBndrs ex_tvs' ; return (TH.ForallC ex_tvs'' cxt main_con) } ; ASSERT( r_arg_tys `equalLength` dcdBangs ) ret_con } + where + mk_specified tv = Bndr tv SpecifiedSpec + + subst_tv_binders subst tv_bndrs = + let tvs = binderVars tv_bndrs + flags = map binderArgFlag tv_bndrs + (subst', tvs') = substTyVarBndrs subst tvs + tv_bndrs' = map (\(tv,fl) -> Bndr tv fl) (zip tvs' flags) + in (subst', tv_bndrs') {- Note [Freshen reified GADT constructors' universal tyvars] @@ -1868,9 +1879,9 @@ reifyClass cls = (n, map bndrName args) tfNames d = pprPanic "tfNames" (text (show d)) - bndrName :: TH.TyVarBndr -> TH.Name - bndrName (TH.PlainTV n) = n - bndrName (TH.KindedTV n _) = n + bndrName :: TH.TyVarBndr flag -> TH.Name + bndrName (TH.PlainTV n _) = n + bndrName (TH.KindedTV n _ _) = n ------------------------------ -- | Annotate (with TH.SigT) a type if the first parameter is True @@ -2113,16 +2124,18 @@ reifyType ty@(CoercionTy {})= noTH (sLit "coercions in types") (ppr ty) reify_for_all :: TyCoRep.ArgFlag -> TyCoRep.Type -> TcM TH.Type -- Arg of reify_for_all is always ForAllTy or a predicate FunTy reify_for_all argf ty = do - tvs' <- reifyTyVars tvs + tvbndrs' <- reifyTyVarBndrs tvbndrs case argToForallVisFlag argf of ForallVis -> do phi' <- reifyType phi - pure $ TH.ForallVisT tvs' phi' + let tvs = map (() <$) tvbndrs' + -- see Note [Specificity in HsForAllTy] in GHC.Hs.Types + pure $ TH.ForallVisT tvs phi' ForallInvis -> do let (cxt, tau) = tcSplitPhiTy phi cxt' <- reifyCxt cxt tau' <- reifyType tau - pure $ TH.ForallT tvs' cxt' tau' + pure $ TH.ForallT tvbndrs' cxt' tau' where - (tvs, phi) = tcSplitForAllTysSameVis argf ty + (tvbndrs, phi) = tcSplitForAllTysSameVis argf ty reifyTyLit :: TyCoRep.TyLit -> TcM TH.TyLit reifyTyLit (NumTyLit n) = return (TH.NumTyLit n) @@ -2132,14 +2145,14 @@ reifyTypes :: [Type] -> TcM [TH.Type] reifyTypes = mapM reifyType reifyPatSynType - :: ([TyVar], ThetaType, [TyVar], ThetaType, [Type], Type) -> TcM TH.Type + :: ([InvisTVBinder], ThetaType, [InvisTVBinder], ThetaType, [Type], Type) -> TcM TH.Type -- reifies a pattern synonym's type and returns its *complete* type -- signature; see NOTE [Pattern synonym signatures and Template -- Haskell] reifyPatSynType (univTyVars, req, exTyVars, prov, argTys, resTy) - = do { univTyVars' <- reifyTyVars univTyVars + = do { univTyVars' <- reifyTyVarBndrs univTyVars ; req' <- reifyCxt req - ; exTyVars' <- reifyTyVars exTyVars + ; exTyVars' <- reifyTyVarBndrs exTyVars ; prov' <- reifyCxt prov ; tau' <- reifyType (mkVisFunTys argTys resTy) ; return $ TH.ForallT univTyVars' req' @@ -2154,18 +2167,37 @@ reifyCxt = mapM reifyType reifyFunDep :: ([TyVar], [TyVar]) -> TH.FunDep reifyFunDep (xs, ys) = TH.FunDep (map reifyName xs) (map reifyName ys) -reifyTyVars :: [TyVar] -> TcM [TH.TyVarBndr] -reifyTyVars tvs = mapM reify_tv tvs +class ReifyFlag flag flag' | flag -> flag' where + reifyFlag :: flag -> flag' + +instance ReifyFlag () () where + reifyFlag () = () + +instance ReifyFlag Specificity TH.Specificity where + reifyFlag SpecifiedSpec = TH.SpecifiedSpec + reifyFlag InferredSpec = TH.InferredSpec + +instance ReifyFlag ArgFlag TH.Specificity where + reifyFlag Required = TH.SpecifiedSpec + reifyFlag (Invisible s) = reifyFlag s + +reifyTyVars :: [TyVar] -> TcM [TH.TyVarBndr ()] +reifyTyVars = reifyTyVarBndrs . map mk_bndr + where + mk_bndr tv = Bndr tv () + +reifyTyVarBndrs :: ReifyFlag flag flag' + => [VarBndr TyVar flag] -> TcM [TH.TyVarBndr flag'] +reifyTyVarBndrs = mapM reify_tvbndr where -- even if the kind is *, we need to include a kind annotation, -- in case a poly-kind would be inferred without the annotation. -- See #8953 or test th/T8953 - reify_tv tv = TH.KindedTV name <$> reifyKind kind - where - kind = tyVarKind tv - name = reifyName tv + reify_tvbndr (Bndr tv fl) = TH.KindedTV (reifyName tv) + (reifyFlag fl) + <$> reifyKind (tyVarKind tv) -reifyTyVarsToMaybe :: [TyVar] -> TcM (Maybe [TH.TyVarBndr]) +reifyTyVarsToMaybe :: [TyVar] -> TcM (Maybe [TH.TyVarBndr ()]) reifyTyVarsToMaybe [] = pure Nothing reifyTyVarsToMaybe tys = Just <$> reifyTyVars tys @@ -2289,7 +2321,7 @@ reifyTypeOfThing th_name = do AGlobal (AConLike (RealDataCon dc)) -> reifyType (idType (dataConWrapId dc)) AGlobal (AConLike (PatSynCon ps)) -> - reifyPatSynType (patSynSig ps) + reifyPatSynType (patSynSigBndr ps) ATcId{tct_id = id} -> zonkTcType (idType id) >>= reifyType ATyVar _ tctv -> zonkTcTyVar tctv >>= reifyType -- Impossible cases, supposedly: diff --git a/compiler/GHC/Tc/Module.hs b/compiler/GHC/Tc/Module.hs index 095fd1c7cc..94402c0989 100644 --- a/compiler/GHC/Tc/Module.hs +++ b/compiler/GHC/Tc/Module.hs @@ -2444,7 +2444,7 @@ getGhciStepIO = do step_ty = noLoc $ HsForAllTy { hst_fvf = ForallInvis - , hst_bndrs = [noLoc $ UserTyVar noExtField (noLoc a_tv)] + , hst_bndrs = [noLoc $ UserTyVar noExtField SpecifiedSpec (noLoc a_tv)] , hst_xforall = noExtField , hst_body = nlHsFunTy ghciM ioM } @@ -2507,7 +2507,7 @@ tcRnExpr hsc_env mode rdr_expr _ <- perhaps_disable_default_warnings $ simplifyInteractive residual ; - let { all_expr_ty = mkInvForAllTys qtvs $ + let { all_expr_ty = mkInfForAllTys qtvs $ mkPhiTy (map idType dicts) res_ty } ; ty <- zonkTcType all_expr_ty ; @@ -2608,7 +2608,7 @@ tcRnType hsc_env flexi normalise rdr_type ; return ty' } else return ty ; - ; return (ty', mkInvForAllTys kvs (tcTypeKind ty')) } + ; return (ty', mkInfForAllTys kvs (tcTypeKind ty')) } {- Note [TcRnExprMode] ~~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/GHC/Tc/Solver.hs b/compiler/GHC/Tc/Solver.hs index 134b230c06..b1017de024 100644 --- a/compiler/GHC/Tc/Solver.hs +++ b/compiler/GHC/Tc/Solver.hs @@ -745,7 +745,7 @@ simplifyInfer rhs_tclvl infer_mode sigs name_taus wanteds = do { -- When quantifying, we want to preserve any order of variables as they -- appear in partial signatures. cf. decideQuantifiedTyVars let psig_tv_tys = [ mkTyVarTy tv | sig <- partial_sigs - , (_,tv) <- sig_inst_skols sig ] + , (_,Bndr tv _) <- sig_inst_skols sig ] psig_theta = [ pred | sig <- partial_sigs , pred <- sig_inst_theta sig ] @@ -1056,7 +1056,7 @@ decideMonoTyVars infer_mode name_taus psigs candidates -- If possible, we quantify over partial-sig qtvs, so they are -- not mono. Need to zonk them because they are meta-tyvar TyVarTvs - ; psig_qtvs <- mapM zonkTcTyVarToTyVar $ + ; psig_qtvs <- mapM zonkTcTyVarToTyVar $ binderVars $ concatMap (map snd . sig_inst_skols) psigs ; psig_theta <- mapM TcM.zonkTcType $ @@ -1222,7 +1222,7 @@ decideQuantifiedTyVars name_taus psigs candidates -- See Note [Quantification and partial signatures] -- Wrinkles 2 and 3 ; psig_tv_tys <- mapM TcM.zonkTcTyVar [ tv | sig <- psigs - , (_,tv) <- sig_inst_skols sig ] + , (_,Bndr tv _) <- sig_inst_skols sig ] ; psig_theta <- mapM TcM.zonkTcType [ pred | sig <- psigs , pred <- sig_inst_theta sig ] ; tau_tys <- mapM (TcM.zonkTcType . snd) name_taus diff --git a/compiler/GHC/Tc/TyCl.hs b/compiler/GHC/Tc/TyCl.hs index 5da467d770..144021caea 100644 --- a/compiler/GHC/Tc/TyCl.hs +++ b/compiler/GHC/Tc/TyCl.hs @@ -1365,8 +1365,8 @@ get_fam_decl_initial_kind mb_parent_tycon , fdInfo = info } = kcDeclHeader InitialKindInfer name flav ktvs $ case resultSig of - KindSig _ ki -> TheKind <$> tcLHsKindSig ctxt ki - TyVarSig _ (L _ (KindedTyVar _ _ ki)) -> TheKind <$> tcLHsKindSig ctxt ki + KindSig _ ki -> TheKind <$> tcLHsKindSig ctxt ki + TyVarSig _ (L _ (KindedTyVar _ _ _ ki)) -> TheKind <$> tcLHsKindSig ctxt ki _ -- open type families have * return kind by default | tcFlavourIsOpen flav -> return (TheKind liftedTypeKind) -- closed type families have their return kind inferred @@ -1601,10 +1601,8 @@ kcConDecl new_or_data res_kind (ConDeclH98 } kcConDecl new_or_data res_kind (ConDeclGADT - { con_names = names, con_qvars = qtvs, con_mb_cxt = cxt - , con_args = args, con_res_ty = res_ty }) - | HsQTvs { hsq_ext = implicit_tkv_nms - , hsq_explicit = explicit_tkv_nms } <- qtvs + { con_names = names, con_qvars = explicit_tkv_nms, con_mb_cxt = cxt + , con_args = args, con_res_ty = res_ty, con_g_ext = implicit_tkv_nms }) = -- Even though the GADT-style data constructor's type is closed, -- we must still kind-check the type, because that may influence -- the inferred kind of the /type/ constructor. Example: @@ -2854,10 +2852,10 @@ a very similar design when generalising over the type of a rewrite rule. -------------------------- tcTyFamInstEqnGuts :: TyCon -> AssocInstInfo - -> [Name] -> [LHsTyVarBndr GhcRn] -- Implicit and explicicit binder - -> HsTyPats GhcRn -- Patterns - -> LHsType GhcRn -- RHS - -> TcM ([TyVar], [TcType], TcType) -- (tyvars, pats, rhs) + -> [Name] -> [LHsTyVarBndr () GhcRn] -- Implicit and explicicit binder + -> HsTyPats GhcRn -- Patterns + -> LHsType GhcRn -- RHS + -> TcM ([TyVar], [TcType], TcType) -- (tyvars, pats, rhs) -- Used only for type families, not data families tcTyFamInstEqnGuts fam_tc mb_clsinfo imp_vars exp_bndrs hs_pats hs_rhs_ty = do { traceTc "tcTyFamInstEqnGuts {" (ppr fam_tc) @@ -3116,7 +3114,7 @@ tcConDecl rep_tycon tag_map tmpl_bndrs res_kind res_tmpl new_or_data ; traceTc "tcConDecl 1" (vcat [ ppr name, ppr explicit_tkv_nms ]) - ; (exp_tvs, (ctxt, arg_tys, field_lbls, stricts)) + ; (exp_tvbndrs, (ctxt, arg_tys, field_lbls, stricts)) <- pushTcLevelM_ $ solveEqualities $ bindExplicitTKBndrs_Skol explicit_tkv_nms $ @@ -3128,12 +3126,14 @@ tcConDecl rep_tycon tag_map tmpl_bndrs res_kind res_tmpl new_or_data ; return (ctxt, arg_tys, field_lbls, stricts) } + ; let tmpl_tvs = binderVars tmpl_bndrs + -- exp_tvs have explicit, user-written binding sites -- the kvs below are those kind variables entirely unmentioned by the user -- and discovered only by generalization - ; kvs <- kindGeneralizeAll (mkSpecForAllTys (binderVars tmpl_bndrs) $ - mkSpecForAllTys exp_tvs $ + ; kvs <- kindGeneralizeAll (mkSpecForAllTys tmpl_tvs $ + mkInvisForAllTys exp_tvbndrs $ mkPhiTy ctxt $ mkVisFunTys arg_tys $ unitTy) @@ -3145,20 +3145,21 @@ tcConDecl rep_tycon tag_map tmpl_bndrs res_kind res_tmpl new_or_data -- quantify over, and this type is fine for that purpose. -- Zonk to Types - ; (ze, qkvs) <- zonkTyBndrs kvs - ; (ze, user_qtvs) <- zonkTyBndrsX ze exp_tvs - ; arg_tys <- zonkTcTypesToTypesX ze arg_tys - ; ctxt <- zonkTcTypesToTypesX ze ctxt + ; (ze, qkvs) <- zonkTyBndrs kvs + ; (ze, user_qtvbndrs) <- zonkTyVarBindersX ze exp_tvbndrs + ; let user_qtvs = binderVars user_qtvbndrs + ; arg_tys <- zonkTcTypesToTypesX ze arg_tys + ; ctxt <- zonkTcTypesToTypesX ze ctxt ; fam_envs <- tcGetFamInstEnvs -- Can't print univ_tvs, arg_tys etc, because we are inside the knot here ; traceTc "tcConDecl 2" (ppr name $$ ppr field_lbls) ; let - univ_tvbs = tyConTyVarBinders tmpl_bndrs + univ_tvbs = tyConInvisTVBinders tmpl_bndrs univ_tvs = binderVars univ_tvbs - ex_tvbs = mkTyVarBinders Inferred qkvs ++ - mkTyVarBinders Specified user_qtvs + ex_tvbs = mkTyVarBinders InferredSpec qkvs ++ + user_qtvbndrs ex_tvs = qkvs ++ user_qtvs -- For H98 datatypes, the user-written tyvar binders are precisely -- the universals followed by the existentials. @@ -3184,17 +3185,16 @@ tcConDecl rep_tycon tag_map tmpl_bndrs res_kind res_tmpl new_or_data tcConDecl rep_tycon tag_map tmpl_bndrs _res_kind res_tmpl new_or_data -- NB: don't use res_kind here, as it's ill-scoped. Instead, we get -- the res_kind by typechecking the result type. - (ConDeclGADT { con_names = names - , con_qvars = qtvs + (ConDeclGADT { con_g_ext = implicit_tkv_nms + , con_names = names + , con_qvars = explicit_tkv_nms , con_mb_cxt = cxt, con_args = hs_args , con_res_ty = hs_res_ty }) - | HsQTvs { hsq_ext = implicit_tkv_nms - , hsq_explicit = explicit_tkv_nms } <- qtvs = addErrCtxt (dataConCtxtName names) $ do { traceTc "tcConDecl 1 gadt" (ppr names) ; let (L _ name : _) = names - ; (imp_tvs, (exp_tvs, (ctxt, arg_tys, res_ty, field_lbls, stricts))) + ; (imp_tvs, (exp_tvbndrs, (ctxt, arg_tys, res_ty, field_lbls, stricts))) <- pushTcLevelM_ $ -- We are going to generalise solveEqualities $ -- We won't get another crack, and we don't -- want an error cascade @@ -3217,32 +3217,26 @@ tcConDecl rep_tycon tag_map tmpl_bndrs _res_kind res_tmpl new_or_data ; return (ctxt, arg_tys, res_ty, field_lbls, stricts) } ; imp_tvs <- zonkAndScopedSort imp_tvs - ; let user_tvs = imp_tvs ++ exp_tvs - ; tkvs <- kindGeneralizeAll (mkSpecForAllTys user_tvs $ + ; tkvs <- kindGeneralizeAll (mkSpecForAllTys imp_tvs $ + mkInvisForAllTys exp_tvbndrs $ mkPhiTy ctxt $ mkVisFunTys arg_tys $ res_ty) + ; let tvbndrs = (mkTyVarBinders InferredSpec tkvs) + ++ (mkTyVarBinders SpecifiedSpec imp_tvs) + ++ exp_tvbndrs + -- Zonk to Types - ; (ze, tkvs) <- zonkTyBndrs tkvs - ; (ze, user_tvs) <- zonkTyBndrsX ze user_tvs - ; arg_tys <- zonkTcTypesToTypesX ze arg_tys - ; ctxt <- zonkTcTypesToTypesX ze ctxt - ; res_ty <- zonkTcTypeToTypeX ze res_ty - - ; let (univ_tvs, ex_tvs, tkvs', user_tvs', eq_preds, arg_subst) - = rejigConRes tmpl_bndrs res_tmpl tkvs user_tvs res_ty - -- NB: this is a /lazy/ binding, so we pass six thunks to - -- buildDataCon without yet forcing the guards in rejigConRes - -- See Note [Checking GADT return types] + ; (ze, tvbndrs) <- zonkTyVarBinders tvbndrs + ; arg_tys <- zonkTcTypesToTypesX ze arg_tys + ; ctxt <- zonkTcTypesToTypesX ze ctxt + ; res_ty <- zonkTcTypeToTypeX ze res_ty - -- Compute the user-written tyvar binders. These have the same - -- tyvars as univ_tvs/ex_tvs, but perhaps in a different order. - -- See Note [DataCon user type variable binders] in GHC.Core.DataCon. - tkv_bndrs = mkTyVarBinders Inferred tkvs' - user_tv_bndrs = mkTyVarBinders Specified user_tvs' - all_user_bndrs = tkv_bndrs ++ user_tv_bndrs + ; let (univ_tvs, ex_tvs, tvbndrs', eq_preds, arg_subst) + = rejigConRes tmpl_bndrs res_tmpl tvbndrs res_ty + -- See Note [Checking GADT return types] ctxt' = substTys arg_subst ctxt arg_tys' = substTys arg_subst arg_tys @@ -3261,7 +3255,7 @@ tcConDecl rep_tycon tag_map tmpl_bndrs _res_kind res_tmpl new_or_data ; buildDataCon fam_envs name is_infix rep_nm stricts Nothing field_lbls - univ_tvs ex_tvs all_user_bndrs eq_preds + univ_tvs ex_tvs tvbndrs' eq_preds ctxt' arg_tys' res_ty' rep_tycon tag_map -- NB: we put data_tc, the type constructor gotten from the -- constructor type signature into the data constructor; @@ -3388,22 +3382,18 @@ errors reported in one pass. See #7175, and #10836. rejigConRes :: [KnotTied TyConBinder] -> KnotTied Type -- Template for result type; e.g. -- data instance T [a] b c ... -- gives template ([a,b,c], T [a] b c) - -> [TyVar] -- The constructor's inferred type variables - -> [TyVar] -- The constructor's user-written, specified - -- type variables + -> [InvisTVBinder] -- The constructor's type variables (both inferred and user-written) -> KnotTied Type -- res_ty -> ([TyVar], -- Universal [TyVar], -- Existential (distinct OccNames from univs) - [TyVar], -- The constructor's rejigged, user-written, - -- inferred type variables - [TyVar], -- The constructor's rejigged, user-written, - -- specified type variables - [EqSpec], -- Equality predicates - TCvSubst) -- Substitution to apply to argument types + [InvisTVBinder], -- The constructor's rejigged, user-written + -- type variables + [EqSpec], -- Equality predicates + TCvSubst) -- Substitution to apply to argument types -- We don't check that the TyCon given in the ResTy is -- the same as the parent tycon, because checkValidDataCon will do it -- NB: All arguments may potentially be knot-tied -rejigConRes tmpl_bndrs res_tmpl dc_inferred_tvs dc_specified_tvs res_ty +rejigConRes tmpl_bndrs res_tmpl dc_tvbndrs 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 @@ -3430,14 +3420,12 @@ rejigConRes tmpl_bndrs res_tmpl dc_inferred_tvs dc_specified_tvs res_ty -- since the dcUserTyVarBinders invariant guarantees that the -- substitution has *all* the tyvars in its domain. -- See Note [DataCon user type variable binders] in GHC.Core.DataCon. - subst_user_tvs = map (getTyVar "rejigConRes" . substTyVar arg_subst) - substed_inferred_tvs = subst_user_tvs dc_inferred_tvs - substed_specified_tvs = subst_user_tvs dc_specified_tvs + subst_user_tvs = mapVarBndrs (getTyVar "rejigConRes" . substTyVar arg_subst) + substed_tvbndrs = subst_user_tvs dc_tvbndrs substed_eqs = map (substEqSpec arg_subst) raw_eqs in - (univ_tvs, substed_ex_tvs, substed_inferred_tvs, substed_specified_tvs, - substed_eqs, arg_subst) + (univ_tvs, substed_ex_tvs, substed_tvbndrs, substed_eqs, arg_subst) | otherwise -- If the return type of the data constructor doesn't match the parent @@ -3450,10 +3438,9 @@ rejigConRes tmpl_bndrs res_tmpl dc_inferred_tvs dc_specified_tvs res_ty -- albeit bogus, relying on checkValidDataCon to check the -- 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, dc_inferred_tvs, dc_specified_tvs, - [], emptyTCvSubst) + = (tmpl_tvs, dc_tvs `minusList` tmpl_tvs, dc_tvbndrs, [], emptyTCvSubst) where - dc_tvs = dc_inferred_tvs ++ dc_specified_tvs + dc_tvs = binderVars dc_tvbndrs tmpl_tvs = binderVars tmpl_bndrs {- Note [mkGADTVars] diff --git a/compiler/GHC/Tc/TyCl/Build.hs b/compiler/GHC/Tc/TyCl/Build.hs index cf490075af..af49e9e28c 100644 --- a/compiler/GHC/Tc/TyCl/Build.hs +++ b/compiler/GHC/Tc/TyCl/Build.hs @@ -106,7 +106,7 @@ buildDataCon :: FamInstEnvs -> [FieldLabel] -- Field labels -> [TyVar] -- Universals -> [TyCoVar] -- Existentials - -> [TyVarBinder] -- User-written 'TyVarBinder's + -> [InvisTVBinder] -- User-written 'TyVarBinder's -> [EqSpec] -- Equality spec -> KnotTied ThetaType -- Does not include the "stupid theta" -- or the GADT equalities @@ -170,12 +170,12 @@ mkDataConStupidTheta tycon arg_tys univ_tvs ------------------------------------------------------ buildPatSyn :: Name -> Bool -> (Id,Bool) -> Maybe (Id, Bool) - -> ([TyVarBinder], ThetaType) -- ^ Univ and req - -> ([TyVarBinder], ThetaType) -- ^ Ex and prov - -> [Type] -- ^ Argument types - -> Type -- ^ Result type - -> [FieldLabel] -- ^ Field labels for - -- a record pattern synonym + -> ([InvisTVBinder], ThetaType) -- ^ Univ and req + -> ([InvisTVBinder], ThetaType) -- ^ Ex and prov + -> [Type] -- ^ Argument types + -> Type -- ^ Result type + -> [FieldLabel] -- ^ Field labels for + -- a record pattern synonym -> PatSyn buildPatSyn src_name declared_infix matcher@(matcher_id,_) builder (univ_tvs, req_theta) (ex_tvs, prov_theta) arg_tys @@ -298,7 +298,7 @@ buildClass tycon_name binders roles fds op_names = [op | (op,_,_) <- sig_stuff] arg_tys = sc_theta ++ op_tys rec_tycon = classTyCon rec_clas - univ_bndrs = tyConTyVarBinders binders + univ_bndrs = tyConInvisTVBinders binders univ_tvs = binderVars univ_bndrs ; rep_nm <- newTyConRepName datacon_name diff --git a/compiler/GHC/Tc/TyCl/Instance.hs b/compiler/GHC/Tc/TyCl/Instance.hs index 22849451bf..734ec05512 100644 --- a/compiler/GHC/Tc/TyCl/Instance.hs +++ b/compiler/GHC/Tc/TyCl/Instance.hs @@ -836,7 +836,7 @@ TyVarEnv will simply be empty, and there is nothing to worry about. ----------------------- tcDataFamInstHeader - :: AssocInstInfo -> TyCon -> [Name] -> Maybe [LHsTyVarBndr GhcRn] + :: AssocInstInfo -> TyCon -> [Name] -> Maybe [LHsTyVarBndr () GhcRn] -> LexicalFixity -> LHsContext GhcRn -> HsTyPats GhcRn -> Maybe (LHsKind GhcRn) -> [LConDecl GhcRn] -> NewOrData @@ -1306,7 +1306,7 @@ tcSuperClasses dfun_id cls tyvars dfun_evs inst_tys dfun_ev_binds sc_theta ; sc_top_name <- newName (mkSuperDictAuxOcc n (getOccName cls)) ; sc_ev_id <- newEvVar sc_pred ; addTcEvBind ev_binds_var $ mkWantedEvBind sc_ev_id sc_ev_tm - ; let sc_top_ty = mkInvForAllTys tyvars $ + ; let sc_top_ty = mkInfForAllTys tyvars $ mkPhiTy (map idType dfun_evs) sc_pred sc_top_id = mkLocalId sc_top_name sc_top_ty export = ABE { abe_ext = noExtField diff --git a/compiler/GHC/Tc/TyCl/PatSyn.hs b/compiler/GHC/Tc/TyCl/PatSyn.hs index 00e0beb5e1..957506c7c5 100644 --- a/compiler/GHC/Tc/TyCl/PatSyn.hs +++ b/compiler/GHC/Tc/TyCl/PatSyn.hs @@ -98,7 +98,7 @@ recoverPSB (PSB { psb_id = L _ name (_arg_names, _rec_fields, is_infix) = collectPatSynArgInfo details mk_placeholder matcher_name = mkPatSyn name is_infix - ([mkTyVarBinder Specified alphaTyVar], []) ([], []) + ([mkTyVarBinder SpecifiedSpec alphaTyVar], []) ([], []) [] -- Arg tys alphaTy (matcher_id, True) Nothing @@ -185,9 +185,9 @@ tcInferPatSynDecl (PSB { psb_id = lname@(L _ name), psb_args = details ; traceTc "tcInferPatSynDecl }" $ (ppr name $$ ppr ex_tvs) ; tc_patsyn_finish lname dir is_infix lpat' - (mkTyVarBinders Inferred univ_tvs + (mkTyVarBinders InferredSpec univ_tvs , req_theta, ev_binds, req_dicts) - (mkTyVarBinders Inferred ex_tvs + (mkTyVarBinders InferredSpec ex_tvs , mkTyVarTys ex_tvs, prov_theta, prov_evs) (map nlHsVar args, map idType args) pat_ty rec_fields } } @@ -345,17 +345,17 @@ tcCheckPatSynDecl :: PatSynBind GhcRn GhcRn -> TcM (LHsBinds GhcTc, TcGblEnv) tcCheckPatSynDecl psb@PSB{ psb_id = lname@(L _ name), psb_args = details , psb_def = lpat, psb_dir = dir } - TPSI{ patsig_implicit_bndrs = implicit_tvs - , patsig_univ_bndrs = explicit_univ_tvs, patsig_prov = prov_theta - , patsig_ex_bndrs = explicit_ex_tvs, patsig_req = req_theta + TPSI{ patsig_implicit_bndrs = implicit_bndrs + , patsig_univ_bndrs = explicit_univ_bndrs, patsig_prov = prov_theta + , patsig_ex_bndrs = explicit_ex_bndrs, patsig_req = req_theta , patsig_body_ty = sig_body_ty } = addPatSynCtxt lname $ do { let decl_arity = length arg_names (arg_names, rec_fields, is_infix) = collectPatSynArgInfo details ; traceTc "tcCheckPatSynDecl" $ - vcat [ ppr implicit_tvs, ppr explicit_univ_tvs, ppr req_theta - , ppr explicit_ex_tvs, ppr prov_theta, ppr sig_body_ty ] + vcat [ ppr implicit_bndrs, ppr explicit_univ_bndrs, ppr req_theta + , ppr explicit_ex_bndrs, ppr prov_theta, ppr sig_body_ty ] ; (arg_tys, pat_ty) <- case tcSplitFunTysN decl_arity sig_body_ty of Right stuff -> return stuff @@ -364,7 +364,7 @@ tcCheckPatSynDecl psb@PSB{ psb_id = lname@(L _ name), psb_args = details -- Complain about: pattern P :: () => forall x. x -> P x -- The existential 'x' should not appear in the result type -- Can't check this until we know P's arity - ; let bad_tvs = filter (`elemVarSet` tyCoVarsOfType pat_ty) explicit_ex_tvs + ; let bad_tvs = filter (`elemVarSet` tyCoVarsOfType pat_ty) $ binderVars explicit_ex_bndrs ; checkTc (null bad_tvs) $ hang (sep [ text "The result type of the signature for" <+> quotes (ppr name) <> comma , text "namely" <+> quotes (ppr pat_ty) ]) @@ -373,10 +373,10 @@ tcCheckPatSynDecl psb@PSB{ psb_id = lname@(L _ name), psb_args = details -- See Note [The pattern-synonym signature splitting rule] in GHC.Tc.Gen.Sig ; let univ_fvs = closeOverKinds $ - (tyCoVarsOfTypes (pat_ty : req_theta) `extendVarSetList` explicit_univ_tvs) - (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 + (tyCoVarsOfTypes (pat_ty : req_theta) `extendVarSetList` (binderVars explicit_univ_bndrs)) + (extra_univ, extra_ex) = partition ((`elemVarSet` univ_fvs) . binderVar) implicit_bndrs + univ_bndrs = extra_univ ++ explicit_univ_bndrs + ex_bndrs = extra_ex ++ explicit_ex_bndrs univ_tvs = binderVars univ_bndrs ex_tvs = binderVars ex_bndrs @@ -594,8 +594,8 @@ tc_patsyn_finish :: Located Name -- ^ PatSyn Name -> HsPatSynDir GhcRn -- ^ PatSyn type (Uni/Bidir/ExplicitBidir) -> Bool -- ^ Whether infix -> LPat GhcTc -- ^ Pattern of the PatSyn - -> ([TcTyVarBinder], [PredType], TcEvBinds, [EvVar]) - -> ([TcTyVarBinder], [TcType], [PredType], [EvTerm]) + -> ([TcInvisTVBinder], [PredType], TcEvBinds, [EvVar]) + -> ([TcInvisTVBinder], [TcType], [PredType], [EvTerm]) -> ([LHsExpr GhcTcId], [TcType]) -- ^ Pattern arguments and -- types -> TcType -- ^ Pattern type @@ -782,8 +782,8 @@ isUnidirectional ExplicitBidirectional{} = False -} mkPatSynBuilderId :: HsPatSynDir a -> Located Name - -> [TyVarBinder] -> ThetaType - -> [TyVarBinder] -> ThetaType + -> [InvisTVBinder] -> ThetaType + -> [InvisTVBinder] -> ThetaType -> [Type] -> Type -> TcM (Maybe (Id, Bool)) mkPatSynBuilderId dir (L _ name) @@ -796,8 +796,8 @@ mkPatSynBuilderId dir (L _ name) ; let theta = req_theta ++ prov_theta need_dummy_arg = isUnliftedType pat_ty && null arg_tys && null theta builder_sigma = add_void need_dummy_arg $ - mkForAllTys univ_bndrs $ - mkForAllTys ex_bndrs $ + mkInvisForAllTys univ_bndrs $ + mkInvisForAllTys ex_bndrs $ mkPhiTy theta $ mkVisFunTys arg_tys $ pat_ty diff --git a/compiler/GHC/Tc/TyCl/Utils.hs b/compiler/GHC/Tc/TyCl/Utils.hs index 249f08beea..00a4c01493 100644 --- a/compiler/GHC/Tc/TyCl/Utils.hs +++ b/compiler/GHC/Tc/TyCl/Utils.hs @@ -784,7 +784,7 @@ mkDefaultMethodType cls _ (GenericDM dm_ty) = mkSigmaTy tv_bndrs [pred] dm_ty where pred = mkClassPred cls (mkTyVarTys (binderVars cls_bndrs)) cls_bndrs = tyConBinders (classTyCon cls) - tv_bndrs = tyConTyVarBinders cls_bndrs + tv_bndrs = tyVarSpecToBinders $ tyConInvisTVBinders cls_bndrs -- NB: the Class doesn't have TyConBinders; we reach into its -- TyCon to get those. We /do/ need the TyConBinders because -- we need the correct visibility: these default methods are @@ -877,7 +877,7 @@ mkOneRecordSelector all_cons idDetails fl data_tv_set= tyCoVarsOfTypes inst_tys is_naughty = not (tyCoVarsOfType field_ty `subVarSet` data_tv_set) sel_ty | is_naughty = unitTy -- See Note [Naughty record selectors] - | otherwise = mkForAllTys data_tvbs $ + | otherwise = mkForAllTys (tyVarSpecToBinders data_tvbs) $ mkPhiTy (conLikeStupidTheta con1) $ -- Urgh! -- req_theta is empty for normal DataCon mkPhiTy req_theta $ diff --git a/compiler/GHC/Tc/Types.hs b/compiler/GHC/Tc/Types.hs index deafb5539d..6e60efd4d5 100644 --- a/compiler/GHC/Tc/Types.hs +++ b/compiler/GHC/Tc/Types.hs @@ -1516,7 +1516,7 @@ sig_extra_cts is Nothing. data TcIdSigInst = TISI { sig_inst_sig :: TcIdSigInfo - , sig_inst_skols :: [(Name, TcTyVar)] + , sig_inst_skols :: [(Name, InvisTVBinder)] -- Instantiated type and kind variables, TyVarTvs -- The Name is the Name that the renamer chose; -- but the TcTyVar may come from instantiating @@ -1602,12 +1602,12 @@ Here we get data TcPatSynInfo = TPSI { patsig_name :: Name, - patsig_implicit_bndrs :: [TyVarBinder], -- Implicitly-bound kind vars (Inferred) and - -- implicitly-bound type vars (Specified) + patsig_implicit_bndrs :: [InvisTVBinder], -- Implicitly-bound kind vars (Inferred) and + -- implicitly-bound type vars (Specified) -- See Note [The pattern-synonym signature splitting rule] in GHC.Tc.TyCl.PatSyn - patsig_univ_bndrs :: [TyVar], -- Bound by explicit user forall + patsig_univ_bndrs :: [InvisTVBinder], -- Bound by explicit user forall patsig_req :: TcThetaType, - patsig_ex_bndrs :: [TyVar], -- Bound by explicit user forall + patsig_ex_bndrs :: [InvisTVBinder], -- Bound by explicit user forall patsig_prov :: TcThetaType, patsig_body_ty :: TcSigmaType } diff --git a/compiler/GHC/Tc/Utils/TcMType.hs b/compiler/GHC/Tc/Utils/TcMType.hs index bbd52bd059..90598e42c4 100644 --- a/compiler/GHC/Tc/Utils/TcMType.hs +++ b/compiler/GHC/Tc/Utils/TcMType.hs @@ -59,7 +59,7 @@ module GHC.Tc.Utils.TcMType ( newMetaTyVarTyVars, newMetaTyVarTyVarX, newTyVarTyVar, cloneTyVarTyVar, newPatSigTyVar, newSkolemTyVar, newWildCardX, - tcInstType, + tcInstType, tcInstTypeBndrs, tcInstSkolTyVars, tcInstSkolTyVarsX, tcInstSkolTyVarsAt, tcSkolDFunType, tcSuperSkolTyVars, tcInstSuperSkolTyVarsX, @@ -79,7 +79,7 @@ module GHC.Tc.Utils.TcMType ( zonkAndSkolemise, skolemiseQuantifiedTyVar, defaultTyVar, quantifyTyVars, isQuantifiableTv, zonkTcType, zonkTcTypes, zonkCo, - zonkTyCoVarKind, + zonkTyCoVarKind, zonkTyCoVarKindBinder, zonkEvVar, zonkWC, zonkSimples, zonkId, zonkCoVar, @@ -507,23 +507,55 @@ inferResultToType (IR { ir_uniq = u, ir_lvl = tc_lvl * * ********************************************************************* -} +tc_inst_internal :: ([VarBndr TyVar flag] -> TcM (TCvSubst, [VarBndr TcTyVar flag])) + -- ^ How to instantiate the type variables + -> [VarBndr TyVar flag] -- ^ Type variable to instantiate + -> Type -- ^ rho + -> TcM ([(Name, VarBndr TcTyVar flag)], TcThetaType, TcType) -- ^ Result + -- (type vars, preds (incl equalities), rho) +tc_inst_internal _inst_tyvars [] rho = + let -- There may be overloading despite no type variables; + -- (?x :: Int) => Int -> Int + (theta, tau) = tcSplitPhiTy rho + in + return ([], theta, tau) +tc_inst_internal inst_tyvars tyvars rho = + do { (subst, tyvars') <- inst_tyvars tyvars + ; let (theta, tau) = tcSplitPhiTy (substTyAddInScope subst rho) + tv_prs = map (tyVarName . binderVar) tyvars `zip` tyvars' + ; return (tv_prs, theta, tau) } + tcInstType :: ([TyVar] -> TcM (TCvSubst, [TcTyVar])) -- ^ How to instantiate the type variables - -> Id -- ^ Type to instantiate - -> TcM ([(Name, TcTyVar)], TcThetaType, TcType) -- ^ Result + -> Id -- ^ Type to instantiate + -> TcM ([(Name, TcTyVar)], TcThetaType, TcType) -- ^ Result -- (type vars, preds (incl equalities), rho) -tcInstType inst_tyvars id - = case tcSplitForAllTys (idType id) of - ([], rho) -> let -- There may be overloading despite no type variables; - -- (?x :: Int) => Int -> Int - (theta, tau) = tcSplitPhiTy rho - in - return ([], theta, tau) - - (tyvars, rho) -> do { (subst, tyvars') <- inst_tyvars tyvars - ; let (theta, tau) = tcSplitPhiTy (substTyAddInScope subst rho) - tv_prs = map tyVarName tyvars `zip` tyvars' - ; return (tv_prs, theta, tau) } +tcInstType inst_tyvars id = + do { let (tyvars, rho) = splitForAllTys (idType id) + tyvars' = mkTyVarBinders () tyvars + ; (tv_prs, preds, rho) <- tc_inst_internal inst_tyvar_bndrs tyvars' rho + ; let tv_prs' = map (\(name, bndr) -> (name, binderVar bndr)) tv_prs + ; return (tv_prs', preds, rho) } + where + inst_tyvar_bndrs :: [VarBndr TyVar ()] -> TcM (TCvSubst, [VarBndr TcTyVar ()]) + inst_tyvar_bndrs bndrs = do { (subst, tvs) <- inst_tyvars $ binderVars bndrs + ; let tvbnds = map (\tv -> Bndr tv ()) tvs + ; return (subst, tvbnds) } + +tcInstTypeBndrs :: ([VarBndr TyVar Specificity] -> TcM (TCvSubst, [VarBndr TcTyVar Specificity])) + -- ^ How to instantiate the type variables + -> Id -- ^ Type to instantiate + -> TcM ([(Name, VarBndr TcTyVar Specificity)], TcThetaType, TcType) -- ^ Result + -- (type vars, preds (incl equalities), rho) +tcInstTypeBndrs inst_tyvars id = + let (tyvars, rho) = splitForAllVarBndrs (idType id) + tyvars' = map argf_to_spec tyvars + in tc_inst_internal inst_tyvars tyvars' rho + where + argf_to_spec :: VarBndr TyCoVar ArgFlag -> VarBndr TyCoVar Specificity + argf_to_spec (Bndr tv Required) = Bndr tv SpecifiedSpec + -- see Note [Specificity in HsForAllTy] in GHC.Hs.Types + argf_to_spec (Bndr tv (Invisible s)) = Bndr tv s tcSkolDFunType :: DFunId -> TcM ([TcTyVar], TcThetaType, TcType) -- Instantiate a type signature with skolem constants. @@ -1000,12 +1032,16 @@ newMetaTyVarX :: TCvSubst -> TyVar -> TcM (TCvSubst, TcTyVar) -- an existing TyVar. We substitute kind variables in the kind. newMetaTyVarX subst tyvar = new_meta_tv_x TauTv subst tyvar -newMetaTyVarTyVars :: [TyVar] -> TcM (TCvSubst, [TcTyVar]) +newMetaTyVarTyVars :: [VarBndr TyVar Specificity] + -> TcM (TCvSubst, [VarBndr TcTyVar Specificity]) newMetaTyVarTyVars = mapAccumLM newMetaTyVarTyVarX emptyTCvSubst -newMetaTyVarTyVarX :: TCvSubst -> TyVar -> TcM (TCvSubst, TcTyVar) +newMetaTyVarTyVarX :: TCvSubst -> (VarBndr TyVar Specificity) + -> TcM (TCvSubst, VarBndr TcTyVar Specificity) -- Just like newMetaTyVarX, but make a TyVarTv -newMetaTyVarTyVarX subst tyvar = new_meta_tv_x TyVarTv subst tyvar +newMetaTyVarTyVarX subst (Bndr tv spec) = + do { (subst', tv') <- new_meta_tv_x TyVarTv subst tv + ; return (subst', (Bndr tv' spec)) } newWildCardX :: TCvSubst -> TyVar -> TcM (TCvSubst, TcTyVar) newWildCardX subst tv @@ -1972,6 +2008,10 @@ zonkTyCoVarKind :: TyCoVar -> TcM TyCoVar zonkTyCoVarKind tv = do { kind' <- zonkTcType (tyVarKind tv) ; return (setTyVarKind tv kind') } +zonkTyCoVarKindBinder :: (VarBndr TyCoVar fl) -> TcM (VarBndr TyCoVar fl) +zonkTyCoVarKindBinder (Bndr tv fl) = do { kind' <- zonkTcType (tyVarKind tv) + ; return $ Bndr (setTyVarKind tv kind') fl } + {- ************************************************************************ * * @@ -2178,12 +2218,12 @@ zonkTcTyVarToTyVar tv (ppr tv $$ ppr ty) ; return tv' } -zonkTyVarTyVarPairs :: [(Name,TcTyVar)] -> TcM [(Name,TcTyVar)] +zonkTyVarTyVarPairs :: [(Name,VarBndr TcTyVar Specificity)] -> TcM [(Name,VarBndr TcTyVar Specificity)] zonkTyVarTyVarPairs prs = mapM do_one prs where - do_one (nm, tv) = do { tv' <- zonkTcTyVarToTyVar tv - ; return (nm, tv') } + do_one (nm, Bndr tv spec) = do { tv' <- zonkTcTyVarToTyVar tv + ; return (nm, Bndr tv' spec) } -- zonkId is used *during* typechecking just to zonk the Id's type zonkId :: TcId -> TcM TcId diff --git a/compiler/GHC/Tc/Utils/TcType.hs b/compiler/GHC/Tc/Utils/TcType.hs index 2ee00a88dc..fb1d6f432b 100644 --- a/compiler/GHC/Tc/Utils/TcType.hs +++ b/compiler/GHC/Tc/Utils/TcType.hs @@ -21,7 +21,7 @@ module GHC.Tc.Utils.TcType ( -- Types TcType, TcSigmaType, TcRhoType, TcTauType, TcPredType, TcThetaType, TcTyVar, TcTyVarSet, TcDTyVarSet, TcTyCoVarSet, TcDTyCoVarSet, - TcKind, TcCoVar, TcTyCoVar, TcTyVarBinder, TcTyCon, + TcKind, TcCoVar, TcTyCoVar, TcTyVarBinder, TcInvisTVBinder, TcTyCon, KnotTied, ExpType(..), InferResult(..), ExpSigmaType, ExpRhoType, mkCheckExpType, @@ -130,8 +130,9 @@ module GHC.Tc.Utils.TcType ( Type, PredType, ThetaType, TyCoBinder, ArgFlag(..), AnonArgFlag(..), ForallVisFlag(..), - mkForAllTy, mkForAllTys, mkTyCoInvForAllTys, mkSpecForAllTys, mkTyCoInvForAllTy, - mkInvForAllTy, mkInvForAllTys, + mkForAllTy, mkForAllTys, mkInvisForAllTys, mkTyCoInvForAllTys, + mkSpecForAllTys, mkTyCoInvForAllTy, + mkInfForAllTy, mkInfForAllTys, mkVisFunTy, mkVisFunTys, mkInvisFunTy, mkInvisFunTys, mkTyConApp, mkAppTy, mkAppTys, mkTyConTy, mkTyVarTy, mkTyVarTys, @@ -337,8 +338,9 @@ type TcTyCoVar = Var -- Either a TcTyVar or a CoVar -- a cannot occur inside a MutTyVar in T; that is, -- T is "flattened" before quantifying over a -type TcTyVarBinder = TyVarBinder -type TcTyCon = TyCon -- these can be the TcTyCon constructor +type TcTyVarBinder = TyVarBinder +type TcInvisTVBinder = InvisTVBinder +type TcTyCon = TyCon -- these can be the TcTyCon constructor -- These types do not have boxy type variables in them type TcPredType = PredType @@ -1213,8 +1215,9 @@ tcSplitForAllTys ty -- @'sameVis' argf supplied_argf@ is 'True', where @argf@ is the visibility -- of the @ForAllTy@'s binder and @supplied_argf@ is the visibility provided -- as an argument to this function. -tcSplitForAllTysSameVis :: ArgFlag -> Type -> ([TyVar], Type) -tcSplitForAllTysSameVis supplied_argf ty = ASSERT( all isTyVar (fst sty) ) sty +-- All split tyvars are annotated with their argf. +tcSplitForAllTysSameVis :: ArgFlag -> Type -> ([TyVarBinder], Type) +tcSplitForAllTysSameVis supplied_argf ty = ASSERT( all (isTyVar . binderVar) (fst sty) ) sty where sty = splitForAllTysSameVis supplied_argf ty -- | Like 'tcSplitForAllTys', but splits off only named binders. diff --git a/compiler/GHC/ThToHs.hs b/compiler/GHC/ThToHs.hs index e1d1c97410..453106eaec 100644 --- a/compiler/GHC/ThToHs.hs +++ b/compiler/GHC/ThToHs.hs @@ -11,6 +11,8 @@ This module converts Template Haskell syntax into Hs syntax {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE LambdaCase #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} @@ -35,7 +37,7 @@ import GHC.Unit.Module import GHC.Parser.PostProcess import GHC.Types.Name.Occurrence as OccName import GHC.Types.SrcLoc -import GHC.Core.Type +import GHC.Core.Type as Hs import qualified GHC.Core.Coercion as Coercion ( Role(..) ) import GHC.Builtin.Types import GHC.Types.Basic as Hs @@ -477,7 +479,7 @@ cvt_ci_decs doc decs ; return (listToBag binds', sigs', fams', ats', adts') } ---------------- -cvt_tycl_hdr :: TH.Cxt -> TH.Name -> [TH.TyVarBndr] +cvt_tycl_hdr :: TH.Cxt -> TH.Name -> [TH.TyVarBndr ()] -> CvtM ( LHsContext GhcPs , Located RdrName , LHsQTyVars GhcPs) @@ -485,13 +487,13 @@ cvt_tycl_hdr cxt tc tvs = do { cxt' <- cvtContext funPrec cxt ; tc' <- tconNameL tc ; tvs' <- cvtTvs tvs - ; return (cxt', tc', tvs') + ; return (cxt', tc', mkHsQTvs tvs') } -cvt_datainst_hdr :: TH.Cxt -> Maybe [TH.TyVarBndr] -> TH.Type +cvt_datainst_hdr :: TH.Cxt -> Maybe [TH.TyVarBndr ()] -> TH.Type -> CvtM ( LHsContext GhcPs , Located RdrName - , Maybe [LHsTyVarBndr GhcPs] + , Maybe [LHsTyVarBndr () GhcPs] , HsTyPats GhcPs) cvt_datainst_hdr cxt bndrs tys = do { cxt' <- cvtContext funPrec cxt @@ -594,17 +596,19 @@ cvtConstr (ForallC tvs ctxt con) add_forall tvs' cxt' con@(ConDeclGADT { con_qvars = qvars, con_mb_cxt = cxt }) = con { con_forall = noLoc $ not (null all_tvs) - , con_qvars = mkHsQTvs all_tvs + , con_qvars = all_tvs , con_mb_cxt = add_cxt cxt' cxt } where - all_tvs = hsQTvExplicit tvs' ++ hsQTvExplicit qvars + all_tvs = tvs' ++ qvars add_forall tvs' cxt' con@(ConDeclH98 { con_ex_tvs = ex_tvs, con_mb_cxt = cxt }) = con { con_forall = noLoc $ not (null all_tvs) , con_ex_tvs = all_tvs , con_mb_cxt = add_cxt cxt' cxt } where - all_tvs = hsQTvExplicit tvs' ++ ex_tvs + all_tvs = tvs' ++ ex_tvs + + add_forall _ _ (XConDecl nec) = noExtCon nec cvtConstr (GadtC [] _strtys _ty) = failWith (text "GadtC must have at least one constructor name") @@ -763,7 +767,7 @@ cvtPragmaD (SpecialiseInstP ty) cvtPragmaD (RuleP nm ty_bndrs tm_bndrs lhs rhs phases) = do { let nm' = mkFastString nm ; let act = cvtPhases phases AlwaysActive - ; ty_bndrs' <- traverse (mapM cvt_tv) ty_bndrs + ; ty_bndrs' <- traverse cvtTvs ty_bndrs ; tm_bndrs' <- mapM cvtRuleBndr tm_bndrs ; lhs' <- cvtl lhs ; rhs' <- cvtl rhs @@ -1342,17 +1346,29 @@ cvtOpAppP x op y ----------------------------------------------------------- -- Types and type variables -cvtTvs :: [TH.TyVarBndr] -> CvtM (LHsQTyVars GhcPs) -cvtTvs tvs = do { tvs' <- mapM cvt_tv tvs; return (mkHsQTvs tvs') } +class CvtFlag flag flag' | flag -> flag' where + cvtFlag :: flag -> flag' + +instance CvtFlag () () where + cvtFlag () = () + +instance CvtFlag TH.Specificity Hs.Specificity where + cvtFlag TH.SpecifiedSpec = Hs.SpecifiedSpec + cvtFlag TH.InferredSpec = Hs.InferredSpec -cvt_tv :: TH.TyVarBndr -> CvtM (LHsTyVarBndr GhcPs) -cvt_tv (TH.PlainTV nm) +cvtTvs :: CvtFlag flag flag' => [TH.TyVarBndr flag] -> CvtM [LHsTyVarBndr flag' GhcPs] +cvtTvs tvs = mapM cvt_tv tvs + +cvt_tv :: CvtFlag flag flag' => (TH.TyVarBndr flag) -> CvtM (LHsTyVarBndr flag' GhcPs) +cvt_tv (TH.PlainTV nm fl) = do { nm' <- tNameL nm - ; returnL $ UserTyVar noExtField nm' } -cvt_tv (TH.KindedTV nm ki) + ; let fl' = cvtFlag fl + ; returnL $ UserTyVar noExtField fl' nm' } +cvt_tv (TH.KindedTV nm fl ki) = do { nm' <- tNameL nm + ; let fl' = cvtFlag fl ; ki' <- cvtKind ki - ; returnL $ KindedTyVar noExtField nm' ki' } + ; returnL $ KindedTyVar noExtField fl' nm' ki' } cvtRole :: TH.Role -> Maybe Coercion.Role cvtRole TH.NominalR = Just Coercion.Nominal @@ -1458,17 +1474,19 @@ cvtTypeKind ty_str ty ; cxt' <- cvtContext funPrec cxt ; ty' <- cvtType ty ; loc <- getL - ; let hs_ty = mkHsForAllTy tvs loc ForallInvis tvs' rho_ty + ; let hs_ty = mkHsForAllTy loc ForallInvis tvs' rho_ty rho_ty = mkHsQualTy cxt loc cxt' ty' ; return hs_ty } ForallVisT tvs ty | null tys' - -> do { tvs' <- cvtTvs tvs - ; ty' <- cvtType ty - ; loc <- getL - ; pure $ mkHsForAllTy tvs loc ForallVis tvs' ty' } + -> do { let tvs_spec = map (TH.SpecifiedSpec <$) tvs + -- see Note [Specificity in HsForAllTy] in GHC.Hs.Types + ; tvs_spec' <- cvtTvs tvs_spec + ; ty' <- cvtType ty + ; loc <- getL + ; pure $ mkHsForAllTy loc ForallVis tvs_spec' ty' } SigT ty ki -> do { ty' <- cvtType ty @@ -1705,7 +1723,7 @@ cvtPatSynSigTy (ForallT univs reqs (ForallT exis provs ty)) , hst_xqual = noExtField , hst_body = ty' }) } | null reqs = do { l <- getL - ; univs' <- hsQTvExplicit <$> cvtTvs univs + ; univs' <- cvtTvs univs ; ty' <- cvtType (ForallT exis provs ty) ; let forTy = HsForAllTy { hst_fvf = ForallInvis @@ -1755,27 +1773,25 @@ unboxedSumChecks alt arity | otherwise = return () --- | If passed an empty list of 'TH.TyVarBndr's, this simply returns the +-- | If passed an empty list of 'LHsTyVarBndr's, this simply returns the -- third argument (an 'LHsType'). Otherwise, return an 'HsForAllTy' -- using the provided 'LHsQTyVars' and 'LHsType'. -mkHsForAllTy :: [TH.TyVarBndr] - -- ^ The original Template Haskell type variable binders - -> SrcSpan +mkHsForAllTy :: SrcSpan -- ^ The location of the returned 'LHsType' if it needs an -- explicit forall -> ForallVisFlag -- ^ Whether this is @forall@ is visible (e.g., @forall a ->@) -- or invisible (e.g., @forall a.@) - -> LHsQTyVars GhcPs + -> [LHsTyVarBndr Hs.Specificity GhcPs] -- ^ The converted type variable binders -> LHsType GhcPs -- ^ The converted rho type -> LHsType GhcPs -- ^ The complete type, quantified with a forall if necessary -mkHsForAllTy tvs loc fvf tvs' rho_ty +mkHsForAllTy loc fvf tvs rho_ty | null tvs = rho_ty | otherwise = L loc $ HsForAllTy { hst_fvf = fvf - , hst_bndrs = hsQTvExplicit tvs' + , hst_bndrs = tvs , hst_xforall = noExtField , hst_body = rho_ty } diff --git a/compiler/GHC/Types/Id/Make.hs b/compiler/GHC/Types/Id/Make.hs index 910d738a8e..176eebc090 100644 --- a/compiler/GHC/Types/Id/Make.hs +++ b/compiler/GHC/Types/Id/Make.hs @@ -406,7 +406,7 @@ mkDictSelId name clas arg_tys = dataConRepArgTys data_con -- Includes the dictionary superclasses val_index = assoc "MkId.mkDictSelId" (sel_names `zip` [0..]) name - sel_ty = mkForAllTys tyvars $ + sel_ty = mkInvisForAllTys tyvars $ mkInvisFunTy (mkClassPred clas (mkTyVarTys (binderVars tyvars))) $ getNth arg_tys val_index @@ -1381,7 +1381,7 @@ proxyHashId [kv,tv] = mkTemplateKiTyVars [liftedTypeKind] id kv_ty = mkTyVarTy kv tv_ty = mkTyVarTy tv - ty = mkInvForAllTy kv $ mkSpecForAllTy tv $ mkProxyPrimTy kv_ty tv_ty + ty = mkInfForAllTy kv $ mkSpecForAllTy tv $ mkProxyPrimTy kv_ty tv_ty ------------------------------------------------ nullAddrId :: Id @@ -1411,7 +1411,7 @@ seqId = pcMiscPrelId seqName ty info -- seq :: forall (r :: RuntimeRep) a (b :: TYPE r). a -> b -> b ty = - mkInvForAllTy runtimeRep2TyVar + mkInfForAllTy runtimeRep2TyVar $ mkSpecForAllTys [alphaTyVar, openBetaTyVar] $ mkVisFunTy alphaTy (mkVisFunTy openBetaTy openBetaTy) @@ -1465,10 +1465,10 @@ coerceId = pcMiscPrelId coerceName ty info `setUnfoldingInfo` mkCompulsoryUnfolding rhs eqRTy = mkTyConApp coercibleTyCon [ tYPE r , a, b ] eqRPrimTy = mkTyConApp eqReprPrimTyCon [ tYPE r, tYPE r, a, b ] - ty = mkForAllTys [ Bndr rv Inferred - , Bndr av Specified - , Bndr bv Specified - ] $ + ty = mkInvisForAllTys [ Bndr rv InferredSpec + , Bndr av SpecifiedSpec + , Bndr bv SpecifiedSpec + ] $ mkInvisFunTy eqRTy $ mkVisFunTy a b diff --git a/compiler/GHC/Types/Var.hs b/compiler/GHC/Types/Var.hs index d58065305e..e97038bf5c 100644 --- a/compiler/GHC/Types/Var.hs +++ b/compiler/GHC/Types/Var.hs @@ -5,7 +5,7 @@ \section{@Vars@: Variables} -} -{-# LANGUAGE CPP, FlexibleContexts, MultiWayIf, FlexibleInstances, DeriveDataTypeable #-} +{-# LANGUAGE CPP, FlexibleContexts, MultiWayIf, FlexibleInstances, DeriveDataTypeable, PatternSynonyms #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} @@ -63,15 +63,18 @@ module GHC.Types.Var ( mustHaveLocalBinding, -- * ArgFlags - ArgFlag(..), isVisibleArgFlag, isInvisibleArgFlag, sameVis, + ArgFlag(Invisible,Required,Specified,Inferred), + isVisibleArgFlag, isInvisibleArgFlag, sameVis, AnonArgFlag(..), ForallVisFlag(..), argToForallVisFlag, + Specificity(..), -- * TyVar's - VarBndr(..), TyCoVarBinder, TyVarBinder, + VarBndr(..), TyCoVarBinder, TyVarBinder, InvisTVBinder, binderVar, binderVars, binderArgFlag, binderType, mkTyCoVarBinder, mkTyCoVarBinders, mkTyVarBinder, mkTyVarBinders, - isTyVarBinder, + isTyVarBinder, tyVarSpecToBinder, tyVarSpecToBinders, + mapVarBndr, mapVarBndrs, lookupVarBndr, -- ** Constructing TyVar's mkTyVar, mkTcTyVar, @@ -396,10 +399,27 @@ updateVarTypeM f id = do { ty' <- f (varType id) -- permitted by request ('Specified') (visible type application), or -- prohibited entirely from appearing in source Haskell ('Inferred')? -- See Note [VarBndrs, TyCoVarBinders, TyConBinders, and visibility] in GHC.Core.TyCo.Rep -data ArgFlag = Inferred | Specified | Required +data ArgFlag = Invisible Specificity + | Required deriving (Eq, Ord, Data) -- (<) on ArgFlag means "is less visible than" +-- | Whether an 'Invisible' argument may appear in source Haskell. +-- see Note [Specificity in HsForAllTy] in GHC.Hs.Types +data Specificity = InferredSpec + -- ^ the argument may not appear in source Haskell, it is + -- only inferred. + | SpecifiedSpec + -- ^ the argument may appear in source Haskell, but isn't + -- required. + deriving (Eq, Ord, Data) + +pattern Inferred, Specified :: ArgFlag +pattern Inferred = Invisible InferredSpec +pattern Specified = Invisible SpecifiedSpec + +{-# COMPLETE Required, Specified, Inferred #-} + -- | Does this 'ArgFlag' classify an argument that is written in Haskell? isVisibleArgFlag :: ArgFlag -> Bool isVisibleArgFlag Required = True @@ -413,16 +433,25 @@ isInvisibleArgFlag = not . isVisibleArgFlag -- arguments are visible, others are not. So this function -- equates 'Specified' and 'Inferred'. Used for printing. sameVis :: ArgFlag -> ArgFlag -> Bool -sameVis Required Required = True -sameVis Required _ = False -sameVis _ Required = False -sameVis _ _ = True +sameVis Required Required = True +sameVis (Invisible _) (Invisible _) = True +sameVis _ _ = False instance Outputable ArgFlag where ppr Required = text "[req]" ppr Specified = text "[spec]" ppr Inferred = text "[infrd]" +instance Binary Specificity where + put_ bh SpecifiedSpec = putByte bh 0 + put_ bh InferredSpec = putByte bh 1 + + get bh = do + h <- getByte bh + case h of + 0 -> return SpecifiedSpec + _ -> return InferredSpec + instance Binary ArgFlag where put_ bh Required = putByte bh 0 put_ bh Specified = putByte bh 1 @@ -529,8 +558,15 @@ data VarBndr var argf = Bndr var argf -- home in GHC.Core.TyCo.Rep, because it's used in GHC.Core.DataCon.hs-boot -- -- A 'TyVarBinder' is a binder with only TyVar -type TyCoVarBinder = VarBndr TyCoVar ArgFlag -type TyVarBinder = VarBndr TyVar ArgFlag +type TyCoVarBinder = VarBndr TyCoVar ArgFlag +type TyVarBinder = VarBndr TyVar ArgFlag +type InvisTVBinder = VarBndr TyVar Specificity + +tyVarSpecToBinders :: [VarBndr a Specificity] -> [VarBndr a ArgFlag] +tyVarSpecToBinders = map tyVarSpecToBinder + +tyVarSpecToBinder :: (VarBndr a Specificity) -> (VarBndr a ArgFlag) +tyVarSpecToBinder (Bndr tv vis) = Bndr tv (Invisible vis) binderVar :: VarBndr tv argf -> tv binderVar (Bndr v _) = v @@ -545,33 +581,47 @@ binderType :: VarBndr TyCoVar argf -> Type binderType (Bndr tv _) = varType tv -- | Make a named binder -mkTyCoVarBinder :: ArgFlag -> TyCoVar -> TyCoVarBinder +mkTyCoVarBinder :: vis -> TyCoVar -> (VarBndr TyCoVar vis) mkTyCoVarBinder vis var = Bndr var vis -- | Make a named binder -- 'var' should be a type variable -mkTyVarBinder :: ArgFlag -> TyVar -> TyVarBinder +mkTyVarBinder :: vis -> TyVar -> (VarBndr TyVar vis) mkTyVarBinder vis var = ASSERT( isTyVar var ) Bndr var vis -- | Make many named binders -mkTyCoVarBinders :: ArgFlag -> [TyCoVar] -> [TyCoVarBinder] +mkTyCoVarBinders :: vis -> [TyCoVar] -> [VarBndr TyCoVar vis] mkTyCoVarBinders vis = map (mkTyCoVarBinder vis) -- | Make many named binders -- Input vars should be type variables -mkTyVarBinders :: ArgFlag -> [TyVar] -> [TyVarBinder] +mkTyVarBinders :: vis -> [TyVar] -> [VarBndr TyVar vis] mkTyVarBinders vis = map (mkTyVarBinder vis) isTyVarBinder :: TyCoVarBinder -> Bool isTyVarBinder (Bndr v _) = isTyVar v +mapVarBndr :: (var -> var') -> (VarBndr var flag) -> (VarBndr var' flag) +mapVarBndr f (Bndr v fl) = Bndr (f v) fl + +mapVarBndrs :: (var -> var') -> [VarBndr var flag] -> [VarBndr var' flag] +mapVarBndrs f = map (mapVarBndr f) + +lookupVarBndr :: Eq var => var -> [VarBndr var flag] -> Maybe flag +lookupVarBndr var bndrs = lookup var zipped_bndrs + where + zipped_bndrs = map (\(Bndr v f) -> (v,f)) bndrs + instance Outputable tv => Outputable (VarBndr tv ArgFlag) where ppr (Bndr v Required) = ppr v ppr (Bndr v Specified) = char '@' <> ppr v ppr (Bndr v Inferred) = braces (ppr v) +instance Outputable tv => Outputable (VarBndr tv Specificity) where + ppr = ppr . tyVarSpecToBinder + instance (Binary tv, Binary vis) => Binary (VarBndr tv vis) where put_ bh (Bndr tv vis) = do { put_ bh tv; put_ bh vis } diff --git a/docs/users_guide/8.12.1-notes.rst b/docs/users_guide/8.12.1-notes.rst index 5c478b8fa4..46a729af70 100644 --- a/docs/users_guide/8.12.1-notes.rst +++ b/docs/users_guide/8.12.1-notes.rst @@ -79,6 +79,13 @@ Language This change prepares the way for Quick Look impredicativity. +* GHC now allows users to manually define the specificity of type variable + binders. By marking a variable with braces ``{tyvar}`` or ``{tyvar :: kind}``, + it becomes inferred despite appearing in a type signature. This feature + effectively allows users to choose which variables can or can't be + instantiated through visible type application. More information can be found + here: :ref:`Manually-defining-inferred-variables`. + Compiler ~~~~~~~~ diff --git a/docs/users_guide/exts/type_applications.rst b/docs/users_guide/exts/type_applications.rst index 2a735436d8..c175008617 100644 --- a/docs/users_guide/exts/type_applications.rst +++ b/docs/users_guide/exts/type_applications.rst @@ -178,4 +178,81 @@ the rules in the subtler cases: The section in this manual on kind polymorphism describes how variables in type and class declarations are ordered (:ref:`inferring-variable-order`). +.. _Manually-defining-inferred-variables: +Manually defining inferred variables +------------------------------------ + +While user-written type or kind variables are specified by default, GHC permits +labelling these variables as inferred. By writing the type variable binder in +braces as ``{tyvar}`` or ``{tyvar :: kind}``, the new variable will be +classified as inferred, not specified. Doing so gives the programmer control +over which variables can be manually instantiated and which can't. +Note that the braces do not influence scoping: variables in braces are still +brought into scope just the same. +Consider for example:: + + myConst :: forall {a} b. a -> b -> a + myConst x _ = x + +In this example, despite both variables appearing in a type signature, ``a`` is +an inferred variable while ``b`` is specified. This means that the expression +``myConst @Int`` has type ``forall {a}. a -> Int -> a``. + +The braces are allowed in the following places: + +- In the type signatures of functions, variables, class methods, as well as type + annotations on expressions. Consider the example above. + +- In data constructor declarations, using the GADT syntax. Consider:: + + data T a where MkT :: forall {k} (a :: k). Proxy a -> T a + + The constructor ``MkT`` defined in this example is kind polymorphic, which is + emphasized to the reader by explicitly abstracting over the ``k`` variable. + As this variable is marked as inferred, it can not be manually instantiated. + +- In existential variable quantifications, e.g.:: + + data HList = HNil + | forall {a}. HCons a HList + +- In pattern synonym signatures. Consider for instance:: + + data T a where MkT :: forall a b. a -> b -> T a + + pattern Pat :: forall {c}. () => forall {d}. c -> d -> T c + pattern Pat x y = MkT x y + + Note that in this example, ``a`` is a universal variable in the data type + ``T``, where ``b`` is existential. When writing the pattern synonym, both + types are allowed to be specified or inferred. + +- On the right-hand side of a type synonym, e.g.:: + + type Foo = forall a {b}. Either a b + +- In type signatures on variables bound in RULES, e.g.:: + + {-# RULES "parametricity" forall (f :: forall {a}. a -> a). map f = id #-} + +The braces are *not* allowed in the following places: + +- In visible dependent quantifiers. Consider:: + + data T :: forall {k} -> k -> Type + + This example is rejected, as a visible argument should by definition be + explicitly applied. Making them inferred (and thus not appliable) would be + conflicting. + +- In default type signatures for class methods, in SPECIALISE pragmas or in + instance declaration heads, e.g.:: + + instance forall {a}. Eq (Maybe a) where ... + + The reason for this is, essentially, that none of these define a new + construct. This means that no new type is being defined where specificity + could play a role. + +- On the left-hand sides of type declarations, such as classes, data types, etc. diff --git a/libraries/ghci/GHCi/TH/Binary.hs b/libraries/ghci/GHCi/TH/Binary.hs index 6f7aaca3e2..69326eb9d1 100644 --- a/libraries/ghci/GHCi/TH/Binary.hs +++ b/libraries/ghci/GHCi/TH/Binary.hs @@ -26,7 +26,8 @@ instance Binary TH.Module instance Binary TH.Info instance Binary TH.Type instance Binary TH.TyLit -instance Binary TH.TyVarBndr +instance Binary TH.Specificity +instance Binary flag => Binary (TH.TyVarBndr flag) instance Binary TH.Role instance Binary TH.Lit instance Binary TH.Range diff --git a/libraries/template-haskell/Language/Haskell/TH.hs b/libraries/template-haskell/Language/Haskell/TH.hs index 693a80fc3d..36529e54dc 100644 --- a/libraries/template-haskell/Language/Haskell/TH.hs +++ b/libraries/template-haskell/Language/Haskell/TH.hs @@ -85,6 +85,7 @@ module Language.Haskell.TH( Pat(..), FieldExp, FieldPat, -- ** Types Type(..), TyVarBndr(..), TyLit(..), Kind, Cxt, Pred, Syntax.Role(..), + Syntax.Specificity(..), FamilyResultSig(..), Syntax.InjectivityAnn(..), PatSynType, BangType, VarBangType, -- * Library functions diff --git a/libraries/template-haskell/Language/Haskell/TH/Lib.hs b/libraries/template-haskell/Language/Haskell/TH/Lib.hs index 0ec932d00b..4df23cd3c5 100644 --- a/libraries/template-haskell/Language/Haskell/TH/Lib.hs +++ b/libraries/template-haskell/Language/Haskell/TH/Lib.hs @@ -18,12 +18,13 @@ module Language.Haskell.TH.Lib ( -- * Library functions -- ** Abbreviations - InfoQ, ExpQ, TExpQ, DecQ, DecsQ, ConQ, TypeQ, KindQ, TyVarBndrQ, + InfoQ, ExpQ, TExpQ, DecQ, DecsQ, ConQ, TypeQ, KindQ, TyLitQ, CxtQ, PredQ, DerivClauseQ, MatchQ, ClauseQ, BodyQ, GuardQ, StmtQ, RangeQ, SourceStrictnessQ, SourceUnpackednessQ, BangQ, BangTypeQ, VarBangTypeQ, StrictTypeQ, VarStrictTypeQ, FieldExpQ, PatQ, FieldPatQ, RuleBndrQ, TySynEqnQ, PatSynDirQ, PatSynArgsQ, FamilyResultSigQ, DerivStrategyQ, + TyVarBndrUnit, TyVarBndrSpec, -- ** Constructors lifted to 'Q' -- *** Literals @@ -75,6 +76,8 @@ module Language.Haskell.TH.Lib ( -- *** Type variable binders plainTV, kindedTV, + plainInvisTV, kindedInvisTV, + specifiedSpec, inferredSpec, -- *** Roles nominalR, representationalR, phantomR, inferR, @@ -174,10 +177,10 @@ import Prelude ------------------------------------------------------------------------------- -- * Dec -tySynD :: Quote m => Name -> [TyVarBndr] -> m Type -> m Dec +tySynD :: Quote m => Name -> [TyVarBndr ()] -> m Type -> m Dec tySynD tc tvs rhs = do { rhs1 <- rhs; return (TySynD tc tvs rhs1) } -dataD :: Quote m => m Cxt -> Name -> [TyVarBndr] -> Maybe Kind -> [m Con] -> [m DerivClause] +dataD :: Quote m => m Cxt -> Name -> [TyVarBndr ()] -> Maybe Kind -> [m Con] -> [m DerivClause] -> m Dec dataD ctxt tc tvs ksig cons derivs = do @@ -186,7 +189,7 @@ dataD ctxt tc tvs ksig cons derivs = derivs1 <- sequenceA derivs return (DataD ctxt1 tc tvs ksig cons1 derivs1) -newtypeD :: Quote m => m Cxt -> Name -> [TyVarBndr] -> Maybe Kind -> m Con -> [m DerivClause] +newtypeD :: Quote m => m Cxt -> Name -> [TyVarBndr ()] -> Maybe Kind -> m Con -> [m DerivClause] -> m Dec newtypeD ctxt tc tvs ksig con derivs = do @@ -195,7 +198,7 @@ newtypeD ctxt tc tvs ksig con derivs = derivs1 <- sequenceA derivs return (NewtypeD ctxt1 tc tvs ksig con1 derivs1) -classD :: Quote m => m Cxt -> Name -> [TyVarBndr] -> [FunDep] -> [m Dec] -> m Dec +classD :: Quote m => m Cxt -> Name -> [TyVarBndr ()] -> [FunDep] -> [m Dec] -> m Dec classD ctxt cls tvs fds decs = do decs1 <- sequenceA decs @@ -230,35 +233,35 @@ newtypeInstD ctxt tc tys ksig con derivs = derivs1 <- sequenceA derivs return (NewtypeInstD ctxt1 Nothing ty1 ksig con1 derivs1) -dataFamilyD :: Quote m => Name -> [TyVarBndr] -> Maybe Kind -> m Dec +dataFamilyD :: Quote m => Name -> [TyVarBndr ()] -> Maybe Kind -> m Dec dataFamilyD tc tvs kind = pure $ DataFamilyD tc tvs kind -openTypeFamilyD :: Quote m => Name -> [TyVarBndr] -> FamilyResultSig +openTypeFamilyD :: Quote m => Name -> [TyVarBndr ()] -> FamilyResultSig -> Maybe InjectivityAnn -> m Dec openTypeFamilyD tc tvs res inj = pure $ OpenTypeFamilyD (TypeFamilyHead tc tvs res inj) -closedTypeFamilyD :: Quote m => Name -> [TyVarBndr] -> FamilyResultSig +closedTypeFamilyD :: Quote m => Name -> [TyVarBndr ()] -> FamilyResultSig -> Maybe InjectivityAnn -> [m TySynEqn] -> m Dec closedTypeFamilyD tc tvs result injectivity eqns = do eqns1 <- sequenceA eqns return (ClosedTypeFamilyD (TypeFamilyHead tc tvs result injectivity) eqns1) -tySynEqn :: Quote m => (Maybe [TyVarBndr]) -> m Type -> m Type -> m TySynEqn +tySynEqn :: Quote m => (Maybe [TyVarBndr ()]) -> m Type -> m Type -> m TySynEqn tySynEqn tvs lhs rhs = do lhs1 <- lhs rhs1 <- rhs return (TySynEqn tvs lhs1 rhs1) -forallC :: Quote m => [TyVarBndr] -> m Cxt -> m Con -> m Con +forallC :: Quote m => [TyVarBndr Specificity] -> m Cxt -> m Con -> m Con forallC ns ctxt con = liftA2 (ForallC ns) ctxt con ------------------------------------------------------------------------------- -- * Type -forallT :: Quote m => [TyVarBndr] -> m Cxt -> m Type -> m Type +forallT :: Quote m => [TyVarBndr Specificity] -> m Cxt -> m Type -> m Type forallT tvars ctxt ty = do ctxt1 <- ctxt ty1 <- ty @@ -273,11 +276,11 @@ sigT t k ------------------------------------------------------------------------------- -- * Kind -plainTV :: Name -> TyVarBndr -plainTV = PlainTV +plainTV :: Name -> TyVarBndr () +plainTV n = PlainTV n () -kindedTV :: Name -> Kind -> TyVarBndr -kindedTV = KindedTV +kindedTV :: Name -> Kind -> TyVarBndr () +kindedTV n k = KindedTV n () k starK :: Kind starK = StarT @@ -294,7 +297,7 @@ noSig = NoSig kindSig :: Kind -> FamilyResultSig kindSig = KindSig -tyVarSig :: TyVarBndr -> FamilyResultSig +tyVarSig :: TyVarBndr () -> FamilyResultSig tyVarSig = TyVarSig ------------------------------------------------------------------------------- diff --git a/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs b/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs index e401ff3e60..e5899dacb8 100644 --- a/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs +++ b/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs @@ -37,7 +37,6 @@ type Decs = [Dec] -- Defined as it is more convenient to wire-in type ConQ = Q Con type TypeQ = Q Type type KindQ = Q Kind -type TyVarBndrQ = Q TyVarBndr type TyLitQ = Q TyLit type CxtQ = Q Cxt type PredQ = Q Pred @@ -67,6 +66,9 @@ type DerivStrategyQ = Q DerivStrategy type Role = TH.Role type InjectivityAnn = TH.InjectivityAnn +type TyVarBndrUnit = TyVarBndr () +type TyVarBndrSpec = TyVarBndr Specificity + ---------------------------------------------------------- -- * Lowercase pattern syntax functions ---------------------------------------------------------- @@ -385,14 +387,14 @@ funD nm cs = ; pure (FunD nm cs1) } -tySynD :: Quote m => Name -> [m TyVarBndr] -> m Type -> m Dec +tySynD :: Quote m => Name -> [m (TyVarBndr ())] -> m Type -> m Dec tySynD tc tvs rhs = do { tvs1 <- sequenceA tvs ; rhs1 <- rhs ; pure (TySynD tc tvs1 rhs1) } -dataD :: Quote m => m Cxt -> Name -> [m TyVarBndr] -> Maybe (m Kind) -> [m Con] +dataD :: Quote m => m Cxt -> Name -> [m (TyVarBndr ())] -> Maybe (m Kind) -> [m Con] -> [m DerivClause] -> m Dec dataD ctxt tc tvs ksig cons derivs = do @@ -403,7 +405,7 @@ dataD ctxt tc tvs ksig cons derivs = derivs1 <- sequenceA derivs pure (DataD ctxt1 tc tvs1 ksig1 cons1 derivs1) -newtypeD :: Quote m => m Cxt -> Name -> [m TyVarBndr] -> Maybe (m Kind) -> m Con +newtypeD :: Quote m => m Cxt -> Name -> [m (TyVarBndr ())] -> Maybe (m Kind) -> m Con -> [m DerivClause] -> m Dec newtypeD ctxt tc tvs ksig con derivs = do @@ -414,7 +416,7 @@ newtypeD ctxt tc tvs ksig con derivs = derivs1 <- sequenceA derivs pure (NewtypeD ctxt1 tc tvs1 ksig1 con1 derivs1) -classD :: Quote m => m Cxt -> Name -> [m TyVarBndr] -> [FunDep] -> [m Dec] -> m Dec +classD :: Quote m => m Cxt -> Name -> [m (TyVarBndr ())] -> [FunDep] -> [m Dec] -> m Dec classD ctxt cls tvs fds decs = do tvs1 <- sequenceA tvs @@ -477,7 +479,7 @@ pragSpecInstD ty ty1 <- ty pure $ PragmaD $ SpecialiseInstP ty1 -pragRuleD :: Quote m => String -> Maybe [m TyVarBndr] -> [m RuleBndr] -> m Exp -> m Exp +pragRuleD :: Quote m => String -> Maybe [m (TyVarBndr ())] -> [m RuleBndr] -> m Exp -> m Exp -> Phases -> m Dec pragRuleD n ty_bndrs tm_bndrs lhs rhs phases = do @@ -499,7 +501,7 @@ pragLineD line file = pure $ PragmaD $ LineP line file pragCompleteD :: Quote m => [Name] -> Maybe Name -> m Dec pragCompleteD cls mty = pure $ PragmaD $ CompleteP cls mty -dataInstD :: Quote m => m Cxt -> (Maybe [m TyVarBndr]) -> m Type -> Maybe (m Kind) -> [m Con] +dataInstD :: Quote m => m Cxt -> (Maybe [m (TyVarBndr ())]) -> m Type -> Maybe (m Kind) -> [m Con] -> [m DerivClause] -> m Dec dataInstD ctxt mb_bndrs ty ksig cons derivs = do @@ -511,7 +513,7 @@ dataInstD ctxt mb_bndrs ty ksig cons derivs = derivs1 <- sequenceA derivs pure (DataInstD ctxt1 mb_bndrs1 ty1 ksig1 cons1 derivs1) -newtypeInstD :: Quote m => m Cxt -> (Maybe [m TyVarBndr]) -> m Type -> Maybe (m Kind) -> m Con +newtypeInstD :: Quote m => m Cxt -> (Maybe [m (TyVarBndr ())]) -> m Type -> Maybe (m Kind) -> m Con -> [m DerivClause] -> m Dec newtypeInstD ctxt mb_bndrs ty ksig con derivs = do @@ -529,20 +531,20 @@ tySynInstD eqn = eqn1 <- eqn pure (TySynInstD eqn1) -dataFamilyD :: Quote m => Name -> [m TyVarBndr] -> Maybe (m Kind) -> m Dec +dataFamilyD :: Quote m => Name -> [m (TyVarBndr ())] -> Maybe (m Kind) -> m Dec dataFamilyD tc tvs kind = do tvs' <- sequenceA tvs kind' <- sequenceA kind pure $ DataFamilyD tc tvs' kind' -openTypeFamilyD :: Quote m => Name -> [m TyVarBndr] -> m FamilyResultSig +openTypeFamilyD :: Quote m => Name -> [m (TyVarBndr ())] -> m FamilyResultSig -> Maybe InjectivityAnn -> m Dec openTypeFamilyD tc tvs res inj = do tvs' <- sequenceA tvs res' <- res pure $ OpenTypeFamilyD (TypeFamilyHead tc tvs' res' inj) -closedTypeFamilyD :: Quote m => Name -> [m TyVarBndr] -> m FamilyResultSig +closedTypeFamilyD :: Quote m => Name -> [m (TyVarBndr ())] -> m FamilyResultSig -> Maybe InjectivityAnn -> [m TySynEqn] -> m Dec closedTypeFamilyD tc tvs result injectivity eqns = do tvs1 <- sequenceA tvs @@ -592,7 +594,7 @@ implicitParamBindD n e = e' <- e pure $ ImplicitParamBindD n e' -tySynEqn :: Quote m => (Maybe [m TyVarBndr]) -> m Type -> m Type -> m TySynEqn +tySynEqn :: Quote m => (Maybe [m (TyVarBndr ())]) -> m Type -> m Type -> m TySynEqn tySynEqn mb_bndrs lhs rhs = do mb_bndrs1 <- traverse sequenceA mb_bndrs @@ -631,7 +633,7 @@ infixC st1 con st2 = do st1' <- st1 st2' <- st2 pure $ InfixC st1' con st2' -forallC :: Quote m => [m TyVarBndr] -> m Cxt -> m Con -> m Con +forallC :: Quote m => [m (TyVarBndr Specificity)] -> m Cxt -> m Con -> m Con forallC ns ctxt con = do ns' <- sequenceA ns ctxt' <- ctxt @@ -647,14 +649,14 @@ recGadtC cons varstrtys ty = liftA2 (RecGadtC cons) (sequenceA varstrtys) ty ------------------------------------------------------------------------------- -- * Type -forallT :: Quote m => [m TyVarBndr] -> m Cxt -> m Type -> m Type +forallT :: Quote m => [m (TyVarBndr Specificity)] -> m Cxt -> m Type -> m Type forallT tvars ctxt ty = do tvars1 <- sequenceA tvars ctxt1 <- ctxt ty1 <- ty pure $ ForallT tvars1 ctxt1 ty1 -forallVisT :: Quote m => [m TyVarBndr] -> m Type -> m Type +forallVisT :: Quote m => [m (TyVarBndr ())] -> m Type -> m Type forallVisT tvars ty = ForallVisT <$> sequenceA tvars <*> ty varT :: Quote m => Name -> m Type @@ -815,11 +817,23 @@ strTyLit s = pure (StrTyLit s) ------------------------------------------------------------------------------- -- * Kind -plainTV :: Quote m => Name -> m TyVarBndr -plainTV = pure . PlainTV +plainTV :: Quote m => Name -> m (TyVarBndr ()) +plainTV n = pure $ PlainTV n () + +plainInvisTV :: Quote m => Name -> Specificity -> m (TyVarBndr Specificity) +plainInvisTV n s = pure $ PlainTV n s + +kindedTV :: Quote m => Name -> m Kind -> m (TyVarBndr ()) +kindedTV n = fmap (KindedTV n ()) + +kindedInvisTV :: Quote m => Name -> Specificity -> m Kind -> m (TyVarBndr Specificity) +kindedInvisTV n s = fmap (KindedTV n s) + +specifiedSpec :: Specificity +specifiedSpec = SpecifiedSpec -kindedTV :: Quote m => Name -> m Kind -> m TyVarBndr -kindedTV n = fmap (KindedTV n) +inferredSpec :: Specificity +inferredSpec = InferredSpec varK :: Name -> Kind varK = VarT @@ -854,7 +868,7 @@ noSig = pure NoSig kindSig :: Quote m => m Kind -> m FamilyResultSig kindSig = fmap KindSig -tyVarSig :: Quote m => m TyVarBndr -> m FamilyResultSig +tyVarSig :: Quote m => m (TyVarBndr ()) -> m FamilyResultSig tyVarSig = fmap TyVarSig ------------------------------------------------------------------------------- diff --git a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs index 8cf39c9af8..6dd90e364b 100644 --- a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs +++ b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs @@ -511,7 +511,7 @@ ppr_tf_head (TypeFamilyHead tc tvs res inj) maybeInj | (Just inj') <- inj = ppr inj' | otherwise = empty -ppr_bndrs :: Maybe [TyVarBndr] -> Doc +ppr_bndrs :: PprFlag flag => Maybe [TyVarBndr flag] -> Doc ppr_bndrs (Just bndrs) = text "forall" <+> sep (map ppr bndrs) <> text "." ppr_bndrs Nothing = empty @@ -660,13 +660,13 @@ instance Ppr PatSynArgs where commaSepApplied :: [Name] -> Doc commaSepApplied = commaSepWith (pprName' Applied) -pprForall :: [TyVarBndr] -> Cxt -> Doc +pprForall :: [TyVarBndr Specificity] -> Cxt -> Doc pprForall = pprForall' ForallInvis -pprForallVis :: [TyVarBndr] -> Cxt -> Doc +pprForallVis :: [TyVarBndr ()] -> Cxt -> Doc pprForallVis = pprForall' ForallVis -pprForall' :: ForallVisFlag -> [TyVarBndr] -> Cxt -> Doc +pprForall' :: PprFlag flag => ForallVisFlag -> [TyVarBndr flag] -> Cxt -> Doc pprForall' fvf tvs cxt -- even in the case without any tvs, there could be a non-empty -- context cxt (e.g., in the case of pattern synonyms, where there @@ -859,9 +859,21 @@ instance Ppr TyLit where ppr = pprTyLit ------------------------------ -instance Ppr TyVarBndr where - ppr (PlainTV nm) = ppr nm - ppr (KindedTV nm k) = parens (ppr nm <+> dcolon <+> ppr k) +class PprFlag flag where + pprTyVarBndr :: (TyVarBndr flag) -> Doc + +instance PprFlag () where + pprTyVarBndr (PlainTV nm ()) = ppr nm + pprTyVarBndr (KindedTV nm () k) = parens (ppr nm <+> dcolon <+> ppr k) + +instance PprFlag Specificity where + pprTyVarBndr (PlainTV nm SpecifiedSpec) = ppr nm + pprTyVarBndr (PlainTV nm InferredSpec) = braces (ppr nm) + pprTyVarBndr (KindedTV nm SpecifiedSpec k) = parens (ppr nm <+> dcolon <+> ppr k) + pprTyVarBndr (KindedTV nm InferredSpec k) = braces (ppr nm <+> dcolon <+> ppr k) + +instance PprFlag flag => Ppr (TyVarBndr flag) where + ppr bndr = pprTyVarBndr bndr instance Ppr Role where ppr NominalR = text "nominal" diff --git a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs index 227d24290c..60fb9d37ca 100644 --- a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs +++ b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs @@ -3,7 +3,7 @@ RankNTypes, RoleAnnotations, ScopedTypeVariables, MagicHash, KindSignatures, PolyKinds, TypeApplications, DataKinds, GADTs, UnboxedTuples, UnboxedSums, TypeInType, - Trustworthy #-} + Trustworthy, DeriveFunctor #-} {-# OPTIONS_GHC -fno-warn-inline-rule-shadowing #-} @@ -2065,19 +2065,19 @@ data Range = FromR Exp | FromThenR Exp Exp data Dec = FunD Name [Clause] -- ^ @{ f p1 p2 = b where decs }@ | ValD Pat Body [Dec] -- ^ @{ p = b where decs }@ - | DataD Cxt Name [TyVarBndr] + | DataD Cxt Name [TyVarBndr ()] (Maybe Kind) -- Kind signature (allowed only for GADTs) [Con] [DerivClause] -- ^ @{ data Cxt x => T x = A x | B (T x) -- deriving (Z,W) -- deriving stock Eq }@ - | NewtypeD Cxt Name [TyVarBndr] + | NewtypeD Cxt Name [TyVarBndr ()] (Maybe Kind) -- Kind signature Con [DerivClause] -- ^ @{ newtype Cxt x => T x = A (B x) -- deriving (Z,W Q) -- deriving stock Eq }@ - | TySynD Name [TyVarBndr] Type -- ^ @{ type T x = (x,x) }@ - | ClassD Cxt Name [TyVarBndr] + | TySynD Name [TyVarBndr ()] Type -- ^ @{ type T x = (x,x) }@ + | ClassD Cxt Name [TyVarBndr ()] [FunDep] [Dec] -- ^ @{ class Eq a => Ord a where ds }@ | InstanceD (Maybe Overlap) Cxt Type [Dec] -- ^ @{ instance {\-\# OVERLAPS \#-\} @@ -2093,18 +2093,18 @@ data Dec | PragmaD Pragma -- ^ @{ {\-\# INLINE [1] foo \#-\} }@ -- | data families (may also appear in [Dec] of 'ClassD' and 'InstanceD') - | DataFamilyD Name [TyVarBndr] + | DataFamilyD Name [TyVarBndr ()] (Maybe Kind) -- ^ @{ data family T a b c :: * }@ - | DataInstD Cxt (Maybe [TyVarBndr]) Type + | DataInstD Cxt (Maybe [TyVarBndr ()]) Type (Maybe Kind) -- Kind signature [Con] [DerivClause] -- ^ @{ data instance Cxt x => T [x] -- = A x | B (T x) -- deriving (Z,W) -- deriving stock Eq }@ - | NewtypeInstD Cxt (Maybe [TyVarBndr]) Type -- Quantified type vars + | NewtypeInstD Cxt (Maybe [TyVarBndr ()]) Type -- Quantified type vars (Maybe Kind) -- Kind signature Con [DerivClause] -- ^ @{ newtype instance Cxt x => T [x] -- = A (B x) @@ -2217,7 +2217,7 @@ type PatSynType = Type -- @TypeFamilyHead@ is defined to be the elements of the declaration -- between @type family@ and @where@. data TypeFamilyHead = - TypeFamilyHead Name [TyVarBndr] FamilyResultSig (Maybe InjectivityAnn) + TypeFamilyHead Name [TyVarBndr ()] FamilyResultSig (Maybe InjectivityAnn) deriving( Show, Eq, Ord, Data, Generic ) -- | One equation of a type family instance or closed type family. The @@ -2237,7 +2237,7 @@ data TypeFamilyHead = -- ('AppT' ('AppKindT' ('ConT' ''Foo) ('VarT' k)) ('VarT' a)) -- ('VarT' a) -- @ -data TySynEqn = TySynEqn (Maybe [TyVarBndr]) Type Type +data TySynEqn = TySynEqn (Maybe [TyVarBndr ()]) Type Type deriving( Show, Eq, Ord, Data, Generic ) data FunDep = FunDep [Name] [Name] @@ -2257,7 +2257,7 @@ data Safety = Unsafe | Safe | Interruptible data Pragma = InlineP Name Inline RuleMatch Phases | SpecialiseP Name Type (Maybe Inline) Phases | SpecialiseInstP Type - | RuleP String (Maybe [TyVarBndr]) [RuleBndr] Exp Exp Phases + | RuleP String (Maybe [TyVarBndr ()]) [RuleBndr] Exp Exp Phases | AnnP AnnTarget Exp | LineP Int String | CompleteP [Name] (Maybe Name) @@ -2346,7 +2346,7 @@ data DecidedStrictness = DecidedLazy data Con = NormalC Name [BangType] -- ^ @C Int a@ | RecC Name [VarBangType] -- ^ @C { v :: Int, w :: a }@ | InfixC BangType Name BangType -- ^ @Int :+ a@ - | ForallC [TyVarBndr] Cxt Con -- ^ @forall a. Eq a => C [a]@ + | ForallC [TyVarBndr Specificity] Cxt Con -- ^ @forall a. Eq a => C [a]@ | GadtC [Name] [BangType] Type -- See Note [GADT return type] -- ^ @C :: a -> b -> T b Int@ @@ -2415,8 +2415,8 @@ data PatSynArgs | RecordPatSyn [Name] -- ^ @pattern P { {x,y,z} } = p@ deriving( Show, Eq, Ord, Data, Generic ) -data Type = ForallT [TyVarBndr] Cxt Type -- ^ @forall \<vars\>. \<ctxt\> => \<type\>@ - | ForallVisT [TyVarBndr] Type -- ^ @forall \<vars\> -> \<type\>@ +data Type = ForallT [TyVarBndr Specificity] Cxt Type -- ^ @forall \<vars\>. \<ctxt\> => \<type\>@ + | ForallVisT [TyVarBndr ()] Type -- ^ @forall \<vars\> -> \<type\>@ | AppT Type Type -- ^ @T a b@ | AppKindT Type Kind -- ^ @T \@k t@ | SigT Type Kind -- ^ @t :: k@ @@ -2446,14 +2446,18 @@ data Type = ForallT [TyVarBndr] Cxt Type -- ^ @forall \<vars\>. \<ctxt\> => \<t | ImplicitParamT String Type -- ^ @?x :: t@ deriving( Show, Eq, Ord, Data, Generic ) -data TyVarBndr = PlainTV Name -- ^ @a@ - | KindedTV Name Kind -- ^ @(a :: k)@ +data Specificity = SpecifiedSpec -- ^ @a@ + | InferredSpec -- ^ @{a}@ deriving( Show, Eq, Ord, Data, Generic ) +data TyVarBndr flag = PlainTV Name flag -- ^ @a@ + | KindedTV Name flag Kind -- ^ @(a :: k)@ + deriving( Show, Eq, Ord, Data, Generic, Functor ) + -- | Type family result signature data FamilyResultSig = NoSig -- ^ no signature | KindSig Kind -- ^ @k@ - | TyVarSig TyVarBndr -- ^ @= r, = (r :: k)@ + | TyVarSig (TyVarBndr ()) -- ^ @= r, = (r :: k)@ deriving( Show, Eq, Ord, Data, Generic ) -- | Injectivity annotation diff --git a/libraries/template-haskell/changelog.md b/libraries/template-haskell/changelog.md index 4a522837af..55aab10c0d 100644 --- a/libraries/template-haskell/changelog.md +++ b/libraries/template-haskell/changelog.md @@ -9,6 +9,12 @@ written in terms of `Q` are now disallowed. The types of `unsafeTExpCoerce` and `unTypeQ` are also generalised in terms of `Quote` rather than specific to `Q`. + + * Implement Explicit specificity in type variable binders (GHC Proposal #99). + In `Language.Haskell.TH.Syntax`, `TyVarBndr` is now annotated with a `flag`, + denoting the additional argument to its constructors `PlainTV` and `KindedTV`. + `flag` is either the `Specificity` of the type variable (`SpecifiedSpec` or + `InferredSpec`) or `()`. * Fix Eq/Ord instances for `Bytes`: we were comparing pointers while we should compare the actual bytes (#16457). diff --git a/testsuite/tests/ghci/scripts/T11098.stdout b/testsuite/tests/ghci/scripts/T11098.stdout index 5a748053c3..7ff1306768 100644 --- a/testsuite/tests/ghci/scripts/T11098.stdout +++ b/testsuite/tests/ghci/scripts/T11098.stdout @@ -1,3 +1,3 @@ [SigD foo_1 (AppT (AppT ArrowT (VarT a_0)) (VarT a_0)),FunD foo_1 [Clause [VarP x_2] (NormalB (VarE x_2)) []]] "[SigD foo_ (AppT (AppT ArrowT (VarT _a_)) (VarT _a_)),FunD foo_ [Clause [VarP x_] (NormalB (VarE x_)) []]]" -[SigD foo_6 (ForallT [PlainTV _a_5] [] (AppT (AppT ArrowT (VarT _a_5)) (VarT _a_5))),FunD foo_6 [Clause [VarP x_7] (NormalB (VarE x_7)) []]] +[SigD foo_6 (ForallT [PlainTV _a_5 SpecifiedSpec] [] (AppT (AppT ArrowT (VarT _a_5)) (VarT _a_5))),FunD foo_6 [Clause [VarP x_7] (NormalB (VarE x_7)) []]] diff --git a/testsuite/tests/indexed-types/should_fail/T9160.hs b/testsuite/tests/indexed-types/should_fail/T9160.hs index 9186686579..cefa18d6f3 100644 --- a/testsuite/tests/indexed-types/should_fail/T9160.hs +++ b/testsuite/tests/indexed-types/should_fail/T9160.hs @@ -7,7 +7,7 @@ $( do { cls_nm <- newName "C" ; a_nm <- newName "a" ; k_nm <- newName "k" ; f_nm <- newName "F" - ; return [ClassD [] cls_nm [KindedTV a_nm (VarT k_nm)] [] + ; return [ClassD [] cls_nm [KindedTV a_nm () (VarT k_nm)] [] [OpenTypeFamilyD (TypeFamilyHead f_nm [] (KindSig (VarT k_nm)) Nothing)]]}) diff --git a/testsuite/tests/parser/should_compile/DumpParsedAst.stderr b/testsuite/tests/parser/should_compile/DumpParsedAst.stderr index 8ae907ee25..7d86febb65 100644 --- a/testsuite/tests/parser/should_compile/DumpParsedAst.stderr +++ b/testsuite/tests/parser/should_compile/DumpParsedAst.stderr @@ -177,6 +177,7 @@ [({ DumpParsedAst.hs:9:21-29 } (KindedTyVar (NoExtField) + (()) ({ DumpParsedAst.hs:9:21-22 } (Unqual {OccName: as})) @@ -215,12 +216,14 @@ [({ DumpParsedAst.hs:14:8 } (UserTyVar (NoExtField) + (()) ({ DumpParsedAst.hs:14:8 } (Unqual {OccName: f})))) ,({ DumpParsedAst.hs:14:11-16 } (KindedTyVar (NoExtField) + (()) ({ DumpParsedAst.hs:14:11 } (Unqual {OccName: a})) @@ -362,6 +365,7 @@ [({ DumpParsedAst.hs:16:17-22 } (KindedTyVar (NoExtField) + (()) ({ DumpParsedAst.hs:16:17 } (Unqual {OccName: a})) @@ -375,6 +379,7 @@ ,({ DumpParsedAst.hs:16:26-39 } (KindedTyVar (NoExtField) + (()) ({ DumpParsedAst.hs:16:26 } (Unqual {OccName: f})) diff --git a/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr b/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr index 57da7c2199..68dc470498 100644 --- a/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr +++ b/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr @@ -206,6 +206,7 @@ [({ DumpRenamedAst.hs:11:21-29 } (KindedTyVar (NoExtField) + (()) ({ DumpRenamedAst.hs:11:21-22 } {Name: as}) ({ DumpRenamedAst.hs:11:27-29 } @@ -352,15 +353,13 @@ {Name: GHC.Types.Type})))))) [({ DumpRenamedAst.hs:19:3-45 } (ConDeclGADT - (NoExtField) + [{Name: f} + ,{Name: g}] [({ DumpRenamedAst.hs:19:3-5 } {Name: DumpRenamedAst.Nat})] ({ DumpRenamedAst.hs:19:10-45 } (False)) - (HsQTvs - [{Name: f} - ,{Name: g}] - []) + [] (Nothing) (PrefixCon [({ DumpRenamedAst.hs:19:10-34 } @@ -373,6 +372,7 @@ [({ DumpRenamedAst.hs:19:18-19 } (UserTyVar (NoExtField) + (SpecifiedSpec) ({ DumpRenamedAst.hs:19:18-19 } {Name: xx})))] ({ DumpRenamedAst.hs:19:22-33 } @@ -451,11 +451,13 @@ [({ DumpRenamedAst.hs:21:8 } (UserTyVar (NoExtField) + (()) ({ DumpRenamedAst.hs:21:8 } {Name: f}))) ,({ DumpRenamedAst.hs:21:11-16 } (KindedTyVar (NoExtField) + (()) ({ DumpRenamedAst.hs:21:11 } {Name: a}) ({ DumpRenamedAst.hs:21:16 } @@ -587,6 +589,7 @@ [({ DumpRenamedAst.hs:23:17-22 } (KindedTyVar (NoExtField) + (()) ({ DumpRenamedAst.hs:23:17 } {Name: a}) ({ DumpRenamedAst.hs:23:22 } @@ -598,6 +601,7 @@ ,({ DumpRenamedAst.hs:23:26-39 } (KindedTyVar (NoExtField) + (()) ({ DumpRenamedAst.hs:23:26 } {Name: f}) ({ DumpRenamedAst.hs:23:31-39 } diff --git a/testsuite/tests/parser/should_compile/KindSigs.stderr b/testsuite/tests/parser/should_compile/KindSigs.stderr index 06ed01539a..1d6c055436 100644 --- a/testsuite/tests/parser/should_compile/KindSigs.stderr +++ b/testsuite/tests/parser/should_compile/KindSigs.stderr @@ -72,6 +72,7 @@ [({ KindSigs.hs:11:17 } (UserTyVar (NoExtField) + (()) ({ KindSigs.hs:11:17 } (Unqual {OccName: a}))))]) @@ -93,6 +94,7 @@ [({ KindSigs.hs:15:10 } (UserTyVar (NoExtField) + (()) ({ KindSigs.hs:15:10 } (Unqual {OccName: a}))))]) @@ -165,6 +167,7 @@ [({ KindSigs.hs:16:11 } (UserTyVar (NoExtField) + (()) ({ KindSigs.hs:16:11 } (Unqual {OccName: a}))))]) @@ -458,6 +461,7 @@ [({ KindSigs.hs:28:12 } (UserTyVar (NoExtField) + (()) ({ KindSigs.hs:28:12 } (Unqual {OccName: b}))))]) diff --git a/testsuite/tests/parser/should_compile/T15323.stderr b/testsuite/tests/parser/should_compile/T15323.stderr index 25b0ed002d..c69f94afba 100644 --- a/testsuite/tests/parser/should_compile/T15323.stderr +++ b/testsuite/tests/parser/should_compile/T15323.stderr @@ -21,6 +21,7 @@ [({ T15323.hs:5:19 } (UserTyVar (NoExtField) + (()) ({ T15323.hs:5:19 } (Unqual {OccName: v}))))]) @@ -40,14 +41,13 @@ {OccName: TestParens}))] ({ T15323.hs:6:21-55 } (True)) - (HsQTvs - (NoExtField) - [({ T15323.hs:6:28 } - (UserTyVar - (NoExtField) - ({ T15323.hs:6:28 } - (Unqual - {OccName: v}))))]) + [({ T15323.hs:6:28 } + (UserTyVar + (NoExtField) + (SpecifiedSpec) + ({ T15323.hs:6:28 } + (Unqual + {OccName: v}))))] (Just ({ T15323.hs:6:32-37 } [({ T15323.hs:6:32-37 } diff --git a/testsuite/tests/polykinds/T7022a.hs b/testsuite/tests/polykinds/T7022a.hs index a286fd3c1d..ee71b806c1 100644 --- a/testsuite/tests/polykinds/T7022a.hs +++ b/testsuite/tests/polykinds/T7022a.hs @@ -9,5 +9,5 @@ makeSList :: Q [Dec] makeSList = do a <- newName "a" k <- newName "k" - return [TySynD (mkName "SList") [KindedTV a (AppT ListT (VarT k))] + return [TySynD (mkName "SList") [KindedTV a () (AppT ListT (VarT k))] (AppT (ConT (mkName "Sing")) (VarT a))] diff --git a/testsuite/tests/printer/T14289b.hs b/testsuite/tests/printer/T14289b.hs index 3ff39805d6..d35292c5cd 100644 --- a/testsuite/tests/printer/T14289b.hs +++ b/testsuite/tests/printer/T14289b.hs @@ -33,7 +33,7 @@ main Bceomes -[DataD [] Foo_0 [PlainTV a_2] Nothing +[DataD [] Foo_0 [PlainTV a_2 ()] Nothing [NormalC Foo_1 [(Bang NoSourceUnpackedness NoSourceStrictness,VarT a_2)]] [DerivClause Nothing [AppT (AppT (ConT Main.C) (VarT y_6989586621679027885)) diff --git a/testsuite/tests/printer/T14289c.hs b/testsuite/tests/printer/T14289c.hs index 6e58df1a54..adf378c41e 100644 --- a/testsuite/tests/printer/T14289c.hs +++ b/testsuite/tests/printer/T14289c.hs @@ -30,7 +30,7 @@ main ---------------------------------------- Becomes -[DataD [] Foo_0 [PlainTV a_2] Nothing +[DataD [] Foo_0 [PlainTV a_2 ()] Nothing [NormalC Foo_1 [(Bang NoSourceUnpackedness NoSourceStrictness,VarT a_2)]] [DerivClause Nothing [AppT (AppT EqualityT (VarT a_2)) diff --git a/testsuite/tests/th/ClosedFam2TH.hs b/testsuite/tests/th/ClosedFam2TH.hs index abe2ddca3b..f1e5eee9c0 100644 --- a/testsuite/tests/th/ClosedFam2TH.hs +++ b/testsuite/tests/th/ClosedFam2TH.hs @@ -7,9 +7,9 @@ import Language.Haskell.TH $( return [ ClosedTypeFamilyD (TypeFamilyHead (mkName "Equals") - [ KindedTV (mkName "a") (VarT (mkName "k")) - , KindedTV (mkName "b") (VarT (mkName "k")) ] - ( TyVarSig (KindedTV (mkName "r") (VarT (mkName "k")))) + [ KindedTV (mkName "a") () (VarT (mkName "k")) + , KindedTV (mkName "b") () (VarT (mkName "k")) ] + ( TyVarSig (KindedTV (mkName "r") () (VarT (mkName "k")))) Nothing) [ TySynEqn Nothing (AppT (AppT (ConT (mkName "Equals")) (VarT (mkName "a"))) @@ -29,7 +29,7 @@ b = False $( return [ ClosedTypeFamilyD (TypeFamilyHead (mkName "Foo") - [ KindedTV (mkName "a") (VarT (mkName "k"))] + [ KindedTV (mkName "a") () (VarT (mkName "k"))] (KindSig StarT ) Nothing ) [ TySynEqn Nothing (AppT (AppKindT (ConT (mkName "Foo")) StarT) diff --git a/testsuite/tests/th/T10267.hs b/testsuite/tests/th/T10267.hs index 009d0f035c..45636bf295 100644 --- a/testsuite/tests/th/T10267.hs +++ b/testsuite/tests/th/T10267.hs @@ -13,7 +13,7 @@ import T10267a $(return [ SigD (mkName "k") - (ForallT [PlainTV (mkName "a")] + (ForallT [PlainTV (mkName "a") SpecifiedSpec] [] (AppT (AppT ArrowT (VarT (mkName "a"))) (VarT (mkName "a")))) , FunD (mkName "k") @@ -22,7 +22,7 @@ $(return [ $(return [ SigD (mkName "l") - (ForallT [PlainTV (mkName "a")] + (ForallT [PlainTV (mkName "a") SpecifiedSpec] [] (AppT (AppT ArrowT (VarT (mkName "a"))) (VarT (mkName "a")))) , FunD (mkName "l") diff --git a/testsuite/tests/th/T10828.hs b/testsuite/tests/th/T10828.hs index 94d9b3967b..ffb4525f6a 100644 --- a/testsuite/tests/th/T10828.hs +++ b/testsuite/tests/th/T10828.hs @@ -31,7 +31,7 @@ $( do { decl <- [d| data family D a :: Type -> Type $( return [ DataD [] (mkName "T") - [ PlainTV (mkName "a") ] + [ PlainTV (mkName "a") () ] (Just StarT) [ GadtC [(mkName "MkT")] [ ( Bang NoSourceUnpackedness NoSourceStrictness @@ -43,7 +43,7 @@ $( return ] (AppT (ConT (mkName "T")) (VarT (mkName "a"))) - , ForallC [PlainTV (mkName "a"), PlainTV (mkName "b")] + , ForallC [PlainTV (mkName "a") SpecifiedSpec, PlainTV (mkName "b") SpecifiedSpec] [AppT (AppT EqualityT (VarT $ mkName "a" ) ) (ConT $ mkName "Int") ] $ RecGadtC [(mkName "MkC")] diff --git a/testsuite/tests/th/T10828a.hs b/testsuite/tests/th/T10828a.hs index c3108c3e38..d66547bad7 100644 --- a/testsuite/tests/th/T10828a.hs +++ b/testsuite/tests/th/T10828a.hs @@ -8,7 +8,7 @@ import System.IO -- attempting to place a kind signature on a H98 data type $( return [ DataD [] (mkName "T") - [ PlainTV (mkName "a") ] + [ PlainTV (mkName "a") () ] (Just StarT) [ NormalC (mkName "MkT") [ ( Bang NoSourceUnpackedness NoSourceStrictness diff --git a/testsuite/tests/th/T10828b.hs b/testsuite/tests/th/T10828b.hs index 1db3b0840c..03706d6b7c 100644 --- a/testsuite/tests/th/T10828b.hs +++ b/testsuite/tests/th/T10828b.hs @@ -8,7 +8,7 @@ import System.IO -- attempting to mix GADT and normal constructors $( return [ DataD [] (mkName "T") - [ PlainTV (mkName "a") ] + [ PlainTV (mkName "a") () ] (Just StarT) [ NormalC (mkName "MkT") @@ -19,7 +19,7 @@ $( return , VarT (mkName "a") ) ] - , ForallC [PlainTV (mkName "a")] + , ForallC [PlainTV (mkName "a") SpecifiedSpec] [AppT (AppT EqualityT (VarT $ mkName "a" ) ) (ConT $ mkName "Int") ] $ RecGadtC diff --git a/testsuite/tests/th/T10945.hs b/testsuite/tests/th/T10945.hs index be7a792d61..d9a24663ab 100644 --- a/testsuite/tests/th/T10945.hs +++ b/testsuite/tests/th/T10945.hs @@ -6,7 +6,7 @@ import Language.Haskell.TH $$(return [ SigD (mkName "m") - (ForallT [PlainTV (mkName "a")] + (ForallT [PlainTV (mkName "a") SpecifiedSpec] [] (AppT (AppT ArrowT (VarT (mkName "a"))) (VarT (mkName "a")))) , FunD (mkName "m") diff --git a/testsuite/tests/th/T10945.stderr b/testsuite/tests/th/T10945.stderr index 786a0befa5..765be1fa80 100644 --- a/testsuite/tests/th/T10945.stderr +++ b/testsuite/tests/th/T10945.stderr @@ -8,7 +8,7 @@ T10945.hs:7:4: error: [SigD (mkName "m") (ForallT - [PlainTV (mkName "a")] [] + [PlainTV (mkName "a") SpecifiedSpec] [] (AppT (AppT ArrowT (VarT (mkName "a"))) (VarT (mkName "a")))), FunD (mkName "m") [Clause [...] (NormalB (VarE (mkName "x"))) []]] In the Template Haskell splice @@ -16,7 +16,7 @@ T10945.hs:7:4: error: [SigD (mkName "m") (ForallT - [PlainTV (mkName "a")] [] + [PlainTV (mkName "a") SpecifiedSpec] [] (AppT (AppT ArrowT (VarT (mkName "a"))) (VarT (mkName "a")))), FunD (mkName "m") [Clause [...] (NormalB (VarE (mkName "x"))) []]]) In the expression: @@ -24,6 +24,6 @@ T10945.hs:7:4: error: [SigD (mkName "m") (ForallT - [PlainTV (mkName "a")] [] + [PlainTV (mkName "a") SpecifiedSpec] [] (AppT (AppT ArrowT (VarT (mkName "a"))) (VarT (mkName "a")))), FunD (mkName "m") [Clause ... (NormalB (VarE (mkName "x"))) []]]) diff --git a/testsuite/tests/th/T11345.hs b/testsuite/tests/th/T11345.hs index 39dd8adc08..2288cdad15 100644 --- a/testsuite/tests/th/T11345.hs +++ b/testsuite/tests/th/T11345.hs @@ -15,7 +15,7 @@ $(do gadtName <- newName "GADT2" prefixName <- newName "Prefix2" infixName <- newName ":****:" a <- newName "a" - return [ DataD [] gadtName [KindedTV a StarT] Nothing + return [ DataD [] gadtName [KindedTV a () StarT] Nothing [ GadtC [prefixName] [ (Bang NoSourceUnpackedness NoSourceStrictness,ConT ''Int) , (Bang NoSourceUnpackedness NoSourceStrictness,ConT ''Int) diff --git a/testsuite/tests/th/T11721_TH.hs b/testsuite/tests/th/T11721_TH.hs index 979ff15b0d..b8e895c155 100644 --- a/testsuite/tests/th/T11721_TH.hs +++ b/testsuite/tests/th/T11721_TH.hs @@ -12,8 +12,8 @@ $(return []) main :: IO () main = print - $(do let rightOrder :: [TyVarBndr] -> Bool - rightOrder [KindedTV b _, KindedTV a _] + $(do let rightOrder :: [TyVarBndr flag] -> Bool + rightOrder [KindedTV b _ _, KindedTV a _ _] = nameBase b == "b" && nameBase a == "a" rightOrder _ = False diff --git a/testsuite/tests/th/T12503.hs b/testsuite/tests/th/T12503.hs index 78175bcf04..d1e3f27a93 100644 --- a/testsuite/tests/th/T12503.hs +++ b/testsuite/tests/th/T12503.hs @@ -9,7 +9,7 @@ import Language.Haskell.TH data T1 k class C1 a -$(do TyConI (DataD [] tName [ KindedTV kName kKind] _ _ _) +$(do TyConI (DataD [] tName [ KindedTV kName () kKind] _ _ _) <- reify ''T1 d <- instanceD (cxt []) (conT ''C1 `appT` diff --git a/testsuite/tests/th/T13098.hs b/testsuite/tests/th/T13098.hs index 8df07d230d..e6a541cc55 100644 --- a/testsuite/tests/th/T13098.hs +++ b/testsuite/tests/th/T13098.hs @@ -6,7 +6,7 @@ module T13098 where import Language.Haskell.TH -$( sequence [ dataD (cxt []) (mkName "T") [PlainTV (mkName "a")] +$( sequence [ dataD (cxt []) (mkName "T") [PlainTV (mkName "a") ()] Nothing [normalC (mkName "T") []] [] , pragCompleteD [mkName "T"] Nothing ] ) diff --git a/testsuite/tests/th/T13782.hs b/testsuite/tests/th/T13782.hs index 0346749ce4..b7af84e0e6 100644 --- a/testsuite/tests/th/T13782.hs +++ b/testsuite/tests/th/T13782.hs @@ -6,10 +6,10 @@ module T13782 where import Language.Haskell.TH -$(do TyConI (DataD _ _ [KindedTV a1 _] _ _ _) <- reify ''Maybe +$(do TyConI (DataD _ _ [KindedTV a1 _ _] _ _ _) <- reify ''Maybe [f,a2] <- mapM newName ["f","a"] - return [ SigD f (ForallT [PlainTV a1, - KindedTV a2 (AppT (ConT ''Maybe) (VarT a1))] + return [ SigD f (ForallT [PlainTV a1 SpecifiedSpec, + KindedTV a2 SpecifiedSpec (AppT (ConT ''Maybe) (VarT a1))] [] (ConT ''Int)) , ValD (VarP f) (NormalB (LitE (IntegerL 42))) [] ]) diff --git a/testsuite/tests/th/T13885.hs b/testsuite/tests/th/T13885.hs index cdcc37f426..42f74a623d 100644 --- a/testsuite/tests/th/T13885.hs +++ b/testsuite/tests/th/T13885.hs @@ -17,8 +17,8 @@ main = print $(do TyConI (DataD _ _ tycon_tyvars _ [ForallC con_tyvars _ _] _) <- reify ''(:~:) - let tvbName :: TyVarBndr -> Name - tvbName (PlainTV n) = n - tvbName (KindedTV n _) = n + let tvbName :: TyVarBndr flag -> Name + tvbName (PlainTV n _) = n + tvbName (KindedTV n _ _) = n - lift $ and $ zipWith ((/=) `on` tvbName) tycon_tyvars con_tyvars) + lift $ and $ zipWith (/=) (map tvbName tycon_tyvars) (map tvbName con_tyvars)) diff --git a/testsuite/tests/th/T16976.stderr b/testsuite/tests/th/T16976.stderr index b711aa4de3..7fe46fb5eb 100644 --- a/testsuite/tests/th/T16976.stderr +++ b/testsuite/tests/th/T16976.stderr @@ -1,9 +1,9 @@ -T16976.aNumber :: forall (p_0 :: *) . GHC.Num.Num p_0 => p_0 +T16976.aNumber :: forall {p_0 :: *} . GHC.Num.Num p_0 => p_0 T16976.aString :: [GHC.Types.Char] T16976.MkT1 :: forall (s_0 :: *) . T16976.T s_0 T16976.MkT2 :: forall (s_0 :: *) . T16976.T s_0 T16976.T :: * -> * -T16976.P :: forall (s_0 :: *) . T16976.T s_0 +T16976.P :: forall {s_0 :: *} . T16976.T s_0 GHC.Classes.not :: GHC.Types.Bool -> GHC.Types.Bool GHC.Base.id :: forall (a_0 :: *) . a_0 -> a_0 GHC.Maybe.Nothing :: forall (a_0 :: *) . GHC.Maybe.Maybe a_0 diff --git a/testsuite/tests/th/T5358.stderr b/testsuite/tests/th/T5358.stderr index 78ad520e46..d6f775fa37 100644 --- a/testsuite/tests/th/T5358.stderr +++ b/testsuite/tests/th/T5358.stderr @@ -31,7 +31,7 @@ T5358.hs:10:21: error: T5358.hs:14:12: error: • Exception when trying to run compile-time code: - runTest called error: forall (t_0 :: *) . t_0 -> GHC.Types.Bool + runTest called error: forall {t_0 :: *} . t_0 -> GHC.Types.Bool CallStack (from HasCallStack): error, called at T5358.hs:15:18 in main:T5358 Code: (do VarI _ t _ <- reify (mkName "prop_x1") diff --git a/testsuite/tests/th/T6018th.hs b/testsuite/tests/th/T6018th.hs index d0f448b80a..41e0b5e607 100644 --- a/testsuite/tests/th/T6018th.hs +++ b/testsuite/tests/th/T6018th.hs @@ -14,8 +14,8 @@ import Language.Haskell.TH $( return [ OpenTypeFamilyD (TypeFamilyHead (mkName "F") - [ PlainTV (mkName "a"), PlainTV (mkName "b"), PlainTV (mkName "c") ] - (TyVarSig (KindedTV (mkName "result") (VarT (mkName "k")))) + [ PlainTV (mkName "a") (), PlainTV (mkName "b") (), PlainTV (mkName "c") () ] + (TyVarSig (KindedTV (mkName "result") () (VarT (mkName "k")))) (Just $ InjectivityAnn (mkName "result") [(mkName "a"), (mkName "b"), (mkName "c") ])) , TySynInstD @@ -41,8 +41,8 @@ $( return $( return [ OpenTypeFamilyD (TypeFamilyHead (mkName "J") - [ PlainTV (mkName "a"), KindedTV (mkName "b") (VarT (mkName "k")) ] - (TyVarSig (PlainTV (mkName "r"))) + [ PlainTV (mkName "a") (), KindedTV (mkName "b") () (VarT (mkName "k")) ] + (TyVarSig (PlainTV (mkName "r") ())) (Just $ InjectivityAnn (mkName "r") [mkName "a"])) , TySynInstD (TySynEqn Nothing (AppT (AppT (ConT (mkName "J")) (ConT (mkName "Int"))) @@ -60,9 +60,9 @@ $( return $( return [ ClosedTypeFamilyD (TypeFamilyHead (mkName "I") - [ KindedTV (mkName "a") StarT, KindedTV (mkName "b") StarT - , KindedTV (mkName "c") StarT ] - (TyVarSig (PlainTV (mkName "r"))) + [ KindedTV (mkName "a") () StarT, KindedTV (mkName "b") () StarT + , KindedTV (mkName "c") () StarT ] + (TyVarSig (PlainTV (mkName "r") ())) (Just $ InjectivityAnn (mkName "r") [(mkName "a"), (mkName "b")])) [ TySynEqn Nothing (AppT (AppT (AppT (ConT (mkName "I")) (ConT (mkName "Int"))) @@ -98,8 +98,8 @@ $( do { decl@([ClosedTypeFamilyD (TypeFamilyHead _ _ _ (Just inj)) _]) <- $( return [ OpenTypeFamilyD (TypeFamilyHead (mkName "H") - [ PlainTV (mkName "a"), PlainTV (mkName "b"), PlainTV (mkName "c") ] - (TyVarSig (PlainTV (mkName "r"))) + [ PlainTV (mkName "a") (), PlainTV (mkName "b") (), PlainTV (mkName "c") () ] + (TyVarSig (PlainTV (mkName "r") ())) (Just $ InjectivityAnn (mkName "r") [(mkName "a"), (mkName "b") ])) diff --git a/testsuite/tests/th/T7667.hs b/testsuite/tests/th/T7667.hs index 59287f1448..eef6fd2cb0 100644 --- a/testsuite/tests/th/T7667.hs +++ b/testsuite/tests/th/T7667.hs @@ -4,5 +4,5 @@ module T7667 where import Language.Haskell.TH -$( return [ TySynD (mkName "+") [PlainTV (mkName "a"), PlainTV (mkName "b")] - (AppT (AppT (ConT ''Either) (VarT $ mkName "a")) (VarT $ mkName "b")) ] )
\ No newline at end of file +$( return [ TySynD (mkName "+") [PlainTV (mkName "a") (), PlainTV (mkName "b") ()] + (AppT (AppT (ConT ''Either) (VarT $ mkName "a")) (VarT $ mkName "b")) ] ) diff --git a/testsuite/tests/th/T8499.hs b/testsuite/tests/th/T8499.hs index 29b9e1678c..d9278b4113 100644 --- a/testsuite/tests/th/T8499.hs +++ b/testsuite/tests/th/T8499.hs @@ -5,8 +5,8 @@ module T8499 where import Language.Haskell.TH -$( do TyConI (DataD _ _ [KindedTV tvb_a _] _ _ _) <- reify ''Maybe +$( do TyConI (DataD _ _ [KindedTV tvb_a _ _] _ _ _) <- reify ''Maybe my_a <- newName "a" return [TySynD (mkName "SMaybe") - [KindedTV my_a (AppT (ConT ''Maybe) (VarT tvb_a))] + [KindedTV my_a () (AppT (ConT ''Maybe) (VarT tvb_a))] (TupleT 0)] ) diff --git a/testsuite/tests/th/TH_RichKinds2.hs b/testsuite/tests/th/TH_RichKinds2.hs index 5cdf919f91..00387c7b4c 100644 --- a/testsuite/tests/th/TH_RichKinds2.hs +++ b/testsuite/tests/th/TH_RichKinds2.hs @@ -14,10 +14,10 @@ import Data.List (splitAt, span, elemIndex) import Language.Haskell.TH $(return [OpenTypeFamilyD (TypeFamilyHead - (mkName "Map") [KindedTV (mkName "f") + (mkName "Map") [KindedTV (mkName "f") () (AppT (AppT ArrowT (VarT (mkName "k1"))) (VarT (mkName "k2"))), - KindedTV (mkName "l") + KindedTV (mkName "l") () (AppT ListT (VarT (mkName "k1")))] (KindSig (AppT ListT (VarT (mkName "k2")))) Nothing)]) diff --git a/testsuite/tests/th/TH_Roles1.hs b/testsuite/tests/th/TH_Roles1.hs index 89d072c485..6ac6128885 100644 --- a/testsuite/tests/th/TH_Roles1.hs +++ b/testsuite/tests/th/TH_Roles1.hs @@ -4,6 +4,6 @@ module TH_Roles1 where import Language.Haskell.TH -$( return [ DataD [] (mkName "T") [PlainTV (mkName "a")] Nothing [] [] +$( return [ DataD [] (mkName "T") [PlainTV (mkName "a") ()] Nothing [] [] , RoleAnnotD (mkName "T") [RepresentationalR] ] ) diff --git a/testsuite/tests/th/TH_Roles2.hs b/testsuite/tests/th/TH_Roles2.hs index 3f7b535b49..e6a0df0c52 100644 --- a/testsuite/tests/th/TH_Roles2.hs +++ b/testsuite/tests/th/TH_Roles2.hs @@ -4,7 +4,7 @@ module TH_Roles2 where import Language.Haskell.TH -$( return [ DataD [] (mkName "T") [KindedTV (mkName "a") (VarT (mkName "k"))] +$( return [ DataD [] (mkName "T") [KindedTV (mkName "a") () (VarT (mkName "k"))] Nothing [] [] , RoleAnnotD (mkName "T") [RepresentationalR] ] ) diff --git a/testsuite/tests/th/TH_genExLib.hs b/testsuite/tests/th/TH_genExLib.hs index d8b646ac90..c0f8bad8e6 100644 --- a/testsuite/tests/th/TH_genExLib.hs +++ b/testsuite/tests/th/TH_genExLib.hs @@ -15,7 +15,7 @@ genAnyClass name decls = DataD [] anyName [] Nothing [constructor] [] where anyName = mkName ("Any" ++ nameBase name ++ "1111") - constructor = ForallC [PlainTV var_a] [AppT (ConT name) (VarT var_a)] $ + constructor = ForallC [PlainTV var_a SpecifiedSpec] [AppT (ConT name) (VarT var_a)] $ NormalC anyName [(Bang NoSourceUnpackedness NoSourceStrictness, VarT var_a)] var_a = mkName "a" diff --git a/testsuite/tests/th/TH_reifyDecl1.stderr b/testsuite/tests/th/TH_reifyDecl1.stderr index 5ae01471f3..1984d85075 100644 --- a/testsuite/tests/th/TH_reifyDecl1.stderr +++ b/testsuite/tests/th/TH_reifyDecl1.stderr @@ -9,7 +9,7 @@ data TH_reifyDecl1.Tree (a_0 :: k_1) | (TH_reifyDecl1.Tree a_0) TH_reifyDecl1.:+: (TH_reifyDecl1.Tree a_0) type TH_reifyDecl1.IntList = [GHC.Types.Int] newtype TH_reifyDecl1.Length = TH_reifyDecl1.Length GHC.Types.Int -Constructor from TH_reifyDecl1.Tree: TH_reifyDecl1.Leaf :: forall (k_0 :: *) (a_1 :: k_0) . +Constructor from TH_reifyDecl1.Tree: TH_reifyDecl1.Leaf :: forall {k_0 :: *} (a_1 :: k_0) . TH_reifyDecl1.Tree a_1 Class op from TH_reifyDecl1.C1: TH_reifyDecl1.m1 :: forall (a_0 :: *) . TH_reifyDecl1.C1 a_0 => a_0 -> GHC.Types.Int diff --git a/testsuite/tests/typecheck/should_compile/ExplicitSpecificityA1.hs b/testsuite/tests/typecheck/should_compile/ExplicitSpecificityA1.hs new file mode 100644 index 0000000000..3da70ee59b --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/ExplicitSpecificityA1.hs @@ -0,0 +1,108 @@ +{-# LANGUAGE RankNTypes + , PolyKinds + , GADTs + , TypeApplications + , PatternSynonyms + , ExistentialQuantification + , StandaloneKindSignatures + , DataKinds + , ExistentialQuantification +#-} + +module ExplicitSpecificityA1 where + +import Data.Proxy +import Data.Kind + +-- Type variables bound in RULES +{-# RULES "parametricity" forall (f :: forall {a}. a -> a). map f = id #-} + +-- Type signatures +foo1 :: a -> a +foo1 x = x + +foo2 :: forall a. a -> a +foo2 x = x + +foo3 :: forall {a}. a -> a +foo3 x = x + +foo4 :: forall a {b}. a -> b -> b +foo4 _ x = x + +foo5 :: forall {a} b. a -> b -> b +foo5 _ x = x + +bar1 :: () +bar1 = let { x1 = foo1 42 + ; x2 = foo2 @Int 42 + ; x3 = foo3 42 + ; x4 = foo4 @Bool True 42 + ; x5 = foo5 @Int True 42 + } + in () + +-- Data declarations +data T1 a = C1 a + +data T2 (a :: k) = C2 { f2 :: Proxy a } + +data T3 a where C3 :: forall k (a::k). Proxy a -> T3 a + +data T4 a where C4 :: forall {k} (a::k). Proxy a -> T4 a + +data T5 k (a :: k) where C5 :: forall k (a::k). Proxy a -> T5 k a + +data T6 k a where C6 :: forall {k} (a::k). Proxy a -> T6 k a + +bar2 :: () +bar2 = let { x1 = C1 @Int 42 + ; x2 = C2 @Type @Int Proxy + ; x3 = C3 @Type @Int Proxy + ; x4 = C4 @Int Proxy + ; x5 = C5 @Type @Int Proxy + ; x6 = C6 @Int Proxy + } + in () + +-- Pattern synonyms +data T7 a where C7 :: forall a b. a -> b -> T7 a + +data T8 a where C8 :: forall a {b}. a -> b -> T8 a + +pattern Pat1 :: forall a. () => forall b. a -> b -> T7 a +pattern Pat1 x y = C7 x y + +pattern Pat2 :: forall {a}. () => forall b. a -> b -> T7 a +pattern Pat2 x y = C7 x y + +pattern Pat3 :: forall a. () => forall b. a -> b -> T8 a +pattern Pat3 x y = C8 x y + +pattern Pat4 :: forall {a}. () => forall b. a -> b -> T8 a +pattern Pat4 x y = C8 x y + +pattern Pat5 :: forall {a}. () => forall {b}. a -> b -> T7 a +pattern Pat5 x y = C7 x y + +bar3 :: (T7 a) -> () +bar3 (Pat1 x y) = () +bar3 (Pat2 x y) = () + +bar4 :: (T8 a) -> () +bar4 (Pat3 x y) = () +bar4 (Pat4 x y) = () + +-- Existential variable quantification +data HList = HNil + | forall {a}. HCons a HList + +-- Type synonyms +type TySy = forall a {b}. Either a b + +-- Standalone kind signatures +type Foo :: forall a {b}. a -> b -> b +type Foo x y = y + +type Bar = Foo @Bool True 42 + diff --git a/testsuite/tests/typecheck/should_compile/ExplicitSpecificityA2.hs b/testsuite/tests/typecheck/should_compile/ExplicitSpecificityA2.hs new file mode 100644 index 0000000000..afac6c4725 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/ExplicitSpecificityA2.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PolyKinds #-} + +module ExplicitSpecificityA2 where + +class C a where + +-- D :: forall {k}. k -> * +data D a where + K :: D a + +-- While the type of D abstracts over an implicit (inferred) variable `k`, +-- this instance should not be rejected for implicitly including an inferred +-- type variable, as it is not user written. +instance C (D a) where + + diff --git a/testsuite/tests/typecheck/should_compile/T18023.hs b/testsuite/tests/typecheck/should_compile/T18023.hs index 4bc5c6eede..9961c95b24 100644 --- a/testsuite/tests/typecheck/should_compile/T18023.hs +++ b/testsuite/tests/typecheck/should_compile/T18023.hs @@ -3,6 +3,8 @@ {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE StandaloneKindSignatures #-} module T18023 where import Data.Kind @@ -32,3 +34,12 @@ toP2True = MkP2 @True @True fromP2True :: P2 True True -> (Proxy True, Proxy True) fromP2True = unP2 @True @True + +type P3 :: forall {k}. k -> Type +newtype P3 a = MkP3 { unP3 :: Proxy a } + +toP3True :: Proxy True -> P3 True +toP3True = MkP3 @True + +fromP3True :: P3 True -> Proxy True +fromP3True = unP3 @True diff --git a/testsuite/tests/typecheck/should_compile/all.T b/testsuite/tests/typecheck/should_compile/all.T index 56eecc0374..c4028d6e25 100644 --- a/testsuite/tests/typecheck/should_compile/all.T +++ b/testsuite/tests/typecheck/should_compile/all.T @@ -707,3 +707,5 @@ test('T18036', normal, compile, ['']) test('T18036a', normal, compile, ['']) test('T17873', normal, compile, ['']) test('T18129', expect_broken(18129), compile, ['']) +test('ExplicitSpecificityA1', normal, compile, ['']) +test('ExplicitSpecificityA2', normal, compile, ['']) diff --git a/testsuite/tests/typecheck/should_fail/ExplicitSpecificity1.hs b/testsuite/tests/typecheck/should_fail/ExplicitSpecificity1.hs new file mode 100644 index 0000000000..4fddd91272 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/ExplicitSpecificity1.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE TypeApplications, RankNTypes #-} + +module ExplicitSpecificity1 where + +foo :: forall {a}. a -> a +foo x = x + +bar :: () +bar = let x = foo @Int 42 + in () diff --git a/testsuite/tests/typecheck/should_fail/ExplicitSpecificity1.stderr b/testsuite/tests/typecheck/should_fail/ExplicitSpecificity1.stderr new file mode 100644 index 0000000000..dd5b456230 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/ExplicitSpecificity1.stderr @@ -0,0 +1,7 @@ + +ExplicitSpecificity1.hs:9:15: error: + • Cannot apply expression of type ‘a0 -> a0’ + to a visible type argument ‘Int’ + • In the expression: foo @Int 42 + In an equation for ‘x’: x = foo @Int 42 + In the expression: let x = foo @Int 42 in () diff --git a/testsuite/tests/typecheck/should_fail/ExplicitSpecificity10.hs b/testsuite/tests/typecheck/should_fail/ExplicitSpecificity10.hs new file mode 100644 index 0000000000..0f763b0a27 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/ExplicitSpecificity10.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE TypeApplications, RankNTypes #-} + +module ExplicitSpecificity10 where + +newtype T = MkT { unT :: forall {a}. a -> a } + +test :: T -> Bool -> Bool +test t = unT t @Bool diff --git a/testsuite/tests/typecheck/should_fail/ExplicitSpecificity10.stderr b/testsuite/tests/typecheck/should_fail/ExplicitSpecificity10.stderr new file mode 100644 index 0000000000..0929129d5e --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/ExplicitSpecificity10.stderr @@ -0,0 +1,6 @@ + +ExplicitSpecificity10.hs:8:10: error: + • Cannot apply expression of type ‘a0 -> a0’ + to a visible type argument ‘Bool’ + • In the expression: unT t @Bool + In an equation for ‘test’: test t = unT t @Bool diff --git a/testsuite/tests/typecheck/should_fail/ExplicitSpecificity2.hs b/testsuite/tests/typecheck/should_fail/ExplicitSpecificity2.hs new file mode 100644 index 0000000000..ec319e74f4 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/ExplicitSpecificity2.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE TypeApplications, RankNTypes, GADTs, PolyKinds #-} + +module ExplicitSpecificity2 where + +import Data.Proxy +import Data.Kind + +data T a where C :: forall {k} (a::k). Proxy a -> T a + +bar :: () +bar = let x = C @Type @Int Proxy + in () diff --git a/testsuite/tests/typecheck/should_fail/ExplicitSpecificity2.stderr b/testsuite/tests/typecheck/should_fail/ExplicitSpecificity2.stderr new file mode 100644 index 0000000000..8c43169157 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/ExplicitSpecificity2.stderr @@ -0,0 +1,7 @@ + +ExplicitSpecificity2.hs:11:15: error: + • Cannot apply expression of type ‘Proxy (*) -> T (*)’ + to a visible type argument ‘Int’ + • In the expression: C @Type @Int Proxy + In an equation for ‘x’: x = C @Type @Int Proxy + In the expression: let x = C @Type @Int Proxy in () diff --git a/testsuite/tests/typecheck/should_fail/ExplicitSpecificity3.hs b/testsuite/tests/typecheck/should_fail/ExplicitSpecificity3.hs new file mode 100644 index 0000000000..7f8144a2a8 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/ExplicitSpecificity3.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE RankNTypes, PolyKinds, TypeFamilies #-} + +module ExplicitSpecificity3 where + +type family F {k} (a::k) :: * +type instance F String = Int + diff --git a/testsuite/tests/typecheck/should_fail/ExplicitSpecificity3.stderr b/testsuite/tests/typecheck/should_fail/ExplicitSpecificity3.stderr new file mode 100644 index 0000000000..751fbefa73 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/ExplicitSpecificity3.stderr @@ -0,0 +1,2 @@ + +ExplicitSpecificity3.hs:5:17: error: parse error on input ‘}’ diff --git a/testsuite/tests/typecheck/should_fail/ExplicitSpecificity4.hs b/testsuite/tests/typecheck/should_fail/ExplicitSpecificity4.hs new file mode 100644 index 0000000000..4d615631b6 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/ExplicitSpecificity4.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module ExplicitSpecificity4 where + +class C a where + f :: forall {z}. z -> a -> a + default f :: forall {z}. z -> a -> a + f _ x = x + diff --git a/testsuite/tests/typecheck/should_fail/ExplicitSpecificity4.stderr b/testsuite/tests/typecheck/should_fail/ExplicitSpecificity4.stderr new file mode 100644 index 0000000000..95a3286ce4 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/ExplicitSpecificity4.stderr @@ -0,0 +1,4 @@ + +ExplicitSpecificity4.hs:8:3: error: + A default type signature cannot contain inferred type variables + In a class method signature for ‘f’ diff --git a/testsuite/tests/typecheck/should_fail/ExplicitSpecificity5.hs b/testsuite/tests/typecheck/should_fail/ExplicitSpecificity5.hs new file mode 100644 index 0000000000..2788f952fe --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/ExplicitSpecificity5.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +module ExplicitSpecificity5 where + +class C a where + +instance forall {a} {b}. C (Either a b) where + diff --git a/testsuite/tests/typecheck/should_fail/ExplicitSpecificity5.stderr b/testsuite/tests/typecheck/should_fail/ExplicitSpecificity5.stderr new file mode 100644 index 0000000000..c8fa860a57 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/ExplicitSpecificity5.stderr @@ -0,0 +1,4 @@ + +ExplicitSpecificity5.hs:7:1: error: + Inferred type variables are not allowed + In an instance declaration diff --git a/testsuite/tests/typecheck/should_fail/ExplicitSpecificity6.hs b/testsuite/tests/typecheck/should_fail/ExplicitSpecificity6.hs new file mode 100644 index 0000000000..88508071b8 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/ExplicitSpecificity6.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module ExplicitSpecificity6 where + +class C a where + +instance forall {a} {b}. C (Either a b) where + {-# SPECIALISE instance forall {a}. C (Either a Int) #-} + + diff --git a/testsuite/tests/typecheck/should_fail/ExplicitSpecificity6.stderr b/testsuite/tests/typecheck/should_fail/ExplicitSpecificity6.stderr new file mode 100644 index 0000000000..326c9b2ae9 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/ExplicitSpecificity6.stderr @@ -0,0 +1,8 @@ + +ExplicitSpecificity6.hs:8:1: error: + Inferred type variables are not allowed + In an instance declaration + +ExplicitSpecificity6.hs:9:3: error: + Inferred type variables are not allowed + In a SPECIALISE instance pragma diff --git a/testsuite/tests/typecheck/should_fail/ExplicitSpecificity7.hs b/testsuite/tests/typecheck/should_fail/ExplicitSpecificity7.hs new file mode 100644 index 0000000000..c5b58cd758 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/ExplicitSpecificity7.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE RankNTypes, StandaloneKindSignatures, DataKinds, PolyKinds, TypeApplications #-} + +module ExplicitSpecificity7 where + +type Foo :: forall a {b}. a -> b -> b +type Foo x y = y + +type Bar = Foo @Bool @Int True 42 diff --git a/testsuite/tests/typecheck/should_fail/ExplicitSpecificity7.stderr b/testsuite/tests/typecheck/should_fail/ExplicitSpecificity7.stderr new file mode 100644 index 0000000000..2d98e47867 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/ExplicitSpecificity7.stderr @@ -0,0 +1,6 @@ + +ExplicitSpecificity7.hs:8:12: error: + • Cannot apply function of kind ‘Bool -> b0 -> b0’ + to visible kind argument ‘Int’ + • In the type ‘Foo @Bool @Int True 42’ + In the type declaration for ‘Bar’ diff --git a/testsuite/tests/typecheck/should_fail/ExplicitSpecificity8.hs b/testsuite/tests/typecheck/should_fail/ExplicitSpecificity8.hs new file mode 100644 index 0000000000..819a060d42 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/ExplicitSpecificity8.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE RankNTypes, PolyKinds, GADTs #-} + +module ExplicitSpecificity8 where + +import GHC.Types + +data T1 :: forall k -> k -> Type + +data T2 :: forall {k} -> k -> Type + +foo1 :: T1 Type Int -> () +foo1 _ = () + +foo2 :: T2 Type Int -> () +foo2 _ = () diff --git a/testsuite/tests/typecheck/should_fail/ExplicitSpecificity8.stderr b/testsuite/tests/typecheck/should_fail/ExplicitSpecificity8.stderr new file mode 100644 index 0000000000..dcb79191d7 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/ExplicitSpecificity8.stderr @@ -0,0 +1,6 @@ + +ExplicitSpecificity8.hs:9:12: error: + • Unexpected inferred variable in visible forall binder: + forall {k} -> k -> Type + • In the kind ‘forall {k} -> k -> Type’ + In the data type declaration for ‘T2’ diff --git a/testsuite/tests/typecheck/should_fail/ExplicitSpecificity9.hs b/testsuite/tests/typecheck/should_fail/ExplicitSpecificity9.hs new file mode 100644 index 0000000000..829e771e46 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/ExplicitSpecificity9.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +module Bug where + +data T a = MkT +deriving instance forall {a}. Show (T a) diff --git a/testsuite/tests/typecheck/should_fail/ExplicitSpecificity9.stderr b/testsuite/tests/typecheck/should_fail/ExplicitSpecificity9.stderr new file mode 100644 index 0000000000..59bb56cf66 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/ExplicitSpecificity9.stderr @@ -0,0 +1,4 @@ + +ExplicitSpecificity9.hs:6:1: error: + Inferred type variables are not allowed + In a deriving declaration diff --git a/testsuite/tests/typecheck/should_fail/all.T b/testsuite/tests/typecheck/should_fail/all.T index 8735cead75..d97c6f96e1 100644 --- a/testsuite/tests/typecheck/should_fail/all.T +++ b/testsuite/tests/typecheck/should_fail/all.T @@ -564,3 +564,13 @@ test('T17021b', normal, compile_fail, ['']) test('T17955', normal, compile_fail, ['']) test('T17173', normal, compile_fail, ['']) test('T18127a', normal, compile_fail, ['']) +test('ExplicitSpecificity1', normal, compile_fail, ['']) +test('ExplicitSpecificity2', normal, compile_fail, ['']) +test('ExplicitSpecificity3', normal, compile_fail, ['']) +test('ExplicitSpecificity4', normal, compile_fail, ['']) +test('ExplicitSpecificity5', normal, compile_fail, ['']) +test('ExplicitSpecificity6', normal, compile_fail, ['']) +test('ExplicitSpecificity7', normal, compile_fail, ['']) +test('ExplicitSpecificity8', normal, compile_fail, ['']) +test('ExplicitSpecificity9', normal, compile_fail, ['']) +test('ExplicitSpecificity10', normal, compile_fail, ['']) diff --git a/utils/haddock b/utils/haddock -Subproject 97f301a63ea8461074bfaa1486eb798e4be65f1 +Subproject a8d7e66da4dcc3b242103271875261604be42d6 |