summaryrefslogtreecommitdiff
path: root/compiler/iface
diff options
context:
space:
mode:
authorSimon Peyton Jones <simonpj@microsoft.com>2014-06-03 14:15:52 +0100
committerSimon Peyton Jones <simonpj@microsoft.com>2014-06-03 14:24:08 +0100
commitb4856f9f4f0fb3db473901b247d3fa94a11c25a0 (patch)
tree64512fff57acca9baf54d0e72d516679763711a9 /compiler/iface
parentda64c97f1c0b147ea80a34fe64fe947ba7820c00 (diff)
downloadhaskell-b4856f9f4f0fb3db473901b247d3fa94a11c25a0.tar.gz
Do pretty-printing of TyThings via IfaceDecl (Trac #7730)
All the initial work on this was done fy 'archblob' (fcsernik@gmail.com); thank you! I reviewed the patch, started some tidying, up and then ended up in a huge swamp of changes, not all of which I can remember now. But: * To suppress kind arguments when we have -fno-print-explicit-kinds, - IfaceTyConApp argument types are in a tagged list IfaceTcArgs * To allow overloaded types to be printed with =>, add IfaceDFunTy to IfaceType. * When printing data/type family instances for the user, I've made them print out an informative RHS, which is a new feature. Thus ghci> info T data family T a data instance T Int = T1 Int Int data instance T Bool = T2 * In implementation terms, pprIfaceDecl has just one "context" argument, of type IfaceSyn.ShowSub, which says - How to print the binders of the decl see note [Printing IfaceDecl binders] in IfaceSyn - Which sub-comoponents (eg constructors) to print * Moved FastStringEnv from RnEnv to OccName It all took a ridiculously long time to do. But it's done!
Diffstat (limited to 'compiler/iface')
-rw-r--r--compiler/iface/IfaceSyn.lhs530
-rw-r--r--compiler/iface/IfaceType.lhs552
-rw-r--r--compiler/iface/LoadIface.lhs6
-rw-r--r--compiler/iface/MkIface.lhs68
-rw-r--r--compiler/iface/TcIface.lhs160
5 files changed, 907 insertions, 409 deletions
diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs
index 5462667c5b..c8e7ea87ff 100644
--- a/compiler/iface/IfaceSyn.lhs
+++ b/compiler/iface/IfaceSyn.lhs
@@ -23,6 +23,7 @@ module IfaceSyn (
IfaceInfoItem(..), IfaceRule(..), IfaceAnnotation(..), IfaceAnnTarget,
IfaceClsInst(..), IfaceFamInst(..), IfaceTickish(..),
IfaceBang(..), IfaceAxBranch(..),
+ IfaceTyConParent(..),
-- Misc
ifaceDeclImplicitBndrs, visibleIfConDecls,
@@ -32,7 +33,9 @@ module IfaceSyn (
freeNamesIfDecl, freeNamesIfRule, freeNamesIfFamInst,
-- Pretty printing
- pprIfaceExpr
+ pprIfaceExpr,
+ pprIfaceDecl,
+ ShowSub(..), ShowHowMuch(..)
) where
#include "HsVersions.h"
@@ -52,11 +55,13 @@ import BasicTypes
import Outputable
import FastString
import Module
-import TysWiredIn ( eqTyConName )
import Fingerprint
import Binary
import BooleanFormula ( BooleanFormula )
import HsBinds
+import TyCon (Role (..))
+import StaticFlags (opt_PprStyle_Debug)
+import Util( filterOut )
import Control.Monad
import System.IO.Unsafe
@@ -89,8 +94,8 @@ data IfaceDecl
ifPromotable :: Bool, -- Promotable to kind level?
ifGadtSyntax :: Bool, -- True <=> declared using
-- GADT syntax
- ifAxiom :: Maybe IfExtName -- The axiom, for a newtype,
- -- or data/newtype family instance
+ ifParent :: IfaceTyConParent -- The axiom, for a newtype,
+ -- or data/newtype family instance
}
| IfaceSyn { ifName :: OccName, -- Type constructor
@@ -266,13 +271,15 @@ instance Binary IfaceDecl where
data IfaceSynTyConRhs
= IfaceOpenSynFamilyTyCon
- | IfaceClosedSynFamilyTyCon IfExtName -- name of associated axiom
+ | IfaceClosedSynFamilyTyCon IfExtName -- name of associated axiom
+ [IfaceAxBranch] -- for pretty printing purposes only
| IfaceAbstractClosedSynFamilyTyCon
| IfaceSynonymTyCon IfaceType
instance Binary IfaceSynTyConRhs where
put_ bh IfaceOpenSynFamilyTyCon = putByte bh 0
- put_ bh (IfaceClosedSynFamilyTyCon ax) = putByte bh 1 >> put_ bh ax
+ put_ bh (IfaceClosedSynFamilyTyCon ax br) = putByte bh 1 >> put_ bh ax
+ >> put_ bh br
put_ bh IfaceAbstractClosedSynFamilyTyCon = putByte bh 2
put_ bh (IfaceSynonymTyCon ty) = putByte bh 3 >> put_ bh ty
@@ -280,7 +287,8 @@ instance Binary IfaceSynTyConRhs where
; case h of
0 -> return IfaceOpenSynFamilyTyCon
1 -> do { ax <- get bh
- ; return (IfaceClosedSynFamilyTyCon ax) }
+ ; br <- get bh
+ ; return (IfaceClosedSynFamilyTyCon ax br) }
2 -> return IfaceAbstractClosedSynFamilyTyCon
_ -> do { ty <- get bh
; return (IfaceSynonymTyCon ty) } }
@@ -290,6 +298,9 @@ data IfaceClassOp = IfaceClassOp OccName DefMethSpec IfaceType
-- Just False => ordinary polymorphic default method
-- Just True => generic default method
+instance HasOccName IfaceClassOp where
+ occName (IfaceClassOp n _ _) = n
+
instance Binary IfaceClassOp where
put_ bh (IfaceClassOp n def ty) = do
put_ bh (occNameFS n)
@@ -315,33 +326,26 @@ instance Binary IfaceAT where
defs <- get bh
return (IfaceAT dec defs)
-instance Outputable IfaceAxBranch where
- ppr = pprAxBranch Nothing
-
-pprAxBranch :: Maybe IfaceTyCon -> IfaceAxBranch -> SDoc
-pprAxBranch mtycon (IfaceAxBranch { ifaxbTyVars = tvs
+pprAxBranch :: SDoc -> IfaceAxBranch -> SDoc
+-- The TyCon might be local (just an OccName), or this might
+-- 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 = ty
+ , ifaxbRHS = rhs
, ifaxbIncomps = incomps })
- = ppr tvs <+> ppr_lhs <+> char '=' <+> ppr ty $+$
+ = hang (pprUserIfaceForAll tvs)
+ 2 (hang pp_lhs 2 (equals <+> ppr rhs))
+ $+$
nest 2 maybe_incomps
- where
- ppr_lhs
- | Just tycon <- mtycon
- = ppr (IfaceTyConApp tycon pat_tys)
- | otherwise
- = hsep (map ppr pat_tys)
-
- maybe_incomps
- | [] <- incomps
- = empty
-
- | otherwise
- = parens (ptext (sLit "incompatible indices:") <+> ppr incomps)
+ where
+ pp_lhs = hang pp_tc 2 (pprParendIfaceTcArgs pat_tys)
+ maybe_incomps = ppUnless (null incomps) $ parens $
+ ptext (sLit "incompatible indices:") <+> ppr incomps
--- this is just like CoAxBranch
+-- This is just like CoAxBranch
data IfaceAxBranch = IfaceAxBranch { ifaxbTyVars :: [IfaceTvBndr]
- , ifaxbLHS :: [IfaceType]
+ , ifaxbLHS :: IfaceTcArgs
, ifaxbRoles :: [Role]
, ifaxbRHS :: IfaceType
, ifaxbIncomps :: [BranchIndex] }
@@ -383,7 +387,7 @@ instance Binary IfaceConDecls where
visibleIfConDecls :: IfaceConDecls -> [IfaceConDecl]
visibleIfConDecls (IfAbstractTyCon {}) = []
-visibleIfConDecls IfDataFamTyCon = []
+visibleIfConDecls IfDataFamTyCon = []
visibleIfConDecls (IfDataTyCon cs) = cs
visibleIfConDecls (IfNewTyCon c) = [c]
@@ -394,13 +398,18 @@ data IfaceConDecl
ifConInfix :: Bool, -- True <=> declared infix
ifConUnivTvs :: [IfaceTvBndr], -- Universal tyvars
ifConExTvs :: [IfaceTvBndr], -- Existential tyvars
- ifConEqSpec :: [(OccName,IfaceType)], -- Equality constraints
+ ifConEqSpec :: IfaceEqSpec, -- Equality constraints
ifConCtxt :: IfaceContext, -- Non-stupid context
ifConArgTys :: [IfaceType], -- Arg types
ifConFields :: [OccName], -- ...ditto... (field labels)
ifConStricts :: [IfaceBang]} -- Empty (meaning all lazy),
-- or 1-1 corresp with arg tys
+type IfaceEqSpec = [(OccName,IfaceType)]
+
+instance HasOccName IfaceConDecl where
+ occName = ifConOcc
+
instance Binary IfaceConDecl where
put_ bh (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9 a10) = do
put_ bh a1
@@ -856,6 +865,29 @@ instance Binary IfaceLetBndr where
b <- get bh
c <- get bh
return (IfLetBndr a b c)
+
+data IfaceTyConParent
+ = IfNoParent
+ | IfDataInstance IfExtName
+ IfaceTyCon
+ IfaceTcArgs
+
+instance Binary IfaceTyConParent where
+ put_ bh IfNoParent = putByte bh 0
+ put_ bh (IfDataInstance ax pr ty) = do
+ putByte bh 1
+ put_ bh ax
+ put_ bh pr
+ put_ bh ty
+ get bh = do
+ h <- getByte bh
+ case h of
+ 0 -> return IfNoParent
+ _ -> do
+ ax <- get bh
+ pr <- get bh
+ ty <- get bh
+ return $ IfDataInstance ax pr ty
\end{code}
Note [Empty case alternatives]
@@ -1043,74 +1075,197 @@ ifaceDeclFingerprints hash decl
----------------------------- Printing IfaceDecl ------------------------------
+instance HasOccName IfaceDecl where
+ occName = ifName
+
instance Outputable IfaceDecl where
- ppr = pprIfaceDecl
+ ppr = pprIfaceDecl showAll
+
+data ShowSub
+ = ShowSub
+ { ss_ppr_bndr :: OccName -> SDoc -- Pretty-printer for binders in IfaceDecl
+ -- See Note [Printing IfaceDecl binders]
+ , ss_how_much :: ShowHowMuch }
+
+data ShowHowMuch
+ = ShowHeader -- Header information only, not rhs
+ | ShowSome [OccName] -- [] <=> Print all sub-components
+ -- (n:ns) <=> print sub-component 'n' with ShowSub=ns
+ -- elide other sub-components to "..."
+ -- May 14: the list is max 1 element long at the moment
+ | ShowIface -- Everything including GHC-internal information (used in --show-iface)
+
+showAll :: ShowSub
+showAll = ShowSub { ss_how_much = ShowIface, ss_ppr_bndr = ppr }
+
+ppShowIface :: ShowSub -> SDoc -> SDoc
+ppShowIface (ShowSub { ss_how_much = ShowIface }) doc = doc
+ppShowIface _ _ = empty
+
+ppShowRhs :: ShowSub -> SDoc -> SDoc
+ppShowRhs (ShowSub { ss_how_much = ShowHeader }) _ = empty
+ppShowRhs _ doc = doc
+
+showSub :: HasOccName n => ShowSub -> n -> Bool
+showSub (ShowSub { ss_how_much = ShowHeader }) _ = False
+showSub (ShowSub { ss_how_much = ShowSome (n:_) }) thing = n == occName thing
+showSub (ShowSub { ss_how_much = _ }) _ = True
+\end{code}
-pprIfaceDecl :: IfaceDecl -> SDoc
-pprIfaceDecl (IfaceId {ifName = var, ifType = ty,
- ifIdDetails = details, ifIdInfo = info})
- = sep [ pprPrefixOcc var <+> dcolon <+> ppr ty,
- nest 2 (ppr details),
- nest 2 (ppr info) ]
+Note [Printing IfaceDecl binders]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The binders in an IfaceDecl are just OccNames, so we don't know what module they
+come from. But when we pretty-print a TyThing by converting to an IfaceDecl
+(see PprTyThing), the TyThing may come from some other module so we really need
+the module qualifier. We solve this by passing in a pretty-printer for the
+binders.
-pprIfaceDecl (IfaceForeign {ifName = tycon})
- = hsep [ptext (sLit "foreign import type dotnet"), ppr tycon]
+When printing an interface file (--show-iface), we want to print
+everything unqualified, so we can just print the OccName directly.
+
+\begin{code}
+ppr_trim :: [Maybe SDoc] -> [SDoc]
+-- Collapse a group of Nothings to a single "..."
+ppr_trim xs
+ = snd (foldr go (False, []) xs)
+ where
+ go (Just doc) (_, so_far) = (False, doc : so_far)
+ go Nothing (True, so_far) = (True, so_far)
+ go Nothing (False, so_far) = (True, ptext (sLit "...") : so_far)
+
+isIfaceDataInstance :: IfaceTyConParent -> Bool
+isIfaceDataInstance IfNoParent = False
+isIfaceDataInstance _ = True
+
+pprIfaceDecl :: ShowSub -> IfaceDecl -> SDoc
+pprIfaceDecl ss (IfaceData { ifName = tycon, ifCType = ctype,
+ ifCtxt = context, ifTyVars = tyvars,
+ ifRoles = roles, ifCons = condecls,
+ ifParent = parent, ifRec = isrec,
+ ifGadtSyntax = gadt,
+ ifPromotable = is_prom })
+
+ | gadt_style = vcat [ pp_roles
+ , pp_nd <+> pp_lhs <+> pp_where
+ , nest 2 (vcat pp_cons)
+ , nest 2 $ ppShowIface ss pp_extra ]
+ | otherwise = vcat [ pp_roles
+ , hang (pp_nd <+> pp_lhs) 2 (add_bars pp_cons)
+ , nest 2 $ ppShowIface ss pp_extra ]
+ where
+ is_data_instance = isIfaceDataInstance parent
+
+ gadt_style = gadt || any (not . isVanillaIfaceConDecl) cons
+ cons = visibleIfConDecls condecls
+ pp_where = ppWhen (gadt_style && not (null cons)) $ ptext (sLit "where")
+ pp_cons = ppr_trim (map show_con cons) :: [SDoc]
+
+ pp_lhs = case parent of
+ IfNoParent -> pprIfaceDeclHead context ss tycon tyvars
+ _ -> ptext (sLit "instance") <+> pprIfaceTyConParent parent
+
+ pp_roles
+ | is_data_instance = empty
+ | otherwise = pprRoles (== Representational) (pprIfDeclBndr ss tycon) tyvars roles
+ -- Don't display roles for data family instances (yet)
+ -- See discussion on Trac #8672.
+
+ add_bars [] = empty
+ add_bars (c:cs) = sep ((equals <+> c) : map (char '|' <+>) cs)
+
+ ok_con dc = showSub ss dc || any (showSub ss) (ifConFields dc)
+
+ show_con dc
+ | ok_con dc = Just $ pprIfaceConDecl ss gadt_style mk_user_con_res_ty dc
+ | otherwise = Nothing
-pprIfaceDecl (IfaceSyn {ifName = tycon,
- ifTyVars = tyvars,
- ifSynRhs = IfaceSynonymTyCon mono_ty})
- = hang (ptext (sLit "type") <+> pprIfaceDeclHead [] tycon tyvars)
- 2 (vcat [equals <+> ppr mono_ty])
+ mk_user_con_res_ty :: [IfaceTvBndr] -> IfaceEqSpec -> ([IfaceTvBndr], SDoc)
+ mk_user_con_res_ty univ_tvs eq_spec
+ = (filterOut done_univ_tv univ_tvs, sdocWithDynFlags pp_res_ty)
+ where
+ gadt_env = mkFsEnv [(occNameFS occ, ty) | (occ,ty) <- eq_spec]
+ done_univ_tv (tv,_) = isJust (lookupFsEnv gadt_env tv)
+
+ pp_res_ty dflags
+ = case parent of
+ IfNoParent
+ -> hang (pprIfDeclBndr ss tycon)
+ 2 (sep (map pprParendIfaceType tc_args))
+ IfDataInstance _ parent_tc tys
+ -> pprIfaceType (IfaceTyConApp parent_tc (substIfaceTcArgs subst tys))
+ where
+ subst = mkIfaceTySubst tyvars tc_args
+ where
+ tc_args = map (substIfaceTyVar gadt_env . fst) (stripIfaceKindVars dflags univ_tvs)
+
+
+ pp_nd = case condecls of
+ IfAbstractTyCon d -> ptext (sLit "abstract") <> ppShowIface ss (parens (ppr d))
+ IfDataFamTyCon -> ptext (sLit "data family")
+ IfDataTyCon _ -> ptext (sLit "data")
+ IfNewTyCon _ -> ptext (sLit "newtype")
-pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars,
- ifSynRhs = rhs, ifSynKind = kind })
- = hang (ptext (sLit "type family") <+> pprIfaceDeclHead [] tycon tyvars)
- 2 (sep [dcolon <+> ppr kind, parens (pp_rhs rhs)])
+ pp_extra = vcat [pprCType ctype, pprRec isrec, pp_prom]
+
+ pp_prom | is_prom = ptext (sLit "Promotable")
+ | otherwise = empty
+
+
+pprIfaceDecl ss (IfaceClass { ifATs = ats, ifSigs = sigs, ifRec = isrec
+ , ifCtxt = context, ifName = clas
+ , ifTyVars = tyvars, ifRoles = roles
+ , ifFDs = fds })
+ = vcat [ pprRoles (== Nominal) (pprIfDeclBndr ss clas) tyvars roles
+ , ptext (sLit "class") <+> pprIfaceDeclHead context ss clas tyvars
+ <+> pprFundeps fds <+> pp_where
+ , nest 2 (vcat [vcat asocs, vcat dsigs, pprec])]
+ where
+ pp_where = ppShowRhs ss $ ppUnless (null sigs && null ats) (ptext (sLit "where"))
+
+ asocs = ppr_trim $ map maybeShowAssoc ats
+ dsigs = ppr_trim $ map maybeShowSig sigs
+ pprec = ppShowIface ss (pprRec isrec)
+
+ maybeShowAssoc :: IfaceAT -> Maybe SDoc
+ maybeShowAssoc asc@(IfaceAT d _)
+ | showSub ss d = Just $ pprIfaceAT ss asc
+ | otherwise = Nothing
+
+ maybeShowSig :: IfaceClassOp -> Maybe SDoc
+ maybeShowSig sg
+ | showSub ss sg = Just $ pprIfaceClassOp ss sg
+ | otherwise = Nothing
+
+pprIfaceDecl ss (IfaceSyn { ifName = tc
+ , ifTyVars = tv
+ , ifSynRhs = IfaceSynonymTyCon mono_ty })
+ = hang (ptext (sLit "type") <+> pprIfaceDeclHead [] ss tc tv <+> equals)
+ 2 (sep [pprIfaceForAll tvs, pprIfaceContextArr theta, ppr tau])
where
- pp_rhs IfaceOpenSynFamilyTyCon = ptext (sLit "open")
- pp_rhs (IfaceClosedSynFamilyTyCon ax) = ptext (sLit "closed, axiom") <+> ppr ax
- pp_rhs IfaceAbstractClosedSynFamilyTyCon = ptext (sLit "closed, abstract")
- pp_rhs _ = panic "pprIfaceDecl syn"
+ (tvs, theta, tau) = splitIfaceSigmaTy mono_ty
-pprIfaceDecl (IfaceData {ifName = tycon, ifCType = cType,
- ifCtxt = context,
- ifTyVars = tyvars, ifRoles = roles, ifCons = condecls,
- ifRec = isrec, ifPromotable = is_prom,
- ifAxiom = mbAxiom})
- = hang (pp_nd <+> pprIfaceDeclHead context tycon tyvars)
- 2 (vcat [ pprCType cType
- , pprRoles roles
- , pprRec isrec <> comma <+> pp_prom
- , pp_condecls tycon condecls
- , pprAxiom mbAxiom])
+pprIfaceDecl ss (IfaceSyn { ifName = tycon, ifTyVars = tyvars
+ , ifSynRhs = rhs, ifSynKind = kind })
+ = vcat [ hang (text "type family" <+> pprIfaceDeclHead [] ss tycon tyvars <+> dcolon)
+ 2 (ppr kind <+> ppShowRhs ss (pp_rhs rhs))
+ , ppShowRhs ss (nest 2 (pp_branches rhs)) ]
where
- pp_prom | is_prom = ptext (sLit "Promotable")
- | otherwise = ptext (sLit "Not promotable")
- pp_nd = case condecls of
- IfAbstractTyCon dis -> ptext (sLit "abstract") <> parens (ppr dis)
- IfDataFamTyCon -> ptext (sLit "data family")
- IfDataTyCon _ -> ptext (sLit "data")
- IfNewTyCon _ -> ptext (sLit "newtype")
-
-pprIfaceDecl (IfaceClass {ifCtxt = context, ifName = clas, ifTyVars = tyvars,
- ifRoles = roles, ifFDs = fds, ifATs = ats, ifSigs = sigs,
- ifRec = isrec})
- = hang (ptext (sLit "class") <+> pprIfaceDeclHead context clas tyvars <+> pprFundeps fds)
- 2 (vcat [pprRoles roles,
- pprRec isrec,
- sep (map ppr ats),
- sep (map ppr sigs)])
-
-pprIfaceDecl (IfaceAxiom {ifName = name, ifTyCon = tycon, ifAxBranches = branches })
- = hang (ptext (sLit "axiom") <+> ppr name <> dcolon)
- 2 (vcat $ map (pprAxBranch $ Just tycon) branches)
-
-pprIfaceDecl (IfacePatSyn { ifName = name, ifPatWrapper = wrapper,
- ifPatIsInfix = is_infix,
- ifPatUnivTvs = _univ_tvs, ifPatExTvs = _ex_tvs,
- ifPatProvCtxt = prov_ctxt, ifPatReqCtxt = req_ctxt,
- ifPatArgs = args,
- ifPatTy = ty })
+ pp_rhs IfaceOpenSynFamilyTyCon = ppShowIface ss (ptext (sLit "open"))
+ pp_rhs IfaceAbstractClosedSynFamilyTyCon = ppShowIface ss (ptext (sLit "closed, abstract"))
+ pp_rhs (IfaceClosedSynFamilyTyCon _ (_:_)) = ptext (sLit "where")
+ pp_rhs _ = panic "pprIfaceDecl syn"
+
+ pp_branches (IfaceClosedSynFamilyTyCon ax brs)
+ = vcat (map (pprAxBranch (pprIfDeclBndr ss tycon)) brs)
+ $$ ppShowIface ss (ptext (sLit "axiom") <+> ppr ax)
+ pp_branches _ = empty
+
+pprIfaceDecl _ (IfacePatSyn { ifName = name, ifPatWrapper = wrapper,
+ ifPatIsInfix = is_infix,
+ ifPatUnivTvs = _univ_tvs, ifPatExTvs = _ex_tvs,
+ ifPatProvCtxt = prov_ctxt, ifPatReqCtxt = req_ctxt,
+ ifPatArgs = args,
+ ifPatTy = ty })
= pprPatSynSig name has_wrap args' ty' (pprCtxt prov_ctxt) (pprCtxt req_ctxt)
where
has_wrap = isJust wrapper
@@ -1125,70 +1280,102 @@ pprIfaceDecl (IfacePatSyn { ifName = name, ifPatWrapper = wrapper,
pprCtxt [] = Nothing
pprCtxt ctxt = Just $ pprIfaceContext ctxt
+pprIfaceDecl ss (IfaceId { ifName = var, ifType = ty,
+ ifIdDetails = details, ifIdInfo = info })
+ = vcat [ hang (parenSymOcc var (pprIfDeclBndr ss var) <+> dcolon)
+ 2 (pprIfaceSigmaType ty)
+ , ppShowIface ss (ppr details)
+ , ppShowIface ss (ppr info)]
+
+pprIfaceDecl _ (IfaceForeign {ifName = tycon})
+ = hsep [ptext (sLit "foreign import type dotnet"), ppr tycon]
+
+pprIfaceDecl _ (IfaceAxiom { ifName = name, ifTyCon = tycon
+ , ifAxBranches = branches })
+ = hang (ptext (sLit "axiom") <+> ppr name <> dcolon)
+ 2 (vcat $ map (pprAxBranch (ppr tycon)) branches)
+
+
pprCType :: Maybe CType -> SDoc
-pprCType Nothing = ptext (sLit "No C type associated")
+pprCType Nothing = empty
pprCType (Just cType) = ptext (sLit "C type:") <+> ppr cType
-pprRoles :: [Role] -> SDoc
-pprRoles [] = empty
-pprRoles roles = text "Roles:" <+> ppr roles
+-- 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
+ = sdocWithDynFlags $ \dflags ->
+ let froles = suppressIfaceKinds dflags tyvars roles
+ in ppUnless (all suppress_if roles || null froles) $
+ ptext (sLit "type role") <+> tyCon <+> hsep (map ppr froles)
pprRec :: RecFlag -> SDoc
-pprRec isrec = ptext (sLit "RecFlag") <+> ppr isrec
+pprRec NonRecursive = empty
+pprRec Recursive = ptext (sLit "RecFlag: Recursive")
-pprAxiom :: Maybe Name -> SDoc
-pprAxiom Nothing = ptext (sLit "FamilyInstance: none")
-pprAxiom (Just ax) = ptext (sLit "FamilyInstance:") <+> ppr ax
+pprIfDeclBndr :: ShowSub -> OccName -> SDoc
+pprIfDeclBndr (ShowSub { ss_ppr_bndr = ppr_bndr }) = ppr_bndr
instance Outputable IfaceClassOp where
- ppr (IfaceClassOp n dm ty) = ppr n <+> ppr dm <+> dcolon <+> ppr ty
+ ppr = pprIfaceClassOp showAll
+
+pprIfaceClassOp :: ShowSub -> IfaceClassOp -> SDoc
+pprIfaceClassOp ss (IfaceClassOp n dm ty) = hang opHdr 2 (pprIfaceSigmaType ty)
+ where opHdr = parenSymOcc n (pprIfDeclBndr ss n) <+>
+ ppShowIface ss (ppr dm) <+> dcolon
instance Outputable IfaceAT where
- ppr (IfaceAT d defs)
- = vcat [ ppr d
- , ppUnless (null defs) $ nest 2 $
- ptext (sLit "Defaults:") <+> vcat (map ppr defs) ]
-
-pprIfaceDeclHead :: IfaceContext -> OccName -> [IfaceTvBndr] -> SDoc
-pprIfaceDeclHead context thing tyvars
- = hsep [pprIfaceContextArr context, parenSymOcc thing (ppr thing),
- pprIfaceTvBndrs tyvars]
-
-pp_condecls :: OccName -> IfaceConDecls -> SDoc
-pp_condecls _ (IfAbstractTyCon {}) = empty
-pp_condecls _ IfDataFamTyCon = empty
-pp_condecls tc (IfNewTyCon c) = equals <+> pprIfaceConDecl tc c
-pp_condecls tc (IfDataTyCon cs) = equals <+> sep (punctuate (ptext (sLit " |"))
- (map (pprIfaceConDecl tc) cs))
-
-mkIfaceEqPred :: IfaceType -> IfaceType -> IfacePredType
--- IA0_NOTE: This is wrong, but only used for pretty-printing.
-mkIfaceEqPred ty1 ty2 = IfaceTyConApp (IfaceTc eqTyConName) [ty1, ty2]
-
-pprIfaceConDecl :: OccName -> IfaceConDecl -> SDoc
-pprIfaceConDecl tc
- (IfCon { ifConOcc = name, ifConInfix = is_infix, ifConWrapper = has_wrap,
+ ppr = pprIfaceAT showAll
+
+pprIfaceAT :: ShowSub -> IfaceAT -> SDoc
+pprIfaceAT ss (IfaceAT d defs)
+ = vcat [ pprIfaceDecl ss d
+ , ppUnless (null defs) $ nest 2 $
+ ptext (sLit "Defaults:") <+> vcat (map (pprAxBranch pp_tc) defs) ]
+ where
+ pp_tc = ppr (ifName d)
+
+instance Outputable IfaceTyConParent where
+ ppr p = pprIfaceTyConParent p
+
+pprIfaceTyConParent :: IfaceTyConParent -> SDoc
+pprIfaceTyConParent IfNoParent
+ = empty
+pprIfaceTyConParent (IfDataInstance _ tc tys)
+ = sdocWithDynFlags $ \dflags ->
+ let ftys = stripKindArgs dflags tys
+ in pprIfaceTypeApp tc ftys
+
+pprIfaceDeclHead :: IfaceContext -> ShowSub -> OccName -> [IfaceTvBndr] -> SDoc
+pprIfaceDeclHead context ss thing tyvars
+ = sdocWithDynFlags $ \ dflags ->
+ let ftyvars = stripIfaceKindVars dflags tyvars
+ in sep [pprIfaceContextArr context, parenSymOcc thing (pprIfDeclBndr ss thing)
+ <+> pprIfaceTvBndrs ftyvars]
+
+isVanillaIfaceConDecl :: IfaceConDecl -> Bool
+isVanillaIfaceConDecl (IfCon { ifConExTvs = ex_tvs
+ , ifConEqSpec = eq_spec
+ , ifConCtxt = ctxt })
+ = (null ex_tvs) && (null eq_spec) && (null ctxt)
+
+pprIfaceConDecl :: ShowSub -> Bool
+ -> ([IfaceTvBndr] -> IfaceEqSpec -> ([IfaceTvBndr], SDoc))
+ -> IfaceConDecl -> SDoc
+pprIfaceConDecl ss gadt_style mk_user_con_res_ty
+ (IfCon { ifConOcc = name, ifConInfix = is_infix,
ifConUnivTvs = univ_tvs, ifConExTvs = ex_tvs,
ifConEqSpec = eq_spec, ifConCtxt = ctxt, ifConArgTys = arg_tys,
- ifConStricts = strs, ifConFields = fields })
- = sep [main_payload,
- if is_infix then ptext (sLit "Infix") else empty,
- if has_wrap then ptext (sLit "HasWrapper") else empty,
- ppUnless (null strs) $
- nest 2 (ptext (sLit "Stricts:") <+> hsep (map ppr_bang strs)),
- ppUnless (null fields) $
- nest 2 (ptext (sLit "Fields:") <+> hsep (map ppr fields))]
+ ifConStricts = stricts, ifConFields = labels })
+ | gadt_style = qualName <+> dcolon <+> ppr_ty
+ | otherwise = ppr_fields tys_w_strs
where
- ppr_bang IfNoBang = char '_' -- Want to see these
- ppr_bang IfStrict = char '!'
- ppr_bang IfUnpack = ptext (sLit "!!")
- ppr_bang (IfUnpackCo co) = ptext (sLit "!!") <> pprParendIfaceCoercion co
+ tys_w_strs :: [(IfaceBang, IfaceType)]
+ tys_w_strs = zip stricts arg_tys
+ qualName = pprIfDeclBndr ss name
- main_payload = ppr name <+> dcolon <+>
- pprIfaceForAllPart (univ_tvs ++ ex_tvs) (eq_ctxt ++ ctxt) pp_tau
-
- eq_ctxt = [(mkIfaceEqPred (IfaceTyVar (occNameFS tv)) ty)
- | (tv,ty) <- eq_spec]
+ (univ_tvs', pp_res_ty) = mk_user_con_res_ty univ_tvs eq_spec
+ ppr_ty = pprIfaceForAllPart (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
@@ -1196,7 +1383,27 @@ pprIfaceConDecl tc
(t:ts) -> fsep (t : map (arrow <+>) ts)
[] -> panic "pp_con_taus"
- pp_res_ty = ppr tc <+> fsep [ppr tv | (tv,_) <- univ_tvs]
+ ppr_bang IfNoBang = ppWhen opt_PprStyle_Debug $ char '_'
+ ppr_bang IfStrict = char '!'
+ ppr_bang IfUnpack = ptext (sLit "{-# UNPACK #-}")
+ ppr_bang (IfUnpackCo co) = ptext (sLit "! {-# UNPACK #-}") <>
+ pprParendIfaceCoercion co
+
+ pprParendBangTy (bang, ty) = ppr_bang bang <> pprParendIfaceType ty
+ pprBangTy (bang, ty) = ppr_bang bang <> ppr ty
+
+ maybe_show_label (lbl,bty)
+ | showSub ss lbl = Just (pprIfDeclBndr ss lbl <+> dcolon <+> pprBangTy bty)
+ | otherwise = Nothing
+
+ ppr_fields [ty1, ty2]
+ | is_infix && null labels
+ = sep [pprParendBangTy ty1, pp_infix_name , pprParendBangTy ty2]
+ where pp_infix_name = pprInfixVar (isSymOcc name) qualName
+ ppr_fields fields
+ | null labels = qualName <+> sep (map pprParendBangTy fields)
+ | otherwise = qualName <+> (braces $ sep $ punctuate comma $ ppr_trim $
+ map maybe_show_label (zip labels fields))
instance Outputable IfaceRule where
ppr (IfaceRule { ifRuleName = name, ifActivation = act, ifRuleBndrs = bndrs,
@@ -1208,15 +1415,15 @@ instance Outputable IfaceRule where
]
instance Outputable IfaceClsInst where
- ppr (IfaceClsInst {ifDFun = dfun_id, ifOFlag = flag,
- ifInstCls = cls, ifInstTys = mb_tcs})
+ ppr (IfaceClsInst { ifDFun = dfun_id, ifOFlag = flag
+ , ifInstCls = cls, ifInstTys = mb_tcs})
= hang (ptext (sLit "instance") <+> ppr flag
<+> ppr cls <+> brackets (pprWithCommas ppr_rough mb_tcs))
2 (equals <+> ppr dfun_id)
instance Outputable IfaceFamInst where
- ppr (IfaceFamInst {ifFamInstFam = fam, ifFamInstTys = mb_tcs,
- ifFamInstAxiom = tycon_ax})
+ ppr (IfaceFamInst { ifFamInstFam = fam, ifFamInstTys = mb_tcs
+ , ifFamInstAxiom = tycon_ax})
= hang (ptext (sLit "family instance") <+>
ppr fam <+> pprWithCommas (brackets . ppr_rough) mb_tcs)
2 (equals <+> ppr tycon_ax)
@@ -1233,6 +1440,9 @@ ppr_rough (Just tc) = ppr tc
instance Outputable IfaceExpr where
ppr e = pprIfaceExpr noParens e
+noParens :: SDoc -> SDoc
+noParens pp = pp
+
pprParendIfaceExpr :: IfaceExpr -> SDoc
pprParendIfaceExpr = pprIfaceExpr parens
@@ -1378,7 +1588,7 @@ freeNamesIfDecl IfaceForeign{} =
emptyNameSet
freeNamesIfDecl d@IfaceData{} =
freeNamesIfTvBndrs (ifTyVars d) &&&
- maybe emptyNameSet unitNameSet (ifAxiom d) &&&
+ freeNamesIfaceTyConParent (ifParent d) &&&
freeNamesIfContext (ifCtxt d) &&&
freeNamesIfConDecls (ifCons d)
freeNamesIfDecl d@IfaceSyn{} =
@@ -1409,7 +1619,7 @@ freeNamesIfAxBranch (IfaceAxBranch { ifaxbTyVars = tyvars
, ifaxbLHS = lhs
, ifaxbRHS = rhs }) =
freeNamesIfTvBndrs tyvars &&&
- fnList freeNamesIfType lhs &&&
+ freeNamesIfTcArgs lhs &&&
freeNamesIfType rhs
freeNamesIfIdDetails :: IfaceIdDetails -> NameSet
@@ -1420,7 +1630,8 @@ freeNamesIfIdDetails _ = emptyNameSet
freeNamesIfSynRhs :: IfaceSynTyConRhs -> NameSet
freeNamesIfSynRhs (IfaceSynonymTyCon ty) = freeNamesIfType ty
freeNamesIfSynRhs IfaceOpenSynFamilyTyCon = emptyNameSet
-freeNamesIfSynRhs (IfaceClosedSynFamilyTyCon ax) = unitNameSet ax
+freeNamesIfSynRhs (IfaceClosedSynFamilyTyCon ax br)
+ = unitNameSet ax &&& fnList freeNamesIfAxBranch br
freeNamesIfSynRhs IfaceAbstractClosedSynFamilyTyCon = emptyNameSet
freeNamesIfContext :: IfaceContext -> NameSet
@@ -1450,15 +1661,21 @@ freeNamesIfConDecl c =
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
+
freeNamesIfType :: IfaceType -> NameSet
freeNamesIfType (IfaceTyVar _) = emptyNameSet
freeNamesIfType (IfaceAppTy s t) = freeNamesIfType s &&& freeNamesIfType t
freeNamesIfType (IfaceTyConApp tc ts) =
- freeNamesIfTc tc &&& fnList freeNamesIfType ts
+ freeNamesIfTc tc &&& freeNamesIfTcArgs ts
freeNamesIfType (IfaceLitTy _) = emptyNameSet
freeNamesIfType (IfaceForAllTy tv t) =
freeNamesIfTvBndr tv &&& freeNamesIfType t
freeNamesIfType (IfaceFunTy s t) = freeNamesIfType s &&& freeNamesIfType t
+freeNamesIfType (IfaceDFunTy s t) = freeNamesIfType s &&& freeNamesIfType t
freeNamesIfCoercion :: IfaceCoercion -> NameSet
freeNamesIfCoercion (IfaceReflCo _ t) = freeNamesIfType t
@@ -1540,8 +1757,7 @@ freeNamesIfExpr (IfaceCast e co) = freeNamesIfExpr e &&& freeNamesIfCoercion co
freeNamesIfExpr (IfaceTick _ e) = freeNamesIfExpr e
freeNamesIfExpr (IfaceECase e ty) = freeNamesIfExpr e &&& freeNamesIfType ty
freeNamesIfExpr (IfaceCase s _ alts)
- = freeNamesIfExpr s
- &&& fnList fn_alt alts &&& fn_cons alts
+ = freeNamesIfExpr s &&& fnList fn_alt alts &&& fn_cons alts
where
fn_alt (_con,_bs,r) = freeNamesIfExpr r
@@ -1563,7 +1779,7 @@ freeNamesIfExpr (IfaceLet (IfaceRec as) x)
freeNamesIfExpr _ = emptyNameSet
freeNamesIfTc :: IfaceTyCon -> NameSet
-freeNamesIfTc (IfaceTc tc) = unitNameSet tc
+freeNamesIfTc tc = unitNameSet (ifaceTyConName tc)
-- ToDo: shouldn't we include IfaceIntTc & co.?
freeNamesIfRule :: IfaceRule -> NameSet
@@ -1573,13 +1789,18 @@ freeNamesIfRule (IfaceRule { ifRuleBndrs = bs, ifRuleHead = f
fnList freeNamesIfBndr bs &&&
fnList freeNamesIfExpr es &&&
freeNamesIfExpr rhs
-
+
freeNamesIfFamInst :: IfaceFamInst -> NameSet
freeNamesIfFamInst (IfaceFamInst { ifFamInstFam = famName
, ifFamInstAxiom = axName })
= unitNameSet famName &&&
unitNameSet axName
+freeNamesIfaceTyConParent :: IfaceTyConParent -> NameSet
+freeNamesIfaceTyConParent IfNoParent = emptyNameSet
+freeNamesIfaceTyConParent (IfDataInstance ax tc tys)
+ = unitNameSet ax &&& freeNamesIfTc tc &&& freeNamesIfTcArgs tys
+
-- helpers
(&&&) :: NameSet -> NameSet -> NameSet
(&&&) = unionNameSets
@@ -1612,4 +1833,3 @@ not happen. Here's the one that bit me:
Now, lookupModule depends on DynFlags, but the transitive dependency
on the *locally-defined* type PackageState is not visible. We need
to take account of the use of the data constructor PS in the pattern match.
-
diff --git a/compiler/iface/IfaceType.lhs b/compiler/iface/IfaceType.lhs
index e4a789f0f5..4a19264432 100644
--- a/compiler/iface/IfaceType.lhs
+++ b/compiler/iface/IfaceType.lhs
@@ -6,17 +6,22 @@
This module defines interface types and binders
\begin{code}
+{-# LANGUAGE CPP #-}
module IfaceType (
IfExtName, IfLclName,
IfaceType(..), IfacePredType, IfaceKind, IfaceTyCon(..), IfaceCoercion(..),
- IfaceTyLit(..),
- IfaceContext, IfaceBndr(..), IfaceTvBndr, IfaceIdBndr,
+ IfaceTyLit(..), IfaceTcArgs(..),
+ IfaceContext, IfaceBndr(..), IfaceTvBndr, IfaceIdBndr,
-- Conversion from Type -> IfaceType
- toIfaceType, toIfaceKind, toIfaceContext,
- toIfaceBndr, toIfaceIdBndr, toIfaceTvBndrs,
- toIfaceTyCon, toIfaceTyCon_name,
+ toIfaceType, toIfaceTypes, toIfaceKind,
+ toIfaceContext, toIfaceBndr, toIfaceIdBndr,
+ toIfaceTvBndrs, toIfaceTyCon, toIfaceTyCon_name,
+ toIfaceTcArgs,
+
+ -- Conversion from IfaceTcArgs -> IfaceType
+ tcArgsIfaceTypes,
-- Conversion from Coercion -> IfaceCoercion
toIfaceCoercion,
@@ -24,31 +29,40 @@ module IfaceType (
-- Printing
pprIfaceType, pprParendIfaceType, pprIfaceContext, pprIfaceContextArr,
pprIfaceIdBndr, pprIfaceTvBndr, pprIfaceTvBndrs,
- pprIfaceBndrs,
- tOP_PREC, tYCON_PREC, noParens, maybeParen, pprIfaceForAllPart,
- pprIfaceCoercion, pprParendIfaceCoercion
-
+ pprIfaceBndrs, pprIfaceTcArgs, pprParendIfaceTcArgs,
+ pprIfaceForAllPart, pprIfaceForAll, pprIfaceSigmaType,
+ pprIfaceCoercion, pprParendIfaceCoercion,
+ splitIfaceSigmaTy, pprIfaceTypeApp, pprUserIfaceForAll,
+
+ suppressIfaceKinds,
+ stripIfaceKindVars,
+ stripKindArgs,
+ substIfaceType, substIfaceTyVar, substIfaceTcArgs, mkIfaceTySubst
) where
+#include "HsVersions.h"
+
import Coercion
+import DataCon ( dataConTyCon )
import TcType
import DynFlags
-import TypeRep hiding( maybeParen )
+import TypeRep
import Unique( hasKey )
-import TyCon
+import Util ( filterOut, lengthIs, zipWithEqual )
+import TyCon hiding ( pprPromotionQuote )
import CoAxiom
import Id
import Var
+-- import RnEnv( FastStringEnv, mkFsEnv, lookupFsEnv )
import TysWiredIn
import TysPrim
-import PrelNames( funTyConKey )
+import PrelNames( funTyConKey, ipClassName )
import Name
import BasicTypes
import Binary
import Outputable
import FastString
-
-import Control.Monad
+import UniqSet
\end{code}
%************************************************************************
@@ -77,8 +91,9 @@ data IfaceType -- A kind of universal type, used for types and kinds
= IfaceTyVar IfLclName -- Type/coercion variable only, not tycon
| IfaceAppTy IfaceType IfaceType
| IfaceFunTy IfaceType IfaceType
+ | IfaceDFunTy IfaceType IfaceType
| IfaceForAllTy IfaceTvBndr IfaceType
- | IfaceTyConApp IfaceTyCon [IfaceType] -- Not necessarily saturated
+ | IfaceTyConApp IfaceTyCon IfaceTcArgs -- Not necessarily saturated
-- Includes newtypes, synonyms, tuples
| IfaceLitTy IfaceTyLit
@@ -89,9 +104,24 @@ data IfaceTyLit
= IfaceNumTyLit Integer
| IfaceStrTyLit FastString
--- Encodes type constructors, kind constructors
--- coercion constructors, the lot
-newtype IfaceTyCon = IfaceTc { ifaceTyConName :: IfExtName }
+-- See Note [Suppressing kinds]
+-- 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
+
+-- Encodes type constructors, kind constructors,
+-- coercion constructors, the lot.
+-- We have to tag them in order to pretty print them
+-- properly.
+data IfaceTyCon
+ = IfaceTc { ifaceTyConName :: IfExtName }
+ | IfacePromotedDataCon { ifaceTyConName :: IfExtName }
+ | IfacePromotedTyCon { ifaceTyConName :: IfExtName }
data IfaceCoercion
= IfaceReflCo Role IfaceType
@@ -131,40 +161,167 @@ splitIfaceSigmaTy ty
= case split_foralls ty of { (tvs, rho) -> (tv:tvs, rho) }
split_foralls rho = ([], rho)
- split_rho (IfaceFunTy ty1 ty2)
- | isIfacePredTy ty1 = case split_rho ty2 of { (ps, tau) -> (ty1:ps, tau) }
+ 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
+ | 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
+
+stripIfaceKindVars :: DynFlags -> [IfaceTvBndr] -> [IfaceTvBndr]
+stripIfaceKindVars dflags tyvars
+ | gopt Opt_PrintExplicitKinds dflags = tyvars
+ | otherwise = filterOut isIfaceKindVar tyvars
+
+isIfaceKindVar :: IfaceTvBndr -> Bool
+isIfaceKindVar (_, IfaceTyConApp tc _) = ifaceTyConName tc == superKindTyConName
+isIfaceKindVar _ = False
+
+ifTyVarsOfType :: IfaceType -> UniqSet IfLclName
+ifTyVarsOfType ty
+ = case ty of
+ IfaceTyVar v -> unitUniqSet v
+ IfaceAppTy fun arg
+ -> ifTyVarsOfType fun `unionUniqSets` ifTyVarsOfType arg
+ IfaceFunTy arg res
+ -> 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
+ IfaceLitTy _ -> emptyUniqSet
+
+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
+\end{code}
+
+Substitutions on IfaceType. This is only used during pretty-printing to construct
+the result type of a GADT, and does not deal with binders (eg IfaceForAll), so
+it doesn't need fancy capture stuff.
+
+\begin{code}
+type IfaceTySubst = FastStringEnv IfaceType
+
+mkIfaceTySubst :: [IfaceTvBndr] -> [IfaceType] -> IfaceTySubst
+mkIfaceTySubst tvs tys = mkFsEnv $ zipWithEqual "mkIfaceTySubst" (\(fs,_) ty -> (fs,ty)) tvs tys
+
+substIfaceType :: IfaceTySubst -> IfaceType -> IfaceType
+substIfaceType env ty
+ = go ty
+ where
+ go (IfaceTyVar tv) = substIfaceTyVar env tv
+ go (IfaceAppTy t1 t2) = IfaceAppTy (go t1) (go t2)
+ go (IfaceFunTy t1 t2) = IfaceFunTy (go t1) (go t2)
+ go (IfaceDFunTy t1 t2) = IfaceDFunTy (go t1) (go t2)
+ go ty@(IfaceLitTy {}) = ty
+ go (IfaceTyConApp tc tys) = IfaceTyConApp tc (substIfaceTcArgs env tys)
+ go (IfaceForAllTy {}) = pprPanic "substIfaceType" (ppr ty)
+
+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)
+
+substIfaceTyVar :: IfaceTySubst -> IfLclName -> IfaceType
+substIfaceTyVar env tv
+ | Just ty <- lookupFsEnv env tv = ty
+ | otherwise = IfaceTyVar tv
\end{code}
%************************************************************************
%* *
- Pretty-printing
+ Functions over IFaceTcArgs
+%* *
+%************************************************************************
+
+
+\begin{code}
+stripKindArgs :: DynFlags -> IfaceTcArgs -> IfaceTcArgs
+stripKindArgs dflags tys
+ | gopt Opt_PrintExplicitKinds dflags = tys
+ | otherwise = suppressKinds tys
+ where
+ suppressKinds c
+ = case c of
+ ITC_Kind _ ts -> suppressKinds ts
+ _ -> c
+
+toIfaceTcArgs :: TyCon -> [Type] -> IfaceTcArgs
+-- See Note [Suppressing kinds]
+toIfaceTcArgs tc ty_args
+ = go (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
+
+tcArgsIfaceTypes :: IfaceTcArgs -> [IfaceType]
+tcArgsIfaceTypes ITC_Nil = []
+tcArgsIfaceTypes (ITC_Kind t ts) = t : tcArgsIfaceTypes ts
+tcArgsIfaceTypes (ITC_Type t ts) = t : tcArgsIfaceTypes ts
+\end{code}
+
+Note [Suppressing kinds]
+~~~~~~~~~~~~~~~~~~~~~~~~
+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.
+For example, given
+ T :: forall k. (k->*) -> k -> * -- Ordinary kind polymorphism
+ 'Just :: forall k. k -> 'Maybe k -- Promoted
+we want
+ T * Tree Int prints as T Tree Int
+ 'Just * prints as Just *
+
+
+%************************************************************************
+%* *
+ Functions over IFaceTyCon
%* *
%************************************************************************
-Precedence
-~~~~~~~~~~
-@ppr_ty@ takes an @Int@ that is the precedence of the context.
-The precedence levels are:
-\begin{description}
-\item[tOP_PREC] No parens required.
-\item[fUN_PREC] Left hand argument of a function arrow.
-\item[tYCON_PREC] Argument of a type constructor.
-\end{description}
+\begin{code}
+--isPromotedIfaceTyCon :: IfaceTyCon -> Bool
+--isPromotedIfaceTyCon (IfacePromotedTyCon _) = True
+--isPromotedIfaceTyCon _ = False
+\end{code}
+%************************************************************************
+%* *
+ Pretty-printing
+%* *
+%************************************************************************
\begin{code}
-tOP_PREC, fUN_PREC, tYCON_PREC :: Int
-tOP_PREC = 0 -- type in ParseIface.y
-fUN_PREC = 1 -- btype in ParseIface.y
-tYCON_PREC = 2 -- atype in ParseIface.y
-
-noParens :: SDoc -> SDoc
-noParens pp = pp
-
-maybeParen :: Int -> Int -> SDoc -> SDoc
-maybeParen ctxt_prec inner_prec pretty
- | ctxt_prec < inner_prec = pretty
- | otherwise = parens pretty
+pprIfaceInfixApp :: (TyPrec -> a -> SDoc) -> TyPrec -> SDoc -> a -> a -> SDoc
+pprIfaceInfixApp pp p pp_tc ty1 ty2
+ = maybeParen p FunPrec $
+ sep [pp FunPrec ty1, pprInfixVar True pp_tc <+> pp FunPrec ty2]
+
+pprIfacePrefixApp :: TyPrec -> SDoc -> [SDoc] -> SDoc
+pprIfacePrefixApp p pp_fun pp_tys
+ | null pp_tys = pp_fun
+ | otherwise = maybeParen p TyConPrec $
+ hang pp_fun 2 (sep pp_tys)
\end{code}
@@ -182,9 +339,9 @@ pprIfaceIdBndr :: (IfLclName, IfaceType) -> SDoc
pprIfaceIdBndr (name, ty) = hsep [ppr name, dcolon, ppr ty]
pprIfaceTvBndr :: IfaceTvBndr -> SDoc
-pprIfaceTvBndr (tv, IfaceTyConApp tc [])
+pprIfaceTvBndr (tv, IfaceTyConApp tc ITC_Nil)
| ifaceTyConName tc == liftedTypeKindTyConName = ppr tv
-pprIfaceTvBndr (tv, kind) = parens (ppr tv <> dcolon <> ppr kind)
+pprIfaceTvBndr (tv, kind) = parens (ppr tv <+> dcolon <+> ppr kind)
pprIfaceTvBndrs :: [IfaceTvBndr] -> SDoc
pprIfaceTvBndrs tyvars = sep (map pprIfaceTvBndr tyvars)
@@ -213,109 +370,200 @@ instance Outputable IfaceType where
ppr ty = pprIfaceType ty
pprIfaceType, pprParendIfaceType ::IfaceType -> SDoc
-pprIfaceType = ppr_ty tOP_PREC
-pprParendIfaceType = ppr_ty tYCON_PREC
-
-isIfacePredTy :: IfaceType -> Bool
-isIfacePredTy _ = False
--- FIXME: fix this to print iface pred tys correctly
--- isIfacePredTy ty = isConstraintKind (ifaceTypeKind ty)
+pprIfaceType = ppr_ty TopPrec
+pprParendIfaceType = ppr_ty TyConPrec
-ppr_ty :: Int -> IfaceType -> SDoc
+ppr_ty :: TyPrec -> IfaceType -> SDoc
ppr_ty _ (IfaceTyVar tyvar) = ppr tyvar
-ppr_ty ctxt_prec (IfaceTyConApp tc tys) = ppr_tc_app ppr_ty ctxt_prec tc tys
-
-ppr_ty _ (IfaceLitTy n) = ppr_tylit n
-
+ppr_ty ctxt_prec (IfaceTyConApp tc tys) = sdocWithDynFlags (pprTyTcApp ctxt_prec tc tys)
+ppr_ty _ (IfaceLitTy n) = ppr_tylit n
-- Function types
ppr_ty ctxt_prec (IfaceFunTy ty1 ty2)
= -- We don't want to lose synonyms, so we mustn't use splitFunTys here.
- maybeParen ctxt_prec fUN_PREC $
- sep (ppr_ty fUN_PREC ty1 : ppr_fun_tail ty2)
+ maybeParen ctxt_prec FunPrec $
+ sep [ppr_ty FunPrec ty1, sep (ppr_fun_tail ty2)]
where
- arr | isIfacePredTy ty1 = darrow
- | otherwise = arrow
-
ppr_fun_tail (IfaceFunTy ty1 ty2)
- = (arr <+> ppr_ty fUN_PREC ty1) : ppr_fun_tail ty2
+ = (arrow <+> ppr_ty FunPrec ty1) : ppr_fun_tail ty2
ppr_fun_tail other_ty
- = [arr <+> pprIfaceType other_ty]
+ = [arrow <+> pprIfaceType other_ty]
ppr_ty ctxt_prec (IfaceAppTy ty1 ty2)
- = maybeParen ctxt_prec tYCON_PREC $
- ppr_ty fUN_PREC ty1 <+> pprParendIfaceType ty2
+ = maybeParen ctxt_prec TyConPrec $
+ ppr_ty FunPrec ty1 <+> pprParendIfaceType ty2
-ppr_ty ctxt_prec ty@(IfaceForAllTy _ _)
- = maybeParen ctxt_prec fUN_PREC (pprIfaceForAllPart tvs theta (pprIfaceType tau))
- where
- (tvs, theta, tau) = splitIfaceSigmaTy ty
+ppr_ty ctxt_prec ty
+ = maybeParen ctxt_prec FunPrec (ppr_iface_sigma_type True ty)
+
+instance Outputable IfaceTcArgs where
+ ppr tca = pprIfaceTcArgs tca
+
+pprIfaceTcArgs, pprParendIfaceTcArgs :: IfaceTcArgs -> SDoc
+pprIfaceTcArgs = ppr_tc_args TopPrec
+pprParendIfaceTcArgs = ppr_tc_args TyConPrec
+
+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
-------------------
--- needs to handle type contexts and coercion contexts, hence the
--- generality
-pprIfaceForAllPart :: Outputable a => [IfaceTvBndr] -> [a] -> SDoc -> SDoc
-pprIfaceForAllPart tvs ctxt doc
- = sep [ppr_tvs, pprIfaceContextArr ctxt, doc]
+ppr_iface_sigma_type :: Bool -> IfaceType -> SDoc
+ppr_iface_sigma_type show_foralls_unconditionally ty
+ = ppr_iface_forall_part show_foralls_unconditionally tvs theta (ppr tau)
where
- ppr_tvs | null tvs = empty
- | otherwise = sdocWithDynFlags $ \ dflags ->
- if gopt Opt_PrintExplicitForalls dflags
- then ptext (sLit "forall") <+> pprIfaceTvBndrs tvs <> dot
- else empty
+ (tvs, theta, tau) = splitIfaceSigmaTy ty
+pprIfaceForAllPart :: Outputable a => [IfaceTvBndr] -> [a] -> SDoc -> SDoc
+pprIfaceForAllPart tvs ctxt sdoc = ppr_iface_forall_part False tvs ctxt sdoc
+
+ppr_iface_forall_part :: Outputable a
+ => Bool -> [IfaceTvBndr] -> [a] -> SDoc -> SDoc
+ppr_iface_forall_part show_foralls_unconditionally tvs ctxt sdoc
+ = sep [ if show_foralls_unconditionally
+ then pprIfaceForAll tvs
+ else pprUserIfaceForAll tvs
+ , pprIfaceContextArr ctxt
+ , sdoc]
+
+pprIfaceForAll :: [IfaceTvBndr] -> SDoc
+pprIfaceForAll [] = empty
+pprIfaceForAll tvs = ptext (sLit "forall") <+> pprIfaceTvBndrs tvs <> dot
+
+pprIfaceSigmaType :: IfaceType -> SDoc
+pprIfaceSigmaType ty = ppr_iface_sigma_type False ty
+
+pprUserIfaceForAll :: [IfaceTvBndr] -> 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))
-------------------
-ppr_tc_app :: (Int -> a -> SDoc) -> Int -> IfaceTyCon -> [a] -> SDoc
-ppr_tc_app _ _ tc [] = ppr_tc tc
-
-
-ppr_tc_app pp _ (IfaceTc n) [ty]
- | n == listTyConName
- = brackets (pp tOP_PREC ty)
- | n == parrTyConName
- = paBrackets (pp tOP_PREC ty)
-ppr_tc_app pp _ (IfaceTc n) tys
- | Just (ATyCon tc) <- wiredInNameTyThing_maybe n
- , Just sort <- tyConTuple_maybe tc
- , tyConArity tc == length tys
- = tupleParens sort (sep (punctuate comma (map (pp tOP_PREC) tys)))
-ppr_tc_app pp ctxt_prec tc tys
- = maybeParen ctxt_prec tYCON_PREC
- (sep [ppr_tc tc, nest 4 (sep (map (pp tYCON_PREC) tys))])
-
-ppr_tc :: IfaceTyCon -> SDoc
--- Wrap infix type constructors in parens
-ppr_tc tc = wrap (ifaceTyConName tc) (ppr tc)
+
+-- See equivalent function in TypeRep.lhs
+pprIfaceTyList :: TyPrec -> IfaceType -> IfaceType -> SDoc
+-- Given a type-level list (t1 ': t2), see if we can print
+-- it in list notation [t1, ...].
+-- Precondition: Opt_PrintExplicitKinds is off
+pprIfaceTyList ctxt_prec ty1 ty2
+ = case gather ty2 of
+ (arg_tys, Nothing)
+ -> char '\'' <> brackets (fsep (punctuate comma
+ (map (ppr_ty TopPrec) (ty1:arg_tys))))
+ (arg_tys, Just tl)
+ -> maybeParen ctxt_prec FunPrec $ hang (ppr_ty FunPrec ty1)
+ 2 (fsep [ colon <+> ppr_ty FunPrec ty | ty <- arg_tys ++ [tl]])
+ where
+ gather :: IfaceType -> ([IfaceType], Maybe IfaceType)
+ -- (gather ty) = (tys, Nothing) means ty is a list [t1, .., tn]
+ -- = (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
+ , (args, tl) <- gather ty2
+ = (ty1:args, tl)
+ | tcname == nilDataConName
+ = ([], Nothing)
+ where tcname = ifaceTyConName tc
+ gather ty = ([], Just ty)
+
+pprIfaceTypeApp :: IfaceTyCon -> IfaceTcArgs -> SDoc
+pprIfaceTypeApp tc args = sdocWithDynFlags (pprTyTcApp TopPrec tc args)
+
+pprTyTcApp :: TyPrec -> IfaceTyCon -> IfaceTcArgs -> DynFlags -> SDoc
+pprTyTcApp ctxt_prec tc tys dflags
+ | ifaceTyConName tc == ipClassName
+ , ITC_Type (IfaceLitTy (IfaceStrTyLit n)) (ITC_Type 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
+ = pprIfaceTyList ctxt_prec ty1 ty2
+
+ | otherwise
+ = ppr_iface_tc_app ppr_ty ctxt_prec tc tys_wo_kinds
+ where
+ tys_wo_kinds = tcArgsIfaceTypes $ stripKindArgs dflags tys
+
+pprIfaceCoTcApp :: TyPrec -> IfaceTyCon -> [IfaceCoercion] -> SDoc
+pprIfaceCoTcApp ctxt_prec tc tys = ppr_iface_tc_app ppr_co ctxt_prec tc tys
+
+ppr_iface_tc_app :: (TyPrec -> a -> SDoc) -> TyPrec -> IfaceTyCon -> [a] -> SDoc
+ppr_iface_tc_app pp _ tc [ty]
+ | n == listTyConName = pprPromotionQuote tc <> brackets (pp TopPrec ty)
+ | n == parrTyConName = pprPromotionQuote tc <> paBrackets (pp TopPrec ty)
+ where
+ n = ifaceTyConName tc
+
+ppr_iface_tc_app pp ctxt_prec tc tys
+ | Just (tup_sort, tup_args) <- is_tuple
+ = pprPromotionQuote tc <>
+ tupleParens tup_sort (sep (punctuate comma (map (pp TopPrec) tup_args)))
+
+ | not (isSymOcc (nameOccName tc_name))
+ = pprIfacePrefixApp ctxt_prec (ppr tc) (map (pp TyConPrec) tys)
+
+ | [ty1,ty2] <- tys -- Infix, two arguments;
+ -- we know nothing of precedence though
+ = pprIfaceInfixApp pp ctxt_prec (ppr tc) ty1 ty2
+
+ | tc_name == liftedTypeKindTyConName || tc_name == unliftedTypeKindTyConName
+ = ppr tc -- Do not wrap *, # in parens
+
+ | otherwise
+ = pprIfacePrefixApp ctxt_prec (parens (ppr tc)) (map (pp TyConPrec) tys)
where
- -- The kind * does not get wrapped in parens.
- wrap name | name == liftedTypeKindTyConName = id
- wrap name = parenSymOcc (getOccName name)
+ tc_name = ifaceTyConName tc
+
+ is_tuple = case wiredInNameTyThing_maybe tc_name of
+ Just (ATyCon tc)
+ | Just sort <- tyConTuple_maybe tc
+ , tyConArity tc == length tys
+ -> Just (sort, tys)
+
+ | Just dc <- isPromotedDataCon_maybe tc
+ , let dc_tc = dataConTyCon dc
+ , isTupleTyCon dc_tc
+ , let arity = tyConArity dc_tc
+ ty_args = drop arity tys
+ , ty_args `lengthIs` arity
+ -> Just (tupleTyConSort tc, ty_args)
+
+ _ -> Nothing
+
ppr_tylit :: IfaceTyLit -> SDoc
ppr_tylit (IfaceNumTyLit n) = integer n
ppr_tylit (IfaceStrTyLit n) = text (show n)
pprIfaceCoercion, pprParendIfaceCoercion :: IfaceCoercion -> SDoc
-pprIfaceCoercion = ppr_co tOP_PREC
-pprParendIfaceCoercion = ppr_co tYCON_PREC
+pprIfaceCoercion = ppr_co TopPrec
+pprParendIfaceCoercion = ppr_co TyConPrec
-ppr_co :: Int -> IfaceCoercion -> SDoc
+ppr_co :: TyPrec -> IfaceCoercion -> SDoc
ppr_co _ (IfaceReflCo r ty) = angleBrackets (ppr ty) <> ppr_role r
ppr_co ctxt_prec (IfaceFunCo r co1 co2)
- = maybeParen ctxt_prec fUN_PREC $
- sep (ppr_co fUN_PREC co1 : ppr_fun_tail co2)
+ = maybeParen ctxt_prec FunPrec $
+ sep (ppr_co FunPrec co1 : ppr_fun_tail co2)
where
ppr_fun_tail (IfaceFunCo r co1 co2)
- = (arrow <> ppr_role r <+> ppr_co fUN_PREC co1) : ppr_fun_tail co2
+ = (arrow <> ppr_role r <+> ppr_co FunPrec co1) : ppr_fun_tail co2
ppr_fun_tail other_co
= [arrow <> ppr_role r <+> pprIfaceCoercion other_co]
ppr_co _ (IfaceTyConAppCo r tc cos)
- = parens (ppr_tc_app ppr_co tOP_PREC tc cos) <> ppr_role r
+ = parens (pprIfaceCoTcApp TopPrec tc cos) <> ppr_role r
ppr_co ctxt_prec (IfaceAppCo co1 co2)
- = maybeParen ctxt_prec tYCON_PREC $
- ppr_co fUN_PREC co1 <+> pprParendIfaceCoercion co2
+ = maybeParen ctxt_prec TyConPrec $
+ ppr_co FunPrec co1 <+> pprParendIfaceCoercion co2
ppr_co ctxt_prec co@(IfaceForAllCo _ _)
- = maybeParen ctxt_prec fUN_PREC (sep [ppr_tvs, pprIfaceCoercion inner_co])
+ = maybeParen ctxt_prec FunPrec (sep [ppr_tvs, pprIfaceCoercion inner_co])
where
(tvs, inner_co) = split_co co
ppr_tvs = ptext (sLit "forall") <+> pprIfaceTvBndrs tvs <> dot
@@ -327,16 +575,16 @@ ppr_co ctxt_prec co@(IfaceForAllCo _ _)
ppr_co _ (IfaceCoVarCo covar) = ppr covar
ppr_co ctxt_prec (IfaceUnivCo r ty1 ty2)
- = maybeParen ctxt_prec tYCON_PREC $
+ = maybeParen ctxt_prec TyConPrec $
ptext (sLit "UnivCo") <+> ppr r <+>
pprParendIfaceType ty1 <+> pprParendIfaceType ty2
ppr_co ctxt_prec (IfaceInstCo co ty)
- = maybeParen ctxt_prec tYCON_PREC $
+ = maybeParen ctxt_prec TyConPrec $
ptext (sLit "Inst") <+> pprParendIfaceCoercion co <+> pprParendIfaceType ty
ppr_co ctxt_prec (IfaceAxiomRuleCo tc tys cos)
- = maybeParen ctxt_prec tYCON_PREC
+ = maybeParen ctxt_prec TyConPrec
(sep [ppr tc, nest 4 (sep (map pprParendIfaceType tys ++ map pprParendIfaceCoercion cos))])
ppr_co ctxt_prec co
@@ -351,9 +599,9 @@ ppr_co ctxt_prec co
; IfaceSubCo co -> (ptext (sLit "Sub"), [co])
; _ -> panic "pprIfaceCo" }
-ppr_special_co :: Int -> SDoc -> [IfaceCoercion] -> SDoc
+ppr_special_co :: TyPrec -> SDoc -> [IfaceCoercion] -> SDoc
ppr_special_co ctxt_prec doc cos
- = maybeParen ctxt_prec tYCON_PREC
+ = maybeParen ctxt_prec TyConPrec
(sep [doc, nest 4 (sep (map pprParendIfaceCoercion cos))])
ppr_role :: Role -> SDoc
@@ -365,14 +613,30 @@ ppr_role r = underscore <> pp_role
-------------------
instance Outputable IfaceTyCon where
- ppr = ppr . ifaceTyConName
+ ppr tc = pprPromotionQuote tc <> ppr (ifaceTyConName tc)
+
+pprPromotionQuote :: IfaceTyCon -> SDoc
+pprPromotionQuote (IfacePromotedDataCon _ ) = char '\''
+pprPromotionQuote (IfacePromotedTyCon _) = ifPprDebug (char '\'')
+pprPromotionQuote _ = empty
instance Outputable IfaceCoercion where
ppr = pprIfaceCoercion
instance Binary IfaceTyCon where
- put_ bh (IfaceTc ext) = put_ bh ext
- get bh = liftM IfaceTc (get bh)
+ put_ bh tc =
+ case tc of
+ IfaceTc n -> putByte bh 0 >> put_ bh n
+ IfacePromotedDataCon n -> putByte bh 1 >> put_ bh n
+ IfacePromotedTyCon n -> putByte bh 2 >> put_ bh n
+
+ get bh =
+ do tc <- getByte bh
+ case tc of
+ 0 -> get bh >>= return . IfaceTc
+ 1 -> get bh >>= return . IfacePromotedDataCon
+ 2 -> get bh >>= return . IfacePromotedTyCon
+ _ -> panic ("get IfaceTyCon " ++ show tc)
instance Outputable IfaceTyLit where
ppr = ppr_tylit
@@ -390,6 +654,27 @@ instance Binary IfaceTyLit where
; return (IfaceStrTyLit n) }
_ -> panic ("get IfaceTyLit " ++ show tag)
+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
+
+ get bh =
+ do c <- getByte bh
+ case c of
+ 0 -> do
+ t <- get bh
+ ts <- get bh
+ return $! ITC_Type t ts
+ 1 -> do
+ t <- get bh
+ ts <- get bh
+ return $! ITC_Kind t ts
+ 2 -> return ITC_Nil
+ _ -> panic ("get IfaceTcArgs " ++ show c)
+
-------------------
pprIfaceContextArr :: Outputable a => [a] -> SDoc
-- Prints "(C a, D b) =>", including the arrow
@@ -398,7 +683,7 @@ pprIfaceContextArr theta = pprIfaceContext theta <+> darrow
pprIfaceContext :: Outputable a => [a] -> SDoc
pprIfaceContext [pred] = ppr pred -- No parens
-pprIfaceContext preds = parens (sep (punctuate comma (map ppr preds)))
+pprIfaceContext preds = parens (fsep (punctuate comma (map ppr preds)))
instance Binary IfaceType where
put_ bh (IfaceForAllTy aa ab) = do
@@ -416,6 +701,10 @@ instance Binary IfaceType where
putByte bh 3
put_ bh ag
put_ bh ah
+ put_ bh (IfaceDFunTy ag ah) = do
+ putByte bh 4
+ put_ bh ag
+ put_ bh ah
put_ bh (IfaceTyConApp tc tys)
= do { putByte bh 5; put_ bh tc; put_ bh tys }
@@ -436,9 +725,11 @@ instance Binary IfaceType where
3 -> do ag <- get bh
ah <- get bh
return (IfaceFunTy ag ah)
+ 4 -> do ag <- get bh
+ ah <- get bh
+ return (IfaceDFunTy ag ah)
5 -> do { tc <- get bh; tys <- get bh
; return (IfaceTyConApp tc tys) }
-
30 -> do n <- get bh
return (IfaceLitTy n)
@@ -558,7 +849,7 @@ instance Binary IfaceCoercion where
b <- get bh
c <- get bh
return $ IfaceAxiomRuleCo a b c
- _ -> panic ("get IfaceCoercion " ++ show tag)
+ _ -> panic ("get IfaceCoercion " ++ show tag)
\end{code}
@@ -590,8 +881,10 @@ toIfaceType :: Type -> IfaceType
-- Synonyms are retained in the interface type
toIfaceType (TyVarTy tv) = IfaceTyVar (toIfaceTyVar tv)
toIfaceType (AppTy t1 t2) = IfaceAppTy (toIfaceType t1) (toIfaceType t2)
-toIfaceType (FunTy t1 t2) = IfaceFunTy (toIfaceType t1) (toIfaceType t2)
-toIfaceType (TyConApp tc tys) = IfaceTyConApp (toIfaceTyCon tc) (toIfaceTypes tys)
+toIfaceType (FunTy t1 t2)
+ | isPredTy t1 = IfaceDFunTy (toIfaceType t1) (toIfaceType t2)
+ | otherwise = IfaceFunTy (toIfaceType t1) (toIfaceType t2)
+toIfaceType (TyConApp tc tys) = IfaceTyConApp (toIfaceTyCon tc) (toIfaceTcArgs tc tys)
toIfaceType (LitTy n) = IfaceLitTy (toIfaceTyLit n)
toIfaceType (ForAllTy tv t) = IfaceForAllTy (toIfaceTvBndr tv) (toIfaceType t)
@@ -603,7 +896,11 @@ toIfaceCoVar = occNameFS . getOccName
----------------
toIfaceTyCon :: TyCon -> IfaceTyCon
-toIfaceTyCon = toIfaceTyCon_name . tyConName
+toIfaceTyCon tc
+ | isPromotedDataCon tc = IfacePromotedDataCon tc_name
+ | isPromotedTyCon tc = IfacePromotedTyCon tc_name
+ | otherwise = IfaceTc tc_name
+ where tc_name = tyConName tc
toIfaceTyCon_name :: Name -> IfaceTyCon
toIfaceTyCon_name = IfaceTc
@@ -652,4 +949,3 @@ toIfaceCoercion (AxiomRuleCo co ts cs) = IfaceAxiomRuleCo
(map toIfaceType ts)
(map toIfaceCoercion cs)
\end{code}
-
diff --git a/compiler/iface/LoadIface.lhs b/compiler/iface/LoadIface.lhs
index 8f02282d26..03ce53fff8 100644
--- a/compiler/iface/LoadIface.lhs
+++ b/compiler/iface/LoadIface.lhs
@@ -753,7 +753,7 @@ pprModIface iface
, vcat (map pprUsage (mi_usages iface))
, vcat (map pprIfaceAnnotation (mi_anns iface))
, pprFixities (mi_fixities iface)
- , vcat (map pprIfaceDecl (mi_decls iface))
+ , vcat [ppr ver $$ nest 2 (ppr decl) | (ver,decl) <- mi_decls iface]
, vcat (map ppr (mi_insts iface))
, vcat (map ppr (mi_fam_insts iface))
, vcat (map ppr (mi_rules iface))
@@ -819,10 +819,6 @@ pprDeps (Deps { dep_mods = mods, dep_pkgs = pkgs, dep_orphs = orphs,
ppr_boot True = text "[boot]"
ppr_boot False = empty
-pprIfaceDecl :: (Fingerprint, IfaceDecl) -> SDoc
-pprIfaceDecl (ver, decl)
- = ppr ver $$ nest 2 (ppr decl)
-
pprFixities :: [(OccName, Fixity)] -> SDoc
pprFixities [] = empty
pprFixities fixes = ptext (sLit "fixities") <+> pprWithCommas pprFix fixes
diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs
index d1a8605b9c..e01097e7b0 100644
--- a/compiler/iface/MkIface.lhs
+++ b/compiler/iface/MkIface.lhs
@@ -80,6 +80,7 @@ import DataCon
import PatSyn
import Type
import TcType
+import TysPrim ( alphaTyVars )
import InstEnv
import FamInstEnv
import TcRnMonad
@@ -1529,18 +1530,18 @@ coAxiomToIfaceDecl ax@(CoAxiom { co_ax_tc = tycon, co_ax_branches = branches
, ifTyCon = toIfaceTyCon tycon
, ifRole = role
, ifAxBranches = brListMap (coAxBranchToIfaceBranch
- emptyTidyEnv
- (brListMap coAxBranchLHS branches)) branches }
+ (brListMap coAxBranchLHS branches))
+ branches }
where
name = getOccName ax
-- 2nd parameter is the list of branch LHSs, for conversion from incompatible branches
-- to incompatible indices
-- See Note [Storing compatibility] in CoAxiom
-coAxBranchToIfaceBranch :: TidyEnv -> [[Type]] -> CoAxBranch -> IfaceAxBranch
-coAxBranchToIfaceBranch env0 lhs_s
+coAxBranchToIfaceBranch :: [[Type]] -> CoAxBranch -> IfaceAxBranch
+coAxBranchToIfaceBranch lhs_s
branch@(CoAxBranch { cab_incomps = incomps })
- = (coAxBranchToIfaceBranch' env0 branch) { ifaxbIncomps = iface_incomps }
+ = (coAxBranchToIfaceBranch' branch) { ifaxbIncomps = iface_incomps }
where
iface_incomps = map (expectJust "iface_incomps"
. (flip findIndex lhs_s
@@ -1548,17 +1549,16 @@ coAxBranchToIfaceBranch env0 lhs_s
. coAxBranchLHS) incomps
-- use this one for standalone branches without incompatibles
-coAxBranchToIfaceBranch' :: TidyEnv -> CoAxBranch -> IfaceAxBranch
-coAxBranchToIfaceBranch' env0
- (CoAxBranch { cab_tvs = tvs, cab_lhs = lhs
- , cab_roles = roles, cab_rhs = rhs })
+coAxBranchToIfaceBranch' :: CoAxBranch -> IfaceAxBranch
+coAxBranchToIfaceBranch' (CoAxBranch { cab_tvs = tvs, cab_lhs = lhs
+ , cab_roles = roles, cab_rhs = rhs })
= IfaceAxBranch { ifaxbTyVars = toIfaceTvBndrs tv_bndrs
- , ifaxbLHS = map (tidyToIfaceType env1) lhs
+ , ifaxbLHS = tidyToIfaceTcArgs env1 lhs
, ifaxbRoles = roles
, ifaxbRHS = tidyToIfaceType env1 rhs
, ifaxbIncomps = [] }
where
- (env1, tv_bndrs) = tidyTyClTyVarBndrs env0 tvs
+ (env1, tv_bndrs) = tidyTyClTyVarBndrs emptyTidyEnv tvs
-- Don't re-bind in-scope tyvars
-- See Note [CoAxBranch type variables] in CoAxiom
@@ -1587,24 +1587,48 @@ tyConToIfaceDecl env tycon
ifRec = boolToRecFlag (isRecursiveTyCon tycon),
ifGadtSyntax = isGadtSyntaxTyCon tycon,
ifPromotable = isJust (promotableTyCon_maybe tycon),
- ifAxiom = fmap coAxiomName (tyConFamilyCoercion_maybe tycon) }
+ ifParent = parent }
| isForeignTyCon tycon
= IfaceForeign { ifName = getOccName tycon,
ifExtName = tyConExtName tycon }
- | otherwise = pprPanic "toIfaceDecl" (ppr tycon)
+ | otherwise
+ -- For pretty printing purposes only.
+ = IfaceData { ifName = getOccName tycon,
+ ifCType = Nothing,
+ ifTyVars = funAndPrimTyVars,
+ ifRoles = tyConRoles tycon,
+ ifCtxt = [],
+ ifCons = IfDataTyCon [],
+ ifRec = boolToRecFlag False,
+ ifGadtSyntax = False,
+ ifPromotable = False,
+ ifParent = IfNoParent }
where
(env1, tyvars) = tidyTyClTyVarBndrs env (tyConTyVars tycon)
- to_ifsyn_rhs OpenSynFamilyTyCon = IfaceOpenSynFamilyTyCon
- to_ifsyn_rhs (ClosedSynFamilyTyCon ax)
- = IfaceClosedSynFamilyTyCon (coAxiomName ax)
- to_ifsyn_rhs AbstractClosedSynFamilyTyCon = IfaceAbstractClosedSynFamilyTyCon
+ funAndPrimTyVars = toIfaceTvBndrs $ take (tyConArity tycon) alphaTyVars
+
+ parent = case tyConFamInstSig_maybe tycon of
+ Just (tc, ty, ax) -> IfDataInstance (coAxiomName ax)
+ (toIfaceTyCon tc)
+ (toIfaceTcArgs tc ty)
+ Nothing -> IfNoParent
+
+ to_ifsyn_rhs OpenSynFamilyTyCon = IfaceOpenSynFamilyTyCon
+ to_ifsyn_rhs (ClosedSynFamilyTyCon ax) = IfaceClosedSynFamilyTyCon axn ibr
+ where defs = fromBranchList $ coAxiomBranches ax
+ ibr = map coAxBranchToIfaceBranch' defs
+ axn = coAxiomName ax
+ to_ifsyn_rhs AbstractClosedSynFamilyTyCon
+ = IfaceAbstractClosedSynFamilyTyCon
+
to_ifsyn_rhs (SynonymTyCon ty)
= IfaceSynonymTyCon (tidyToIfaceType env1 ty)
- to_ifsyn_rhs (BuiltInSynFamTyCon {}) = pprPanic "toIfaceDecl: BuiltInFamTyCon" (ppr tycon)
+ to_ifsyn_rhs (BuiltInSynFamTyCon {})
+ = pprPanic "toIfaceDecl: BuiltInFamTyCon" (ppr tycon)
ifaceConDecls (NewTyCon { data_con = con }) = IfNewTyCon (ifaceConDecl con)
@@ -1665,7 +1689,7 @@ classToIfaceDecl env clas
toIfaceAT :: ClassATItem -> IfaceAT
toIfaceAT (tc, defs)
- = IfaceAT (tyConToIfaceDecl env1 tc) (map (coAxBranchToIfaceBranch' env1) defs)
+ = IfaceAT (tyConToIfaceDecl env1 tc) (map coAxBranchToIfaceBranch' defs)
toIfaceClassOp (sel_id, def_meth)
= ASSERT(sel_tyvars == clas_tyvars)
@@ -1691,6 +1715,12 @@ classToIfaceDecl env clas
tidyToIfaceType :: TidyEnv -> Type -> IfaceType
tidyToIfaceType env ty = toIfaceType (tidyType env ty)
+tidyToIfaceTcArgs :: TidyEnv -> [Type] -> IfaceTcArgs
+tidyToIfaceTcArgs _ [] = ITC_Nil
+tidyToIfaceTcArgs env (t:ts)
+ | isKind t = ITC_Kind (tidyToIfaceType env t) (tidyToIfaceTcArgs env ts)
+ | otherwise = ITC_Type (tidyToIfaceType env t) (tidyToIfaceTcArgs env ts)
+
tidyToIfaceContext :: TidyEnv -> ThetaType -> IfaceContext
tidyToIfaceContext env theta = map (tidyToIfaceType env) theta
diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs
index 2cf0cf7816..e5da3568a9 100644
--- a/compiler/iface/TcIface.lhs
+++ b/compiler/iface/TcIface.lhs
@@ -452,41 +452,26 @@ tc_iface_decl parent _ (IfaceData {ifName = occ_name,
ifCtxt = ctxt, ifGadtSyntax = gadt_syn,
ifCons = rdr_cons,
ifRec = is_rec, ifPromotable = is_prom,
- ifAxiom = mb_axiom_name })
+ ifParent = mb_parent })
= bindIfaceTyVars_AT tv_bndrs $ \ tyvars -> do
{ tc_name <- lookupIfaceTop occ_name
; tycon <- fixM $ \ tycon -> do
{ stupid_theta <- tcIfaceCtxt ctxt
- ; parent' <- tc_parent tyvars mb_axiom_name
+ ; parent' <- tc_parent mb_parent
; cons <- tcIfaceDataCons tc_name tycon tyvars rdr_cons
; return (buildAlgTyCon tc_name tyvars roles cType stupid_theta
cons is_rec is_prom gadt_syn parent') }
; traceIf (text "tcIfaceDecl4" <+> ppr tycon)
; return (ATyCon tycon) }
where
- tc_parent :: [TyVar] -> Maybe Name -> IfL TyConParent
- tc_parent _ Nothing = return parent
- tc_parent tyvars (Just ax_name)
+ tc_parent :: IfaceTyConParent -> IfL TyConParent
+ tc_parent IfNoParent = return parent
+ tc_parent (IfDataInstance ax_name _ arg_tys)
= ASSERT( isNoParent parent )
do { ax <- tcIfaceCoAxiom ax_name
- ; let fam_tc = coAxiomTyCon ax
+ ; let fam_tc = coAxiomTyCon ax
ax_unbr = toUnbranchedAxiom ax
- -- data families don't have branches:
- branch = coAxiomSingleBranch ax_unbr
- ax_tvs = coAxBranchTyVars branch
- ax_lhs = coAxBranchLHS branch
- tycon_tys = mkTyVarTys tyvars
- subst = mkTopTvSubst (ax_tvs `zip` tycon_tys)
- -- The subst matches the tyvar of the TyCon
- -- with those from the CoAxiom. They aren't
- -- necessarily the same, since the two may be
- -- gotten from separate interface-file declarations
- -- NB: ax_tvs may be shorter because of eta-reduction
- -- See Note [Eta reduction for data family axioms] in TcInstDcls
- lhs_tys = substTys subst ax_lhs `chkAppend`
- dropList ax_tvs tycon_tys
- -- The 'lhs_tys' should be 1-1 with the 'tyvars'
- -- but ax_tvs maybe shorter because of eta-reduction
+ ; lhs_tys <- tcIfaceTcArgs arg_tys
; return (FamInstTyCon ax_unbr fam_tc lhs_tys) }
tc_iface_decl parent _ (IfaceSyn {ifName = occ_name, ifTyVars = tv_bndrs,
@@ -503,7 +488,7 @@ tc_iface_decl parent _ (IfaceSyn {ifName = occ_name, ifTyVars = tv_bndrs,
where
mk_doc n = ptext (sLit "Type syonym") <+> ppr n
tc_syn_rhs IfaceOpenSynFamilyTyCon = return OpenSynFamilyTyCon
- tc_syn_rhs (IfaceClosedSynFamilyTyCon ax_name)
+ tc_syn_rhs (IfaceClosedSynFamilyTyCon ax_name _)
= do { ax <- tcIfaceCoAxiom ax_name
; return (ClosedSynFamilyTyCon ax) }
tc_syn_rhs IfaceAbstractClosedSynFamilyTyCon = return AbstractClosedSynFamilyTyCon
@@ -551,7 +536,7 @@ tc_iface_decl _parent ignore_prags
tc_at cls (IfaceAT tc_decl defs_decls)
= do ATyCon tc <- tc_iface_decl (AssocFamilyTyCon cls) ignore_prags tc_decl
- defs <- forkM (mk_at_doc tc) (tc_ax_branches tc defs_decls)
+ defs <- forkM (mk_at_doc tc) (tc_ax_branches defs_decls)
-- Must be done lazily in case the RHS of the defaults mention
-- the type constructor being defined here
-- e.g. type AT a; type AT b = AT [b] Trac #8002
@@ -574,7 +559,7 @@ tc_iface_decl _ _ (IfaceAxiom { ifName = ax_occ, ifTyCon = tc
, ifAxBranches = branches, ifRole = role })
= do { tc_name <- lookupIfaceTop ax_occ
; tc_tycon <- tcIfaceTyCon tc
- ; tc_branches <- tc_ax_branches tc_tycon branches
+ ; tc_branches <- tc_ax_branches branches
; let axiom = CoAxiom { co_ax_unique = nameUnique tc_name
, co_ax_name = tc_name
, co_ax_tc = tc_tycon
@@ -614,16 +599,16 @@ tc_iface_decl _ _ (IfacePatSyn{ ifName = occ_name
mk_doc n = ptext (sLit "Pattern synonym") <+> ppr n
tcExt s name = forkM (ptext (sLit s) <+> ppr name) $ tcIfaceExtId name
-tc_ax_branches :: TyCon -> [IfaceAxBranch] -> IfL [CoAxBranch]
-tc_ax_branches tc if_branches = foldlM (tc_ax_branch (tyConKind tc)) [] if_branches
+tc_ax_branches :: [IfaceAxBranch] -> IfL [CoAxBranch]
+tc_ax_branches if_branches = foldlM tc_ax_branch [] if_branches
-tc_ax_branch :: Kind -> [CoAxBranch] -> IfaceAxBranch -> IfL [CoAxBranch]
-tc_ax_branch tc_kind prev_branches
+tc_ax_branch :: [CoAxBranch] -> IfaceAxBranch -> IfL [CoAxBranch]
+tc_ax_branch prev_branches
(IfaceAxBranch { ifaxbTyVars = tv_bndrs, ifaxbLHS = lhs, ifaxbRHS = rhs
, ifaxbRoles = roles, ifaxbIncomps = incomps })
= bindIfaceTyVars_AT tv_bndrs $ \ tvs -> do
-- The _AT variant is needed here; see Note [CoAxBranch type variables] in CoAxiom
- { tc_lhs <- tcIfaceTcArgs tc_kind lhs -- See Note [Checking IfaceTypes vs IfaceKinds]
+ { tc_lhs <- tcIfaceTcArgs lhs -- See Note [Checking IfaceTypes vs IfaceKinds]
; tc_rhs <- tcIfaceType rhs
; let br = CoAxBranch { cab_loc = noSrcSpan
, cab_tvs = tvs
@@ -963,25 +948,38 @@ 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) = do { t1' <- tcIfaceType t1; t2' <- tcIfaceType t2; return (FunTy t1' t2') }
+tcIfaceType (IfaceFunTy t1 t2) = tcIfaceTypeFun t1 t2
+tcIfaceType (IfaceDFunTy t1 t2) = tcIfaceTypeFun t1 t2
tcIfaceType (IfaceTyConApp tc tks) = do { tc' <- tcIfaceTyCon tc
- ; tks' <- tcIfaceTcArgs (tyConKind tc') tks
+ ; tks' <- tcIfaceTcArgs tks
; return (mkTyConApp tc' tks') }
tcIfaceType (IfaceForAllTy tv t) = bindIfaceTyVar tv $ \ tv' -> do { t' <- tcIfaceType t; return (ForAllTy tv' t') }
-tcIfaceTypes :: [IfaceType] -> IfL [Type]
-tcIfaceTypes tys = mapM tcIfaceType tys
-
-tcIfaceTcArgs :: Kind -> [IfaceType] -> IfL [Type]
-tcIfaceTcArgs _ []
- = return []
-tcIfaceTcArgs kind (tk:tks)
- = case splitForAllTy_maybe kind of
- Nothing -> tcIfaceTypes (tk:tks)
- Just (_, kind') -> do { k' <- tcIfaceKind tk
- ; tks' <- tcIfaceTcArgs kind' tks
- ; return (k':tks') }
-
+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') }
+
+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 []
-----------------------------------------
tcIfaceCtxt :: IfaceContext -> IfL ThetaType
tcIfaceCtxt sts = mapM tcIfaceType sts
@@ -990,43 +988,8 @@ tcIfaceCtxt sts = mapM tcIfaceType sts
tcIfaceTyLit :: IfaceTyLit -> IfL TyLit
tcIfaceTyLit (IfaceNumTyLit n) = return (NumTyLit n)
tcIfaceTyLit (IfaceStrTyLit n) = return (StrTyLit n)
-
------------------------------------------
-tcIfaceKind :: IfaceKind -> IfL Kind -- See Note [Checking IfaceTypes vs IfaceKinds]
-tcIfaceKind (IfaceTyVar n) = do { tv <- tcIfaceTyVar n; return (TyVarTy tv) }
-tcIfaceKind (IfaceAppTy t1 t2) = do { t1' <- tcIfaceKind t1; t2' <- tcIfaceKind t2; return (AppTy t1' t2') }
-tcIfaceKind (IfaceFunTy t1 t2) = do { t1' <- tcIfaceKind t1; t2' <- tcIfaceKind t2; return (FunTy t1' t2') }
-tcIfaceKind (IfaceTyConApp tc ts) = do { tc' <- tcIfaceKindCon tc; ts' <- tcIfaceKinds ts; return (mkTyConApp tc' ts') }
-tcIfaceKind (IfaceForAllTy tv t) = bindIfaceTyVar tv $ \ tv' -> do { t' <- tcIfaceKind t; return (ForAllTy tv' t') }
-tcIfaceKind t = pprPanic "tcIfaceKind" (ppr t) -- IfaceCoApp, IfaceLitTy
-
-tcIfaceKinds :: [IfaceKind] -> IfL [Kind]
-tcIfaceKinds tys = mapM tcIfaceKind tys
\end{code}
-Note [Checking IfaceTypes vs IfaceKinds]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We need to know whether we are checking a *type* or a *kind*.
-Consider module M where
- Proxy :: forall k. k -> *
- data T = T
-and consider the two IfaceTypes
- M.Proxy * M.T{tc}
- M.Proxy 'M.T{tc} 'M.T(d}
-The first is conventional, but in the latter we use the promoted
-type constructor (as a kind) and data constructor (as a type). However,
-the Name of the promoted type constructor is just M.T; it's the *same name*
-as the ordinary type constructor.
-
-We could add a "promoted" flag to an IfaceTyCon, but that's a bit heavy.
-Instead we use context to distinguish, as in the source language.
- - When checking a kind, we look up M.T{tc} and promote it
- - When checking a type, we look up M.T{tc} and don't promote it
- and M.T{d} and promote it
- See tcIfaceKindCon and tcIfaceKTyCon respectively
-
-This context business is why we need tcIfaceTcArgs, and tcIfaceApps
-
%************************************************************************
%* *
@@ -1192,7 +1155,7 @@ tcIfaceApps fun arg
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 -- See Note [Checking IfaceTypes vs IfaceKinds]
+ = do { t' <- if isKindVar tv
then tcIfaceKind t
else tcIfaceType t
; let fun_ty' = substTyWith [tv] [t'] body_ty
@@ -1439,26 +1402,19 @@ tcIfaceGlobal name
-- emasculated form (e.g. lacking data constructors).
tcIfaceTyCon :: IfaceTyCon -> IfL TyCon
-tcIfaceTyCon (IfaceTc name)
- = do { thing <- tcIfaceGlobal name
- ; case thing of -- A "type constructor" can be a promoted data constructor
- -- c.f. Trac #5881
- ATyCon tc -> return tc
- AConLike (RealDataCon dc) -> return (promoteDataCon dc)
- _ -> pprPanic "tcIfaceTyCon" (ppr name $$ ppr thing) }
-
-tcIfaceKindCon :: IfaceTyCon -> IfL TyCon
-tcIfaceKindCon (IfaceTc name)
- = do { thing <- tcIfaceGlobal name
- ; case thing of -- A "type constructor" here is a promoted type constructor
- -- c.f. Trac #5881
- ATyCon tc
- | isSuperKind (tyConKind tc)
- -> return tc -- Mainly just '*' or 'AnyK'
- | Just prom_tc <- promotableTyCon_maybe tc
- -> return prom_tc
-
- _ -> pprPanic "tcIfaceKindCon" (ppr name $$ ppr thing) }
+tcIfaceTyCon itc
+ = do {
+ ; thing <- tcIfaceGlobal (ifaceTyConName itc)
+ ; case itc of
+ IfaceTc _ -> return $ tyThingTyCon thing
+ IfacePromotedDataCon _ -> return $ promoteDataCon $ tyThingDataCon thing
+ IfacePromotedTyCon name ->
+ let ktycon tc
+ | isSuperKind (tyConKind tc) = return tc
+ | Just prom_tc <- promotableTyCon_maybe tc = return prom_tc
+ | otherwise = pprPanic "tcIfaceTyCon" (ppr name $$ ppr thing)
+ in ktycon (tyThingTyCon thing)
+ }
tcIfaceCoAxiom :: Name -> IfL (CoAxiom Branched)
tcIfaceCoAxiom name = do { thing <- tcIfaceGlobal name
@@ -1522,7 +1478,7 @@ bindIfaceTyVars bndrs thing_inside
(occs,kinds) = unzip bndrs
isSuperIfaceKind :: IfaceKind -> Bool
-isSuperIfaceKind (IfaceTyConApp (IfaceTc n) []) = n == superKindTyConName
+isSuperIfaceKind (IfaceTyConApp tc ITC_Nil) = ifaceTyConName tc == superKindTyConName
isSuperIfaceKind _ = False
mk_iface_tyvar :: Name -> IfaceKind -> IfL TyVar
View Lorry Controller Status