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
......
......@@ -95,9 +95,9 @@ data IfaceDecl
ifIdInfo :: IfaceIdInfo }
| IfaceData { ifName :: IfaceTopBndr, -- Type constructor
ifKind :: IfaceType, -- Kind of type constructor
ifBinders :: [IfaceTyConBinder],
ifResKind :: IfaceType, -- Result kind of type constructor
ifCType :: Maybe CType, -- C type for CAPI FFI
ifTyVars :: [IfaceTvBndr], -- Type variables
ifRoles :: [Role], -- Roles
ifCtxt :: IfaceContext, -- The "stupid theta"
ifCons :: IfaceConDecls, -- Includes new/data/data family info
......@@ -109,25 +109,24 @@ data IfaceDecl
}
| IfaceSynonym { ifName :: IfaceTopBndr, -- Type constructor
ifTyVars :: [IfaceTvBndr], -- Type variables
ifRoles :: [Role], -- Roles
ifSynKind :: IfaceKind, -- Kind of the *tycon*
ifBinders :: [IfaceTyConBinder],
ifResKind :: IfaceKind, -- Kind of the *result*
ifSynRhs :: IfaceType }
| IfaceFamily { ifName :: IfaceTopBndr, -- Type constructor
ifTyVars :: [IfaceTvBndr], -- Type variables
ifResVar :: Maybe IfLclName, -- Result variable name, used
-- only for pretty-printing
-- with --show-iface
ifFamKind :: IfaceKind, -- Kind of the *tycon*
ifBinders :: [IfaceTyConBinder],
ifResKind :: IfaceKind, -- Kind of the *tycon*
ifFamFlav :: IfaceFamTyConFlav,
ifFamInj :: Injectivity } -- injectivity information
| IfaceClass { ifCtxt :: IfaceContext, -- Superclasses
ifName :: IfaceTopBndr, -- Name of the class TyCon
ifTyVars :: [IfaceTvBndr], -- Type variables
ifRoles :: [Role], -- Roles
ifKind :: IfaceType, -- Kind of TyCon
ifBinders :: [IfaceTyConBinder],
ifFDs :: [FunDep FastString], -- Functional dependencies
ifATs :: [IfaceAT], -- Associated type families
ifSigs :: [IfaceClassOp], -- Method signatures
......@@ -619,11 +618,11 @@ pprIfaceDecl :: ShowSub -> IfaceDecl -> SDoc
-- NB: pprIfaceDecl is also used for pretty-printing TyThings in GHCi
-- See Note [Pretty-printing TyThings] in PprTyThing
pprIfaceDecl ss (IfaceData { ifName = tycon, ifCType = ctype,
ifCtxt = context, ifTyVars = tc_tyvars,
ifCtxt = context,
ifRoles = roles, ifCons = condecls,
ifParent = parent, ifRec = isrec,
ifGadtSyntax = gadt,
ifKind = kind })
ifBinders = binders })
| gadt_style = vcat [ pp_roles
, pp_nd <+> pp_lhs <+> pp_where
......@@ -641,14 +640,14 @@ pprIfaceDecl ss (IfaceData { ifName = tycon, ifCType = ctype,
pp_cons = ppr_trim (map show_con cons) :: [SDoc]
pp_lhs = case parent of
IfNoParent -> pprIfaceDeclHead context ss tycon kind tc_tyvars
IfNoParent -> pprIfaceDeclHead context ss tycon binders Nothing
_ -> text "instance" <+> pprIfaceTyConParent parent
pp_roles
| is_data_instance = empty
| otherwise = pprRoles (== Representational)
(pprPrefixIfDeclBndr ss tycon)
tc_bndrs roles
binders roles
-- Don't display roles for data family instances (yet)
-- See discussion on Trac #8672.
......@@ -658,50 +657,29 @@ pprIfaceDecl ss (IfaceData { ifName = tycon, ifCType = ctype,
ok_con dc = showSub ss dc || any (showSub ss) (ifConFields dc)
show_con dc
| ok_con dc = Just $ pprIfaceConDecl ss gadt_style mk_user_con_res_ty fls dc
| ok_con dc = Just $ pprIfaceConDecl ss gadt_style fls tycon binders parent dc
| otherwise = Nothing
fls = ifaceConDeclFields condecls
mk_user_con_res_ty :: IfaceEqSpec -> ([IfaceTvBndr], SDoc)
-- See Note [Result type of a data family GADT]
mk_user_con_res_ty eq_spec
| IfDataInstance _ tc tys <- parent
= (con_univ_tvs, pprIfaceType (IfaceTyConApp tc (substIfaceTcArgs gadt_subst tys)))
| otherwise
= (con_univ_tvs, sdocWithDynFlags (ppr_tc_app gadt_subst))
where
gadt_subst = mkFsEnv eq_spec
done_univ_tv (tv,_) = isJust (lookupFsEnv gadt_subst tv)
con_univ_tvs = filterOut done_univ_tv tc_tyvars
ppr_tc_app gadt_subst dflags
= pprPrefixIfDeclBndr ss tycon
<+> sep [ pprParendIfaceType (substIfaceTyVar gadt_subst tv)
| (tv,_kind)
<- suppressIfaceInvisibles dflags tc_bndrs tc_tyvars ]
(tc_bndrs, _, _) = splitIfaceSigmaTy kind
pp_nd = case condecls of
IfAbstractTyCon d -> text "abstract" <> ppShowIface ss (parens (ppr d))
IfDataTyCon{} -> text "data"
IfNewTyCon{} -> text "newtype"
pp_extra = vcat [pprCType ctype, pprRec isrec, text "Kind:" <+> ppr kind]
pp_extra = vcat [pprCType ctype, pprRec isrec]
pprIfaceDecl ss (IfaceClass { ifATs = ats, ifSigs = sigs, ifRec = isrec
, ifCtxt = context, ifName = clas
, ifTyVars = tyvars, ifRoles = roles
, ifRoles = roles
, ifFDs = fds, ifMinDef = minDef
, ifKind = kind })
= vcat [ pprRoles (== Nominal) (pprPrefixIfDeclBndr ss clas) bndrs roles
, text "class" <+> pprIfaceDeclHead context ss clas kind tyvars
, ifBinders = binders })
= vcat [ pprRoles (== Nominal) (pprPrefixIfDeclBndr ss clas) binders roles
, text "class" <+> pprIfaceDeclHead context ss clas binders Nothing
<+> pprFundeps fds <+> pp_where
, nest 2 (vcat [ vcat asocs, vcat dsigs, pprec
, ppShowAllSubs ss (pprMinDef minDef)])]
where
(bndrs, _, _) = splitIfaceSigmaTy kind
pp_where = ppShowRhs ss $ ppUnless (null sigs && null ats) (text "where")
asocs = ppr_trim $ map maybeShowAssoc ats
......@@ -726,26 +704,27 @@ pprIfaceDecl ss (IfaceClass { ifATs = ats, ifSigs = sigs, ifRec = isrec
text "#-}"
pprIfaceDecl ss (IfaceSynonym { ifName = tc
, ifTyVars = tv
, ifBinders = binders
, ifSynRhs = mono_ty
, ifSynKind = kind})
= hang (text "type" <+> pprIfaceDeclHead [] ss tc kind tv <+> equals)
2 (sep [pprIfaceForAll tvs, pprIfaceContextArr theta, ppr tau])
, ifResKind = res_kind})
= hang (text "type" <+> pprIfaceDeclHead [] ss tc binders Nothing <+> equals)
2 (sep [ pprIfaceForAll tvs, pprIfaceContextArr theta, ppr tau
, ppUnless (isIfaceLiftedTypeKind res_kind) (dcolon <+> ppr res_kind) ])
where
(tvs, theta, tau) = splitIfaceSigmaTy mono_ty
pprIfaceDecl ss (IfaceFamily { ifName = tycon, ifTyVars = tyvars
, ifFamFlav = rhs, ifFamKind = kind
pprIfaceDecl ss (IfaceFamily { ifName = tycon
, ifFamFlav = rhs, ifBinders = binders
, ifResKind = res_kind
, ifResVar = res_var, ifFamInj = inj })
| IfaceDataFamilyTyCon <- rhs
= text "data family" <+> pprIfaceDeclHead [] ss tycon kind tyvars
= text "data family" <+> pprIfaceDeclHead [] ss tycon binders Nothing
| otherwise
= hang (text "type family" <+> pprIfaceDeclHead [] ss tycon kind tyvars)
= hang (text "type family" <+> pprIfaceDeclHead [] ss tycon binders (Just res_kind))
2 (pp_inj res_var inj <+> ppShowRhs ss (pp_rhs rhs))
$$
nest 2 ( vcat [ text "Kind:" <+> ppr kind
, ppShowRhs ss (pp_branches rhs) ] )
nest 2 (ppShowRhs ss (pp_branches rhs))
where
pp_inj Nothing _ = empty
pp_inj (Just res) inj
......@@ -753,9 +732,9 @@ pprIfaceDecl ss (IfaceFamily { ifName = tycon, ifTyVars = tyvars
, pp_inj_cond res injectivity]
| otherwise = hsep [ equals, ppr res ]
pp_inj_cond res inj = case filterByList inj tyvars of
pp_inj_cond res inj = case filterByList inj binders of
[] -> empty
tvs -> hsep [vbar, ppr res, text "->", interppSP (map fst tvs)]
tvs -> hsep [vbar, ppr res, text "->", interppSP (map ifTyConBinderName tvs)]
pp_rhs IfaceDataFamilyTyCon
= ppShowIface ss (text "data")
......@@ -808,7 +787,7 @@ pprCType (Just cType) = text "C type:" <+> ppr cType
-- if, for each role, suppress_if role is True, then suppress the role
-- output
pprRoles :: (Role -> Bool) -> SDoc -> [IfaceForAllBndr]
pprRoles :: (Role -> Bool) -> SDoc -> [IfaceTyConBinder]
-> [Role] -> SDoc
pprRoles suppress_if tyCon bndrs roles
= sdocWithDynFlags $ \dflags ->
......@@ -862,15 +841,15 @@ pprIfaceTyConParent (IfDataInstance _ tc tys)
in pprIfaceTypeApp tc ftys
pprIfaceDeclHead :: IfaceContext -> ShowSub -> OccName
-> IfaceType -- of the tycon, for invisible-suppression
-> [IfaceTvBndr] -> SDoc
pprIfaceDeclHead context ss tc_occ kind tyvars
-> [IfaceTyConBinder] -- of the tycon, for invisible-suppression
-> Maybe IfaceKind
-> SDoc
pprIfaceDeclHead context ss tc_occ bndrs m_res_kind
= sdocWithDynFlags $ \ dflags ->
sep [ pprIfaceContextArr context
, pprPrefixIfDeclBndr ss tc_occ
<+> pprIfaceTvBndrs (suppressIfaceInvisibles dflags bndrs tyvars) ]
where
(bndrs, _, _) = splitIfaceSigmaTy kind
<+> pprIfaceTyConBinders (suppressIfaceInvisibles dflags bndrs bndrs)
, maybe empty (\res_kind -> dcolon <+> pprIfaceType res_kind) m_res_kind ]
isVanillaIfaceConDecl :: IfaceConDecl -> Bool
isVanillaIfaceConDecl (IfCon { ifConExTvs = ex_tvs
......@@ -879,10 +858,12 @@ isVanillaIfaceConDecl (IfCon { ifConExTvs = ex_tvs
= (null ex_tvs) && (null eq_spec) && (null ctxt)
pprIfaceConDecl :: ShowSub -> Bool
-> (IfaceEqSpec -> ([IfaceTvBndr], SDoc))
-> [FieldLbl OccName]
-> IfaceTopBndr
-> [IfaceTyConBinder]
-> IfaceTyConParent
-> IfaceConDecl -> SDoc
pprIfaceConDecl ss gadt_style mk_user_con_res_ty fls
pprIfaceConDecl ss gadt_style fls tycon tc_binders parent
(IfCon { ifConOcc = name, ifConInfix = is_infix,
ifConExTvs = ex_tvs,
ifConEqSpec = eq_spec, ifConCtxt = ctxt, ifConArgTys = arg_tys,
......@@ -935,6 +916,25 @@ pprIfaceConDecl ss gadt_style mk_user_con_res_ty fls
-- DuplicateRecordFields was used for the definition)
lbl = maybe sel (mkVarOccFS . flLabel) $ find (\ fl -> flSelector fl == sel) fls
mk_user_con_res_ty :: IfaceEqSpec -> ([IfaceTvBndr], SDoc)
-- See Note [Result type of a data family GADT]
mk_user_con_res_ty eq_spec
| IfDataInstance _ tc tys <- parent
= (con_univ_tvs, pprIfaceType (IfaceTyConApp tc (substIfaceTcArgs gadt_subst tys)))
| otherwise
= (con_univ_tvs, sdocWithDynFlags (ppr_tc_app gadt_subst))
where
gadt_subst = mkFsEnv eq_spec
done_univ_tv (tv,_) = isJust (lookupFsEnv gadt_subst tv)
con_univ_tvs = filterOut done_univ_tv (map ifTyConBinderTyVar tc_binders)