Commit b4856f9f authored by Simon Peyton Jones's avatar Simon Peyton Jones

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!
parent da64c97f
......@@ -102,7 +102,10 @@ module OccName (
-- * Lexical characteristics of Haskell names
isLexCon, isLexVar, isLexId, isLexSym,
isLexConId, isLexConSym, isLexVarId, isLexVarSym,
startsVarSym, startsVarId, startsConSym, startsConId
startsVarSym, startsVarId, startsConSym, startsConId,
-- FsEnv
FastStringEnv, emptyFsEnv, lookupFsEnv, extendFsEnv, mkFsEnv
) where
import Util
......@@ -117,6 +120,29 @@ import Data.Char
import Data.Data
\end{code}
%************************************************************************
%* *
FastStringEnv
%* *
%************************************************************************
FastStringEnv can't be in FastString becuase the env depends on UniqFM
\begin{code}
type FastStringEnv a = UniqFM a -- Keyed by FastString
emptyFsEnv :: FastStringEnv a
lookupFsEnv :: FastStringEnv a -> FastString -> Maybe a
extendFsEnv :: FastStringEnv a -> FastString -> a -> FastStringEnv a
mkFsEnv :: [(FastString,a)] -> FastStringEnv a
emptyFsEnv = emptyUFM
lookupFsEnv = lookupUFM
extendFsEnv = addToUFM
mkFsEnv = listToUFM
\end{code}
%************************************************************************
%* *
\subsection{Name space}
......@@ -246,6 +272,9 @@ instance Data OccName where
toConstr _ = abstractConstr "OccName"
gunfold _ _ = error "gunfold"
dataTypeOf _ = mkNoRepType "OccName"
instance HasOccName OccName where
occName = id
\end{code}
......
This diff is collapsed.
This diff is collapsed.
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -262,6 +262,7 @@ import InteractiveEval
import TcRnDriver ( runTcInteractive )
#endif
import PprTyThing ( pprFamInst )
import HscMain
import GhcMake
import DriverPipeline ( compileOne' )
......@@ -284,7 +285,7 @@ import DataCon
import Name hiding ( varName )
import Avail
import InstEnv
import FamInstEnv
import FamInstEnv ( FamInst )
import SrcLoc
import CoreSyn
import TidyPgm
......
......@@ -6,6 +6,7 @@
--
-----------------------------------------------------------------------------
{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -fno-warn-tabs #-}
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and
......@@ -19,50 +20,47 @@ module PprTyThing (
pprTyThingLoc,
pprTyThingInContextLoc,
pprTyThingHdr,
pprTypeForUser
pprTypeForUser,
pprFamInst
) where
#include "HsVersions.h"
import TypeRep ( TyThing(..) )
import DataCon
import Id
import TyCon
import Class
import Coercion( pprCoAxBranch )
import CoAxiom( CoAxiom(..), brListMap )
import CoAxiom ( coAxiomTyCon )
import HscTypes( tyThingParent_maybe )
import Type( tidyTopType, tidyOpenType, splitForAllTys, funResultTy )
import Kind( synTyConResKind )
import TypeRep( pprTvBndrs, pprUserForAll, suppressKinds )
import TysPrim( alphaTyVars )
import MkIface ( tyThingToIfaceDecl )
import Type ( tidyOpenType )
import IfaceSyn ( pprIfaceDecl, ShowSub(..), ShowHowMuch(..) )
import FamInstEnv( FamInst( .. ), FamFlavor(..) )
import TcType
import Name
import VarEnv( emptyTidyEnv )
import StaticFlags( opt_PprStyle_Debug )
import Outputable
import FastString
-- -----------------------------------------------------------------------------
-- Pretty-printing entities that we get from the GHC API
-- This should be a good source of sample code for using the GHC API to
-- inspect source code entities.
type ShowSub = [Name]
-- [] <=> print all sub-components of the current thing
-- (n:ns) <=> print sub-component 'n' with ShowSub=ns
-- elide other sub-components to "..."
showAll :: ShowSub
showAll = []
--------------------
-- | Pretty-prints a 'FamInst' (type/data family instance) with its defining location.
pprFamInst :: FamInst -> SDoc
-- * For data instances we go via pprTyThing of the represntational TyCon,
-- becuase there is already much cleverness associated with printing
-- data type declarations that I don't want to duplicate
-- * For type instances we print directly here; there is no TyCon
-- to give to pprTyThing
--
-- FamInstEnv.pprFamInst does a more quick-and-dirty job for internal purposes
showSub :: NamedThing n => ShowSub -> n -> Bool
showSub [] _ = True
showSub (n:_) thing = n == getName thing
pprFamInst (FamInst { fi_flavor = DataFamilyInst rep_tc })
= pprTyThingInContextLoc (ATyCon rep_tc)
showSub_maybe :: NamedThing n => ShowSub -> n -> Maybe ShowSub
showSub_maybe [] _ = Just []
showSub_maybe (n:ns) thing = if n == getName thing then Just ns
else Nothing
pprFamInst (FamInst { fi_flavor = SynFamilyInst, fi_axiom = axiom
, fi_tys = lhs_tys, fi_rhs = rhs })
= showWithLoc (pprDefinedAt (getName axiom)) $
hang (ptext (sLit "type instance") <+> pprTypeApp (coAxiomTyCon axiom) lhs_tys)
2 (equals <+> ppr rhs)
----------------------------
-- | Pretty-prints a 'TyThing' with its defining location.
......@@ -72,7 +70,13 @@ pprTyThingLoc tyThing
-- | Pretty-prints a 'TyThing'.
pprTyThing :: TyThing -> SDoc
pprTyThing thing = ppr_ty_thing (Just showAll) thing
pprTyThing = ppr_ty_thing False []
-- | Pretty-prints the 'TyThing' header. For functions and data constructors
-- the function is equivalent to 'pprTyThing' but for type constructors
-- and classes it prints only the header part of the declaration.
pprTyThingHdr :: TyThing -> SDoc
pprTyThingHdr = ppr_ty_thing True []
-- | Pretty-prints a 'TyThing' in context: that is, if the entity
-- is a data constructor, record selector, or class method, then
......@@ -83,8 +87,8 @@ pprTyThingInContext thing
= go [] thing
where
go ss thing = case tyThingParent_maybe thing of
Just parent -> go (getName thing : ss) parent
Nothing -> ppr_ty_thing (Just ss) thing
Just parent -> go (getOccName thing : ss) parent
Nothing -> ppr_ty_thing False ss thing
-- | Like 'pprTyThingInContext', but adds the defining location.
pprTyThingInContextLoc :: TyThing -> SDoc
......@@ -92,65 +96,26 @@ pprTyThingInContextLoc tyThing
= showWithLoc (pprDefinedAt (getName tyThing))
(pprTyThingInContext tyThing)
-- | Pretty-prints the 'TyThing' header. For functions and data constructors
-- the function is equivalent to 'pprTyThing' but for type constructors
-- and classes it prints only the header part of the declaration.
pprTyThingHdr :: TyThing -> SDoc
pprTyThingHdr = ppr_ty_thing Nothing
------------------------
ppr_ty_thing :: Bool -> [OccName] -> TyThing -> SDoc
-- NOTE: We pretty-print 'TyThing' via 'IfaceDecl' so that we can reuse the
-- 'TyCon' tidying happening in 'tyThingToIfaceDecl'. See #8776 for details.
ppr_ty_thing :: Maybe ShowSub -> TyThing -> SDoc
ppr_ty_thing mss tyThing = case tyThing of
AnId id -> pprId id
ATyCon tyCon -> case mss of
Nothing -> pprTyConHdr tyCon
Just ss -> pprTyCon ss tyCon
_ -> ppr $ tyThingToIfaceDecl tyThing
pprTyConHdr :: TyCon -> SDoc
pprTyConHdr tyCon
| Just (fam_tc, tys) <- tyConFamInst_maybe tyCon
= ptext keyword <+> ptext (sLit "instance") <+> pprTypeApp fam_tc tys
| Just cls <- tyConClass_maybe tyCon
= pprClassHdr cls
| otherwise
= sdocWithDynFlags $ \dflags ->
ptext keyword <+> opt_family <+> opt_stupid <+> ppr_bndr tyCon
<+> pprTvBndrs (suppressKinds dflags (tyConKind tyCon) vars)
where
vars | isPrimTyCon tyCon ||
isFunTyCon tyCon = take (tyConArity tyCon) alphaTyVars
| otherwise = tyConTyVars tyCon
keyword | isSynTyCon tyCon = sLit "type"
| isNewTyCon tyCon = sLit "newtype"
| otherwise = sLit "data"
opt_family
| isFamilyTyCon tyCon = ptext (sLit "family")
| otherwise = empty
opt_stupid -- The "stupid theta" part of the declaration
| isAlgTyCon tyCon = pprThetaArrowTy (tyConStupidTheta tyCon)
| otherwise = empty -- Returns 'empty' if null theta
pprClassHdr :: Class -> SDoc
pprClassHdr cls
= sdocWithDynFlags $ \dflags ->
ptext (sLit "class") <+>
sep [ pprThetaArrowTy (classSCTheta cls)
, ppr_bndr cls
<+> pprTvBndrs (suppressKinds dflags (tyConKind (classTyCon cls)) tvs)
, pprFundeps funDeps ]
ppr_ty_thing hdr_only path ty_thing
= pprIfaceDecl (ShowSub { ss_how_much = how_much, ss_ppr_bndr = ppr_bndr }) if_decl
where
(tvs, funDeps) = classTvsFds cls
pprId :: Var -> SDoc
pprId ident
= hang (ppr_bndr ident <+> dcolon)
2 (pprTypeForUser (idType ident))
how_much | hdr_only = ShowHeader
| otherwise = ShowSome path
if_decl = tyThingToIfaceDecl ty_thing