diff options
| author | Gert-Jan Bottu <gertjan.bottu@kuleuven.be> | 2020-03-23 09:36:28 +0100 |
|---|---|---|
| committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2020-05-21 12:11:31 -0400 |
| commit | a9311cd53d33439e8fe79967ba5fb85bcd114fec (patch) | |
| tree | 2254ef735a24f9de8d192203a3c6f4871a8b6ae9 /compiler/GHC | |
| parent | 55f0e783d234af103cf4e1d51cd31c99961c5abe (diff) | |
| download | haskell-a9311cd53d33439e8fe79967ba5fb85bcd114fec.tar.gz | |
Explicit Specificity
Implementation for Ticket #16393.
Explicit specificity allows users to manually create inferred type variables,
by marking them with braces.
This way, the user determines which variables can be instantiated through
visible type application.
The additional syntax is included in the parser, allowing users to write
braces in type variable binders (type signatures, data constructors etc).
This information is passed along through the renamer and verified in the
type checker.
The AST for type variable binders, data constructors, pattern synonyms,
partial signatures and Template Haskell has been updated to include the
specificity of type variables.
Minor notes:
- Bumps haddock submodule
- Disables pattern match checking in GHC.Iface.Type with GHC 8.8
Diffstat (limited to 'compiler/GHC')
57 files changed, 1052 insertions, 644 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 } |