Commit a9311cd5 authored by Gert-Jan Bottu's avatar Gert-Jan Bottu Committed by Marge Bot

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
parent 55f0e783
Pipeline #19595 passed with stages
in 699 minutes and 32 seconds
......@@ -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
  • @Gertjan423 In future please can you add new builtin names to the end of the list so that the unique numbers increment monotonically? It is easy to introduce collisions (like I did) if you don't do this.

Please register or sign in to reply
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
{-
************************************************************************
* *
......
......@@ -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))
......
......@@ -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)
......
......@@ -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) =
......
......@@ -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
......
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]
......
......@@ -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)) }
......
......@@ -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)
......@@ -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)
......
......@@ -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
......
......@@ -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 }
......
......@@ -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
......
......@@ -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
----------------
......
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
......
......@@ -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