diff options
Diffstat (limited to 'compiler/main/PprTyThing.hs')
| -rw-r--r-- | compiler/main/PprTyThing.hs | 379 |
1 files changed, 102 insertions, 277 deletions
diff --git a/compiler/main/PprTyThing.hs b/compiler/main/PprTyThing.hs index 1fd5d0cbcf..eed4671b67 100644 --- a/compiler/main/PprTyThing.hs +++ b/compiler/main/PprTyThing.hs @@ -6,64 +6,90 @@ -- ----------------------------------------------------------------------------- -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - +{-# LANGUAGE CPP #-} module PprTyThing ( - pprTyThing, - pprTyThingInContext, - pprTyThingLoc, - pprTyThingInContextLoc, - pprTyThingHdr, - pprTypeForUser + pprTyThing, + pprTyThingInContext, + pprTyThingLoc, + pprTyThingInContextLoc, + pprTyThingHdr, + 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, pprForAll, 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 DynFlags 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 = [] +{- Note [Pretty-printing TyThings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We pretty-print a TyThing by converting it to an IfaceDecl, +and pretty-printing that (see ppr_ty_thing below). +Here is why: + +* When pretty-printing (a type, say), the idiomatic solution is not to + "rename type variables on the fly", but rather to "tidy" the type + (which gives each variable a distinct print-name), and then + pretty-print it (without renaming). Separate the two + concerns. Functions like tidyType do this. + +* Alas, for type constructors, TyCon, tidying does not work well, + because a TyCon includes DataCons which include Types, which mention + TyCons. And tidying can't tidy a mutually recursive data structure + graph, only trees. + +* One alternative would be to ensure that TyCons get type variables + with distinct print-names. That's ok for type variables but less + easy for kind variables. Processing data type declarations is + already so complicated that I don't think it's sensible to add the + extra requirement that it generates only "pretty" types and kinds. + +* One place the non-pretty names can show up is in GHCi. But another + is in interface files. Look at MkIface.tyThingToIfaceDecl which + converts a TyThing (i.e. TyCon, Class etc) to an IfaceDecl. And it + already does tidying as part of that conversion! Why? Because + interface files contains fast-strings, not uniques, so the names + must at least be distinct. + +So if we convert to IfaceDecl, we get a nice tidy IfaceDecl, and can +print that. Of course, that means that pretty-printing IfaceDecls +must be careful to display nice user-friendly results, but that's ok. + +See #7730, #8776 for details -} + +-------------------- +-- | 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, +-- because 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. @@ -73,7 +99,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 @@ -84,8 +116,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 @@ -93,256 +125,49 @@ 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 - ------------------------ --- 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 :: Bool -> [OccName] -> TyThing -> SDoc +-- We pretty-print 'TyThing' via 'IfaceDecl' +-- See Note [Pretty-pringint TyThings] +ppr_ty_thing hdr_only path ty_thing + = pprIfaceDecl ss (tyThingToIfaceDecl ty_thing) where - (tvs, funDeps) = classTvsFds cls - -pprId :: Var -> SDoc -pprId ident - = hang (ppr_bndr ident <+> dcolon) - 2 (pprTypeForUser (idType ident)) + ss = ShowSub { ss_how_much = how_much, ss_ppr_bndr = ppr_bndr } + how_much | hdr_only = ShowHeader + | otherwise = ShowSome path + name = getName ty_thing + ppr_bndr :: OccName -> SDoc + ppr_bndr | isBuiltInSyntax name + = ppr + | otherwise + = case nameModule_maybe name of + Just mod -> \ occ -> getPprStyle $ \sty -> + pprModulePrefix sty mod occ <> ppr occ + Nothing -> WARN( True, ppr name ) ppr + -- Nothing is unexpected here; TyThings have External names pprTypeForUser :: Type -> SDoc -- We do two things here. -- a) We tidy the type, regardless --- b) If Opt_PrintExplicitForAlls is True, we discard the foralls --- but we do so `deeply' +-- b) Swizzle the foralls to the top, so that without +-- -fprint-explicit-foralls we'll suppress all the foralls -- Prime example: a class op might have type --- forall a. C a => forall b. Ord b => stuff +-- forall a. C a => forall b. Ord b => stuff -- Then we want to display --- (C a, Ord b) => stuff +-- (C a, Ord b) => stuff pprTypeForUser ty - = sdocWithDynFlags $ \ dflags -> - if gopt Opt_PrintExplicitForalls dflags - then ppr tidy_ty - else ppr (mkPhiTy ctxt ty') + = pprSigmaType (mkSigmaTy tvs ctxt tau) where - (_, ctxt, ty') = tcSplitSigmaTy tidy_ty - (_, tidy_ty) = tidyOpenType emptyTidyEnv ty + (tvs, ctxt, tau) = tcSplitSigmaTy tidy_ty + (_, tidy_ty) = tidyOpenType emptyTidyEnv ty -- Often the types/kinds we print in ghci are fully generalised -- and have no free variables, but it turns out that we sometimes -- print un-generalised kinds (eg when doing :k T), so it's -- better to use tidyOpenType here -pprTyCon :: ShowSub -> TyCon -> SDoc -pprTyCon ss tyCon - | Just syn_rhs <- synTyConRhs_maybe tyCon - = case syn_rhs of - OpenSynFamilyTyCon -> pp_tc_with_kind - BuiltInSynFamTyCon {} -> pp_tc_with_kind - - ClosedSynFamilyTyCon (CoAxiom { co_ax_branches = branches }) - -> hang closed_family_header - 2 (vcat (brListMap (pprCoAxBranch tyCon) branches)) - - AbstractClosedSynFamilyTyCon - -> closed_family_header <+> ptext (sLit "..") - - SynonymTyCon rhs_ty - -> hang (pprTyConHdr tyCon <+> equals) - 2 (ppr rhs_ty) -- Don't suppress foralls on RHS type! - - -- e.g. type T = forall a. a->a - | Just cls <- tyConClass_maybe tyCon - = (pp_roles (== Nominal)) $$ pprClass ss cls - - | otherwise - = (pp_roles (== Representational)) $$ pprAlgTyCon ss tyCon - - where - -- if, for each role, suppress_if role is True, then suppress the role - -- output - pp_roles :: (Role -> Bool) -> SDoc - pp_roles suppress_if - = sdocWithDynFlags $ \dflags -> - let roles = suppressKinds dflags (tyConKind tyCon) (tyConRoles tyCon) - in ppUnless (isFamInstTyCon tyCon || all suppress_if roles) $ - -- Don't display roles for data family instances (yet) - -- See discussion on Trac #8672. - ptext (sLit "type role") <+> ppr tyCon <+> hsep (map ppr roles) - - pp_tc_with_kind = vcat [ pp_roles (const True) - , pprTyConHdr tyCon <+> dcolon - <+> pprTypeForUser (synTyConResKind tyCon) ] - closed_family_header - = pp_tc_with_kind <+> ptext (sLit "where") - -pprAlgTyCon :: ShowSub -> TyCon -> SDoc -pprAlgTyCon ss tyCon - | gadt = pprTyConHdr tyCon <+> ptext (sLit "where") $$ - nest 2 (vcat (ppr_trim (map show_con datacons))) - | otherwise = hang (pprTyConHdr tyCon) - 2 (add_bars (ppr_trim (map show_con datacons))) - where - datacons = tyConDataCons tyCon - gadt = any (not . isVanillaDataCon) datacons - - ok_con dc = showSub ss dc || any (showSub ss) (dataConFieldLabels dc) - show_con dc - | ok_con dc = Just (pprDataConDecl ss gadt dc) - | otherwise = Nothing - -pprDataConDecl :: ShowSub -> Bool -> DataCon -> SDoc -pprDataConDecl ss gadt_style dataCon - | not gadt_style = ppr_fields tys_w_strs - | otherwise = ppr_bndr dataCon <+> dcolon <+> - sep [ pp_foralls, pprThetaArrowTy theta, pp_tau ] - -- Printing out the dataCon as a type signature, in GADT style - where - (forall_tvs, theta, tau) = tcSplitSigmaTy (dataConUserType dataCon) - (arg_tys, res_ty) = tcSplitFunTys tau - labels = dataConFieldLabels dataCon - stricts = dataConStrictMarks dataCon - tys_w_strs = zip (map user_ify stricts) arg_tys - pp_foralls = sdocWithDynFlags $ \dflags -> - ppWhen (gopt Opt_PrintExplicitForalls dflags) - (pprForAll forall_tvs) - - pp_tau = foldr add (ppr res_ty) tys_w_strs - add str_ty pp_ty = pprParendBangTy str_ty <+> arrow <+> pp_ty - - pprParendBangTy (bang,ty) = ppr bang <> pprParendType ty - pprBangTy (bang,ty) = ppr bang <> ppr ty - - -- See Note [Printing bangs on data constructors] - user_ify :: HsBang -> HsBang - user_ify bang | opt_PprStyle_Debug = bang - user_ify HsStrict = HsUserBang Nothing True - user_ify (HsUnpack {}) = HsUserBang (Just True) True - user_ify bang = bang - - maybe_show_label (lbl,bty) - | showSub ss lbl = Just (ppr_bndr lbl <+> dcolon <+> pprBangTy bty) - | otherwise = Nothing - - ppr_fields [ty1, ty2] - | dataConIsInfix dataCon && null labels - = sep [pprParendBangTy ty1, pprInfixName dataCon, pprParendBangTy ty2] - ppr_fields fields - | null labels - = ppr_bndr dataCon <+> sep (map pprParendBangTy fields) - | otherwise - = ppr_bndr dataCon - <+> (braces $ sep $ punctuate comma $ ppr_trim $ - map maybe_show_label (zip labels fields)) - -pprClass :: ShowSub -> Class -> SDoc -pprClass ss cls - | null methods && null assoc_ts - = pprClassHdr cls - | otherwise - = vcat [ pprClassHdr cls <+> ptext (sLit "where") - , nest 2 (vcat $ ppr_trim $ - map show_at assoc_ts ++ map show_meth methods)] - where - methods = classMethods cls - assoc_ts = classATs cls - show_meth id | showSub ss id = Just (pprClassMethod id) - | otherwise = Nothing - show_at tc = case showSub_maybe ss tc of - Just ss' -> Just (pprTyCon ss' tc) - Nothing -> Nothing - -pprClassMethod :: Id -> SDoc -pprClassMethod id - = hang (ppr_bndr id <+> dcolon) 2 (pprTypeForUser op_ty) - where - -- Here's the magic incantation to strip off the dictionary - -- from the class op type. Stolen from IfaceSyn.tyThingToIfaceDecl. - -- - -- It's important to tidy it *before* splitting it up, so that if - -- we have class C a b where - -- op :: forall a. a -> b - -- then the inner forall on op gets renamed to a1, and we print - -- (when dropping foralls) - -- class C a b where - -- op :: a1 -> b - - tidy_sel_ty = tidyTopType (idType id) - (_sel_tyvars, rho_ty) = splitForAllTys tidy_sel_ty - op_ty = funResultTy rho_ty - -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) - -add_bars :: [SDoc] -> SDoc -add_bars [] = empty -add_bars [c] = equals <+> c -add_bars (c:cs) = sep ((equals <+> c) : map (char '|' <+>) cs) - --- Wrap operators in () -ppr_bndr :: NamedThing a => a -> SDoc -ppr_bndr a = parenSymOcc (getOccName a) (ppr (getName a)) - showWithLoc :: SDoc -> SDoc -> SDoc showWithLoc loc doc = hang doc 2 (char '\t' <> comment <+> loc) - -- The tab tries to make them line up a bit + -- The tab tries to make them line up a bit where comment = ptext (sLit "--") - -{- -Note [Printing bangs on data constructors] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For imported data constructors the dataConStrictMarks are the -representation choices (see Note [Bangs on data constructor arguments] -in DataCon.lhs). So we have to fiddle a little bit here to turn them -back into user-printable form. --} |