Commit d8c64e86 authored by eir@cis.upenn.edu's avatar eir@cis.upenn.edu

Address #11471 by putting RuntimeRep in kinds.

See Note [TYPE] in TysPrim. There are still some outstanding
pieces in #11471 though, so this doesn't actually nail the bug.

This commit also contains a few performance improvements:

* Short-cut equality checking of nullary type syns

* Compare types before kinds in eqType

* INLINE coreViewOneStarKind

* Store tycon binders separately from kinds.

This resulted in a ~10% performance improvement in compiling
the Cabal package. No change in functionality other than
performance. (This affects the interface file format, though.)

This commit updates the haddock submodule.
parent ce36115b
Pipeline #244 failed with stages
in 41 seconds
......@@ -720,6 +720,7 @@ mkDataCon :: Name
-> ThetaType -- ^ Theta-type occuring before the arguments proper
-> [Type] -- ^ Original argument types
-> Type -- ^ Original result type
-> RuntimeRepInfo -- ^ See comments on 'TyCon.RuntimeRepInfo'
-> TyCon -- ^ Representation type constructor
-> ThetaType -- ^ The "stupid theta", context of the data
-- declaration e.g. @data Eq a => T a ...@
......@@ -733,7 +734,7 @@ mkDataCon name declared_infix prom_info
fields
univ_tvs ex_tvs
eq_spec theta
orig_arg_tys orig_res_ty rep_tycon
orig_arg_tys orig_res_ty rep_info rep_tycon
stupid_theta work_id rep
-- Warning: mkDataCon is not a good place to check invariants.
-- If the programmer writes the wrong result type in the decl, thus:
......@@ -774,8 +775,15 @@ mkDataCon name declared_infix prom_info
mkFunTys rep_arg_tys $
mkTyConApp rep_tycon (mkTyVarTys univ_tvs)
promoted -- See Note [Promoted data constructors] in TyCon
= mkPromotedDataCon con name prom_info (dataConUserType con) roles
-- See Note [Promoted data constructors] in TyCon
prom_binders = map (mkNamedBinder Specified)
((univ_tvs `minusList` map eqSpecTyVar eq_spec) ++
ex_tvs) ++
map mkAnonBinder theta ++
map mkAnonBinder orig_arg_tys
prom_res_kind = orig_res_ty
promoted
= mkPromotedDataCon con name prom_info prom_binders prom_res_kind roles rep_info
roles = map (const Nominal) (univ_tvs ++ ex_tvs) ++
map (const Representational) orig_arg_tys
......@@ -1106,9 +1114,7 @@ isVanillaDataCon dc = dcVanilla dc
-- | Should this DataCon be allowed in a type even without -XDataKinds?
-- Currently, only Lifted & Unlifted
specialPromotedDc :: DataCon -> Bool
specialPromotedDc dc
= dc `hasKey` liftedDataConKey ||
dc `hasKey` unliftedDataConKey
specialPromotedDc = isKindTyCon . dataConTyCon
-- | Was this datacon promotable before GHC 8.0? That is, is it promotable
-- without -XTypeInType
......@@ -1228,7 +1234,7 @@ buildAlgTyCon :: Name
buildAlgTyCon tc_name ktvs roles cType stupid_theta rhs
is_rec gadt_syn parent
= mkAlgTyCon tc_name kind ktvs roles cType stupid_theta
= mkAlgTyCon tc_name binders liftedTypeKind ktvs roles cType stupid_theta
rhs parent is_rec gadt_syn
where
kind = mkPiTypesPreferFunTy ktvs liftedTypeKind
binders = mkTyBindersPreferAnon ktvs liftedTypeKind
......@@ -1062,11 +1062,11 @@ dollarId = pcMiscPrelId dollarName ty
(noCafIdInfo `setUnfoldingInfo` unf)
where
fun_ty = mkFunTy alphaTy openBetaTy
ty = mkSpecForAllTys [levity2TyVar, alphaTyVar, openBetaTyVar] $
ty = mkSpecForAllTys [runtimeRep2TyVar, alphaTyVar, openBetaTyVar] $
mkFunTy fun_ty fun_ty
unf = mkInlineUnfolding (Just 2) rhs
[f,x] = mkTemplateLocals [fun_ty, alphaTy]
rhs = mkLams [levity2TyVar, alphaTyVar, openBetaTyVar, f, x] $
rhs = mkLams [runtimeRep2TyVar, alphaTyVar, openBetaTyVar, f, x] $
App (Var f) (Var x)
------------------------------------------------
......@@ -1083,7 +1083,9 @@ proxyHashId
t = mkTyVarTy tv
------------------------------------------------
-- unsafeCoerce# :: forall a b. a -> b
-- unsafeCoerce# :: forall (r1 :: RuntimeRep) (r2 :: RuntimeRep)
-- (a :: TYPE r1) (b :: TYPE r2).
-- a -> b
unsafeCoerceId :: Id
unsafeCoerceId
= pcMiscPrelId unsafeCoerceName ty info
......@@ -1091,14 +1093,13 @@ unsafeCoerceId
info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma
`setUnfoldingInfo` mkCompulsoryUnfolding rhs
ty = mkSpecForAllTys [ levity1TyVar, levity2TyVar
, openAlphaTyVar, openBetaTyVar ]
(mkFunTy openAlphaTy openBetaTy)
tvs = [ runtimeRep1TyVar, runtimeRep2TyVar
, openAlphaTyVar, openBetaTyVar ]
ty = mkSpecForAllTys tvs $ mkFunTy openAlphaTy openBetaTy
[x] = mkTemplateLocals [openAlphaTy]
rhs = mkLams [ levity1TyVar, levity2TyVar
, openAlphaTyVar, openBetaTyVar
, x] $
rhs = mkLams (tvs ++ [x]) $
Cast (Var x) (mkUnsafeCo Representational openAlphaTy openBetaTy)
------------------------------------------------
......@@ -1166,13 +1167,13 @@ oneShotId = pcMiscPrelId oneShotName ty info
where
info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma
`setUnfoldingInfo` mkCompulsoryUnfolding rhs
ty = mkSpecForAllTys [ levity1TyVar, levity2TyVar
ty = mkSpecForAllTys [ runtimeRep1TyVar, runtimeRep2TyVar
, openAlphaTyVar, openBetaTyVar ]
(mkFunTy fun_ty fun_ty)
fun_ty = mkFunTy alphaTy betaTy
fun_ty = mkFunTy openAlphaTy openBetaTy
[body, x] = mkTemplateLocals [fun_ty, openAlphaTy]
x' = setOneShotLambda x
rhs = mkLams [ levity1TyVar, levity2TyVar
rhs = mkLams [ runtimeRep1TyVar, runtimeRep2TyVar
, openAlphaTyVar, openBetaTyVar
, body, x'] $
Var body `App` Var x
......@@ -1196,7 +1197,7 @@ runRWId = pcMiscPrelId runRWName ty info
arg_ty = stateRW `mkFunTy` ret_ty
-- (State# RealWorld -> (# State# RealWorld, o #))
-- -> (# State# RealWorld, o #)
ty = mkSpecForAllTys [levity1TyVar, openAlphaTyVar] $
ty = mkSpecForAllTys [runtimeRep1TyVar, openAlphaTyVar] $
arg_ty `mkFunTy` ret_ty
--------------------------------------------------------------------------------
......@@ -1375,7 +1376,7 @@ no further floating will occur. This allows us to safely inline things like
While the definition of @GHC.Magic.runRW#@, we override its type in @MkId@
to be open-kinded,
runRW# :: forall (lev :: Levity). (o :: TYPE lev)
runRW# :: forall (r1 :: RuntimeRep). (o :: TYPE r)
=> (State# RealWorld -> (# State# RealWorld, o #))
-> (# State# RealWorld, o #)
......
......@@ -79,7 +79,7 @@ data PatSyn
-- Matcher function.
-- If Bool is True then prov_theta and arg_tys are empty
-- and type is
-- forall (v :: Levity) (r :: TYPE v) univ_tvs.
-- forall (p :: RuntimeRep) (r :: TYPE p) univ_tvs.
-- req_theta
-- => res_ty
-- -> (forall ex_tvs. Void# -> r)
......@@ -87,7 +87,7 @@ data PatSyn
-- -> r
--
-- Otherwise type is
-- forall (v :: Levity) (r :: TYPE v) univ_tvs.
-- forall (p :: RuntimeRep) (r :: TYPE r) univ_tvs.
-- req_theta
-- => res_ty
-- -> (forall ex_tvs. prov_theta => arg_tys -> r)
......
......@@ -988,8 +988,8 @@ lintAndScopeId id linterF
(text "Non-local Id binder" <+> ppr id)
-- See Note [Checking for global Ids]
; (ty, k) <- lintInTy (idType id)
; lintL (not (isLevityPolymorphic k))
(text "Levity polymorphic binder:" <+>
; lintL (not (isRuntimeRepPolymorphic k))
(text "RuntimeRep-polymorphic binder:" <+>
(ppr id <+> dcolon <+> parens (ppr ty <+> dcolon <+> ppr k)))
; let id' = setIdType id ty
; addInScopeVar id' $ (linterF id') }
......
......@@ -512,7 +512,7 @@ cpeRhsE env (Var f `App` _{-type-} `App` arg)
| f `hasKey` lazyIdKey -- Replace (lazy a) by a
= cpeRhsE env arg -- See Note [lazyId magic] in MkId
cpeRhsE env (Var f `App` _levity `App` _type `App` arg)
cpeRhsE env (Var f `App` _runtimeRep `App` _type `App` arg)
-- See Note [runRW magic] in MkId
| f `hasKey` runRWKey -- Replace (runRW# f) by (f realWorld#),
= case arg of -- beta reducing if possible
......
......@@ -322,13 +322,13 @@ mkCoreTup cs = mkCoreConApps (tupleDataCon Boxed (length cs))
-- | Build a small unboxed tuple holding the specified expressions,
-- with the given types. The types must be the types of the expressions.
-- Do not include the levity specifiers; this function calculates them
-- Do not include the RuntimeRep specifiers; this function calculates them
-- for you.
mkCoreUbxTup :: [Type] -> [CoreExpr] -> CoreExpr
mkCoreUbxTup tys exps
= ASSERT( tys `equalLength` exps)
mkCoreConApps (tupleDataCon Unboxed (length tys))
(map (Type . getLevity "mkCoreUbxTup") tys ++ map Type tys ++ exps)
(map (Type . getRuntimeRep "mkCoreUbxTup") tys ++ map Type tys ++ exps)
-- | Make a core tuple of the given boxity
mkCoreTupBoxity :: Boxity -> [CoreExpr] -> CoreExpr
......@@ -588,7 +588,8 @@ mkRuntimeErrorApp
-> CoreExpr
mkRuntimeErrorApp err_id res_ty err_msg
= mkApps (Var err_id) [Type (getLevity "mkRuntimeErrorApp" res_ty), Type res_ty, err_string]
= mkApps (Var err_id) [ Type (getRuntimeRep "mkRuntimeErrorApp" res_ty)
, Type res_ty, err_string ]
where
err_string = Lit (mkMachString err_msg)
......@@ -672,21 +673,18 @@ mkRuntimeErrorId name = pc_bottoming_Id1 name runtimeErrorTy
runtimeErrorTy :: Type
-- The runtime error Ids take a UTF8-encoded string as argument
runtimeErrorTy = mkSpecSigmaTy [levity1TyVar, openAlphaTyVar] []
runtimeErrorTy = mkSpecSigmaTy [runtimeRep1TyVar, openAlphaTyVar] []
(mkFunTy addrPrimTy openAlphaTy)
{-
Note [Error and friends have an "open-tyvar" forall]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'error' and 'undefined' have types
error :: forall (v :: Levity) (a :: TYPE v). String -> a
undefined :: forall (v :: Levity) (a :: TYPE v). a
Notice the levity polymophism. This ensures that
"error" can be instantiated at
* unboxed as well as boxed types
* polymorphic types
error :: forall (v :: RuntimeRep) (a :: TYPE v). String -> a
undefined :: forall (v :: RuntimeRep) (a :: TYPE v). a
Notice the runtime-representation polymophism. This ensures that
"error" can be instantiated at unboxed as well as boxed types.
This is OK because it never returns, so the return type is irrelevant.
See Note [Sort-polymorphic tyvars accept foralls] in TcMType.
************************************************************************
......
......@@ -1067,7 +1067,7 @@ dsEvTerm (EvDelayedError ty msg) = return $ dsEvDelayedError ty msg
dsEvDelayedError :: Type -> FastString -> CoreExpr
dsEvDelayedError ty msg
= Var errorId `mkTyApps` [getLevity "dsEvTerm" ty, ty] `mkApps` [litMsg]
= Var errorId `mkTyApps` [getRuntimeRep "dsEvTerm" ty, ty] `mkApps` [litMsg]
where
errorId = tYPE_ERROR_ID
litMsg = Lit (MachStr (fastStringToByteString msg))
......
......@@ -198,7 +198,10 @@ dsFCall fn_id co fcall mDeclHeader = do
ty = pFst $ coercionKind co
(all_bndrs, io_res_ty) = tcSplitPiTys ty
(named_bndrs, arg_tys) = partitionBindersIntoBinders all_bndrs
tvs = map (binderVar "dsFCall") named_bndrs
tvs = ASSERT( fst (span isNamedBinder all_bndrs)
`equalLength` named_bndrs )
-- ensure that the named binders all come first
map (binderVar "dsFCall") named_bndrs
-- Must use tcSplit* functions because we want to
-- see that (IO t) in the corner
......@@ -302,6 +305,7 @@ dsPrimCall fn_id co fcall = do
-- Must use tcSplit* functions because we want to
-- see that (IO t) in the corner
MASSERT( fst (span isNamedBinder bndrs) `equalLength` tvs )
args <- newSysLocalsDs arg_tys
ccall_uniq <- newUnique
......@@ -412,6 +416,8 @@ dsFExportDynamic :: Id
-> CCallConv
-> DsM ([Binding], SDoc, SDoc)
dsFExportDynamic id co0 cconv = do
MASSERT( fst (span isNamedBinder bndrs) `equalLength` tvs )
-- make sure that the named binders all come first
fe_id <- newSysLocalDs ty
mod <- getModule
dflags <- getDynFlags
......
......@@ -343,7 +343,7 @@ sort_alts = sortWith (dataConTag . alt_pat)
mkPatSynCase :: Id -> Type -> CaseAlt PatSyn -> CoreExpr -> DsM CoreExpr
mkPatSynCase var ty alt fail = do
matcher <- dsLExpr $ mkLHsWrap wrapper $
nlHsTyApp matcher [getLevity "mkPatSynCase" ty, ty]
nlHsTyApp matcher [getRuntimeRep "mkPatSynCase" ty, ty]
let MatchResult _ mkCont = match_result
cont <- mkCoreLams bndrs <$> mkCont fail
return $ mkCoreAppsDs (text "patsyn" <+> ppr var) matcher [Var var, ensure_unstrict cont, Lam voidArgId fail]
......@@ -469,7 +469,7 @@ mkErrorAppDs err_id ty msg = do
full_msg = showSDoc dflags (hcat [ppr src_loc, vbar, msg])
core_msg = Lit (mkMachString full_msg)
-- mkMachString returns a result of type String#
return (mkApps (Var err_id) [Type (getLevity "mkErrorAppDs" ty), Type ty, core_msg])
return (mkApps (Var err_id) [Type (getRuntimeRep "mkErrorAppDs" ty), Type ty, core_msg])
{-
'mkCoreAppDs' and 'mkCoreAppsDs' hand the special-case desugaring of 'seq'.
......
......@@ -800,8 +800,8 @@ extractSubTerms recurse clos = liftM thdOf3 . go 0 (nonPtrs clos)
go ptr_i ws (ty:tys)
| Just (tc, elem_tys) <- tcSplitTyConApp_maybe ty
, isUnboxedTupleTyCon tc
-- See Note [Unboxed tuple levity vars] in TyCon
= do (ptr_i, ws, terms0) <- go ptr_i ws (dropLevityArgs elem_tys)
-- See Note [Unboxed tuple RuntimeRep vars] in TyCon
= do (ptr_i, ws, terms0) <- go ptr_i ws (dropRuntimeRepArgs elem_tys)
(ptr_i, ws, terms1) <- go ptr_i ws tys
return (ptr_i, ws, unboxedTupleTerm ty terms0 : terms1)
| otherwise
......
......@@ -344,7 +344,7 @@ putTupleName_ bh tc tup_sort thing_tag
(sort_tag, arity) = case tup_sort of
BoxedTuple -> (0, fromIntegral (tyConArity tc))
UnboxedTuple -> (1, fromIntegral (tyConArity tc `div` 2))
-- See Note [Unboxed tuple levity vars] in TyCon
-- See Note [Unboxed tuple RuntimeRep vars] in TyCon
ConstraintTuple -> pprPanic "putTupleName:ConstraintTuple" (ppr tc)
-- See Note [Symbol table representation of names]
......
......@@ -138,7 +138,7 @@ buildDataCon fam_envs src_name declared_infix prom_info src_bangs impl_bangs fie
data_con = mkDataCon src_name declared_infix prom_info
src_bangs field_lbls
univ_tvs ex_tvs eq_spec ctxt
arg_tys res_ty rep_tycon
arg_tys res_ty NoRRI rep_tycon
stupid_ctxt dc_wrk dc_rep
dc_wrk = mkDataConWorkId work_name data_con
dc_rep = initUs_ us (mkDataConRep dflags fam_envs wrap_name
......@@ -215,7 +215,7 @@ type TcMethInfo = (Name, Type, Maybe (DefMethSpec Type))
buildClass :: Name -- Name of the class/tycon (they have the same Name)
-> [TyVar] -> [Role] -> ThetaType
-> Kind
-> [TyBinder]
-> [FunDep TyVar] -- Functional dependencies
-> [ClassATItem] -- Associated types
-> [TcMethInfo] -- Method info
......@@ -223,7 +223,8 @@ buildClass :: Name -- Name of the class/tycon (they have the same Name)
-> RecFlag -- Info for type constructor
-> TcRnIf m n Class
buildClass tycon_name tvs roles sc_theta kind fds at_items sig_stuff mindef tc_isrec
buildClass tycon_name tvs roles sc_theta binders
fds at_items sig_stuff mindef tc_isrec
= fixM $ \ rec_clas -> -- Only name generation inside loop
do { traceIf (text "buildClass")
......@@ -286,7 +287,7 @@ buildClass tycon_name tvs roles sc_theta kind fds at_items sig_stuff mindef tc_i
, tup_sort = ConstraintTuple })
else return (mkDataTyConRhs [dict_con])
; let { tycon = mkClassTyCon tycon_name kind tvs roles
; let { tycon = mkClassTyCon tycon_name binders tvs roles
rhs rec_clas tc_isrec tc_rep_name
-- A class can be recursive, and in the case of newtypes
-- this matters. For example
......
......@@ -49,7 +49,7 @@ import Data.List ( partition )
Note [The Name Cache]
~~~~~~~~~~~~~~~~~~~~~
The Name Cache makes sure that, during any invovcation of GHC, each
The Name Cache makes sure that, during any invocation of GHC, each
External Name "M.x" has one, and only one globally-agreed Unique.
* The first time we come across M.x we make up a Unique and record that
......
This diff is collapsed.
......@@ -17,18 +17,21 @@ module IfaceType (
IfaceTyCon(..), IfaceTyConInfo(..),
IfaceTyLit(..), IfaceTcArgs(..),
IfaceContext, IfaceBndr(..), IfaceOneShot(..), IfaceLamBndr,
IfaceTvBndr, IfaceIdBndr,
IfaceTvBndr, IfaceIdBndr, IfaceTyConBinder(..),
IfaceForAllBndr(..), VisibilityFlag(..),
ifConstraintKind, ifTyConBinderTyVar, ifTyConBinderName,
-- Equality testing
IfRnEnv2, emptyIfRnEnv2, eqIfaceType, eqIfaceTypes,
eqIfaceTcArgs, eqIfaceTvBndrs,
eqIfaceTcArgs, eqIfaceTvBndrs, isIfaceLiftedTypeKind,
-- Conversion from Type -> IfaceType
toIfaceType, toIfaceTypes, toIfaceKind, toIfaceTyVar,
toIfaceContext, toIfaceBndr, toIfaceIdBndr,
toIfaceTyCon, toIfaceTyCon_name,
toIfaceTcArgs, toIfaceTvBndrs,
zipIfaceBinders, toDegenerateBinders,
-- Conversion from IfaceTcArgs -> IfaceType
tcArgsIfaceTypes,
......@@ -39,7 +42,7 @@ module IfaceType (
-- Printing
pprIfaceType, pprParendIfaceType,
pprIfaceContext, pprIfaceContextArr, pprIfaceContextMaybe,
pprIfaceIdBndr, pprIfaceLamBndr, pprIfaceTvBndr, pprIfaceTvBndrs,
pprIfaceIdBndr, pprIfaceLamBndr, pprIfaceTvBndr, pprIfaceTyConBinders,
pprIfaceBndrs, pprIfaceTcArgs, pprParendIfaceTcArgs,
pprIfaceForAllPart, pprIfaceForAll, pprIfaceSigmaType,
pprIfaceCoercion, pprParendIfaceCoercion,
......@@ -59,7 +62,6 @@ import DataCon ( isTupleDataCon )
import TcType
import DynFlags
import TyCoRep -- needs to convert core types to iface types
import Unique( hasKey )
import TyCon hiding ( pprPromotionQuote )
import CoAxiom
import Id
......@@ -67,7 +69,7 @@ import Var
-- import RnEnv( FastStringEnv, mkFsEnv, lookupFsEnv )
import TysWiredIn
import TysPrim
import PrelNames( funTyConKey, ipClassKey )
import PrelNames
import Name
import BasicTypes
import Binary
......@@ -145,6 +147,11 @@ data IfaceTyLit
data IfaceForAllBndr
= IfaceTv IfaceTvBndr VisibilityFlag
data IfaceTyConBinder
= IfaceAnon IfLclName IfaceType -- like Anon, but it includes a name from
-- which to produce a tyConTyVar
| IfaceNamed IfaceForAllBndr
-- See Note [Suppressing invisible arguments]
-- We use a new list type (rather than [(IfaceType,Bool)], because
-- it'll be more compact and faster to parse in interface
......@@ -194,6 +201,12 @@ data IfaceUnivCoProv
| IfaceProofIrrelProv IfaceCoercion
| IfacePluginProv String
-- this constant is needed for dealing with pretty-printing classes
ifConstraintKind :: IfaceKind
ifConstraintKind = IfaceTyConApp (IfaceTyCon { ifaceTyConName = getName constraintKindTyCon
, ifaceTyConInfo = NoIfaceTyConInfo })
ITC_Nil
{-
%************************************************************************
%* *
......@@ -205,6 +218,15 @@ data IfaceUnivCoProv
eqIfaceTvBndr :: IfaceTvBndr -> IfaceTvBndr -> Bool
eqIfaceTvBndr (occ1, _) (occ2, _) = occ1 == occ2
isIfaceLiftedTypeKind :: IfaceKind -> Bool
isIfaceLiftedTypeKind (IfaceTyConApp tc ITC_Nil)
= isLiftedTypeKindTyConName (ifaceTyConName tc)
isIfaceLiftedTypeKind (IfaceTyConApp tc
(ITC_Vis (IfaceTyConApp ptr_rep_lifted ITC_Nil) ITC_Nil))
= ifaceTyConName tc == tYPETyConName
&& ifaceTyConName ptr_rep_lifted `hasKey` ptrRepLiftedDataConKey
isIfaceLiftedTypeKind _ = False
splitIfaceSigmaTy :: IfaceType -> ([IfaceForAllBndr], [IfacePredType], IfaceType)
-- Mainly for printing purposes
splitIfaceSigmaTy ty
......@@ -221,7 +243,7 @@ splitIfaceSigmaTy ty
= case split_rho ty2 of { (ps, tau) -> (ty1:ps, tau) }
split_rho tau = ([], tau)
suppressIfaceInvisibles :: DynFlags -> [IfaceForAllBndr] -> [a] -> [a]
suppressIfaceInvisibles :: DynFlags -> [IfaceTyConBinder] -> [a] -> [a]
suppressIfaceInvisibles dflags tys xs
| gopt Opt_PrintExplicitKinds dflags = xs
| otherwise = suppress tys xs
......@@ -232,14 +254,25 @@ suppressIfaceInvisibles dflags tys xs
| isIfaceInvisBndr k = suppress ks xs
| otherwise = a
stripIfaceInvisVars :: DynFlags -> [IfaceForAllBndr] -> [IfaceForAllBndr]
stripIfaceInvisVars :: DynFlags -> [IfaceTyConBinder] -> [IfaceTyConBinder]
stripIfaceInvisVars dflags tyvars
| gopt Opt_PrintExplicitKinds dflags = tyvars
| otherwise = filterOut isIfaceInvisBndr tyvars
isIfaceInvisBndr :: IfaceForAllBndr -> Bool
isIfaceInvisBndr (IfaceTv _ Visible) = False
isIfaceInvisBndr _ = True
isIfaceInvisBndr :: IfaceTyConBinder -> Bool
isIfaceInvisBndr (IfaceNamed (IfaceTv _ Invisible)) = True
isIfaceInvisBndr (IfaceNamed (IfaceTv _ Specified)) = True
isIfaceInvisBndr _ = False
-- | Extract a IfaceTvBndr from a IfaceTyConBinder
ifTyConBinderTyVar :: IfaceTyConBinder -> IfaceTvBndr
ifTyConBinderTyVar (IfaceAnon name ki) = (name, ki)
ifTyConBinderTyVar (IfaceNamed (IfaceTv tv _)) = tv
-- | Extract the variable name from a IfaceTyConBinder
ifTyConBinderName :: IfaceTyConBinder -> IfLclName
ifTyConBinderName (IfaceAnon name _) = name
ifTyConBinderName (IfaceNamed (IfaceTv (name, _) _)) = name
ifTyVarsOfType :: IfaceType -> UniqSet IfLclName
ifTyVarsOfType ty
......@@ -568,16 +601,15 @@ pprIfaceIdBndr :: (IfLclName, IfaceType) -> SDoc
pprIfaceIdBndr (name, ty) = parens (ppr name <+> dcolon <+> ppr ty)
pprIfaceTvBndr :: IfaceTvBndr -> SDoc
pprIfaceTvBndr (tv, IfaceTyConApp tc ITC_Nil)
| isLiftedTypeKindTyConName (ifaceTyConName tc) = ppr tv
pprIfaceTvBndr (tv, IfaceTyConApp tc (ITC_Vis (IfaceTyConApp lifted ITC_Nil) ITC_Nil))
| ifaceTyConName tc == tYPETyConName
, ifaceTyConName lifted == liftedDataConName
= ppr tv
pprIfaceTvBndr (tv, kind) = parens (ppr tv <+> dcolon <+> ppr kind)
pprIfaceTvBndr (tv, ki)
| isIfaceLiftedTypeKind ki = ppr tv
| otherwise = parens (ppr tv <+> dcolon <+> ppr ki)
pprIfaceTvBndrs :: [IfaceTvBndr] -> SDoc
pprIfaceTvBndrs tyvars = sep (map pprIfaceTvBndr tyvars)
pprIfaceTyConBinders :: [IfaceTyConBinder] -> SDoc
pprIfaceTyConBinders = sep . map go
where
go (IfaceAnon name ki) = pprIfaceTvBndr (name, ki)
go (IfaceNamed (IfaceTv tv _)) = pprIfaceTvBndr tv
instance Binary IfaceBndr where
put_ bh (IfaceIdBndr aa) = do
......@@ -786,11 +818,14 @@ pprTyTcApp ctxt_prec tc tys dflags
= pprIfaceTyList ctxt_prec ty1 ty2
| ifaceTyConName tc == tYPETyConName
, ITC_Vis (IfaceTyConApp lev_tc ITC_Nil) ITC_Nil <- tys
= let n = ifaceTyConName lev_tc in
if n == liftedDataConName then char '*'
else if n == unliftedDataConName then char '#'
else pprPanic "IfaceType.pprTyTcApp" (ppr lev_tc)
, ITC_Vis (IfaceTyConApp ptr_rep ITC_Nil) ITC_Nil <- tys
, ifaceTyConName ptr_rep `hasKey` ptrRepLiftedDataConKey
= char '*'
| ifaceTyConName tc == tYPETyConName
, ITC_Vis (IfaceTyConApp ptr_rep ITC_Nil) ITC_Nil <- tys
, ifaceTyConName ptr_rep `hasKey` ptrRepUnliftedDataConKey
= char '#'
| otherwise
= ppr_iface_tc_app ppr_ty ctxt_prec tc tys_wo_kinds
......@@ -826,8 +861,8 @@ ppr_iface_tc_app pp ctxt_prec tc tys
pprTuple :: TupleSort -> IfaceTyConInfo -> IfaceTcArgs -> SDoc
pprTuple sort info args
= -- drop the levity vars.
-- See Note [Unboxed tuple levity vars] in TyCon
= -- drop the RuntimeRep vars.
-- See Note [Unboxed tuple RuntimeRep vars] in TyCon
let tys = tcArgsIfaceTypes args
args' = case sort of
UnboxedTuple -> drop (length tys `div` 2) tys
......@@ -968,6 +1003,21 @@ instance Binary IfaceForAllBndr where
vis <- get bh
return (IfaceTv tv vis)
instance Binary IfaceTyConBinder where
put_ bh (IfaceAnon n ty) = putByte bh 0 >> put_ bh n >> put_ bh ty
put_ bh (IfaceNamed b) = putByte bh 1 >> put_ bh b
get bh =
do c <- getByte bh
case c of
0 -> do
n <- get bh
ty <- get bh
return $! IfaceAnon n ty
_ -> do
b <- get bh
return $! IfaceNamed b
instance Binary IfaceTcArgs where
put_ bh tk =
case tk of
......@@ -1360,3 +1410,20 @@ toIfaceUnivCoProv (PhantomProv co) = IfacePhantomProv (toIfaceCoercion co)
toIfaceUnivCoProv (ProofIrrelProv co) = IfaceProofIrrelProv (toIfaceCoercion co)
toIfaceUnivCoProv (PluginProv str) = IfacePluginProv str
toIfaceUnivCoProv (HoleProv h) = pprPanic "toIfaceUnivCoProv hit a hole" (ppr h)
----------------------
-- | Zip together tidied tyConTyVars with tyConBinders to make IfaceTyConBinders
zipIfaceBinders :: [TyVar] -> [TyBinder] -> [IfaceTyConBinder]
zipIfaceBinders = zipWith go
where
go tv (Anon _) = let (name, ki) = toIfaceTvBndr tv in
IfaceAnon name ki
go tv (Named _ vis) = IfaceNamed (IfaceTv (toIfaceTvBndr tv) vis)
-- | Make IfaceTyConBinders without tyConTyVars. Used for pretty-printing only
toDegenerateBinders :: [TyBinder] -> [IfaceTyConBinder]
toDegenerateBinders = zipWith go [1..]
where
go :: Int -> TyBinder -> IfaceTyConBinder
go n (Anon ty) = IfaceAnon (mkFastString ("t" ++ show n)) (toIfaceType ty)
go _ (Named tv vis) = IfaceNamed (IfaceTv (toIfaceTvBndr tv) vis)
......@@ -76,7 +76,6 @@ import DataCon
import PatSyn
import Type
import TcType
import TysPrim ( alphaTyVars )
import InstEnv
import FamInstEnv
import TcRnMonad
......@@ -1377,28 +1376,28 @@ tyConToIfaceDecl env tycon
| Just syn_rhs <- synTyConRhs_maybe tycon
= ( tc_env1
, IfaceSynonym { ifName = getOccName tycon,
ifTyVars = if_tc_tyvars,
ifRoles = tyConRoles tycon,
ifSynRhs = if_syn_type syn_rhs,
ifSynKind = if_kind
ifBinders = if_binders,
ifResKind = if_res_kind
})
| Just fam_flav <- famTyConFlav_maybe tycon
= ( tc_env1
, IfaceFamily { ifName = getOccName tycon,
ifTyVars = if_tc_tyvars,
ifResVar = if_res_var,
ifFamFlav = to_if_fam_flav fam_flav,
ifFamKind = if_kind,
ifBinders = if_binders,
ifResKind = if_res_kind,
ifFamInj = familyTyConInjectivityInfo tycon
})
| isAlgTyCon tycon
= ( tc_env1
, IfaceData { ifName = getOccName tycon,
ifKind = if_kind,
ifBinders = if_binders,
ifResKind = if_res_kind,
ifCType = tyConCType tycon,
ifTyVars = if_tc_tyvars,
ifRoles = tyConRoles tycon,
ifCtxt = tidyToIfaceContext tc_env1 (tyConStupidTheta tycon),
ifCons = ifaceConDecls (algTyConRhs tycon) (algTcFields tycon),
......@@ -1410,12 +1409,10 @@ tyConToIfaceDecl env tycon
-- For pretty printing purposes only.
= ( env
, IfaceData { ifName = getOccName tycon,
ifKind =
-- These don't have `tyConTyVars`, so we use an empty
-- environment here, instead of `tc_env1` defined below.
tidyToIfaceType emptyTidyEnv (tyConKind tycon),
ifBinders = if_degenerate_binders,
ifResKind = if_degenerate_res_kind,
-- These don't have `tyConTyVars`, hence "degenerate"
ifCType = Nothing,
ifTyVars = funAndPrimTyVars,
ifRoles = tyConRoles tycon,
ifCtxt = [],
ifCons = IfDataTyCon [] False [],
......@@ -1427,12 +1424,16 @@ tyConToIfaceDecl env tycon
-- is one of these TyCons (FunTyCon, PrimTyCon, PromotedDataCon) will cause
-- an error.
(tc_env1, tc_tyvars) = tidyTyClTyCoVarBndrs env (tyConTyVars tycon)
if_tc_tyvars = toIfaceTvBndrs tc_tyvars
if_kind = tidyToIfaceType tc_env1 (tyConKind tycon)
if_binders = zipIfaceBinders tc_tyvars (tyConBinders tycon)
if_res_kind = tidyToIfaceType tc_env1 (tyConResKind tycon)
if_syn_type ty = tidyToIfaceType tc_env1 ty
if_res_var = getFS `fmap` tyConFamilyResVar_maybe tycon
funAndPrimTyVars = toIfaceTvBndrs $ take (tyConArity tycon) alphaTyVars
-- use these when you don't have tyConTyVars
(degenerate_binders, degenerate_res_kind)
= splitPiTys (tidyType env (tyConKind tycon))
if_degenerate_binders = toDegenerateBinders degenerate_binders
if_degenerate_res_kind = toIfaceType degenerate_res_kind
parent = case tyConFamInstSig_maybe tycon of
Just (tc, ty, ax) -> IfDataInstance (coAxiomName ax)
......@@ -1522,9 +1523,8 @@ classToIfaceDecl env clas
= ( env1
, IfaceClass { ifCtxt = tidyToIfaceContext env1 sc_theta,
ifName = getOccName tycon,
ifTyVars = toIfaceTvBndrs clas_tyvars',
ifRoles = tyConRoles (classTyCon clas),
ifKind = tidyToIfaceType env1 (tyConKind tycon),
ifBinders = binders,
ifFDs = map toIfaceFD clas_fds,
ifATs = map toIfaceAT clas_ats,
ifSigs = map toIfaceClassOp op_stuff,
......@@ -1536,6 +1536,7 @@ classToIfaceDecl env clas
tycon = classTyCon clas
(env1, clas_tyvars') = tidyTyCoVarBndrs env clas_tyvars
binders = zipIfaceBinders clas_tyvars' (tyConBinders tycon)
toIfaceAT :: ClassATItem -> IfaceAT
toIfaceAT (ATI tc def)
......
......@@ -312,20 +312,21 @@ tc_iface_decl _ ignore_prags (IfaceId {ifName = occ_name, ifType = iface_type,
tc_iface_decl _ _ (IfaceData {ifName = occ_name,
ifCType = cType,
ifKind = kind,
ifTyVars = tv_bndrs,
ifBinders = binders,