summaryrefslogtreecommitdiff
path: root/compiler/iface
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/iface')
-rw-r--r--compiler/iface/BinIface.hs20
-rw-r--r--compiler/iface/BuildTyCl.hs92
-rw-r--r--compiler/iface/IfaceEnv.hs25
-rw-r--r--compiler/iface/IfaceSyn.hs203
-rw-r--r--compiler/iface/IfaceType.hs633
-rw-r--r--compiler/iface/MkIface.hs56
-rw-r--r--compiler/iface/TcIface.hs346
-rw-r--r--compiler/iface/TcIface.hs-boot2
8 files changed, 806 insertions, 571 deletions
diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs
index 13a6649140..c0926fc22e 100644
--- a/compiler/iface/BinIface.hs
+++ b/compiler/iface/BinIface.hs
@@ -146,7 +146,7 @@ readBinIface_ dflags checkHiWay traceBinIFaceReading hi_path ncu = do
seekBin bh symtab_p
symtab <- getSymbolTable bh ncu
seekBin bh data_p -- Back to where we were before
-
+
-- It is only now that we know how to get a Name
return $ setUserData bh $ newReadState (getSymtabName ncu dict symtab)
(getDictFastString dict)
@@ -194,8 +194,8 @@ writeBinIface dflags hi_path mod_iface = do
let bin_dict = BinDictionary {
bin_dict_next = dict_next_ref,
bin_dict_map = dict_map_ref }
-
- -- Put the main thing,
+
+ -- Put the main thing,
bh <- return $ setUserData bh $ newWriteState (putName bin_dict bin_symtab)
(putFastString bin_dict)
put_ bh mod_iface
@@ -209,7 +209,7 @@ writeBinIface dflags hi_path mod_iface = do
symtab_next <- readFastMutInt symtab_next
symtab_map <- readIORef symtab_map
putSymbolTable bh symtab_next symtab_map
- debugTraceMsg dflags 3 (text "writeBinIface:" <+> int symtab_next
+ debugTraceMsg dflags 3 (text "writeBinIface:" <+> int symtab_next
<+> text "Names")
-- NB. write the dictionary after the symbol table, because
@@ -256,7 +256,7 @@ getSymbolTable bh ncu = do
od_names <- sequence (replicate sz (get bh))
updateNameCache ncu $ \namecache ->
let arr = listArray (0,sz-1) names
- (namecache', names) =
+ (namecache', names) =
mapAccumR (fromOnDiskName arr) namecache od_names
in (namecache', arr)
@@ -341,11 +341,11 @@ putTupleName_ bh tc tup_sort thing_tag
= -- ASSERT(arity < 2^(30 :: Int))
put_ bh (0x80000000 .|. (sort_tag `shiftL` 28) .|. (thing_tag `shiftL` 26) .|. arity)
where
- arity = fromIntegral (tyConArity tc)
- sort_tag = case tup_sort of
- BoxedTuple -> 0
- UnboxedTuple -> 1
- ConstraintTuple -> pprPanic "putTupleName:ConstraintTuple" (ppr tc)
+ (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
+ ConstraintTuple -> pprPanic "putTupleName:ConstraintTuple" (ppr tc)
-- See Note [Symbol table representation of names]
getSymtabName :: NameCacheUpdater
diff --git a/compiler/iface/BuildTyCl.hs b/compiler/iface/BuildTyCl.hs
index 0b8680d164..7c62bc2be5 100644
--- a/compiler/iface/BuildTyCl.hs
+++ b/compiler/iface/BuildTyCl.hs
@@ -6,9 +6,6 @@
{-# LANGUAGE CPP #-}
module BuildTyCl (
- buildSynonymTyCon,
- buildFamilyTyCon,
- buildAlgTyCon,
buildDataCon,
buildPatSyn,
TcMethInfo, buildClass,
@@ -44,32 +41,6 @@ import UniqSupply
import Util
import Outputable
-------------------------------------------------------
-buildSynonymTyCon :: Name -> [TyVar] -> [Role]
- -> Type
- -> Kind -- ^ Kind of the RHS
- -> TyCon
-buildSynonymTyCon tc_name tvs roles rhs rhs_kind
- = mkSynonymTyCon tc_name kind tvs roles rhs
- where
- kind = mkPiKinds tvs rhs_kind
-
-
-buildFamilyTyCon :: Name -- ^ Type family name
- -> [TyVar] -- ^ Type variables
- -> Maybe Name -- ^ Result variable name
- -> FamTyConFlav -- ^ Open, closed or in a boot file?
- -> Kind -- ^ Kind of the RHS
- -> Maybe Class -- ^ Parent, if exists
- -> Injectivity -- ^ Injectivity annotation
- -- See [Injectivity annotation] in HsDecls
- -> TyCon
-buildFamilyTyCon tc_name tvs res_tv rhs rhs_kind parent injectivity
- = mkFamilyTyCon tc_name kind tvs res_tv rhs parent injectivity
- where kind = mkPiKinds tvs rhs_kind
-
-
-------------------------------------------------------
distinctAbstractTyConRhs, totallyAbstractTyConRhs :: AlgTyConRhs
distinctAbstractTyConRhs = AbstractTyCon True
totallyAbstractTyConRhs = AbstractTyCon False
@@ -83,8 +54,9 @@ mkDataTyConRhs cons
}
where
is_enum_con con
- | (_tvs, theta, arg_tys, _res) <- dataConSig con
- = null theta && null arg_tys
+ | (_univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _res)
+ <- dataConFullSig con
+ = null ex_tvs && null eq_spec && null theta && null arg_tys
mkNewTyConRhs :: Name -> TyCon -> DataCon -> TcRnIf m n AlgTyConRhs
@@ -128,22 +100,21 @@ mkNewTyConRhs tycon_name tycon con
eta_reduce (a:as) (_:rs) ty | Just (fun, arg) <- splitAppTy_maybe ty,
Just tv <- getTyVar_maybe arg,
tv == a,
- not (a `elemVarSet` tyVarsOfType fun)
+ not (a `elemVarSet` tyCoVarsOfType fun)
= eta_reduce as rs fun
eta_reduce tvs rs ty = (reverse tvs, reverse rs, ty)
-
------------------------------------------------------
buildDataCon :: FamInstEnvs
-> Name
-> Bool -- Declared infix
- -> Promoted TyConRepName -- Promotable
+ -> TyConRepName
-> [HsSrcBang]
-> Maybe [HsImplBang]
-- See Note [Bangs on imported data constructors] in MkId
-> [FieldLabel] -- Field labels
-> [TyVar] -> [TyVar] -- Univ and ext
- -> [(TyVar,Type)] -- Equality spec
+ -> [EqSpec] -- Equality spec
-> ThetaType -- Does not include the "stupid theta"
-- or the GADT equalities
-> [Type] -> Type -- Argument and result types
@@ -188,14 +159,14 @@ mkDataConStupidTheta tycon arg_tys univ_tvs
| null stupid_theta = [] -- The common case
| otherwise = filter in_arg_tys stupid_theta
where
- tc_subst = zipTopTvSubst (tyConTyVars tycon) (mkTyVarTys univ_tvs)
+ tc_subst = zipTopTCvSubst (tyConTyVars tycon) (mkTyVarTys univ_tvs)
stupid_theta = substTheta tc_subst (tyConStupidTheta tycon)
-- Start by instantiating the master copy of the
-- stupid theta, taken from the TyCon
- arg_tyvars = tyVarsOfTypes arg_tys
+ arg_tyvars = tyCoVarsOfTypes arg_tys
in_arg_tys pred = not $ isEmptyVarSet $
- tyVarsOfType pred `intersectVarSet` arg_tyvars
+ tyCoVarsOfType pred `intersectVarSet` arg_tyvars
------------------------------------------------------
@@ -211,31 +182,38 @@ buildPatSyn :: Name -> Bool
buildPatSyn src_name declared_infix matcher@(matcher_id,_) builder
(univ_tvs, req_theta) (ex_tvs, prov_theta) arg_tys
pat_ty field_labels
- = ASSERT((and [ univ_tvs == univ_tvs'
- , ex_tvs == ex_tvs'
- , pat_ty `eqType` pat_ty'
- , prov_theta `eqTypes` prov_theta'
- , req_theta `eqTypes` req_theta'
- , arg_tys `eqTypes` arg_tys'
- ]))
+ = ASSERT2((and [ univ_tvs == univ_tvs1
+ , ex_tvs == ex_tvs1
+ , pat_ty `eqType` pat_ty1
+ , prov_theta `eqTypes` prov_theta1
+ , req_theta `eqTypes` req_theta1
+ , arg_tys `eqTypes` arg_tys1
+ ])
+ , (vcat [ ppr univ_tvs <+> twiddle <+> ppr univ_tvs1
+ , ppr ex_tvs <+> twiddle <+> ppr ex_tvs1
+ , ppr pat_ty <+> twiddle <+> ppr pat_ty1
+ , ppr prov_theta <+> twiddle <+> ppr prov_theta1
+ , ppr req_theta <+> twiddle <+> ppr req_theta1
+ , ppr arg_tys <+> twiddle <+> ppr arg_tys1]))
mkPatSyn src_name declared_infix
(univ_tvs, req_theta) (ex_tvs, prov_theta)
arg_tys pat_ty
matcher builder field_labels
where
- ((_:univ_tvs'), req_theta', tau) = tcSplitSigmaTy $ idType matcher_id
- ([pat_ty', cont_sigma, _], _) = tcSplitFunTys tau
- (ex_tvs', prov_theta', cont_tau) = tcSplitSigmaTy cont_sigma
- (arg_tys', _) = tcSplitFunTys cont_tau
-
--- ------------------------------------------------------
+ ((_:_:univ_tvs1), req_theta1, tau) = tcSplitSigmaTy $ idType matcher_id
+ ([pat_ty1, cont_sigma, _], _) = tcSplitFunTys tau
+ (ex_tvs1, prov_theta1, cont_tau) = tcSplitSigmaTy cont_sigma
+ (arg_tys1, _) = tcSplitFunTys cont_tau
+ twiddle = char '~'
+------------------------------------------------------
type TcMethInfo = (Name, Type, Maybe (DefMethSpec Type))
-- A temporary intermediate, to communicate between
-- tcClassSigs and buildClass.
-buildClass :: Name -- Name of the class/tycon (they have the same Name)
+buildClass :: Name -- Name of the class/tycon (they have the same Name)
-> [TyVar] -> [Role] -> ThetaType
+ -> Kind
-> [FunDep TyVar] -- Functional dependencies
-> [ClassATItem] -- Associated types
-> [TcMethInfo] -- Method info
@@ -243,7 +221,7 @@ 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 fds at_items sig_stuff mindef tc_isrec
+buildClass tycon_name tvs roles sc_theta kind fds at_items sig_stuff mindef tc_isrec
= fixM $ \ rec_clas -> -- Only name generation inside loop
do { traceIf (text "buildClass")
@@ -284,10 +262,11 @@ buildClass tycon_name tvs roles sc_theta fds at_items sig_stuff mindef tc_isrec
arg_tys = sc_theta ++ op_tys
rec_tycon = classTyCon rec_clas
+ ; rep_nm <- newTyConRepName datacon_name
; dict_con <- buildDataCon (panic "buildClass: FamInstEnvs")
datacon_name
False -- Not declared infix
- NotPromoted -- Class tycons are not promoted
+ rep_nm
(map (const no_bang) args)
(Just (map (const HsLazy) args))
[{- No fields -}]
@@ -305,9 +284,8 @@ buildClass tycon_name tvs roles sc_theta fds at_items sig_stuff mindef tc_isrec
, tup_sort = ConstraintTuple })
else return (mkDataTyConRhs [dict_con])
- ; let { clas_kind = mkPiKinds tvs constraintKind
- ; tycon = mkClassTyCon tycon_name clas_kind tvs roles
- rhs rec_clas tc_isrec tc_rep_name
+ ; let { tycon = mkClassTyCon tycon_name kind 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
-- class C a where { op :: C b => a -> b -> Int }
diff --git a/compiler/iface/IfaceEnv.hs b/compiler/iface/IfaceEnv.hs
index 645ceda5c0..43094f94aa 100644
--- a/compiler/iface/IfaceEnv.hs
+++ b/compiler/iface/IfaceEnv.hs
@@ -9,7 +9,8 @@ module IfaceEnv (
lookupOrig, lookupOrigNameCache, extendNameCache,
newIfaceName, newIfaceNames,
extendIfaceIdEnv, extendIfaceTyVarEnv,
- tcIfaceLclId, tcIfaceTyVar, lookupIfaceTyVar,
+ tcIfaceLclId, tcIfaceTyVar, lookupIfaceVar,
+ lookupIfaceTyVar, extendIfaceEnvs,
ifaceExportNames,
@@ -31,11 +32,13 @@ import Avail
import Module
import UniqFM
import FastString
+import IfaceType
import UniqSupply
import SrcLoc
import Util
import Outputable
+import Data.List ( partition )
{-
*********************************************************
@@ -277,8 +280,16 @@ tcIfaceTyVar occ
Nothing -> failIfM (text "Iface type variable out of scope: " <+> ppr occ)
}
-lookupIfaceTyVar :: FastString -> IfL (Maybe TyVar)
-lookupIfaceTyVar occ
+lookupIfaceTyVar :: IfaceTvBndr -> IfL (Maybe TyVar)
+lookupIfaceTyVar (occ, _)
+ = do { lcl <- getLclEnv
+ ; return (lookupUFM (if_tv_env lcl) occ) }
+
+lookupIfaceVar :: IfaceBndr -> IfL (Maybe TyCoVar)
+lookupIfaceVar (IfaceIdBndr (occ, _))
+ = do { lcl <- getLclEnv
+ ; return (lookupUFM (if_id_env lcl) occ) }
+lookupIfaceVar (IfaceTvBndr (occ, _))
= do { lcl <- getLclEnv
; return (lookupUFM (if_tv_env lcl) occ) }
@@ -289,6 +300,14 @@ extendIfaceTyVarEnv tyvars thing_inside
; pairs = [(occNameFS (getOccName tv), tv) | tv <- tyvars] }
; setLclEnv (env { if_tv_env = tv_env' }) thing_inside }
+extendIfaceEnvs :: [TyCoVar] -> IfL a -> IfL a
+extendIfaceEnvs tcvs thing_inside
+ = extendIfaceTyVarEnv tvs $
+ extendIfaceIdEnv cvs $
+ thing_inside
+ where
+ (tvs, cvs) = partition isTyVar tcvs
+
{-
************************************************************************
* *
diff --git a/compiler/iface/IfaceSyn.hs b/compiler/iface/IfaceSyn.hs
index 307a448ec9..247566cebc 100644
--- a/compiler/iface/IfaceSyn.hs
+++ b/compiler/iface/IfaceSyn.hs
@@ -94,14 +94,14 @@ data IfaceDecl
ifIdDetails :: IfaceIdDetails,
ifIdInfo :: IfaceIdInfo }
- | IfaceData { ifName :: IfaceTopBndr, -- Type constructor
+ | IfaceData { ifName :: IfaceTopBndr, -- Type constructor
+ ifKind :: IfaceType, -- 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
ifRec :: RecFlag, -- Recursive or not?
- ifPromotable :: Bool, -- Promotable to kind level?
ifGadtSyntax :: Bool, -- True <=> declared using
-- GADT syntax
ifParent :: IfaceTyConParent -- The axiom, for a newtype,
@@ -111,8 +111,7 @@ data IfaceDecl
| IfaceSynonym { ifName :: IfaceTopBndr, -- Type constructor
ifTyVars :: [IfaceTvBndr], -- Type variables
ifRoles :: [Role], -- Roles
- ifSynKind :: IfaceKind, -- Kind of the *rhs* (not of
- -- the tycon)
+ ifSynKind :: IfaceKind, -- Kind of the *tycon*
ifSynRhs :: IfaceType }
| IfaceFamily { ifName :: IfaceTopBndr, -- Type constructor
@@ -120,8 +119,7 @@ data IfaceDecl
ifResVar :: Maybe IfLclName, -- Result variable name, used
-- only for pretty-printing
-- with --show-iface
- ifFamKind :: IfaceKind, -- Kind of the *rhs* (not of
- -- the tycon)
+ ifFamKind :: IfaceKind, -- Kind of the *tycon*
ifFamFlav :: IfaceFamTyConFlav,
ifFamInj :: Injectivity } -- injectivity information
@@ -129,6 +127,7 @@ data IfaceDecl
ifName :: IfaceTopBndr, -- Name of the class TyCon
ifTyVars :: [IfaceTvBndr], -- Type variables
ifRoles :: [Role], -- Roles
+ ifKind :: IfaceType, -- Kind of TyCon
ifFDs :: [FunDep FastString], -- Functional dependencies
ifATs :: [IfaceAT], -- Associated type families
ifSigs :: [IfaceClassOp], -- Method signatures
@@ -187,11 +186,12 @@ data IfaceAT = IfaceAT -- See Class.ClassATItem
-- This is just like CoAxBranch
-data IfaceAxBranch = IfaceAxBranch { ifaxbTyVars :: [IfaceTvBndr]
- , ifaxbLHS :: IfaceTcArgs
- , ifaxbRoles :: [Role]
- , ifaxbRHS :: IfaceType
- , ifaxbIncomps :: [BranchIndex] }
+data IfaceAxBranch = IfaceAxBranch { ifaxbTyVars :: [IfaceTvBndr]
+ , ifaxbCoVars :: [IfaceIdBndr]
+ , ifaxbLHS :: IfaceTcArgs
+ , ifaxbRoles :: [Role]
+ , ifaxbRHS :: IfaceType
+ , ifaxbIncomps :: [BranchIndex] }
-- See Note [Storing compatibility] in CoAxiom
data IfaceConDecls
@@ -511,14 +511,20 @@ pprAxBranch :: SDoc -> IfaceAxBranch -> SDoc
-- be a branch for an imported TyCon, so it would be an ExtName
-- So it's easier to take an SDoc here
pprAxBranch pp_tc (IfaceAxBranch { ifaxbTyVars = tvs
- , ifaxbLHS = pat_tys
- , ifaxbRHS = rhs
- , ifaxbIncomps = incomps })
- = hang (pprUserIfaceForAll tvs)
- 2 (hang pp_lhs 2 (equals <+> ppr rhs))
+ , ifaxbCoVars = cvs
+ , ifaxbLHS = pat_tys
+ , ifaxbRHS = rhs
+ , ifaxbIncomps = incomps })
+ = hang ppr_binders 2 (hang pp_lhs 2 (equals <+> ppr rhs))
$+$
nest 2 maybe_incomps
where
+ ppr_binders
+ | null tvs && null cvs = empty
+ | null cvs = brackets (pprWithCommas pprIfaceTvBndr tvs)
+ | otherwise
+ = brackets (pprWithCommas pprIfaceTvBndr tvs <> semi <+>
+ pprWithCommas pprIfaceIdBndr cvs)
pp_lhs = hang pp_tc 2 (pprParendIfaceTcArgs pat_tys)
maybe_incomps = ppUnless (null incomps) $ parens $
ptext (sLit "incompatible indices:") <+> ppr incomps
@@ -617,7 +623,7 @@ pprIfaceDecl ss (IfaceData { ifName = tycon, ifCType = ctype,
ifRoles = roles, ifCons = condecls,
ifParent = parent, ifRec = isrec,
ifGadtSyntax = gadt,
- ifPromotable = is_prom })
+ ifKind = kind })
| gadt_style = vcat [ pp_roles
, pp_nd <+> pp_lhs <+> pp_where
@@ -635,13 +641,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 tc_tyvars
+ IfNoParent -> pprIfaceDeclHead context ss tycon kind tc_tyvars
_ -> ptext (sLit "instance") <+> pprIfaceTyConParent parent
pp_roles
- | is_data_instance = Outputable.empty
- | otherwise = pprRoles (== Representational) (pprPrefixIfDeclBndr ss tycon)
- tc_tyvars roles
+ | is_data_instance = empty
+ | otherwise = pprRoles (== Representational)
+ (pprPrefixIfDeclBndr ss tycon)
+ tc_bndrs roles
-- Don't display roles for data family instances (yet)
-- See discussion on Trac #8672.
@@ -670,29 +677,31 @@ pprIfaceDecl ss (IfaceData { ifName = tycon, ifCType = ctype,
ppr_tc_app gadt_subst dflags
= pprPrefixIfDeclBndr ss tycon
<+> sep [ pprParendIfaceType (substIfaceTyVar gadt_subst tv)
- | (tv,_kind) <- stripIfaceKindVars dflags tc_tyvars ]
+ | (tv,_kind)
+ <- suppressIfaceInvisibles dflags tc_bndrs tc_tyvars ]
+ (tc_bndrs, _, _) = splitIfaceSigmaTy kind
pp_nd = case condecls of
IfAbstractTyCon d -> ptext (sLit "abstract") <> ppShowIface ss (parens (ppr d))
IfDataTyCon{} -> ptext (sLit "data")
IfNewTyCon{} -> ptext (sLit "newtype")
- pp_extra = vcat [pprCType ctype, pprRec isrec, pp_prom]
-
- pp_prom | is_prom = ptext (sLit "Promotable")
- | otherwise = Outputable.empty
+ pp_extra = vcat [pprCType ctype, pprRec isrec, text "Kind:" <+> ppr kind]
pprIfaceDecl ss (IfaceClass { ifATs = ats, ifSigs = sigs, ifRec = isrec
, ifCtxt = context, ifName = clas
, ifTyVars = tyvars, ifRoles = roles
- , ifFDs = fds, ifMinDef = minDef })
- = vcat [ pprRoles (== Nominal) (pprPrefixIfDeclBndr ss clas) tyvars roles
- , ptext (sLit "class") <+> pprIfaceDeclHead context ss clas tyvars
+ , ifFDs = fds, ifMinDef = minDef
+ , ifKind = kind })
+ = vcat [ pprRoles (== Nominal) (pprPrefixIfDeclBndr ss clas) bndrs roles
+ , ptext (sLit "class") <+> pprIfaceDeclHead context ss clas kind tyvars
<+> 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) (ptext (sLit "where"))
asocs = ppr_trim $ map maybeShowAssoc ats
@@ -716,10 +725,11 @@ pprIfaceDecl ss (IfaceClass { ifATs = ats, ifSigs = sigs, ifRec = isrec
(\_ def -> cparen (isLexSym def) (ppr def)) 0 minDef <+>
ptext (sLit "#-}")
-pprIfaceDecl ss (IfaceSynonym { ifName = tc
- , ifTyVars = tv
- , ifSynRhs = mono_ty })
- = hang (ptext (sLit "type") <+> pprIfaceDeclHead [] ss tc tv <+> equals)
+pprIfaceDecl ss (IfaceSynonym { ifName = tc
+ , ifTyVars = tv
+ , ifSynRhs = mono_ty
+ , ifSynKind = kind})
+ = hang (ptext (sLit "type") <+> pprIfaceDeclHead [] ss tc kind tv <+> equals)
2 (sep [pprIfaceForAll tvs, pprIfaceContextArr theta, ppr tau])
where
(tvs, theta, tau) = splitIfaceSigmaTy mono_ty
@@ -728,19 +738,20 @@ pprIfaceDecl ss (IfaceFamily { ifName = tycon, ifTyVars = tyvars
, ifFamFlav = rhs, ifFamKind = kind
, ifResVar = res_var, ifFamInj = inj })
| IfaceDataFamilyTyCon <- rhs
- = ptext (sLit "data family") <+> pprIfaceDeclHead [] ss tycon tyvars
+ = ptext (sLit "data family") <+> pprIfaceDeclHead [] ss tycon kind tyvars
| otherwise
- = vcat [ hang (ptext (sLit "type family")
- <+> pprIfaceDeclHead [] ss tycon tyvars)
- 2 (pp_inj res_var inj <+> ppShowRhs ss (pp_rhs rhs))
- , ppShowRhs ss (nest 2 (pp_branches rhs)) ]
+ = hang (text "type family" <+> pprIfaceDeclHead [] ss tycon kind tyvars)
+ 2 (pp_inj res_var inj <+> ppShowRhs ss (pp_rhs rhs))
+ $$
+ nest 2 ( vcat [ text "Kind:" <+> ppr kind
+ , ppShowRhs ss (pp_branches rhs) ] )
where
- pp_inj Nothing _ = dcolon <+> ppr kind
+ pp_inj Nothing _ = empty
pp_inj (Just res) inj
- | Injective injectivity <- inj = hsep [ equals, ppr res, dcolon, ppr kind
+ | Injective injectivity <- inj = hsep [ equals, ppr res
, pp_inj_cond res injectivity]
- | otherwise = hsep [ equals, ppr res, dcolon, ppr kind ]
+ | otherwise = hsep [ equals, ppr res ]
pp_inj_cond res inj = case filterByList inj tyvars of
[] -> empty
@@ -753,13 +764,14 @@ pprIfaceDecl ss (IfaceFamily { ifName = tycon, ifTyVars = tyvars
pp_rhs IfaceAbstractClosedSynFamilyTyCon
= ppShowIface ss (ptext (sLit "closed, abstract"))
pp_rhs (IfaceClosedSynFamilyTyCon {})
- = ptext (sLit "where")
+ = empty -- see pp_branches
pp_rhs IfaceBuiltInSynFamTyCon
= ppShowIface ss (ptext (sLit "built-in"))
pp_branches (IfaceClosedSynFamilyTyCon (Just (ax, brs)))
- = vcat (map (pprAxBranch (pprPrefixIfDeclBndr ss tycon)) brs)
- $$ ppShowIface ss (ptext (sLit "axiom") <+> ppr ax)
+ = hang (text "where")
+ 2 (vcat (map (pprAxBranch (pprPrefixIfDeclBndr ss tycon)) brs)
+ $$ ppShowIface ss (ptext (sLit "axiom") <+> ppr ax))
pp_branches _ = Outputable.empty
pprIfaceDecl _ (IfacePatSyn { ifName = name, ifPatBuilder = builder,
@@ -768,7 +780,7 @@ pprIfaceDecl _ (IfacePatSyn { ifName = name, ifPatBuilder = builder,
ifPatArgs = arg_tys,
ifPatTy = pat_ty} )
= pprPatSynSig name is_bidirectional
- (pprUserIfaceForAll tvs)
+ (pprUserIfaceForAll (map tv_to_forall_bndr tvs))
(pprIfaceContextMaybe req_ctxt)
(pprIfaceContextMaybe prov_ctxt)
(pprIfaceType ty)
@@ -796,10 +808,11 @@ pprCType (Just cType) = ptext (sLit "C type:") <+> ppr cType
-- if, for each role, suppress_if role is True, then suppress the role
-- output
-pprRoles :: (Role -> Bool) -> SDoc -> [IfaceTvBndr] -> [Role] -> SDoc
-pprRoles suppress_if tyCon tyvars roles
+pprRoles :: (Role -> Bool) -> SDoc -> [IfaceForAllBndr]
+ -> [Role] -> SDoc
+pprRoles suppress_if tyCon bndrs roles
= sdocWithDynFlags $ \dflags ->
- let froles = suppressIfaceKinds dflags tyvars roles
+ let froles = suppressIfaceInvisibles dflags bndrs roles
in ppUnless (all suppress_if roles || null froles) $
ptext (sLit "type role") <+> tyCon <+> hsep (map ppr froles)
@@ -845,15 +858,19 @@ pprIfaceTyConParent IfNoParent
= Outputable.empty
pprIfaceTyConParent (IfDataInstance _ tc tys)
= sdocWithDynFlags $ \dflags ->
- let ftys = stripKindArgs dflags tys
+ let ftys = stripInvisArgs dflags tys
in pprIfaceTypeApp tc ftys
-pprIfaceDeclHead :: IfaceContext -> ShowSub -> OccName -> [IfaceTvBndr] -> SDoc
-pprIfaceDeclHead context ss tc_occ tv_bndrs
+pprIfaceDeclHead :: IfaceContext -> ShowSub -> OccName
+ -> IfaceType -- of the tycon, for invisible-suppression
+ -> [IfaceTvBndr] -> SDoc
+pprIfaceDeclHead context ss tc_occ kind tyvars
= sdocWithDynFlags $ \ dflags ->
sep [ pprIfaceContextArr context
, pprPrefixIfDeclBndr ss tc_occ
- <+> pprIfaceTvBndrs (stripIfaceKindVars dflags tv_bndrs) ]
+ <+> pprIfaceTvBndrs (suppressIfaceInvisibles dflags bndrs tyvars) ]
+ where
+ (bndrs, _, _) = splitIfaceSigmaTy kind
isVanillaIfaceConDecl :: IfaceConDecl -> Bool
isVanillaIfaceConDecl (IfCon { ifConExTvs = ex_tvs
@@ -881,7 +898,8 @@ pprIfaceConDecl ss gadt_style mk_user_con_res_ty fls
pp_prefix_con = pprPrefixIfDeclBndr ss name
(univ_tvs, pp_res_ty) = mk_user_con_res_ty eq_spec
- ppr_ty = pprIfaceForAllPart (univ_tvs ++ ex_tvs) ctxt pp_tau
+ ppr_ty = pprIfaceForAllPart (map tv_to_forall_bndr (univ_tvs ++ ex_tvs))
+ 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
@@ -944,6 +962,9 @@ ppr_rough :: Maybe IfaceTyCon -> SDoc
ppr_rough Nothing = dot
ppr_rough (Just tc) = ppr tc
+tv_to_forall_bndr :: IfaceTvBndr -> IfaceForAllBndr
+tv_to_forall_bndr tv = IfaceTv tv Invisible
+
{-
Note [Result type of a data family GADT]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1128,6 +1149,7 @@ freeNamesIfDecl (IfaceId _s t d i) =
freeNamesIfIdInfo i &&&
freeNamesIfIdDetails d
freeNamesIfDecl d@IfaceData{} =
+ freeNamesIfType (ifKind d) &&&
freeNamesIfTvBndrs (ifTyVars d) &&&
freeNamesIfaceTyConParent (ifParent d) &&&
freeNamesIfContext (ifCtxt d) &&&
@@ -1135,16 +1157,15 @@ freeNamesIfDecl d@IfaceData{} =
freeNamesIfDecl d@IfaceSynonym{} =
freeNamesIfTvBndrs (ifTyVars d) &&&
freeNamesIfType (ifSynRhs d) &&&
- freeNamesIfKind (ifSynKind d) -- IA0_NOTE: because of promotion, we
- -- return names in the kind signature
+ freeNamesIfKind (ifSynKind d)
freeNamesIfDecl d@IfaceFamily{} =
freeNamesIfTvBndrs (ifTyVars d) &&&
freeNamesIfFamFlav (ifFamFlav d) &&&
- freeNamesIfKind (ifFamKind d) -- IA0_NOTE: because of promotion, we
- -- return names in the kind signature
+ freeNamesIfKind (ifFamKind d)
freeNamesIfDecl d@IfaceClass{} =
freeNamesIfTvBndrs (ifTyVars d) &&&
freeNamesIfContext (ifCtxt d) &&&
+ freeNamesIfType (ifKind d) &&&
fnList freeNamesIfAT (ifATs d) &&&
fnList freeNamesIfClsSig (ifSigs d)
freeNamesIfDecl d@IfaceAxiom{} =
@@ -1162,10 +1183,12 @@ freeNamesIfDecl d@IfacePatSyn{} =
mkNameSet (map flSelector (ifFieldLabels d))
freeNamesIfAxBranch :: IfaceAxBranch -> NameSet
-freeNamesIfAxBranch (IfaceAxBranch { ifaxbTyVars = tyvars
- , ifaxbLHS = lhs
- , ifaxbRHS = rhs }) =
+freeNamesIfAxBranch (IfaceAxBranch { ifaxbTyVars = tyvars
+ , ifaxbCoVars = covars
+ , ifaxbLHS = lhs
+ , ifaxbRHS = rhs }) =
freeNamesIfTvBndrs tyvars &&&
+ fnList freeNamesIfIdBndr covars &&&
freeNamesIfTcArgs lhs &&&
freeNamesIfType rhs
@@ -1217,9 +1240,9 @@ freeNamesIfKind :: IfaceType -> NameSet
freeNamesIfKind = freeNamesIfType
freeNamesIfTcArgs :: IfaceTcArgs -> NameSet
-freeNamesIfTcArgs (ITC_Type t ts) = freeNamesIfType t &&& freeNamesIfTcArgs ts
-freeNamesIfTcArgs (ITC_Kind k ks) = freeNamesIfKind k &&& freeNamesIfTcArgs ks
-freeNamesIfTcArgs ITC_Nil = emptyNameSet
+freeNamesIfTcArgs (ITC_Vis t ts) = freeNamesIfType t &&& freeNamesIfTcArgs ts
+freeNamesIfTcArgs (ITC_Invis k ks) = freeNamesIfKind k &&& freeNamesIfTcArgs ks
+freeNamesIfTcArgs ITC_Nil = emptyNameSet
freeNamesIfType :: IfaceType -> NameSet
freeNamesIfType (IfaceTyVar _) = emptyNameSet
@@ -1227,9 +1250,12 @@ freeNamesIfType (IfaceAppTy s t) = freeNamesIfType s &&& freeNamesIfType t
freeNamesIfType (IfaceTyConApp tc ts) = freeNamesIfTc tc &&& freeNamesIfTcArgs ts
freeNamesIfType (IfaceTupleTy _ _ ts) = freeNamesIfTcArgs ts
freeNamesIfType (IfaceLitTy _) = emptyNameSet
-freeNamesIfType (IfaceForAllTy tv t) = freeNamesIfTvBndr tv &&& freeNamesIfType t
+freeNamesIfType (IfaceForAllTy tv t) =
+ freeNamesIfForAllBndr tv &&& freeNamesIfType t
freeNamesIfType (IfaceFunTy s t) = freeNamesIfType s &&& freeNamesIfType t
freeNamesIfType (IfaceDFunTy s t) = freeNamesIfType s &&& freeNamesIfType t
+freeNamesIfType (IfaceCastTy t c) = freeNamesIfType t &&& freeNamesIfCoercion c
+freeNamesIfType (IfaceCoercionTy c) = freeNamesIfCoercion c
freeNamesIfCoercion :: IfaceCoercion -> NameSet
freeNamesIfCoercion (IfaceReflCo _ t) = freeNamesIfType t
@@ -1239,14 +1265,14 @@ freeNamesIfCoercion (IfaceTyConAppCo _ tc cos)
= freeNamesIfTc tc &&& fnList freeNamesIfCoercion cos
freeNamesIfCoercion (IfaceAppCo c1 c2)
= freeNamesIfCoercion c1 &&& freeNamesIfCoercion c2
-freeNamesIfCoercion (IfaceForAllCo tv co)
- = freeNamesIfTvBndr tv &&& freeNamesIfCoercion co
+freeNamesIfCoercion (IfaceForAllCo _ kind_co co)
+ = freeNamesIfCoercion kind_co &&& freeNamesIfCoercion co
freeNamesIfCoercion (IfaceCoVarCo _)
= emptyNameSet
freeNamesIfCoercion (IfaceAxiomInstCo ax _ cos)
= unitNameSet ax &&& fnList freeNamesIfCoercion cos
-freeNamesIfCoercion (IfaceUnivCo _ _ t1 t2)
- = freeNamesIfType t1 &&& freeNamesIfType t2
+freeNamesIfCoercion (IfaceUnivCo p _ t1 t2)
+ = freeNamesIfProv p &&& freeNamesIfType t1 &&& freeNamesIfType t2
freeNamesIfCoercion (IfaceSymCo c)
= freeNamesIfCoercion c
freeNamesIfCoercion (IfaceTransCo c1 c2)
@@ -1255,22 +1281,37 @@ freeNamesIfCoercion (IfaceNthCo _ co)
= freeNamesIfCoercion co
freeNamesIfCoercion (IfaceLRCo _ co)
= freeNamesIfCoercion co
-freeNamesIfCoercion (IfaceInstCo co ty)
- = freeNamesIfCoercion co &&& freeNamesIfType ty
+freeNamesIfCoercion (IfaceInstCo co co2)
+ = freeNamesIfCoercion co &&& freeNamesIfCoercion co2
+freeNamesIfCoercion (IfaceCoherenceCo c1 c2)
+ = freeNamesIfCoercion c1 &&& freeNamesIfCoercion c2
+freeNamesIfCoercion (IfaceKindCo c)
+ = freeNamesIfCoercion c
freeNamesIfCoercion (IfaceSubCo co)
= freeNamesIfCoercion co
-freeNamesIfCoercion (IfaceAxiomRuleCo _ax tys cos)
+freeNamesIfCoercion (IfaceAxiomRuleCo _ax cos)
-- the axiom is just a string, so we don't count it as a name.
- = fnList freeNamesIfType tys &&&
- fnList freeNamesIfCoercion cos
+ = fnList freeNamesIfCoercion cos
+
+freeNamesIfProv :: IfaceUnivCoProv -> NameSet
+freeNamesIfProv IfaceUnsafeCoerceProv = emptyNameSet
+freeNamesIfProv (IfacePhantomProv co) = freeNamesIfCoercion co
+freeNamesIfProv (IfaceProofIrrelProv co) = freeNamesIfCoercion co
+freeNamesIfProv (IfacePluginProv _) = emptyNameSet
freeNamesIfTvBndrs :: [IfaceTvBndr] -> NameSet
freeNamesIfTvBndrs = fnList freeNamesIfTvBndr
+freeNamesIfForAllBndr :: IfaceForAllBndr -> NameSet
+freeNamesIfForAllBndr (IfaceTv tv _) = freeNamesIfTvBndr tv
+
freeNamesIfBndr :: IfaceBndr -> NameSet
freeNamesIfBndr (IfaceIdBndr b) = freeNamesIfIdBndr b
freeNamesIfBndr (IfaceTvBndr b) = freeNamesIfTvBndr b
+freeNamesIfBndrs :: [IfaceBndr] -> NameSet
+freeNamesIfBndrs = fnList freeNamesIfBndr
+
freeNamesIfLetBndr :: IfaceLetBndr -> NameSet
-- Remember IfaceLetBndr is used only for *nested* bindings
-- The IdInfo can contain an unfolding (in the case of
@@ -1283,7 +1324,7 @@ freeNamesIfTvBndr (_fs,k) = freeNamesIfKind k
-- kinds can have Names inside, because of promotion
freeNamesIfIdBndr :: IfaceIdBndr -> NameSet
-freeNamesIfIdBndr = freeNamesIfTvBndr
+freeNamesIfIdBndr (_fs,k) = freeNamesIfKind k
freeNamesIfIdInfo :: IfaceIdInfo -> NameSet
freeNamesIfIdInfo NoInfo = emptyNameSet
@@ -1297,7 +1338,7 @@ freeNamesIfUnfold :: IfaceUnfolding -> NameSet
freeNamesIfUnfold (IfCoreUnfold _ e) = freeNamesIfExpr e
freeNamesIfUnfold (IfCompulsory e) = freeNamesIfExpr e
freeNamesIfUnfold (IfInlineRule _ _ _ e) = freeNamesIfExpr e
-freeNamesIfUnfold (IfDFunUnfold bs es) = fnList freeNamesIfBndr bs &&& fnList freeNamesIfExpr es
+freeNamesIfUnfold (IfDFunUnfold bs es) = freeNamesIfBndrs bs &&& fnList freeNamesIfExpr es
freeNamesIfExpr :: IfaceExpr -> NameSet
freeNamesIfExpr (IfaceExt v) = unitNameSet v
@@ -1434,7 +1475,7 @@ instance Binary IfaceDecl where
put_ bh a5
put_ bh a6
- put_ bh (IfaceClass a1 a2 a3 a4 a5 a6 a7 a8 a9) = do
+ put_ bh (IfaceClass a1 a2 a3 a4 a5 a6 a7 a8 a9 a10) = do
putByte bh 5
put_ bh a1
put_ bh (occNameFS a2)
@@ -1445,6 +1486,7 @@ instance Binary IfaceDecl where
put_ bh a7
put_ bh a8
put_ bh a9
+ put_ bh a10
put_ bh (IfaceAxiom a1 a2 a3 a4) = do
putByte bh 6
@@ -1513,8 +1555,9 @@ instance Binary IfaceDecl where
a7 <- get bh
a8 <- get bh
a9 <- get bh
+ a10 <- get bh
occ <- return $! mkClsOccFS a2
- return (IfaceClass a1 occ a3 a4 a5 a6 a7 a8 a9)
+ return (IfaceClass a1 occ a3 a4 a5 a6 a7 a8 a9 a10)
6 -> do a1 <- get bh
a2 <- get bh
a3 <- get bh
@@ -1576,19 +1619,21 @@ instance Binary IfaceAT where
return (IfaceAT dec defs)
instance Binary IfaceAxBranch where
- put_ bh (IfaceAxBranch a1 a2 a3 a4 a5) = do
+ put_ bh (IfaceAxBranch a1 a2 a3 a4 a5 a6) = do
put_ bh a1
put_ bh a2
put_ bh a3
put_ bh a4
put_ bh a5
+ put_ bh a6
get bh = do
a1 <- get bh
a2 <- get bh
a3 <- get bh
a4 <- get bh
a5 <- get bh
- return (IfaceAxBranch a1 a2 a3 a4 a5)
+ a6 <- get bh
+ return (IfaceAxBranch a1 a2 a3 a4 a5 a6)
instance Binary IfaceConDecls where
put_ bh (IfAbstractTyCon d) = putByte bh 0 >> put_ bh d
diff --git a/compiler/iface/IfaceType.hs b/compiler/iface/IfaceType.hs
index 7bf949e24f..f744f812a7 100644
--- a/compiler/iface/IfaceType.hs
+++ b/compiler/iface/IfaceType.hs
@@ -13,19 +13,22 @@ module IfaceType (
IfExtName, IfLclName,
IfaceType(..), IfacePredType, IfaceKind, IfaceCoercion(..),
+ IfaceUnivCoProv(..),
IfaceTyCon(..), IfaceTyConInfo(..),
IfaceTyLit(..), IfaceTcArgs(..),
- IfaceContext, IfaceBndr(..), IfaceOneShot(..), IfaceLamBndr, IfaceTvBndr, IfaceIdBndr,
+ IfaceContext, IfaceBndr(..), IfaceOneShot(..), IfaceLamBndr,
+ IfaceTvBndr, IfaceIdBndr,
+ IfaceForAllBndr(..), VisibilityFlag(..),
-- Equality testing
IfRnEnv2, emptyIfRnEnv2, eqIfaceType, eqIfaceTypes,
- eqIfaceTcArgs, eqIfaceTvBndrs, eqIfaceCoercion,
+ eqIfaceTcArgs, eqIfaceTvBndrs,
-- Conversion from Type -> IfaceType
toIfaceType, toIfaceTypes, toIfaceKind, toIfaceTyVar,
toIfaceContext, toIfaceBndr, toIfaceIdBndr,
- toIfaceTvBndrs, toIfaceTyCon, toIfaceTyCon_name,
- toIfaceTcArgs,
+ toIfaceTyCon, toIfaceTyCon_name,
+ toIfaceTcArgs, toIfaceTvBndrs,
-- Conversion from IfaceTcArgs -> IfaceType
tcArgsIfaceTypes,
@@ -42,10 +45,11 @@ module IfaceType (
pprIfaceCoercion, pprParendIfaceCoercion,
splitIfaceSigmaTy, pprIfaceTypeApp, pprUserIfaceForAll,
- suppressIfaceKinds,
- stripIfaceKindVars,
- stripKindArgs,
- substIfaceType, substIfaceTyVar, substIfaceTcArgs, mkIfaceTySubst
+ suppressIfaceInvisibles,
+ stripIfaceInvisVars,
+ stripInvisArgs,
+ substIfaceType, substIfaceTyVar, substIfaceTcArgs, mkIfaceTySubst,
+ eqIfaceTvBndr
) where
#include "HsVersions.h"
@@ -54,7 +58,7 @@ import Coercion
import DataCon ( isTupleDataCon )
import TcType
import DynFlags
-import TypeRep
+import TyCoRep -- needs to convert core types to iface types
import Unique( hasKey )
import TyCon hiding ( pprPromotionQuote )
import CoAxiom
@@ -70,9 +74,10 @@ import Binary
import Outputable
import FastString
import UniqSet
+import VarEnv
+import Data.Maybe
import UniqFM
import Util
-import Data.Maybe( fromMaybe )
{-
************************************************************************
@@ -102,6 +107,14 @@ data IfaceOneShot -- See Note [Preserve OneShotInfo] in CoreTicy
type IfaceLamBndr
= (IfaceBndr, IfaceOneShot)
+{-
+%************************************************************************
+%* *
+ IfaceType
+%* *
+%************************************************************************
+-}
+
-------------------------------
type IfaceKind = IfaceType
@@ -111,11 +124,11 @@ data IfaceType -- A kind of universal type, used for types and kinds
| IfaceAppTy IfaceType IfaceType
| IfaceFunTy IfaceType IfaceType
| IfaceDFunTy IfaceType IfaceType
- | IfaceForAllTy IfaceTvBndr IfaceType
-
+ | IfaceForAllTy IfaceForAllBndr IfaceType
| IfaceTyConApp IfaceTyCon IfaceTcArgs -- Not necessarily saturated
- -- Includes newtypes, synonyms
-
+ -- Includes newtypes, synonyms, tuples
+ | IfaceCastTy IfaceType IfaceCoercion
+ | IfaceCoercionTy IfaceCoercion
| IfaceTupleTy -- Saturated tuples (unsaturated ones use IfaceTyConApp)
TupleSort IfaceTyConInfo -- A bit like IfaceTyCon
IfaceTcArgs -- arity = length args
@@ -129,15 +142,18 @@ data IfaceTyLit
| IfaceStrTyLit FastString
deriving (Eq)
--- See Note [Suppressing kinds]
+data IfaceForAllBndr
+ = IfaceTv IfaceTvBndr VisibilityFlag
+
+-- 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
-- files. Rather than two bytes and two decisions (nil/cons, and
-- type/kind) there'll just be one.
data IfaceTcArgs
= ITC_Nil
- | ITC_Type IfaceType IfaceTcArgs
- | ITC_Kind IfaceKind IfaceTcArgs
+ | ITC_Vis IfaceType IfaceTcArgs
+ | ITC_Invis IfaceKind IfaceTcArgs
-- Encodes type constructors, kind constructors,
-- coercion constructors, the lot.
@@ -151,69 +167,79 @@ data IfaceTyConInfo -- Used to guide pretty-printing
-- and to disambiguate D from 'D (they share a name)
= NoIfaceTyConInfo
| IfacePromotedDataCon
- | IfacePromotedTyCon
deriving (Eq)
data IfaceCoercion
- = IfaceReflCo Role IfaceType
- | IfaceFunCo Role IfaceCoercion IfaceCoercion
- | IfaceTyConAppCo Role IfaceTyCon [IfaceCoercion]
- | IfaceAppCo IfaceCoercion IfaceCoercion
- | IfaceForAllCo IfaceTvBndr IfaceCoercion
- | IfaceCoVarCo IfLclName
- | IfaceAxiomInstCo IfExtName BranchIndex [IfaceCoercion]
- | IfaceUnivCo FastString Role IfaceType IfaceType
- | IfaceSymCo IfaceCoercion
- | IfaceTransCo IfaceCoercion IfaceCoercion
- | IfaceNthCo Int IfaceCoercion
- | IfaceLRCo LeftOrRight IfaceCoercion
- | IfaceInstCo IfaceCoercion IfaceType
- | IfaceSubCo IfaceCoercion
- | IfaceAxiomRuleCo IfLclName [IfaceType] [IfaceCoercion]
+ = IfaceReflCo Role IfaceType
+ | IfaceFunCo Role IfaceCoercion IfaceCoercion
+ | IfaceTyConAppCo Role IfaceTyCon [IfaceCoercion]
+ | IfaceAppCo IfaceCoercion IfaceCoercion
+ | IfaceForAllCo IfaceTvBndr IfaceCoercion IfaceCoercion
+ | IfaceCoVarCo IfLclName
+ | IfaceAxiomInstCo IfExtName BranchIndex [IfaceCoercion]
+ | IfaceUnivCo IfaceUnivCoProv Role IfaceType IfaceType
+ | IfaceSymCo IfaceCoercion
+ | IfaceTransCo IfaceCoercion IfaceCoercion
+ | IfaceNthCo Int IfaceCoercion
+ | IfaceLRCo LeftOrRight IfaceCoercion
+ | IfaceInstCo IfaceCoercion IfaceCoercion
+ | IfaceCoherenceCo IfaceCoercion IfaceCoercion
+ | IfaceKindCo IfaceCoercion
+ | IfaceSubCo IfaceCoercion
+ | IfaceAxiomRuleCo IfLclName [IfaceCoercion]
+
+data IfaceUnivCoProv
+ = IfaceUnsafeCoerceProv
+ | IfacePhantomProv IfaceCoercion
+ | IfaceProofIrrelProv IfaceCoercion
+ | IfacePluginProv String
{-
-************************************************************************
-* *
+%************************************************************************
+%* *
Functions over IFaceTypes
* *
************************************************************************
-}
-splitIfaceSigmaTy :: IfaceType -> ([IfaceTvBndr], [IfacePredType], IfaceType)
+eqIfaceTvBndr :: IfaceTvBndr -> IfaceTvBndr -> Bool
+eqIfaceTvBndr (occ1, _) (occ2, _) = occ1 == occ2
+
+splitIfaceSigmaTy :: IfaceType -> ([IfaceForAllBndr], [IfacePredType], IfaceType)
-- Mainly for printing purposes
splitIfaceSigmaTy ty
- = (tvs, theta, tau)
+ = (bndrs, theta, tau)
where
- (tvs, rho) = split_foralls ty
+ (bndrs, rho) = split_foralls ty
(theta, tau) = split_rho rho
- split_foralls (IfaceForAllTy tv ty)
- = case split_foralls ty of { (tvs, rho) -> (tv:tvs, rho) }
+ split_foralls (IfaceForAllTy bndr ty)
+ = case split_foralls ty of { (bndrs, rho) -> (bndr:bndrs, rho) }
split_foralls rho = ([], rho)
split_rho (IfaceDFunTy ty1 ty2)
= case split_rho ty2 of { (ps, tau) -> (ty1:ps, tau) }
split_rho tau = ([], tau)
-suppressIfaceKinds :: DynFlags -> [IfaceTvBndr] -> [a] -> [a]
-suppressIfaceKinds dflags tys xs
+suppressIfaceInvisibles :: DynFlags -> [IfaceForAllBndr] -> [a] -> [a]
+suppressIfaceInvisibles dflags tys xs
| gopt Opt_PrintExplicitKinds dflags = xs
| otherwise = suppress tys xs
where
suppress _ [] = []
suppress [] a = a
suppress (k:ks) a@(_:xs)
- | isIfaceKindVar k = suppress ks xs
- | otherwise = a
+ | isIfaceInvisBndr k = suppress ks xs
+ | otherwise = a
-stripIfaceKindVars :: DynFlags -> [IfaceTvBndr] -> [IfaceTvBndr]
-stripIfaceKindVars dflags tyvars
+stripIfaceInvisVars :: DynFlags -> [IfaceForAllBndr] -> [IfaceForAllBndr]
+stripIfaceInvisVars dflags tyvars
| gopt Opt_PrintExplicitKinds dflags = tyvars
- | otherwise = filterOut isIfaceKindVar tyvars
+ | otherwise = filterOut isIfaceInvisBndr tyvars
-isIfaceKindVar :: IfaceTvBndr -> Bool
-isIfaceKindVar (_, IfaceTyConApp tc _) = ifaceTyConName tc == superKindTyConName
-isIfaceKindVar _ = False
+isIfaceInvisBndr :: IfaceForAllBndr -> Bool
+isIfaceInvisBndr (IfaceTv _ Visible) = False
+isIfaceInvisBndr _ = True
ifTyVarsOfType :: IfaceType -> UniqSet IfLclName
ifTyVarsOfType ty
@@ -225,19 +251,62 @@ ifTyVarsOfType ty
-> ifTyVarsOfType arg `unionUniqSets` ifTyVarsOfType res
IfaceDFunTy arg res
-> ifTyVarsOfType arg `unionUniqSets` ifTyVarsOfType res
- IfaceForAllTy (var,t) ty
- -> delOneFromUniqSet (ifTyVarsOfType ty) var `unionUniqSets`
- ifTyVarsOfType t
- IfaceTyConApp _ args -> ifTyVarsOfArgs args
+ IfaceForAllTy bndr ty
+ -> let (free, bound) = ifTyVarsOfForAllBndr bndr in
+ delListFromUniqSet (ifTyVarsOfType ty) bound `unionUniqSets` free
+ IfaceTyConApp _ args -> ifTyVarsOfArgs args
+ IfaceLitTy _ -> emptyUniqSet
+ IfaceCastTy ty co
+ -> ifTyVarsOfType ty `unionUniqSets` ifTyVarsOfCoercion co
+ IfaceCoercionTy co -> ifTyVarsOfCoercion co
IfaceTupleTy _ _ args -> ifTyVarsOfArgs args
- IfaceLitTy _ -> emptyUniqSet
+
+ifTyVarsOfForAllBndr :: IfaceForAllBndr
+ -> ( UniqSet IfLclName -- names used free in the binder
+ , [IfLclName] ) -- names bound by this binder
+ifTyVarsOfForAllBndr (IfaceTv (name, kind) _) = (ifTyVarsOfType kind, [name])
ifTyVarsOfArgs :: IfaceTcArgs -> UniqSet IfLclName
ifTyVarsOfArgs args = argv emptyUniqSet args
where
- argv vs (ITC_Type t ts) = argv (vs `unionUniqSets` (ifTyVarsOfType t)) ts
- argv vs (ITC_Kind k ks) = argv (vs `unionUniqSets` (ifTyVarsOfType k)) ks
- argv vs ITC_Nil = vs
+ argv vs (ITC_Vis t ts) = argv (vs `unionUniqSets` (ifTyVarsOfType t)) ts
+ argv vs (ITC_Invis k ks) = argv (vs `unionUniqSets` (ifTyVarsOfType k)) ks
+ argv vs ITC_Nil = vs
+
+ifTyVarsOfCoercion :: IfaceCoercion -> UniqSet IfLclName
+ifTyVarsOfCoercion = go
+ where
+ go (IfaceReflCo _ ty) = ifTyVarsOfType ty
+ go (IfaceFunCo _ c1 c2) = go c1 `unionUniqSets` go c2
+ go (IfaceTyConAppCo _ _ cos) = ifTyVarsOfCoercions cos
+ go (IfaceAppCo c1 c2) = go c1 `unionUniqSets` go c2
+ go (IfaceForAllCo (bound, _) kind_co co)
+ = go co `delOneFromUniqSet` bound `unionUniqSets` go kind_co
+ go (IfaceCoVarCo cv) = unitUniqSet cv
+ go (IfaceAxiomInstCo _ _ cos) = ifTyVarsOfCoercions cos
+ go (IfaceUnivCo p _ ty1 ty2) = go_prov p `unionUniqSets`
+ ifTyVarsOfType ty1 `unionUniqSets`
+ ifTyVarsOfType ty2
+ go (IfaceSymCo co) = go co
+ go (IfaceTransCo c1 c2) = go c1 `unionUniqSets` go c2
+ go (IfaceNthCo _ co) = go co
+ go (IfaceLRCo _ co) = go co
+ go (IfaceInstCo c1 c2) = go c1 `unionUniqSets` go c2
+ go (IfaceCoherenceCo c1 c2) = go c1 `unionUniqSets` go c2
+ go (IfaceKindCo co) = go co
+ go (IfaceSubCo co) = go co
+ go (IfaceAxiomRuleCo rule cos)
+ = unionManyUniqSets
+ [ unitUniqSet rule
+ , ifTyVarsOfCoercions cos ]
+
+ go_prov IfaceUnsafeCoerceProv = emptyUniqSet
+ go_prov (IfacePhantomProv co) = go co
+ go_prov (IfaceProofIrrelProv co) = go co
+ go_prov (IfacePluginProv _) = emptyUniqSet
+
+ifTyVarsOfCoercions :: [IfaceCoercion] -> UniqSet IfLclName
+ifTyVarsOfCoercions = foldr (unionUniqSets . ifTyVarsOfCoercion) emptyUniqSet
{-
Substitutions on IfaceType. This is only used during pretty-printing to construct
@@ -262,14 +331,41 @@ substIfaceType env ty
go (IfaceTyConApp tc tys) = IfaceTyConApp tc (substIfaceTcArgs env tys)
go (IfaceTupleTy s i tys) = IfaceTupleTy s i (substIfaceTcArgs env tys)
go (IfaceForAllTy {}) = pprPanic "substIfaceType" (ppr ty)
+ go (IfaceCastTy ty co) = IfaceCastTy (go ty) (go_co co)
+ go (IfaceCoercionTy co) = IfaceCoercionTy (go_co co)
+
+ go_co (IfaceReflCo r ty) = IfaceReflCo r (go ty)
+ go_co (IfaceFunCo r c1 c2) = IfaceFunCo r (go_co c1) (go_co c2)
+ go_co (IfaceTyConAppCo r tc cos) = IfaceTyConAppCo r tc (go_cos cos)
+ go_co (IfaceAppCo c1 c2) = IfaceAppCo (go_co c1) (go_co c2)
+ go_co (IfaceForAllCo {}) = pprPanic "substIfaceCoercion" (ppr ty)
+ go_co (IfaceCoVarCo cv) = IfaceCoVarCo cv
+ go_co (IfaceAxiomInstCo a i cos) = IfaceAxiomInstCo a i (go_cos cos)
+ go_co (IfaceUnivCo prov r t1 t2) = IfaceUnivCo (go_prov prov) r (go t1) (go t2)
+ go_co (IfaceSymCo co) = IfaceSymCo (go_co co)
+ go_co (IfaceTransCo co1 co2) = IfaceTransCo (go_co co1) (go_co co2)
+ go_co (IfaceNthCo n co) = IfaceNthCo n (go_co co)
+ go_co (IfaceLRCo lr co) = IfaceLRCo lr (go_co co)
+ go_co (IfaceInstCo c1 c2) = IfaceInstCo (go_co c1) (go_co c2)
+ go_co (IfaceCoherenceCo c1 c2) = IfaceCoherenceCo (go_co c1) (go_co c2)
+ go_co (IfaceKindCo co) = IfaceKindCo (go_co co)
+ go_co (IfaceSubCo co) = IfaceSubCo (go_co co)
+ go_co (IfaceAxiomRuleCo n cos) = IfaceAxiomRuleCo n (go_cos cos)
+
+ go_cos = map go_co
+
+ go_prov IfaceUnsafeCoerceProv = IfaceUnsafeCoerceProv
+ go_prov (IfacePhantomProv co) = IfacePhantomProv (go_co co)
+ go_prov (IfaceProofIrrelProv co) = IfaceProofIrrelProv (go_co co)
+ go_prov (IfacePluginProv str) = IfacePluginProv str
substIfaceTcArgs :: IfaceTySubst -> IfaceTcArgs -> IfaceTcArgs
substIfaceTcArgs env args
= go args
where
- go ITC_Nil = ITC_Nil
- go (ITC_Type ty tys) = ITC_Type (substIfaceType env ty) (go tys)
- go (ITC_Kind ty tys) = ITC_Kind (substIfaceType env ty) (go tys)
+ go ITC_Nil = ITC_Nil
+ go (ITC_Vis ty tys) = ITC_Vis (substIfaceType env ty) (go tys)
+ go (ITC_Invis ty tys) = ITC_Invis (substIfaceType env ty) (go tys)
substIfaceTyVar :: IfaceTySubst -> IfLclName -> IfaceType
substIfaceTyVar env tv
@@ -282,6 +378,14 @@ substIfaceTyVar env tv
Equality over IfaceTypes
* *
************************************************************************
+
+Note [No kind check in ifaces]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We check iface types for equality only when checking the consistency
+between two user-written signatures. In these cases, there is no possibility
+for a kind mismatch. So we omit the kind check (which would be impossible to
+write, anyway.)
+
-}
-- Like an RnEnv2, but mapping from FastString to deBruijn index
@@ -313,6 +417,7 @@ extendIfRnEnv2 IRV2 { ifenvL = lenv
, ifenv_next = n + 1
}
+-- See Note [No kind check in ifaces]
eqIfaceType :: IfRnEnv2 -> IfaceType -> IfaceType -> Bool
eqIfaceType env (IfaceTyVar tv1) (IfaceTyVar tv2) =
case (rnIfOccL env tv1, rnIfOccR env tv2) of
@@ -326,22 +431,33 @@ eqIfaceType env (IfaceFunTy t11 t12) (IfaceFunTy t21 t22)
= eqIfaceType env t11 t21 && eqIfaceType env t12 t22
eqIfaceType env (IfaceDFunTy t11 t12) (IfaceDFunTy t21 t22)
= eqIfaceType env t11 t21 && eqIfaceType env t12 t22
-eqIfaceType env (IfaceForAllTy (tv1, k1) t1) (IfaceForAllTy (tv2, k2) t2)
- = eqIfaceType env k1 k2 && eqIfaceType (extendIfRnEnv2 env tv1 tv2) t1 t2
+eqIfaceType env (IfaceForAllTy bndr1 t1) (IfaceForAllTy bndr2 t2)
+ = eqIfaceForAllBndr env bndr1 bndr2 (\env' -> eqIfaceType env' t1 t2)
eqIfaceType env (IfaceTyConApp tc1 tys1) (IfaceTyConApp tc2 tys2)
= tc1 == tc2 && eqIfaceTcArgs env tys1 tys2
eqIfaceType env (IfaceTupleTy s1 tc1 tys1) (IfaceTupleTy s2 tc2 tys2)
= s1 == s2 && tc1 == tc2 && eqIfaceTcArgs env tys1 tys2
+eqIfaceType env (IfaceCastTy t1 _) (IfaceCastTy t2 _)
+ = eqIfaceType env t1 t2
+eqIfaceType _ (IfaceCoercionTy {}) (IfaceCoercionTy {})
+ = True
eqIfaceType _ _ _ = False
eqIfaceTypes :: IfRnEnv2 -> [IfaceType] -> [IfaceType] -> Bool
eqIfaceTypes env tys1 tys2 = and (zipWith (eqIfaceType env) tys1 tys2)
+eqIfaceForAllBndr :: IfRnEnv2 -> IfaceForAllBndr -> IfaceForAllBndr
+ -> (IfRnEnv2 -> Bool) -- continuation
+ -> Bool
+eqIfaceForAllBndr env (IfaceTv (tv1, k1) vis1) (IfaceTv (tv2, k2) vis2) k
+ = eqIfaceType env k1 k2 && vis1 == vis2 &&
+ k (extendIfRnEnv2 env tv1 tv2)
+
eqIfaceTcArgs :: IfRnEnv2 -> IfaceTcArgs -> IfaceTcArgs -> Bool
eqIfaceTcArgs _ ITC_Nil ITC_Nil = True
-eqIfaceTcArgs env (ITC_Type ty1 tys1) (ITC_Type ty2 tys2)
+eqIfaceTcArgs env (ITC_Vis ty1 tys1) (ITC_Vis ty2 tys2)
= eqIfaceType env ty1 ty2 && eqIfaceTcArgs env tys1 tys2
-eqIfaceTcArgs env (ITC_Kind ty1 tys1) (ITC_Kind ty2 tys2)
+eqIfaceTcArgs env (ITC_Invis ty1 tys1) (ITC_Invis ty2 tys2)
= eqIfaceType env ty1 ty2 && eqIfaceTcArgs env tys1 tys2
eqIfaceTcArgs _ _ _ = False
@@ -355,57 +471,6 @@ eqIfaceTvBndrs env ((tv1, k1):tvs1) ((tv2, k2):tvs2)
= eqIfaceTvBndrs (extendIfRnEnv2 env tv1 tv2) tvs1 tvs2
eqIfaceTvBndrs _ _ _ = Nothing
--- coreEqCoercion2
-eqIfaceCoercion :: IfRnEnv2 -> IfaceCoercion -> IfaceCoercion -> Bool
-eqIfaceCoercion env (IfaceReflCo eq1 ty1) (IfaceReflCo eq2 ty2)
- = eq1 == eq2 && eqIfaceType env ty1 ty2
-eqIfaceCoercion env (IfaceFunCo eq1 co11 co12) (IfaceFunCo eq2 co21 co22)
- = eq1 == eq2 && eqIfaceCoercion env co11 co21
- && eqIfaceCoercion env co12 co22
-eqIfaceCoercion env (IfaceTyConAppCo eq1 tc1 cos1) (IfaceTyConAppCo eq2 tc2 cos2)
- = eq1 == eq2 && tc1 == tc2 && all2 (eqIfaceCoercion env) cos1 cos2
-eqIfaceCoercion env (IfaceAppCo co11 co12) (IfaceAppCo co21 co22)
- = eqIfaceCoercion env co11 co21 && eqIfaceCoercion env co12 co22
-
-eqIfaceCoercion env (IfaceForAllCo (v1,k1) co1) (IfaceForAllCo (v2,k2) co2)
- = eqIfaceType env k1 k2 &&
- eqIfaceCoercion (extendIfRnEnv2 env v1 v2) co1 co2
-
-eqIfaceCoercion env (IfaceCoVarCo cv1) (IfaceCoVarCo cv2)
- = rnIfOccL env cv1 == rnIfOccR env cv2
-
-eqIfaceCoercion env (IfaceAxiomInstCo con1 ind1 cos1)
- (IfaceAxiomInstCo con2 ind2 cos2)
- = con1 == con2
- && ind1 == ind2
- && all2 (eqIfaceCoercion env) cos1 cos2
-
--- the provenance string is just a note, so don't use in comparisons
-eqIfaceCoercion env (IfaceUnivCo _ r1 ty11 ty12) (IfaceUnivCo _ r2 ty21 ty22)
- = r1 == r2 && eqIfaceType env ty11 ty21 && eqIfaceType env ty12 ty22
-
-eqIfaceCoercion env (IfaceSymCo co1) (IfaceSymCo co2)
- = eqIfaceCoercion env co1 co2
-
-eqIfaceCoercion env (IfaceTransCo co11 co12) (IfaceTransCo co21 co22)
- = eqIfaceCoercion env co11 co21 && eqIfaceCoercion env co12 co22
-
-eqIfaceCoercion env (IfaceNthCo d1 co1) (IfaceNthCo d2 co2)
- = d1 == d2 && eqIfaceCoercion env co1 co2
-eqIfaceCoercion env (IfaceLRCo d1 co1) (IfaceLRCo d2 co2)
- = d1 == d2 && eqIfaceCoercion env co1 co2
-
-eqIfaceCoercion env (IfaceInstCo co1 ty1) (IfaceInstCo co2 ty2)
- = eqIfaceCoercion env co1 co2 && eqIfaceType env ty1 ty2
-
-eqIfaceCoercion env (IfaceSubCo co1) (IfaceSubCo co2)
- = eqIfaceCoercion env co1 co2
-
-eqIfaceCoercion env (IfaceAxiomRuleCo a1 ts1 cs1) (IfaceAxiomRuleCo a2 ts2 cs2)
- = a1 == a2 && all2 (eqIfaceType env) ts1 ts2 && all2 (eqIfaceCoercion env) cs1 cs2
-
-eqIfaceCoercion _ _ _ = False
-
{-
************************************************************************
* *
@@ -414,39 +479,52 @@ eqIfaceCoercion _ _ _ = False
************************************************************************
-}
-stripKindArgs :: DynFlags -> IfaceTcArgs -> IfaceTcArgs
-stripKindArgs dflags tys
+stripInvisArgs :: DynFlags -> IfaceTcArgs -> IfaceTcArgs
+stripInvisArgs dflags tys
| gopt Opt_PrintExplicitKinds dflags = tys
- | otherwise = suppressKinds tys
+ | otherwise = suppress_invis tys
where
- suppressKinds c
+ suppress_invis c
= case c of
- ITC_Kind _ ts -> suppressKinds ts
+ ITC_Invis _ ts -> suppress_invis ts
_ -> c
toIfaceTcArgs :: TyCon -> [Type] -> IfaceTcArgs
--- See Note [Suppressing kinds]
+-- See Note [Suppressing invisible arguments]
toIfaceTcArgs tc ty_args
- = go (tyConKind tc) ty_args
+ = go (mkEmptyTCvSubst in_scope) (tyConKind tc) ty_args
where
- go _ [] = ITC_Nil
- go (ForAllTy _ res) (t:ts) = ITC_Kind (toIfaceKind t) (go res ts)
- go (FunTy _ res) (t:ts) = ITC_Type (toIfaceType t) (go res ts)
- go kind (t:ts) = WARN( True, ppr tc $$ ppr (tyConKind tc) $$ ppr ty_args )
- ITC_Type (toIfaceType t) (go kind ts) -- Ill-kinded
+ in_scope = mkInScopeSet (tyCoVarsOfTypes ty_args)
+
+ go _ _ [] = ITC_Nil
+ go env ty ts
+ | Just ty' <- coreView ty
+ = go env ty' ts
+ go env (ForAllTy bndr res) (t:ts)
+ | isVisibleBinder bndr = ITC_Vis t' ts'
+ | otherwise = ITC_Invis t' ts'
+ where
+ t' = toIfaceType t
+ ts' = go (extendTCvSubstBinder env bndr t) res ts
+
+ go env (TyVarTy tv) ts
+ | Just ki <- lookupTyVar env tv = go env ki ts
+ go env kind (t:ts) = WARN( True, ppr tc $$ ppr (tyConKind tc) $$ ppr ty_args )
+ ITC_Vis (toIfaceType t) (go env kind ts) -- Ill-kinded
tcArgsIfaceTypes :: IfaceTcArgs -> [IfaceType]
tcArgsIfaceTypes ITC_Nil = []
-tcArgsIfaceTypes (ITC_Kind t ts) = t : tcArgsIfaceTypes ts
-tcArgsIfaceTypes (ITC_Type t ts) = t : tcArgsIfaceTypes ts
+tcArgsIfaceTypes (ITC_Invis t ts) = t : tcArgsIfaceTypes ts
+tcArgsIfaceTypes (ITC_Vis t ts) = t : tcArgsIfaceTypes ts
{-
-Note [Suppressing kinds]
-~~~~~~~~~~~~~~~~~~~~~~~~
+Note [Suppressing invisible arguments]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We use the IfaceTcArgs to specify which of the arguments to a type
-constructor instantiate a for-all, and which are regular kind args.
-This in turn used to control kind-suppression when printing types,
-under the control of -fprint-explicit-kinds. See also TypeRep.suppressKinds.
+constructor should be visible.
+This in turn used to control suppression when printing types,
+under the control of -fprint-explicit-kinds.
+See also Type.filterOutInvisibleTypes.
For example, given
T :: forall k. (k->*) -> k -> * -- Ordinary kind polymorphism
'Just :: forall k. k -> 'Maybe k -- Promoted
@@ -491,7 +569,11 @@ pprIfaceIdBndr (name, ty) = hsep [ppr name, dcolon, ppr ty]
pprIfaceTvBndr :: IfaceTvBndr -> SDoc
pprIfaceTvBndr (tv, IfaceTyConApp tc ITC_Nil)
- | ifaceTyConName tc == liftedTypeKindTyConName = ppr tv
+ | 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)
pprIfaceTvBndrs :: [IfaceTvBndr] -> SDoc
@@ -553,6 +635,13 @@ ppr_ty ctxt_prec (IfaceAppTy ty1 ty2)
= maybeParen ctxt_prec TyConPrec $
ppr_ty FunPrec ty1 <+> pprParendIfaceType ty2
+ppr_ty ctxt_prec (IfaceCastTy ty co)
+ = maybeParen ctxt_prec FunPrec $
+ sep [ppr_ty FunPrec ty, ptext (sLit "`cast`"), ppr_co FunPrec co]
+
+ppr_ty ctxt_prec (IfaceCoercionTy co)
+ = ppr_co ctxt_prec co
+
ppr_ty ctxt_prec ty
= maybeParen ctxt_prec FunPrec (ppr_iface_sigma_type True ty)
@@ -567,9 +656,9 @@ ppr_tc_args :: TyPrec -> IfaceTcArgs -> SDoc
ppr_tc_args ctx_prec args
= let pprTys t ts = ppr_ty ctx_prec t <+> ppr_tc_args ctx_prec ts
in case args of
- ITC_Nil -> empty
- ITC_Type t ts -> pprTys t ts
- ITC_Kind t ts -> pprTys t ts
+ ITC_Nil -> empty
+ ITC_Vis t ts -> pprTys t ts
+ ITC_Invis t ts -> pprTys t ts
-------------------
ppr_iface_sigma_type :: Bool -> IfaceType -> SDoc
@@ -578,11 +667,19 @@ ppr_iface_sigma_type show_foralls_unconditionally ty
where
(tvs, theta, tau) = splitIfaceSigmaTy ty
-pprIfaceForAllPart :: Outputable a => [IfaceTvBndr] -> [a] -> SDoc -> SDoc
+-------------------
+instance Outputable IfaceForAllBndr where
+ ppr = pprIfaceForAllBndr
+
+pprIfaceForAllPart :: [IfaceForAllBndr] -> [IfaceType] -> SDoc -> SDoc
pprIfaceForAllPart tvs ctxt sdoc = ppr_iface_forall_part False tvs ctxt sdoc
+pprIfaceForAllCoPart :: [(IfLclName, IfaceCoercion)] -> SDoc -> SDoc
+pprIfaceForAllCoPart tvs sdoc = sep [ pprIfaceForAllCo tvs
+ , sdoc ]
+
ppr_iface_forall_part :: Outputable a
- => Bool -> [IfaceTvBndr] -> [a] -> SDoc -> SDoc
+ => Bool -> [IfaceForAllBndr] -> [a] -> SDoc -> SDoc
ppr_iface_forall_part show_foralls_unconditionally tvs ctxt sdoc
= sep [ if show_foralls_unconditionally
then pprIfaceForAll tvs
@@ -590,23 +687,59 @@ ppr_iface_forall_part show_foralls_unconditionally tvs ctxt sdoc
, pprIfaceContextArr ctxt
, sdoc]
-pprIfaceForAll :: [IfaceTvBndr] -> SDoc
-pprIfaceForAll [] = empty
-pprIfaceForAll tvs = ptext (sLit "forall") <+> pprIfaceTvBndrs tvs <> dot
+-- | Render the "forall ... ." or "forall ... ->" bit of a type.
+pprIfaceForAll :: [IfaceForAllBndr] -> SDoc
+pprIfaceForAll [] = empty
+pprIfaceForAll bndrs@(IfaceTv _ vis : _)
+ = add_separator (text "forall" <+> doc) <+> pprIfaceForAll bndrs'
+ where
+ (bndrs', doc) = ppr_itv_bndrs bndrs vis
+
+ add_separator stuff = case vis of
+ Invisible -> stuff <> dot
+ Visible -> stuff <+> arrow
+
+-- | Render the ... in @(forall ... .)@ or @(forall ... ->)@.
+-- Returns both the list of not-yet-rendered binders and the doc.
+-- No anonymous binders here!
+ppr_itv_bndrs :: [IfaceForAllBndr]
+ -> VisibilityFlag -- ^ visibility of the first binder in the list
+ -> ([IfaceForAllBndr], SDoc)
+ppr_itv_bndrs all_bndrs@(IfaceTv tv vis : bndrs) vis1
+ | vis == vis1 = let (bndrs', doc) = ppr_itv_bndrs bndrs vis1 in
+ (bndrs', pprIfaceTvBndr tv <+> doc)
+ | otherwise = (all_bndrs, empty)
+ppr_itv_bndrs [] _ = ([], empty)
+
+pprIfaceForAllCo :: [(IfLclName, IfaceCoercion)] -> SDoc
+pprIfaceForAllCo [] = empty
+pprIfaceForAllCo tvs = text "forall" <+> pprIfaceForAllCoBndrs tvs <> dot
+
+pprIfaceForAllCoBndrs :: [(IfLclName, IfaceCoercion)] -> SDoc
+pprIfaceForAllCoBndrs bndrs = hsep $ map pprIfaceForAllCoBndr bndrs
+
+pprIfaceForAllBndr :: IfaceForAllBndr -> SDoc
+pprIfaceForAllBndr (IfaceTv tv _) = pprIfaceTvBndr tv
+
+pprIfaceForAllCoBndr :: (IfLclName, IfaceCoercion) -> SDoc
+pprIfaceForAllCoBndr (tv, kind_co)
+ = parens (ppr tv <+> dcolon <+> pprIfaceCoercion kind_co)
pprIfaceSigmaType :: IfaceType -> SDoc
pprIfaceSigmaType ty = ppr_iface_sigma_type False ty
-pprUserIfaceForAll :: [IfaceTvBndr] -> SDoc
+pprUserIfaceForAll :: [IfaceForAllBndr] -> SDoc
pprUserIfaceForAll tvs
= sdocWithDynFlags $ \dflags ->
ppWhen (any tv_has_kind_var tvs || gopt Opt_PrintExplicitForalls dflags) $
pprIfaceForAll tvs
where
- tv_has_kind_var (_,t) = not (isEmptyUniqSet (ifTyVarsOfType t))
+ tv_has_kind_var bndr
+ = not (isEmptyUniqSet (fst (ifTyVarsOfForAllBndr bndr)))
+
-------------------
--- See equivalent function in TypeRep.hs
+-- See equivalent function in TyCoRep.hs
pprIfaceTyList :: TyPrec -> IfaceType -> IfaceType -> SDoc
-- Given a type-level list (t1 ': t2), see if we can print
-- it in list notation [t1, ...].
@@ -625,7 +758,7 @@ pprIfaceTyList ctxt_prec ty1 ty2
-- = (tys, Just tl) means ty is of form t1:t2:...tn:tl
gather (IfaceTyConApp tc tys)
| tcname == consDataConName
- , (ITC_Kind _ (ITC_Type ty1 (ITC_Type ty2 ITC_Nil))) <- tys
+ , (ITC_Invis _ (ITC_Vis ty1 (ITC_Vis ty2 ITC_Nil))) <- tys
, (args, tl) <- gather ty2
= (ty1:args, tl)
| tcname == nilDataConName
@@ -639,18 +772,25 @@ pprIfaceTypeApp tc args = sdocWithDynFlags (pprTyTcApp TopPrec tc args)
pprTyTcApp :: TyPrec -> IfaceTyCon -> IfaceTcArgs -> DynFlags -> SDoc
pprTyTcApp ctxt_prec tc tys dflags
| ifaceTyConName tc == getName ipTyCon
- , ITC_Type (IfaceLitTy (IfaceStrTyLit n)) (ITC_Type ty ITC_Nil) <- tys
+ , ITC_Vis (IfaceLitTy (IfaceStrTyLit n)) (ITC_Vis ty ITC_Nil) <- tys
= char '?' <> ftext n <> ptext (sLit "::") <> ppr_ty TopPrec ty
| ifaceTyConName tc == consDataConName
, not (gopt Opt_PrintExplicitKinds dflags)
- , ITC_Kind _ (ITC_Type ty1 (ITC_Type ty2 ITC_Nil)) <- tys
+ , ITC_Invis _ (ITC_Vis ty1 (ITC_Vis ty2 ITC_Nil)) <- tys
= 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)
+
| otherwise
= ppr_iface_tc_app ppr_ty ctxt_prec tc tys_wo_kinds
where
- tys_wo_kinds = tcArgsIfaceTypes $ stripKindArgs dflags tys
+ tys_wo_kinds = tcArgsIfaceTypes $ stripInvisArgs dflags tys
pprIfaceCoTcApp :: TyPrec -> IfaceTyCon -> [IfaceCoercion] -> SDoc
pprIfaceCoTcApp ctxt_prec tc tys = ppr_iface_tc_app ppr_co ctxt_prec tc tys
@@ -670,7 +810,8 @@ ppr_iface_tc_app pp ctxt_prec tc tys
-- we know nothing of precedence though
= pprIfaceInfixApp pp ctxt_prec (ppr tc) ty1 ty2
- | tc_name == liftedTypeKindTyConName || tc_name == unliftedTypeKindTyConName
+ | tc_name == starKindTyConName || tc_name == unliftedTypeKindTyConName
+ || tc_name == unicodeStarKindTyConName
= ppr tc -- Do not wrap *, # in parens
| otherwise
@@ -680,8 +821,15 @@ ppr_iface_tc_app pp ctxt_prec tc tys
pprTuple :: TupleSort -> IfaceTyConInfo -> IfaceTcArgs -> SDoc
pprTuple sort info args
- = pprPromotionQuoteI info <>
- tupleParens sort (pprWithCommas pprIfaceType (tcArgsIfaceTypes args))
+ = -- drop the levity vars.
+ -- See Note [Unboxed tuple levity vars] in TyCon
+ let tys = tcArgsIfaceTypes args
+ args' = case sort of
+ UnboxedTuple -> drop (length tys `div` 2) tys
+ _ -> tys
+ in
+ pprPromotionQuoteI info <>
+ tupleParens sort (pprWithCommas pprIfaceType args')
ppr_tylit :: IfaceTyLit -> SDoc
ppr_tylit (IfaceNumTyLit n) = integer n
@@ -707,30 +855,32 @@ ppr_co _ (IfaceTyConAppCo r tc cos)
ppr_co ctxt_prec (IfaceAppCo co1 co2)
= maybeParen ctxt_prec TyConPrec $
ppr_co FunPrec co1 <+> pprParendIfaceCoercion co2
-ppr_co ctxt_prec co@(IfaceForAllCo _ _)
- = maybeParen ctxt_prec FunPrec (sep [ppr_tvs, pprIfaceCoercion inner_co])
+ppr_co ctxt_prec co@(IfaceForAllCo {})
+ = maybeParen ctxt_prec FunPrec (pprIfaceForAllCoPart tvs (pprIfaceCoercion inner_co))
where
(tvs, inner_co) = split_co co
- ppr_tvs = ptext (sLit "forall") <+> pprIfaceTvBndrs tvs <> dot
- split_co (IfaceForAllCo tv co')
- = let (tvs, co'') = split_co co' in (tv:tvs,co'')
+ split_co (IfaceForAllCo (name, _) kind_co co')
+ = let (tvs, co'') = split_co co' in ((name,kind_co):tvs,co'')
split_co co' = ([], co')
ppr_co _ (IfaceCoVarCo covar) = ppr covar
-ppr_co ctxt_prec (IfaceUnivCo s r ty1 ty2)
+ppr_co ctxt_prec (IfaceUnivCo IfaceUnsafeCoerceProv r ty1 ty2)
= maybeParen ctxt_prec TyConPrec $
- ptext (sLit "UnivCo") <+> ftext s <+> ppr r <+>
+ ptext (sLit "UnsafeCo") <+> ppr r <+>
pprParendIfaceType ty1 <+> pprParendIfaceType ty2
+ppr_co _ (IfaceUnivCo _ _ ty1 ty2)
+ = angleBrackets ( ppr ty1 <> comma <+> ppr ty2 )
+
ppr_co ctxt_prec (IfaceInstCo co ty)
= maybeParen ctxt_prec TyConPrec $
- ptext (sLit "Inst") <+> pprParendIfaceCoercion co <+> pprParendIfaceType ty
+ ptext (sLit "Inst") <+> pprParendIfaceCoercion co
+ <+> pprParendIfaceCoercion ty
-ppr_co ctxt_prec (IfaceAxiomRuleCo tc tys cos)
- = maybeParen ctxt_prec TyConPrec
- (sep [ppr tc, nest 4 (sep (map pprParendIfaceType tys ++ map pprParendIfaceCoercion cos))])
+ppr_co ctxt_prec (IfaceAxiomRuleCo tc cos)
+ = maybeParen ctxt_prec TyConPrec $ ppr tc <+> parens (interpp'SP cos)
ppr_co ctxt_prec co
= ppr_special_co ctxt_prec doc cos
@@ -766,7 +916,6 @@ pprPromotionQuote tc = pprPromotionQuoteI (ifaceTyConInfo tc)
pprPromotionQuoteI :: IfaceTyConInfo -> SDoc
pprPromotionQuoteI NoIfaceTyConInfo = empty
pprPromotionQuoteI IfacePromotedDataCon = char '\''
-pprPromotionQuoteI IfacePromotedTyCon = ifPprDebug (char '\'')
instance Outputable IfaceCoercion where
ppr = pprIfaceCoercion
@@ -781,14 +930,12 @@ instance Binary IfaceTyCon where
instance Binary IfaceTyConInfo where
put_ bh NoIfaceTyConInfo = putByte bh 0
put_ bh IfacePromotedDataCon = putByte bh 1
- put_ bh IfacePromotedTyCon = putByte bh 2
get bh =
do i <- getByte bh
case i of
0 -> return NoIfaceTyConInfo
- 1 -> return IfacePromotedDataCon
- _ -> return IfacePromotedTyCon
+ _ -> return IfacePromotedDataCon
instance Outputable IfaceTyLit where
ppr = ppr_tylit
@@ -806,12 +953,22 @@ instance Binary IfaceTyLit where
; return (IfaceStrTyLit n) }
_ -> panic ("get IfaceTyLit " ++ show tag)
+instance Binary IfaceForAllBndr where
+ put_ bh (IfaceTv tv vis) = do
+ put_ bh tv
+ put_ bh vis
+
+ get bh = do
+ tv <- get bh
+ vis <- get bh
+ return (IfaceTv tv vis)
+
instance Binary IfaceTcArgs where
put_ bh tk =
case tk of
- ITC_Type t ts -> putByte bh 0 >> put_ bh t >> put_ bh ts
- ITC_Kind t ts -> putByte bh 1 >> put_ bh t >> put_ bh ts
- ITC_Nil -> putByte bh 2
+ ITC_Vis t ts -> putByte bh 0 >> put_ bh t >> put_ bh ts
+ ITC_Invis t ts -> putByte bh 1 >> put_ bh t >> put_ bh ts
+ ITC_Nil -> putByte bh 2
get bh =
do c <- getByte bh
@@ -819,11 +976,11 @@ instance Binary IfaceTcArgs where
0 -> do
t <- get bh
ts <- get bh
- return $! ITC_Type t ts
+ return $! ITC_Vis t ts
1 -> do
t <- get bh
ts <- get bh
- return $! ITC_Kind t ts
+ return $! ITC_Invis t ts
2 -> return ITC_Nil
_ -> panic ("get IfaceTcArgs " ++ show c)
@@ -862,10 +1019,14 @@ instance Binary IfaceType where
put_ bh ah
put_ bh (IfaceTyConApp tc tys)
= do { putByte bh 5; put_ bh tc; put_ bh tys }
+ put_ bh (IfaceCastTy a b)
+ = do { putByte bh 6; put_ bh a; put_ bh b }
+ put_ bh (IfaceCoercionTy a)
+ = do { putByte bh 7; put_ bh a }
put_ bh (IfaceTupleTy s i tys)
- = do { putByte bh 6; put_ bh s; put_ bh i; put_ bh tys }
+ = do { putByte bh 8; put_ bh s; put_ bh i; put_ bh tys }
put_ bh (IfaceLitTy n)
- = do { putByte bh 7; put_ bh n }
+ = do { putByte bh 9; put_ bh n }
get bh = do
h <- getByte bh
@@ -886,7 +1047,12 @@ instance Binary IfaceType where
return (IfaceDFunTy ag ah)
5 -> do { tc <- get bh; tys <- get bh
; return (IfaceTyConApp tc tys) }
- 6 -> do { s <- get bh; i <- get bh; tys <- get bh
+ 6 -> do { a <- get bh; b <- get bh
+ ; return (IfaceCastTy a b) }
+ 7 -> do { a <- get bh
+ ; return (IfaceCoercionTy a) }
+
+ 8 -> do { s <- get bh; i <- get bh; tys <- get bh
; return (IfaceTupleTy s i tys) }
_ -> do n <- get bh
return (IfaceLitTy n)
@@ -910,10 +1076,11 @@ instance Binary IfaceCoercion where
putByte bh 4
put_ bh a
put_ bh b
- put_ bh (IfaceForAllCo a b) = do
+ put_ bh (IfaceForAllCo a b c) = do
putByte bh 5
put_ bh a
put_ bh b
+ put_ bh c
put_ bh (IfaceCoVarCo a) = do
putByte bh 6
put_ bh a
@@ -947,14 +1114,20 @@ instance Binary IfaceCoercion where
putByte bh 13
put_ bh a
put_ bh b
- put_ bh (IfaceSubCo a) = do
+ put_ bh (IfaceCoherenceCo a b) = do
putByte bh 14
put_ bh a
- put_ bh (IfaceAxiomRuleCo a b c) = do
+ put_ bh b
+ put_ bh (IfaceKindCo a) = do
putByte bh 15
put_ bh a
+ put_ bh (IfaceSubCo a) = do
+ putByte bh 16
+ put_ bh a
+ put_ bh (IfaceAxiomRuleCo a b) = do
+ putByte bh 17
+ put_ bh a
put_ bh b
- put_ bh c
get bh = do
tag <- getByte bh
@@ -975,7 +1148,8 @@ instance Binary IfaceCoercion where
return $ IfaceAppCo a b
5 -> do a <- get bh
b <- get bh
- return $ IfaceForAllCo a b
+ c <- get bh
+ return $ IfaceForAllCo a b c
6 -> do a <- get bh
return $ IfaceCoVarCo a
7 -> do a <- get bh
@@ -1002,13 +1176,42 @@ instance Binary IfaceCoercion where
b <- get bh
return $ IfaceInstCo a b
14-> do a <- get bh
- return $ IfaceSubCo a
+ b <- get bh
+ return $ IfaceCoherenceCo a b
15-> do a <- get bh
+ return $ IfaceKindCo a
+ 16-> do a <- get bh
+ return $ IfaceSubCo a
+ 17-> do a <- get bh
b <- get bh
- c <- get bh
- return $ IfaceAxiomRuleCo a b c
+ return $ IfaceAxiomRuleCo a b
_ -> panic ("get IfaceCoercion " ++ show tag)
+instance Binary IfaceUnivCoProv where
+ put_ bh IfaceUnsafeCoerceProv = putByte bh 1
+ put_ bh (IfacePhantomProv a) = do
+ putByte bh 2
+ put_ bh a
+ put_ bh (IfaceProofIrrelProv a) = do
+ putByte bh 3
+ put_ bh a
+ put_ bh (IfacePluginProv a) = do
+ putByte bh 4
+ put_ bh a
+
+ get bh = do
+ tag <- getByte bh
+ case tag of
+ 1 -> return $ IfaceUnsafeCoerceProv
+ 2 -> do a <- get bh
+ return $ IfacePhantomProv a
+ 3 -> do a <- get bh
+ return $ IfaceProofIrrelProv a
+ 4 -> do a <- get bh
+ return $ IfacePluginProv a
+ _ -> panic ("get IfaceUnivCoProv " ++ show tag)
+
+
instance Binary (DefMethSpec IfaceType) where
put_ bh VanillaDM = putByte bh 0
put_ bh (GenericDM t) = putByte bh 1 >> put_ bh t
@@ -1027,12 +1230,16 @@ instance Binary (DefMethSpec IfaceType) where
-}
----------------
-toIfaceTvBndr :: TyVar -> (IfLclName, IfaceType)
-toIfaceTvBndr tyvar = (occNameFS (getOccName tyvar), toIfaceKind (tyVarKind tyvar))
+toIfaceTvBndr :: TyVar -> (IfLclName, IfaceKind)
+toIfaceTvBndr tyvar = ( occNameFS (getOccName tyvar)
+ , toIfaceKind (tyVarKind tyvar)
+ )
+
toIfaceIdBndr :: Id -> (IfLclName, IfaceType)
toIfaceIdBndr id = (occNameFS (getOccName id), toIfaceType (idType id))
-toIfaceTvBndrs :: [TyVar] -> [(IfLclName, IfaceType)]
-toIfaceTvBndrs tyvars = map toIfaceTvBndr tyvars
+
+toIfaceTvBndrs :: [TyVar] -> [IfaceTvBndr]
+toIfaceTvBndrs = map toIfaceTvBndr
toIfaceBndr :: Var -> IfaceBndr
toIfaceBndr var
@@ -1048,21 +1255,19 @@ toIfaceType :: Type -> IfaceType
toIfaceType (TyVarTy tv) = IfaceTyVar (toIfaceTyVar tv)
toIfaceType (AppTy t1 t2) = IfaceAppTy (toIfaceType t1) (toIfaceType t2)
toIfaceType (LitTy n) = IfaceLitTy (toIfaceTyLit n)
-toIfaceType (ForAllTy tv t) = IfaceForAllTy (toIfaceTvBndr tv) (toIfaceType t)
-toIfaceType (FunTy t1 t2)
+toIfaceType (ForAllTy (Named tv vis) t)
+ = IfaceForAllTy (varToIfaceForAllBndr tv vis) (toIfaceType t)
+toIfaceType (ForAllTy (Anon t1) t2)
| isPredTy t1 = IfaceDFunTy (toIfaceType t1) (toIfaceType t2)
| otherwise = IfaceFunTy (toIfaceType t1) (toIfaceType t2)
+toIfaceType (CastTy ty co) = IfaceCastTy (toIfaceType ty) (toIfaceCoercion co)
+toIfaceType (CoercionTy co) = IfaceCoercionTy (toIfaceCoercion co)
-toIfaceType (TyConApp tc tys) -- Look for the three sorts of saturated tuple
+toIfaceType (TyConApp tc tys) -- Look for the two sorts of saturated tuple
| Just sort <- tyConTuple_maybe tc
, n_tys == arity
= IfaceTupleTy sort NoIfaceTyConInfo (toIfaceTcArgs tc tys)
- | Just tc' <- isPromotedTyCon_maybe tc
- , Just sort <- tyConTuple_maybe tc'
- , n_tys == arity
- = IfaceTupleTy sort IfacePromotedTyCon (toIfaceTcArgs tc tys)
-
| Just dc <- isPromotedDataCon_maybe tc
, isTupleDataCon dc
, n_tys == 2*arity
@@ -1080,6 +1285,10 @@ toIfaceTyVar = occNameFS . getOccName
toIfaceCoVar :: CoVar -> FastString
toIfaceCoVar = occNameFS . getOccName
+varToIfaceForAllBndr :: TyVar -> VisibilityFlag -> IfaceForAllBndr
+varToIfaceForAllBndr v vis
+ = IfaceTv (toIfaceTvBndr v) vis
+
----------------
toIfaceTyCon :: TyCon -> IfaceTyCon
toIfaceTyCon tc
@@ -1087,7 +1296,6 @@ toIfaceTyCon tc
where
tc_name = tyConName tc
info | isPromotedDataCon tc = IfacePromotedDataCon
- | isPromotedTyCon tc = IfacePromotedTyCon
| otherwise = NoIfaceTyConInfo
toIfaceTyCon_name :: Name -> IfaceTyCon
@@ -1114,27 +1322,36 @@ toIfaceCoercion (TyConAppCo r tc cos)
| tc `hasKey` funTyConKey
, [arg,res] <- cos = IfaceFunCo r (toIfaceCoercion arg) (toIfaceCoercion res)
| otherwise = IfaceTyConAppCo r (toIfaceTyCon tc)
- (map toIfaceCoercion cos)
+ (map toIfaceCoercion cos)
toIfaceCoercion (AppCo co1 co2) = IfaceAppCo (toIfaceCoercion co1)
(toIfaceCoercion co2)
-toIfaceCoercion (ForAllCo v co) = IfaceForAllCo (toIfaceTvBndr v)
+toIfaceCoercion (ForAllCo tv k co) = IfaceForAllCo (toIfaceTvBndr tv)
+ (toIfaceCoercion k)
(toIfaceCoercion co)
toIfaceCoercion (CoVarCo cv) = IfaceCoVarCo (toIfaceCoVar cv)
toIfaceCoercion (AxiomInstCo con ind cos)
= IfaceAxiomInstCo (coAxiomName con) ind
(map toIfaceCoercion cos)
-toIfaceCoercion (UnivCo s r ty1 ty2)= IfaceUnivCo s r (toIfaceType ty1)
- (toIfaceType ty2)
+toIfaceCoercion (UnivCo p r t1 t2) = IfaceUnivCo (toIfaceUnivCoProv p) r
+ (toIfaceType t1)
+ (toIfaceType t2)
toIfaceCoercion (SymCo co) = IfaceSymCo (toIfaceCoercion co)
toIfaceCoercion (TransCo co1 co2) = IfaceTransCo (toIfaceCoercion co1)
(toIfaceCoercion co2)
toIfaceCoercion (NthCo d co) = IfaceNthCo d (toIfaceCoercion co)
toIfaceCoercion (LRCo lr co) = IfaceLRCo lr (toIfaceCoercion co)
-toIfaceCoercion (InstCo co ty) = IfaceInstCo (toIfaceCoercion co)
- (toIfaceType ty)
+toIfaceCoercion (InstCo co arg) = IfaceInstCo (toIfaceCoercion co)
+ (toIfaceCoercion arg)
+toIfaceCoercion (CoherenceCo c1 c2) = IfaceCoherenceCo (toIfaceCoercion c1)
+ (toIfaceCoercion c2)
+toIfaceCoercion (KindCo c) = IfaceKindCo (toIfaceCoercion c)
toIfaceCoercion (SubCo co) = IfaceSubCo (toIfaceCoercion co)
-
-toIfaceCoercion (AxiomRuleCo co ts cs) = IfaceAxiomRuleCo
- (coaxrName co)
- (map toIfaceType ts)
+toIfaceCoercion (AxiomRuleCo co cs) = IfaceAxiomRuleCo (coaxrName co)
(map toIfaceCoercion cs)
+
+toIfaceUnivCoProv :: UnivCoProvenance -> IfaceUnivCoProv
+toIfaceUnivCoProv UnsafeCoerceProv = IfaceUnsafeCoerceProv
+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)
diff --git a/compiler/iface/MkIface.hs b/compiler/iface/MkIface.hs
index e428b58e35..644bea9691 100644
--- a/compiler/iface/MkIface.hs
+++ b/compiler/iface/MkIface.hs
@@ -69,7 +69,6 @@ import Coercion( tidyCo )
import Annotations
import CoreSyn
import Class
-import Kind
import TyCon
import CoAxiom
import ConLike
@@ -1315,8 +1314,8 @@ patSynToIfaceDecl ps
}
where
(univ_tvs, req_theta, ex_tvs, prov_theta, args, rhs_ty) = patSynSig ps
- (env1, univ_tvs') = tidyTyVarBndrs emptyTidyEnv univ_tvs
- (env2, ex_tvs') = tidyTyVarBndrs env1 ex_tvs
+ (env1, univ_tvs') = tidyTyCoVarBndrs emptyTidyEnv univ_tvs
+ (env2, ex_tvs') = tidyTyCoVarBndrs env1 ex_tvs
to_if_pr (id, needs_dummy) = (idName id, needs_dummy)
--------------------------
@@ -1350,15 +1349,18 @@ coAxBranchToIfaceBranch tc lhs_s
-- use this one for standalone branches without incompatibles
coAxBranchToIfaceBranch' :: TyCon -> CoAxBranch -> IfaceAxBranch
-coAxBranchToIfaceBranch' tc (CoAxBranch { cab_tvs = tvs, cab_lhs = lhs
+coAxBranchToIfaceBranch' tc (CoAxBranch { cab_tvs = tvs, cab_cvs = cvs
+ , cab_lhs = lhs
, cab_roles = roles, cab_rhs = rhs })
- = IfaceAxBranch { ifaxbTyVars = toIfaceTvBndrs tv_bndrs
- , ifaxbLHS = tidyToIfaceTcArgs env1 tc lhs
- , ifaxbRoles = roles
- , ifaxbRHS = tidyToIfaceType env1 rhs
+ = IfaceAxBranch { ifaxbTyVars = toIfaceTvBndrs tv_bndrs
+ , ifaxbCoVars = map toIfaceIdBndr cvs
+ , ifaxbLHS = tidyToIfaceTcArgs env1 tc lhs
+ , ifaxbRoles = roles
+ , ifaxbRHS = tidyToIfaceType env1 rhs
, ifaxbIncomps = [] }
where
- (env1, tv_bndrs) = tidyTyClTyVarBndrs emptyTidyEnv tvs
+
+ (env1, tv_bndrs) = tidyTyClTyCoVarBndrs emptyTidyEnv tvs
-- Don't re-bind in-scope tyvars
-- See Note [CoAxBranch type variables] in CoAxiom
@@ -1377,7 +1379,7 @@ tyConToIfaceDecl env tycon
ifTyVars = if_tc_tyvars,
ifRoles = tyConRoles tycon,
ifSynRhs = if_syn_type syn_rhs,
- ifSynKind = tidyToIfaceType tc_env1 (tyConResKind tycon)
+ ifSynKind = if_kind
})
| Just fam_flav <- famTyConFlav_maybe tycon
@@ -1386,13 +1388,14 @@ tyConToIfaceDecl env tycon
ifTyVars = if_tc_tyvars,
ifResVar = if_res_var,
ifFamFlav = to_if_fam_flav fam_flav,
- ifFamKind = tidyToIfaceType tc_env1 (tyConResKind tycon),
+ ifFamKind = if_kind,
ifFamInj = familyTyConInjectivityInfo tycon
})
| isAlgTyCon tycon
= ( tc_env1
, IfaceData { ifName = getOccName tycon,
+ ifKind = if_kind,
ifCType = tyConCType tycon,
ifTyVars = if_tc_tyvars,
ifRoles = tyConRoles tycon,
@@ -1400,7 +1403,6 @@ tyConToIfaceDecl env tycon
ifCons = ifaceConDecls (algTyConRhs tycon) (algTcFields tycon),
ifRec = boolToRecFlag (isRecursiveTyCon tycon),
ifGadtSyntax = isGadtSyntaxTyCon tycon,
- ifPromotable = isPromotableTyCon tycon,
ifParent = parent })
| otherwise -- FunTyCon, PrimTyCon, promoted TyCon/DataCon
@@ -1410,15 +1412,16 @@ tyConToIfaceDecl env tycon
ifCType = Nothing,
ifTyVars = funAndPrimTyVars,
ifRoles = tyConRoles tycon,
+ ifKind = if_kind,
ifCtxt = [],
ifCons = IfDataTyCon [] False [],
ifRec = boolToRecFlag False,
ifGadtSyntax = False,
- ifPromotable = False,
ifParent = IfNoParent })
where
- (tc_env1, tc_tyvars) = tidyTyClTyVarBndrs env (tyConTyVars tycon)
- if_tc_tyvars = toIfaceTvBndrs tc_tyvars
+ (tc_env1, tc_tyvars) = tidyTyClTyCoVarBndrs env (tyConTyVars tycon)
+ if_tc_tyvars = toIfaceTvBndrs tc_tyvars
+ if_kind = tidyToIfaceType tc_env1 (tyConKind tycon)
if_syn_type ty = tidyToIfaceType tc_env1 ty
if_res_var = getFS `fmap` tyConFamilyResVar_maybe tycon
@@ -1460,7 +1463,7 @@ tyConToIfaceDecl env tycon
ifConInfix = dataConIsInfix data_con,
ifConWrapper = isJust (dataConWrapId_maybe data_con),
ifConExTvs = toIfaceTvBndrs ex_tvs',
- ifConEqSpec = map to_eq_spec eq_spec,
+ ifConEqSpec = map (to_eq_spec . eqSpecPair) eq_spec,
ifConCtxt = tidyToIfaceContext con_env2 theta,
ifConArgTys = map (tidyToIfaceType con_env2) arg_tys,
ifConFields = map (nameOccName . flSelector)
@@ -1470,7 +1473,8 @@ tyConToIfaceDecl env tycon
ifConSrcStricts = map toIfaceSrcBang
(dataConSrcBangs data_con)}
where
- (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _) = dataConFullSig data_con
+ (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _)
+ = dataConFullSig data_con
-- Tidy the univ_tvs of the data constructor to be identical
-- to the tyConTyVars of the type constructor. This means
@@ -1482,7 +1486,7 @@ tyConToIfaceDecl env tycon
con_env1 = (fst tc_env1, mkVarEnv (zipEqual "ifaceConDecl" univ_tvs tc_tyvars))
-- A bit grimy, perhaps, but it's simple!
- (con_env2, ex_tvs') = tidyTyVarBndrs con_env1 ex_tvs
+ (con_env2, ex_tvs') = tidyTyCoVarBndrs con_env1 ex_tvs
to_eq_spec (tv,ty) = (toIfaceTyVar (tidyTyVar con_env2 tv), tidyToIfaceType con_env2 ty)
ifaceOverloaded flds = case fsEnvElts flds of
@@ -1510,9 +1514,10 @@ classToIfaceDecl :: TidyEnv -> Class -> (TidyEnv, IfaceDecl)
classToIfaceDecl env clas
= ( env1
, IfaceClass { ifCtxt = tidyToIfaceContext env1 sc_theta,
- ifName = getOccName (classTyCon clas),
+ ifName = getOccName tycon,
ifTyVars = toIfaceTvBndrs clas_tyvars',
ifRoles = tyConRoles (classTyCon clas),
+ ifKind = tidyToIfaceType env1 (tyConKind tycon),
ifFDs = map toIfaceFD clas_fds,
ifATs = map toIfaceAT clas_ats,
ifSigs = map toIfaceClassOp op_stuff,
@@ -1523,7 +1528,7 @@ classToIfaceDecl env clas
= classExtraBigSig clas
tycon = classTyCon clas
- (env1, clas_tyvars') = tidyTyVarBndrs env clas_tyvars
+ (env1, clas_tyvars') = tidyTyCoVarBndrs env clas_tyvars
toIfaceAT :: ClassATItem -> IfaceAT
toIfaceAT (ATI tc def)
@@ -1562,16 +1567,16 @@ tidyToIfaceTcArgs env tc tys = toIfaceTcArgs tc (tidyTypes env tys)
tidyToIfaceContext :: TidyEnv -> ThetaType -> IfaceContext
tidyToIfaceContext env theta = map (tidyToIfaceType env) theta
-tidyTyClTyVarBndrs :: TidyEnv -> [TyVar] -> (TidyEnv, [TyVar])
-tidyTyClTyVarBndrs env tvs = mapAccumL tidyTyClTyVarBndr env tvs
+tidyTyClTyCoVarBndrs :: TidyEnv -> [TyCoVar] -> (TidyEnv, [TyCoVar])
+tidyTyClTyCoVarBndrs env tvs = mapAccumL tidyTyClTyCoVarBndr env tvs
-tidyTyClTyVarBndr :: TidyEnv -> TyVar -> (TidyEnv, TyVar)
+tidyTyClTyCoVarBndr :: TidyEnv -> TyCoVar -> (TidyEnv, TyCoVar)
-- If the type variable "binder" is in scope, don't re-bind it
-- In a class decl, for example, the ATD binders mention
-- (amd must mention) the class tyvars
-tidyTyClTyVarBndr env@(_, subst) tv
+tidyTyClTyCoVarBndr env@(_, subst) tv
| Just tv' <- lookupVarEnv subst tv = (env, tv')
- | otherwise = tidyTyVarBndr env tv
+ | otherwise = tidyTyCoVarBndr env tv
tidyTyVar :: TidyEnv -> TyVar -> TyVar
tidyTyVar (_, subst) tv = lookupVarEnv subst tv `orElse` tv
@@ -1647,7 +1652,6 @@ toIfaceIdDetails (RecSelId { sel_naughty = n
-- through interface files. We easily could if it mattered
toIfaceIdDetails PatSynId = IfVanillaId
toIfaceIdDetails ReflectionId = IfVanillaId
-toIfaceIdDetails DefMethId = IfVanillaId
-- The remaining cases are all "implicit Ids" which don't
-- appear in interface files at all
diff --git a/compiler/iface/TcIface.hs b/compiler/iface/TcIface.hs
index da94136218..3931b18237 100644
--- a/compiler/iface/TcIface.hs
+++ b/compiler/iface/TcIface.hs
@@ -27,8 +27,9 @@ import BuildTyCl
import TcRnMonad
import TcType
import Type
-import Coercion hiding (substTy)
-import TypeRep
+import Coercion
+import CoAxiom
+import TyCoRep -- needs to build types & coercions in a knot
import HscTypes
import Annotations
import InstEnv
@@ -43,14 +44,10 @@ import MkId
import IdInfo
import Class
import TyCon
-import CoAxiom
import ConLike
import DataCon
import PrelNames
import TysWiredIn
-import TysPrim ( superKindTyConName )
-import BasicTypes ( strongLoopBreaker, Arity, TupleSort(..)
- , Boxity(..), DefMethSpec(..), pprRuleName )
import Literal
import qualified Var
import VarEnv
@@ -69,6 +66,8 @@ import SrcLoc
import DynFlags
import Util
import FastString
+import BasicTypes hiding ( SuccessFlag(..) )
+import ListSetOps
import Data.List
import Control.Monad
@@ -316,20 +315,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,
ifRoles = roles,
ifCtxt = ctxt, ifGadtSyntax = gadt_syn,
ifCons = rdr_cons,
- ifRec = is_rec, ifPromotable = is_prom,
- ifParent = mb_parent })
+ ifRec = is_rec, ifParent = mb_parent })
= bindIfaceTyVars_AT tv_bndrs $ \ tyvars -> do
{ tc_name <- lookupIfaceTop occ_name
+ ; kind' <- tcIfaceType kind
; tycon <- fixM $ \ tycon -> do
{ stupid_theta <- tcIfaceCtxt ctxt
; parent' <- tc_parent tc_name mb_parent
- ; cons <- tcIfaceDataCons tc_name tycon tyvars rdr_cons is_prom
- ; return (buildAlgTyCon tc_name tyvars roles cType stupid_theta
- cons is_rec is_prom gadt_syn parent') }
+ ; cons <- tcIfaceDataCons tc_name tycon tyvars rdr_cons
+ ; return (mkAlgTyCon tc_name kind' tyvars roles cType stupid_theta
+ cons parent' is_rec gadt_syn) }
; traceIf (text "tcIfaceDecl4" <+> ppr tycon)
; return (ATyCon tycon) }
where
@@ -350,10 +350,10 @@ tc_iface_decl _ _ (IfaceSynonym {ifName = occ_name, ifTyVars = tv_bndrs,
ifSynKind = kind })
= bindIfaceTyVars_AT tv_bndrs $ \ tyvars -> do
{ tc_name <- lookupIfaceTop occ_name
- ; rhs_kind <- tcIfaceKind kind -- Note [Synonym kind loop]
+ ; kind <- tcIfaceType kind -- Note [Synonym kind loop]
; rhs <- forkM (mk_doc tc_name) $
tcIfaceType rhs_ty
- ; let tycon = buildSynonymTyCon tc_name tyvars roles rhs rhs_kind
+ ; let tycon = mkSynonymTyCon tc_name kind tyvars roles rhs
; return (ATyCon tycon) }
where
mk_doc n = ptext (sLit "Type synonym") <+> ppr n
@@ -364,12 +364,11 @@ tc_iface_decl parent _ (IfaceFamily {ifName = occ_name, ifTyVars = tv_bndrs,
ifResVar = res, ifFamInj = inj })
= bindIfaceTyVars_AT tv_bndrs $ \ tyvars -> do
{ tc_name <- lookupIfaceTop occ_name
- ; rhs_kind <- tcIfaceKind kind -- Note [Synonym kind loop]
+ ; kind <- tcIfaceType kind -- Note [Synonym kind loop]
; rhs <- forkM (mk_doc tc_name) $
tc_fam_flav tc_name fam_flav
; res_name <- traverse (newIfaceName . mkTyVarOccFS) res
- ; let tycon = buildFamilyTyCon tc_name tyvars res_name rhs rhs_kind
- parent inj
+ ; let tycon = mkFamilyTyCon tc_name kind tyvars res_name rhs parent inj
; return (ATyCon tycon) }
where
mk_doc n = ptext (sLit "Type synonym") <+> ppr n
@@ -390,13 +389,15 @@ tc_iface_decl parent _ (IfaceFamily {ifName = occ_name, ifTyVars = tv_bndrs,
tc_iface_decl _parent ignore_prags
(IfaceClass {ifCtxt = rdr_ctxt, ifName = tc_occ,
- ifTyVars = tv_bndrs, ifRoles = roles, ifFDs = rdr_fds,
+ ifTyVars = tv_bndrs, ifRoles = roles, ifKind = kind,
+ ifFDs = rdr_fds,
ifATs = rdr_ats, ifSigs = rdr_sigs,
ifMinDef = mindef_occ, ifRec = tc_isrec })
-- ToDo: in hs-boot files we should really treat abstract classes specially,
-- as we do abstract tycons
- = bindIfaceTyVars tv_bndrs $ \ tyvars -> do
+ = bindIfaceTvBndrs tv_bndrs $ \ tyvars -> do
{ tc_name <- lookupIfaceTop tc_occ
+ ; kind' <- tcIfaceType kind
; traceIf (text "tc-iface-class1" <+> ppr tc_occ)
; ctxt <- mapM tc_sc rdr_ctxt
; traceIf (text "tc-iface-class2" <+> ppr tc_occ)
@@ -407,7 +408,7 @@ tc_iface_decl _parent ignore_prags
; cls <- fixM $ \ cls -> do
{ ats <- mapM (tc_at cls) rdr_ats
; traceIf (text "tc-iface-class4" <+> ppr tc_occ)
- ; buildClass tc_name tyvars roles ctxt fds ats sigs mindef tc_isrec }
+ ; buildClass tc_name tyvars roles ctxt kind' fds ats sigs mindef tc_isrec }
; return (ATyCon (classTyCon cls)) }
where
tc_sc pred = forkM (mk_sc_doc pred) (tcIfaceType pred)
@@ -486,8 +487,8 @@ tc_iface_decl _ _ (IfacePatSyn{ ifName = occ_name
; traceIf (ptext (sLit "tc_iface_decl") <+> ppr name)
; matcher <- tc_pr if_matcher
; builder <- fmapMaybeM tc_pr if_builder
- ; bindIfaceTyVars univ_tvs $ \univ_tvs -> do
- { bindIfaceTyVars ex_tvs $ \ex_tvs -> do
+ ; bindIfaceTvBndrs univ_tvs $ \univ_tvs -> do
+ { bindIfaceTvBndrs ex_tvs $ \ex_tvs -> do
{ patsyn <- forkM (mk_doc name) $
do { prov_theta <- tcIfaceCtxt prov_ctxt
; req_theta <- tcIfaceCtxt req_ctxt
@@ -508,22 +509,25 @@ tc_ax_branches if_branches = foldlM tc_ax_branch [] if_branches
tc_ax_branch :: [CoAxBranch] -> IfaceAxBranch -> IfL [CoAxBranch]
tc_ax_branch prev_branches
- (IfaceAxBranch { ifaxbTyVars = tv_bndrs, ifaxbLHS = lhs, ifaxbRHS = rhs
+ (IfaceAxBranch { ifaxbTyVars = tv_bndrs, ifaxbCoVars = cv_bndrs
+ , ifaxbLHS = lhs, ifaxbRHS = rhs
, ifaxbRoles = roles, ifaxbIncomps = incomps })
- = bindIfaceTyVars_AT tv_bndrs $ \ tvs -> do
+ = bindIfaceTyVars_AT tv_bndrs $ \ tvs ->
-- The _AT variant is needed here; see Note [CoAxBranch type variables] in CoAxiom
- { tc_lhs <- tcIfaceTcArgs lhs -- See Note [Checking IfaceTypes vs IfaceKinds]
+ bindIfaceIds cv_bndrs $ \ cvs -> do
+ { tc_lhs <- tcIfaceTcArgs lhs
; tc_rhs <- tcIfaceType rhs
; let br = CoAxBranch { cab_loc = noSrcSpan
, cab_tvs = tvs
+ , cab_cvs = cvs
, cab_lhs = tc_lhs
, cab_roles = roles
, cab_rhs = tc_rhs
- , cab_incomps = map (prev_branches !!) incomps }
+ , cab_incomps = map (prev_branches `getNth`) incomps }
; return (prev_branches ++ [br]) }
-tcIfaceDataCons :: Name -> TyCon -> [TyVar] -> IfaceConDecls -> Bool -> IfL AlgTyConRhs
-tcIfaceDataCons tycon_name tycon tc_tyvars if_cons is_prom
+tcIfaceDataCons :: Name -> TyCon -> [TyVar] -> IfaceConDecls -> IfL AlgTyConRhs
+tcIfaceDataCons tycon_name tycon tc_tyvars if_cons
= case if_cons of
IfAbstractTyCon dis -> return (AbstractTyCon dis)
IfDataTyCon cons _ _ -> do { field_lbls <- mapM (traverse lookupIfaceTop) (ifaceConDeclFields if_cons)
@@ -541,7 +545,7 @@ tcIfaceDataCons tycon_name tycon tc_tyvars if_cons is_prom
ifConSrcStricts = if_src_stricts})
= -- Universally-quantified tyvars are shared with
-- parent TyCon, and are alrady in scope
- bindIfaceTyVars ex_tvs $ \ ex_tyvars -> do
+ bindIfaceTvBndrs ex_tvs $ \ ex_tyvars -> do
{ traceIf (text "Start interface-file tc_con_decl" <+> ppr occ)
; dc_name <- lookupIfaceTop occ
@@ -568,14 +572,13 @@ tcIfaceDataCons tycon_name tycon tc_tyvars if_cons is_prom
-- Remember, tycon is the representation tycon
; let orig_res_ty = mkFamilyTyConApp tycon
- (substTyVars (mkTopTvSubst eq_spec) tc_tyvars)
+ (substTyVars (mkTopTCvSubst (map eqSpecPair eq_spec))
+ tc_tyvars)
- ; prom_info <- if is_prom then do { n <- newTyConRepName dc_name
- ; return (Promoted n) }
- else return NotPromoted
+ ; prom_rep_name <- newTyConRepName dc_name
; con <- buildDataCon (pprPanic "tcIfaceDataCons: FamInstEnvs" (ppr dc_name))
- dc_name is_infix prom_info
+ dc_name is_infix prom_rep_name
(map src_strict if_src_stricts)
(Just stricts)
-- Pass the HsImplBangs (i.e. final
@@ -601,13 +604,13 @@ tcIfaceDataCons tycon_name tycon tc_tyvars if_cons is_prom
src_strict :: IfaceSrcBang -> HsSrcBang
src_strict (IfSrcBang unpk bang) = HsSrcBang Nothing unpk bang
-tcIfaceEqSpec :: IfaceEqSpec -> IfL [(TyVar, Type)]
+tcIfaceEqSpec :: IfaceEqSpec -> IfL [EqSpec]
tcIfaceEqSpec spec
= mapM do_item spec
where
do_item (occ, if_ty) = do { tv <- tcIfaceTyVar occ
; ty <- tcIfaceType if_ty
- ; return (tv,ty) }
+ ; return (mkEqSpec tv ty) }
{-
Note [Synonym kind loop]
@@ -874,70 +877,55 @@ tcIfaceVectInfo mod typeEnv (IfaceVectInfo
-}
tcIfaceType :: IfaceType -> IfL Type
-tcIfaceType (IfaceTyVar n) = do { tv <- tcIfaceTyVar n; return (TyVarTy tv) }
-tcIfaceType (IfaceAppTy t1 t2) = do { t1' <- tcIfaceType t1; t2' <- tcIfaceType t2; return (AppTy t1' t2') }
-tcIfaceType (IfaceLitTy l) = do { l1 <- tcIfaceTyLit l; return (LitTy l1) }
-tcIfaceType (IfaceFunTy t1 t2) = tcIfaceTypeFun t1 t2
-tcIfaceType (IfaceDFunTy t1 t2) = tcIfaceTypeFun t1 t2
-tcIfaceType (IfaceTupleTy s i tks) = tcIfaceTupleTy s i tks
-tcIfaceType (IfaceTyConApp tc tks) = do { tc' <- tcIfaceTyCon tc
- ; tks' <- tcIfaceTcArgs tks
- ; return (mkTyConApp tc' tks') }
-tcIfaceType (IfaceForAllTy tv t) = bindIfaceTyVar tv $ \ tv' -> do { t' <- tcIfaceType t; return (ForAllTy tv' t') }
-
-tcIfaceTypeFun :: IfaceType -> IfaceType -> IfL Type
-tcIfaceTypeFun t1 t2 = do { t1' <- tcIfaceType t1; t2' <- tcIfaceType t2; return (FunTy t1' t2') }
-
-tcIfaceKind :: IfaceKind -> IfL Type
-tcIfaceKind (IfaceAppTy t1 t2) = do { t1' <- tcIfaceKind t1; t2' <- tcIfaceKind t2; return (AppTy t1' t2') }
-tcIfaceKind (IfaceFunTy t1 t2) = tcIfaceKindFun t1 t2
-tcIfaceKind (IfaceDFunTy t1 t2) = tcIfaceKindFun t1 t2
-tcIfaceKind (IfaceLitTy l) = pprPanic "tcIfaceKind" (ppr l)
-tcIfaceKind k = tcIfaceType k
-
-tcIfaceKindFun :: IfaceKind -> IfaceKind -> IfL Type
-tcIfaceKindFun t1 t2 = do { t1' <- tcIfaceKind t1; t2' <- tcIfaceKind t2; return (FunTy t1' t2') }
+tcIfaceType = go
+ where
+ go (IfaceTyVar n) = TyVarTy <$> tcIfaceTyVar n
+ go (IfaceAppTy t1 t2) = AppTy <$> go t1 <*> go t2
+ go (IfaceLitTy l) = LitTy <$> tcIfaceTyLit l
+ go (IfaceFunTy t1 t2) = ForAllTy <$> (Anon <$> go t1) <*> go t2
+ go (IfaceDFunTy t1 t2) = ForAllTy <$> (Anon <$> go t1) <*> go t2
+ go (IfaceTupleTy s i tks) = tcIfaceTupleTy s i tks
+ go (IfaceTyConApp tc tks)
+ = do { tc' <- tcIfaceTyCon tc
+ ; tks' <- mapM go (tcArgsIfaceTypes tks)
+ ; return (mkTyConApp tc' tks') }
+ go (IfaceForAllTy bndr t)
+ = bindIfaceBndrTy bndr $ \ tv' vis -> mkNamedForAllTy tv' vis <$> go t
+ go (IfaceCastTy ty co) = CastTy <$> go ty <*> tcIfaceCo co
+ go (IfaceCoercionTy co) = CoercionTy <$> tcIfaceCo co
tcIfaceTupleTy :: TupleSort -> IfaceTyConInfo -> IfaceTcArgs -> IfL Type
tcIfaceTupleTy sort info args
= do { args' <- tcIfaceTcArgs args
; let arity = length args'
- ; base_tc <- tcTupleTyCon sort arity
+ ; base_tc <- tcTupleTyCon True sort arity
; case info of
NoIfaceTyConInfo
-> return (mkTyConApp base_tc args')
- IfacePromotedTyCon
- | Promoted tc <- promotableTyCon_maybe base_tc
- -> return (mkTyConApp tc args')
- | otherwise
- -> panic "tcIfaceTupleTy" (ppr base_tc)
-
IfacePromotedDataCon
-> do { let tc = promoteDataCon (tyConSingleDataCon base_tc)
kind_args = map typeKind args'
; return (mkTyConApp tc (kind_args ++ args')) } }
-tcTupleTyCon :: TupleSort -> Arity -> IfL TyCon
-tcTupleTyCon sort arity
+-- See Note [Unboxed tuple levity vars] in TyCon
+tcTupleTyCon :: Bool -- True <=> typechecking a *type* (vs. an expr)
+ -> TupleSort
+ -> Arity -- the number of args. *not* the tuple arity.
+ -> IfL TyCon
+tcTupleTyCon in_type sort arity
= case sort of
ConstraintTuple -> do { thing <- tcIfaceGlobal (cTupleTyConName arity)
; return (tyThingTyCon thing) }
BoxedTuple -> return (tupleTyCon Boxed arity)
- UnboxedTuple -> return (tupleTyCon Unboxed arity)
+ UnboxedTuple -> return (tupleTyCon Unboxed arity')
+ where arity' | in_type = arity `div` 2
+ | otherwise = arity
+ -- in expressions, we only have term args
tcIfaceTcArgs :: IfaceTcArgs -> IfL [Type]
-tcIfaceTcArgs args
- = case args of
- ITC_Type t ts ->
- do { t' <- tcIfaceType t
- ; ts' <- tcIfaceTcArgs ts
- ; return (t':ts') }
- ITC_Kind k ks ->
- do { k' <- tcIfaceKind k
- ; ks' <- tcIfaceTcArgs ks
- ; return (k':ks') }
- ITC_Nil -> return []
+tcIfaceTcArgs = mapM tcIfaceType . tcArgsIfaceTypes
+
-----------------------------------------
tcIfaceCtxt :: IfaceContext -> IfL ThetaType
tcIfaceCtxt sts = mapM tcIfaceType sts
@@ -948,49 +936,56 @@ tcIfaceTyLit (IfaceNumTyLit n) = return (NumTyLit n)
tcIfaceTyLit (IfaceStrTyLit n) = return (StrTyLit n)
{-
-************************************************************************
-* *
+%************************************************************************
+%* *
Coercions
* *
************************************************************************
-}
tcIfaceCo :: IfaceCoercion -> IfL Coercion
-tcIfaceCo (IfaceReflCo r t) = mkReflCo r <$> tcIfaceType t
-tcIfaceCo (IfaceFunCo r c1 c2) = mkFunCo r <$> tcIfaceCo c1 <*> tcIfaceCo c2
-tcIfaceCo (IfaceTyConAppCo r tc cs) = mkTyConAppCo r <$> tcIfaceTyCon tc
- <*> mapM tcIfaceCo cs
-tcIfaceCo (IfaceAppCo c1 c2) = mkAppCo <$> tcIfaceCo c1
- <*> tcIfaceCo c2
-tcIfaceCo (IfaceForAllCo tv c) = bindIfaceTyVar tv $ \ tv' ->
- mkForAllCo tv' <$> tcIfaceCo c
-tcIfaceCo (IfaceCoVarCo n) = mkCoVarCo <$> tcIfaceCoVar n
-tcIfaceCo (IfaceAxiomInstCo n i cs) = AxiomInstCo <$> tcIfaceCoAxiom n
- <*> pure i
- <*> mapM tcIfaceCo cs
-tcIfaceCo (IfaceUnivCo s r t1 t2) = UnivCo s r <$> tcIfaceType t1
- <*> tcIfaceType t2
-tcIfaceCo (IfaceSymCo c) = SymCo <$> tcIfaceCo c
-tcIfaceCo (IfaceTransCo c1 c2) = TransCo <$> tcIfaceCo c1
- <*> tcIfaceCo c2
-tcIfaceCo (IfaceInstCo c1 t2) = InstCo <$> tcIfaceCo c1
- <*> tcIfaceType t2
-tcIfaceCo (IfaceNthCo d c) = NthCo d <$> tcIfaceCo c
-tcIfaceCo (IfaceLRCo lr c) = LRCo lr <$> tcIfaceCo c
-tcIfaceCo (IfaceSubCo c) = SubCo <$> tcIfaceCo c
-tcIfaceCo (IfaceAxiomRuleCo ax tys cos) = AxiomRuleCo
- <$> tcIfaceCoAxiomRule ax
- <*> mapM tcIfaceType tys
- <*> mapM tcIfaceCo cos
-
-tcIfaceCoVar :: FastString -> IfL CoVar
-tcIfaceCoVar = tcIfaceLclId
-
-tcIfaceCoAxiomRule :: FastString -> IfL CoAxiomRule
-tcIfaceCoAxiomRule n =
- case Map.lookup n typeNatCoAxiomRules of
- Just ax -> return ax
- _ -> pprPanic "tcIfaceCoAxiomRule" (ppr n)
+tcIfaceCo = go
+ where
+ go (IfaceReflCo r t) = Refl r <$> tcIfaceType t
+ go (IfaceFunCo r c1 c2) = mkFunCo r <$> go c1 <*> go c2
+ go (IfaceTyConAppCo r tc cs)
+ = TyConAppCo r <$> tcIfaceTyCon tc <*> mapM go cs
+ go (IfaceAppCo c1 c2) = AppCo <$> go c1 <*> go c2
+ go (IfaceForAllCo tv k c) = do { k' <- go k
+ ; bindIfaceTyVar tv $ \ tv' ->
+ ForAllCo tv' k' <$> go c }
+ go (IfaceCoVarCo n) = CoVarCo <$> go_var n
+ go (IfaceAxiomInstCo n i cs) = AxiomInstCo <$> tcIfaceCoAxiom n <*> pure i <*> mapM go cs
+ go (IfaceUnivCo p r t1 t2) = UnivCo <$> tcIfaceUnivCoProv p <*> pure r
+ <*> tcIfaceType t1 <*> tcIfaceType t2
+ go (IfaceSymCo c) = SymCo <$> go c
+ go (IfaceTransCo c1 c2) = TransCo <$> go c1
+ <*> go c2
+ go (IfaceInstCo c1 t2) = InstCo <$> go c1
+ <*> go t2
+ go (IfaceNthCo d c) = NthCo d <$> go c
+ go (IfaceLRCo lr c) = LRCo lr <$> go c
+ go (IfaceCoherenceCo c1 c2) = CoherenceCo <$> go c1
+ <*> go c2
+ go (IfaceKindCo c) = KindCo <$> go c
+ go (IfaceSubCo c) = SubCo <$> go c
+ go (IfaceAxiomRuleCo ax cos) = AxiomRuleCo <$> go_axiom_rule ax
+ <*> mapM go cos
+
+ go_var :: FastString -> IfL CoVar
+ go_var = tcIfaceLclId
+
+ go_axiom_rule :: FastString -> IfL CoAxiomRule
+ go_axiom_rule n =
+ case Map.lookup n typeNatCoAxiomRules of
+ Just ax -> return ax
+ _ -> pprPanic "go_axiom_rule" (ppr n)
+
+tcIfaceUnivCoProv :: IfaceUnivCoProv -> IfL UnivCoProvenance
+tcIfaceUnivCoProv IfaceUnsafeCoerceProv = return UnsafeCoerceProv
+tcIfaceUnivCoProv (IfacePhantomProv kco) = PhantomProv <$> tcIfaceCo kco
+tcIfaceUnivCoProv (IfaceProofIrrelProv kco) = ProofIrrelProv <$> tcIfaceCo kco
+tcIfaceUnivCoProv (IfacePluginProv str) = return $ PluginProv str
{-
************************************************************************
@@ -1028,8 +1023,12 @@ tcIfaceExpr (IfaceFCall cc ty) = do
tcIfaceExpr (IfaceTuple sort args)
= do { args' <- mapM tcIfaceExpr args
- ; tc <- tcTupleTyCon sort arity
- ; let con_args = map (Type . exprType) args' ++ args'
+ ; tc <- tcTupleTyCon False sort arity
+ ; let con_tys = map exprType args'
+ some_con_args = map Type con_tys ++ args'
+ con_args = case sort of
+ UnboxedTuple -> map (Type . getLevity "tcIfaceExpr") con_tys ++ some_con_args
+ _ -> some_con_args
-- Put the missing type arguments back in
con_id = dataConWorkId (tyConSingleDataCon tc)
; return (mkApps (Var con_id) con_args) }
@@ -1044,7 +1043,7 @@ tcIfaceExpr (IfaceLam (bndr, os) body)
tcIfaceOneShot _ b = b
tcIfaceExpr (IfaceApp fun arg)
- = tcIfaceApps fun arg
+ = App <$> tcIfaceExpr fun <*> tcIfaceExpr arg
tcIfaceExpr (IfaceECase scrut ty)
= do { scrut' <- tcIfaceExpr scrut
@@ -1056,7 +1055,7 @@ tcIfaceExpr (IfaceCase scrut case_bndr alts) = do
case_bndr_name <- newIfaceName (mkVarOccFS case_bndr)
let
scrut_ty = exprType scrut'
- case_bndr' = mkLocalId case_bndr_name scrut_ty
+ case_bndr' = mkLocalIdOrCoVar case_bndr_name scrut_ty
tc_app = splitTyConApp scrut_ty
-- NB: Won't always succeed (polymorphic case)
-- but won't be demanded in those cases
@@ -1073,7 +1072,7 @@ tcIfaceExpr (IfaceLet (IfaceNonRec (IfLetBndr fs ty info) rhs) body)
; ty' <- tcIfaceType ty
; id_info <- tcIdInfo False {- Don't ignore prags; we are inside one! -}
name ty' info
- ; let id = mkLocalIdWithInfo name ty' id_info
+ ; let id = mkLocalIdOrCoVarWithInfo name ty' id_info
; rhs' <- tcIfaceExpr rhs
; body' <- extendIfaceIdEnv [id] (tcIfaceExpr body)
; return (Let (NonRec id rhs') body') }
@@ -1088,7 +1087,7 @@ tcIfaceExpr (IfaceLet (IfaceRec pairs) body)
tc_rec_bndr (IfLetBndr fs ty _)
= do { name <- newIfaceName (mkVarOccFS fs)
; ty' <- tcIfaceType ty
- ; return (mkLocalId name ty') }
+ ; return (mkLocalIdOrCoVar name ty') }
tc_pair (IfLetBndr _ _ info, rhs) id
= do { rhs' <- tcIfaceExpr rhs
; id_info <- tcIdInfo False {- Don't ignore prags; we are inside one! -}
@@ -1107,31 +1106,6 @@ tcIfaceExpr (IfaceTick tickish expr) = do
return (Tick tickish' expr')
-------------------------
-tcIfaceApps :: IfaceExpr -> IfaceExpr -> IfL CoreExpr
--- See Note [Checking IfaceTypes vs IfaceKinds]
-tcIfaceApps fun arg
- = go_down fun [arg]
- where
- go_down (IfaceApp fun arg) args = go_down fun (arg:args)
- go_down fun args = do { fun' <- tcIfaceExpr fun
- ; go_up fun' (exprType fun') args }
-
- go_up :: CoreExpr -> Type -> [IfaceExpr] -> IfL CoreExpr
- go_up fun _ [] = return fun
- go_up fun fun_ty (IfaceType t : args)
- | Just (tv,body_ty) <- splitForAllTy_maybe fun_ty
- = do { t' <- if isKindVar tv
- then tcIfaceKind t
- else tcIfaceType t
- ; let fun_ty' = substTyWith [tv] [t'] body_ty
- ; go_up (App fun (Type t')) fun_ty' args }
- go_up fun fun_ty (arg : args)
- | Just (_, fun_ty') <- splitFunTy_maybe fun_ty
- = do { arg' <- tcIfaceExpr arg
- ; go_up (App fun arg') fun_ty' args }
- go_up fun fun_ty args = pprPanic "tcIfaceApps" (ppr fun $$ ppr fun_ty $$ ppr args)
-
--------------------------
tcIfaceTickish :: IfaceTickish -> IfM lcl (Tickish Id)
tcIfaceTickish (IfaceHpcTick modl ix) = return (HpcTick modl ix)
tcIfaceTickish (IfaceSCC cc tick push) = return (ProfNote cc tick push)
@@ -1179,7 +1153,7 @@ tcIfaceDataAlt con inst_tys arg_strs rhs
; let (ex_tvs, arg_ids)
= dataConRepFSInstPat arg_strs uniqs con inst_tys
- ; rhs' <- extendIfaceTyVarEnv ex_tvs $
+ ; rhs' <- extendIfaceEnvs ex_tvs $
extendIfaceIdEnv arg_ids $
tcIfaceExpr rhs
; return (DataAlt con, ex_tvs ++ arg_ids, rhs') }
@@ -1377,17 +1351,9 @@ tcIfaceTyConByName name
tcIfaceTyCon :: IfaceTyCon -> IfL TyCon
tcIfaceTyCon (IfaceTyCon name info)
= do { thing <- tcIfaceGlobal name
- ; case info of
- NoIfaceTyConInfo -> return (tyThingTyCon thing)
- IfacePromotedDataCon -> return (promoteDataCon (tyThingDataCon thing))
- -- Same Name as its underlying DataCon
- IfacePromotedTyCon -> return (promote_tc (tyThingTyCon thing)) }
- -- Same Name as its underlying TyCon
- where
- promote_tc tc
- | Promoted prom_tc <- promotableTyCon_maybe tc = prom_tc
- | isSuperKind (tyConKind tc) = tc
- | otherwise = pprPanic "tcIfaceTyCon" (ppr name $$ ppr tc)
+ ; return $ case info of
+ NoIfaceTyConInfo -> tyThingTyCon thing
+ IfacePromotedDataCon -> promoteDataCon $ tyThingDataCon thing }
tcIfaceCoAxiom :: Name -> IfL (CoAxiom Branched)
tcIfaceCoAxiom name = do { thing <- tcIfaceGlobal name
@@ -1413,12 +1379,23 @@ tcIfaceExtId name = do { thing <- tcIfaceGlobal name
************************************************************************
-}
-bindIfaceBndr :: IfaceBndr -> (CoreBndr -> IfL a) -> IfL a
-bindIfaceBndr (IfaceIdBndr (fs, ty)) thing_inside
+bindIfaceId :: IfaceIdBndr -> (Id -> IfL a) -> IfL a
+bindIfaceId (fs, ty) thing_inside
= do { name <- newIfaceName (mkVarOccFS fs)
; ty' <- tcIfaceType ty
- ; let id = mkLocalId name ty'
+ ; let id = mkLocalIdOrCoVar name ty'
; extendIfaceIdEnv [id] (thing_inside id) }
+
+bindIfaceIds :: [IfaceIdBndr] -> ([Id] -> IfL a) -> IfL a
+bindIfaceIds [] thing_inside = thing_inside []
+bindIfaceIds (b:bs) thing_inside
+ = bindIfaceId b $ \b' ->
+ bindIfaceIds bs $ \bs' ->
+ thing_inside (b':bs')
+
+bindIfaceBndr :: IfaceBndr -> (CoreBndr -> IfL a) -> IfL a
+bindIfaceBndr (IfaceIdBndr bndr) thing_inside
+ = bindIfaceId bndr thing_inside
bindIfaceBndr (IfaceTvBndr bndr) thing_inside
= bindIfaceTyVar bndr thing_inside
@@ -1430,33 +1407,26 @@ bindIfaceBndrs (b:bs) thing_inside
thing_inside (b':bs')
-----------------------
+bindIfaceBndrTy :: IfaceForAllBndr -> (TyVar -> VisibilityFlag -> IfL a) -> IfL a
+bindIfaceBndrTy (IfaceTv tv vis) thing_inside
+ = bindIfaceTyVar tv $ \tv' -> thing_inside tv' vis
+
bindIfaceTyVar :: IfaceTvBndr -> (TyVar -> IfL a) -> IfL a
bindIfaceTyVar (occ,kind) thing_inside
= do { name <- newIfaceName (mkTyVarOccFS occ)
; tyvar <- mk_iface_tyvar name kind
; extendIfaceTyVarEnv [tyvar] (thing_inside tyvar) }
-bindIfaceTyVars :: [IfaceTvBndr] -> ([TyVar] -> IfL a) -> IfL a
-bindIfaceTyVars bndrs thing_inside
- = do { names <- newIfaceNames (map mkTyVarOccFS occs)
- ; let (kis_kind, tys_kind) = span isSuperIfaceKind kinds
- (kis_name, tys_name) = splitAt (length kis_kind) names
- -- We need to bring the kind variables in scope since type
- -- variables may mention them.
- ; kvs <- zipWithM mk_iface_tyvar kis_name kis_kind
- ; extendIfaceTyVarEnv kvs $ do
- { tvs <- zipWithM mk_iface_tyvar tys_name tys_kind
- ; extendIfaceTyVarEnv tvs (thing_inside (kvs ++ tvs)) } }
- where
- (occs,kinds) = unzip bndrs
-
-isSuperIfaceKind :: IfaceKind -> Bool
-isSuperIfaceKind (IfaceTyConApp tc ITC_Nil) = ifaceTyConName tc == superKindTyConName
-isSuperIfaceKind _ = False
+bindIfaceTvBndrs :: [IfaceTvBndr] -> ([TyVar] -> IfL a) -> IfL a
+bindIfaceTvBndrs [] thing_inside = thing_inside []
+bindIfaceTvBndrs (tv:tvs) thing_inside
+ = bindIfaceTyVar tv $ \tv' ->
+ bindIfaceTvBndrs tvs $ \tvs' ->
+ thing_inside (tv':tvs')
mk_iface_tyvar :: Name -> IfaceKind -> IfL TyVar
mk_iface_tyvar name ifKind
- = do { kind <- tcIfaceKind ifKind
+ = do { kind <- tcIfaceType ifKind
; return (Var.mkTyVar name kind) }
bindIfaceTyVars_AT :: [IfaceTvBndr] -> ([TyVar] -> IfL a) -> IfL a
@@ -1466,12 +1436,14 @@ bindIfaceTyVars_AT :: [IfaceTvBndr] -> ([TyVar] -> IfL a) -> IfL a
-- Here 'a' is in scope when we look at the 'data T'
bindIfaceTyVars_AT [] thing_inside
= thing_inside []
-bindIfaceTyVars_AT (b@(tv_occ,_) : bs) thing_inside
- = do { mb_tv <- lookupIfaceTyVar tv_occ
- ; let bind_b :: (TyVar -> IfL a) -> IfL a
- bind_b = case mb_tv of
- Just b' -> \k -> k b'
- Nothing -> bindIfaceTyVar b
- ; bind_b $ \b' ->
+bindIfaceTyVars_AT (b : bs) thing_inside
+ = do { bindIfaceTyVar_AT b $ \b' ->
bindIfaceTyVars_AT bs $ \bs' ->
thing_inside (b':bs') }
+
+bindIfaceTyVar_AT :: IfaceTvBndr -> (TyVar -> IfL a) -> IfL a
+bindIfaceTyVar_AT tv thing
+ = do { mb_tv <- lookupIfaceTyVar tv
+ ; case mb_tv of
+ Just b' -> thing b'
+ Nothing -> bindIfaceTyVar tv thing }
diff --git a/compiler/iface/TcIface.hs-boot b/compiler/iface/TcIface.hs-boot
index 619e3efdbb..9c1b16b520 100644
--- a/compiler/iface/TcIface.hs-boot
+++ b/compiler/iface/TcIface.hs-boot
@@ -1,7 +1,7 @@
module TcIface where
import IfaceSyn ( IfaceDecl, IfaceClsInst, IfaceFamInst, IfaceRule, IfaceAnnotation )
-import TypeRep ( TyThing )
+import TyCoRep ( TyThing )
import TcRnTypes ( IfL )
import InstEnv ( ClsInst )
import FamInstEnv ( FamInst )
View Lorry Controller Status