summaryrefslogtreecommitdiff
path: root/compiler/iface
diff options
context:
space:
mode:
authorRichard Eisenberg <eir@cis.upenn.edu>2015-12-11 18:19:53 -0500
committerRichard Eisenberg <eir@cis.upenn.edu>2015-12-11 18:23:12 -0500
commit6746549772c5cc0ac66c0fce562f297f4d4b80a2 (patch)
tree96869fcfb5757651462511d64d99a3712f09e7fb /compiler/iface
parent6e56ac58a6905197412d58e32792a04a63b94d7e (diff)
downloadhaskell-6746549772c5cc0ac66c0fce562f297f4d4b80a2.tar.gz
Add kind equalities to GHC.
This implements the ideas originally put forward in "System FC with Explicit Kind Equality" (ICFP'13). There are several noteworthy changes with this patch: * We now have casts in types. These change the kind of a type. See new constructor `CastTy`. * All types and all constructors can be promoted. This includes GADT constructors. GADT pattern matches take place in type family equations. In Core, types can now be applied to coercions via the `CoercionTy` constructor. * Coercions can now be heterogeneous, relating types of different kinds. A coercion proving `t1 :: k1 ~ t2 :: k2` proves both that `t1` and `t2` are the same and also that `k1` and `k2` are the same. * The `Coercion` type has been significantly enhanced. The documentation in `docs/core-spec/core-spec.pdf` reflects the new reality. * The type of `*` is now `*`. No more `BOX`. * Users can write explicit kind variables in their code, anywhere they can write type variables. For backward compatibility, automatic inference of kind-variable binding is still permitted. * The new extension `TypeInType` turns on the new user-facing features. * Type families and synonyms are now promoted to kinds. This causes trouble with parsing `*`, leading to the somewhat awkward new `HsAppsTy` constructor for `HsType`. This is dispatched with in the renamer, where the kind `*` can be told apart from a type-level multiplication operator. Without `-XTypeInType` the old behavior persists. With `-XTypeInType`, you need to import `Data.Kind` to get `*`, also known as `Type`. * The kind-checking algorithms in TcHsType have been significantly rewritten to allow for enhanced kinds. * The new features are still quite experimental and may be in flux. * TODO: Several open tickets: #11195, #11196, #11197, #11198, #11203. * TODO: Update user manual. Tickets addressed: #9017, #9173, #7961, #10524, #8566, #11142. Updates Haddock submodule.
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