Simplify PprTyThing
[ghc.git] / compiler / main / PprTyThing.hs
1 -----------------------------------------------------------------------------
2 --
3 -- Pretty-printing TyThings
4 --
5 -- (c) The GHC Team 2005
6 --
7 -----------------------------------------------------------------------------
8
9 {-# OPTIONS -fno-warn-tabs #-}
10 -- The above warning supression flag is a temporary kludge.
11 -- While working on this module you are encouraged to remove it and
12 -- detab the module (please do the detabbing in a separate patch). See
13 -- http://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
14 -- for details
15
16 module PprTyThing (
17 pprTyThing,
18 pprTyThingInContext,
19 pprTyThingLoc,
20 pprTyThingInContextLoc,
21 pprTyThingHdr,
22 pprTypeForUser
23 ) where
24
25 import TypeRep ( TyThing(..) )
26 import DataCon
27 import Id
28 import TyCon
29 import Class
30 import Coercion( pprCoAxiom, pprCoAxBranch )
31 import CoAxiom( CoAxiom(..), brListMap )
32 import HscTypes( tyThingParent_maybe )
33 import Type( tidyTopType, tidyOpenType, splitForAllTys, funResultTy )
34 import Kind( synTyConResKind )
35 import TypeRep( pprTvBndrs, pprForAll, suppressKinds )
36 import TysPrim( alphaTyVars )
37 import TcType
38 import Name
39 import VarEnv( emptyTidyEnv )
40 import StaticFlags( opt_PprStyle_Debug )
41 import DynFlags
42 import Outputable
43 import FastString
44
45 -- -----------------------------------------------------------------------------
46 -- Pretty-printing entities that we get from the GHC API
47
48 -- This should be a good source of sample code for using the GHC API to
49 -- inspect source code entities.
50
51 type ShowSub = [Name]
52 -- [] <=> print all sub-components of the current thing
53 -- (n:ns) <=> print sub-component 'n' with ShowSub=ns
54 -- elide other sub-components to "..."
55 showAll :: ShowSub
56 showAll = []
57
58 showSub :: NamedThing n => ShowSub -> n -> Bool
59 showSub [] _ = True
60 showSub (n:_) thing = n == getName thing
61
62 showSub_maybe :: NamedThing n => ShowSub -> n -> Maybe ShowSub
63 showSub_maybe [] _ = Just []
64 showSub_maybe (n:ns) thing = if n == getName thing then Just ns
65 else Nothing
66
67 ----------------------------
68 -- | Pretty-prints a 'TyThing' with its defining location.
69 pprTyThingLoc :: TyThing -> SDoc
70 pprTyThingLoc tyThing
71 = showWithLoc (pprDefinedAt (getName tyThing)) (pprTyThing tyThing)
72
73 -- | Pretty-prints a 'TyThing'.
74 pprTyThing :: TyThing -> SDoc
75 pprTyThing thing = ppr_ty_thing showAll thing
76
77 -- | Pretty-prints a 'TyThing' in context: that is, if the entity
78 -- is a data constructor, record selector, or class method, then
79 -- the entity's parent declaration is pretty-printed with irrelevant
80 -- parts omitted.
81 pprTyThingInContext :: TyThing -> SDoc
82 pprTyThingInContext thing
83 = go [] thing
84 where
85 go ss thing = case tyThingParent_maybe thing of
86 Just parent -> go (getName thing : ss) parent
87 Nothing -> ppr_ty_thing ss thing
88
89 -- | Like 'pprTyThingInContext', but adds the defining location.
90 pprTyThingInContextLoc :: TyThing -> SDoc
91 pprTyThingInContextLoc tyThing
92 = showWithLoc (pprDefinedAt (getName tyThing))
93 (pprTyThingInContext tyThing)
94
95 -- | Pretty-prints the 'TyThing' header. For functions and data constructors
96 -- the function is equivalent to 'pprTyThing' but for type constructors
97 -- and classes it prints only the header part of the declaration.
98 pprTyThingHdr :: TyThing -> SDoc
99 pprTyThingHdr (AnId id) = pprId id
100 pprTyThingHdr (ADataCon dataCon) = pprDataConSig dataCon
101 pprTyThingHdr (ATyCon tyCon) = pprTyConHdr tyCon
102 pprTyThingHdr (ACoAxiom ax) = pprCoAxiom ax
103
104 ------------------------
105 ppr_ty_thing :: ShowSub -> TyThing -> SDoc
106 ppr_ty_thing _ (AnId id) = pprId id
107 ppr_ty_thing _ (ADataCon dataCon) = pprDataConSig dataCon
108 ppr_ty_thing ss (ATyCon tyCon) = pprTyCon ss tyCon
109 ppr_ty_thing _ (ACoAxiom ax) = pprCoAxiom ax
110
111 pprTyConHdr :: TyCon -> SDoc
112 pprTyConHdr tyCon
113 | Just (fam_tc, tys) <- tyConFamInst_maybe tyCon
114 = ptext keyword <+> ptext (sLit "instance") <+> pprTypeApp fam_tc tys
115 | Just cls <- tyConClass_maybe tyCon
116 = pprClassHdr cls
117 | otherwise
118 = sdocWithDynFlags $ \dflags ->
119 ptext keyword <+> opt_family <+> opt_stupid <+> ppr_bndr tyCon
120 <+> pprTvBndrs (suppressKinds dflags (tyConKind tyCon) vars)
121 where
122 vars | isPrimTyCon tyCon ||
123 isFunTyCon tyCon = take (tyConArity tyCon) alphaTyVars
124 | otherwise = tyConTyVars tyCon
125
126 keyword | isSynTyCon tyCon = sLit "type"
127 | isNewTyCon tyCon = sLit "newtype"
128 | otherwise = sLit "data"
129
130 opt_family
131 | isFamilyTyCon tyCon = ptext (sLit "family")
132 | otherwise = empty
133
134 opt_stupid -- The "stupid theta" part of the declaration
135 | isAlgTyCon tyCon = pprThetaArrowTy (tyConStupidTheta tyCon)
136 | otherwise = empty -- Returns 'empty' if null theta
137
138 pprDataConSig :: DataCon -> SDoc
139 pprDataConSig dataCon
140 = ppr_bndr dataCon <+> dcolon <+> pprTypeForUser (dataConUserType dataCon)
141
142 pprClassHdr :: Class -> SDoc
143 pprClassHdr cls
144 = sdocWithDynFlags $ \dflags ->
145 ptext (sLit "class") <+>
146 sep [ pprThetaArrowTy (classSCTheta cls)
147 , ppr_bndr cls
148 <+> pprTvBndrs (suppressKinds dflags (tyConKind (classTyCon cls)) tvs)
149 , pprFundeps funDeps ]
150 where
151 (tvs, funDeps) = classTvsFds cls
152
153 pprId :: Var -> SDoc
154 pprId ident
155 = hang (ppr_bndr ident <+> dcolon)
156 2 (pprTypeForUser (idType ident))
157
158 pprTypeForUser :: Type -> SDoc
159 -- We do two things here.
160 -- a) We tidy the type, regardless
161 -- b) If Opt_PrintExplicitForAlls is True, we discard the foralls
162 -- but we do so `deeply'
163 -- Prime example: a class op might have type
164 -- forall a. C a => forall b. Ord b => stuff
165 -- Then we want to display
166 -- (C a, Ord b) => stuff
167 pprTypeForUser ty
168 = sdocWithDynFlags $ \ dflags ->
169 if gopt Opt_PrintExplicitForalls dflags
170 then ppr tidy_ty
171 else ppr (mkPhiTy ctxt ty')
172 where
173 (_, ctxt, ty') = tcSplitSigmaTy tidy_ty
174 (_, tidy_ty) = tidyOpenType emptyTidyEnv ty
175 -- Often the types/kinds we print in ghci are fully generalised
176 -- and have no free variables, but it turns out that we sometimes
177 -- print un-generalised kinds (eg when doing :k T), so it's
178 -- better to use tidyOpenType here
179
180 pprTyCon :: ShowSub -> TyCon -> SDoc
181 pprTyCon ss tyCon
182 | Just syn_rhs <- synTyConRhs_maybe tyCon
183 = case syn_rhs of
184 OpenSynFamilyTyCon -> pprTyConHdr tyCon <+> dcolon <+>
185 pprTypeForUser (synTyConResKind tyCon)
186 ClosedSynFamilyTyCon (CoAxiom { co_ax_branches = branches }) ->
187 hang closed_family_header
188 2 (vcat (brListMap (pprCoAxBranch tyCon) branches))
189 AbstractClosedSynFamilyTyCon -> closed_family_header <+> ptext (sLit "..")
190 SynonymTyCon rhs_ty -> hang (pprTyConHdr tyCon <+> equals)
191 2 (ppr rhs_ty) -- Don't suppress foralls on RHS type!
192 BuiltInSynFamTyCon {} -> pprTyConHdr tyCon <+> dcolon <+>
193 pprTypeForUser (synTyConResKind tyCon)
194
195 -- e.g. type T = forall a. a->a
196 | Just cls <- tyConClass_maybe tyCon
197 = pprClass ss cls
198 | otherwise
199 = pprAlgTyCon ss tyCon
200
201 where
202 closed_family_header
203 = pprTyConHdr tyCon <+> dcolon <+>
204 pprTypeForUser (synTyConResKind tyCon) <+> ptext (sLit "where")
205
206 pprAlgTyCon :: ShowSub -> TyCon -> SDoc
207 pprAlgTyCon ss tyCon
208 | gadt = pprTyConHdr tyCon <+> ptext (sLit "where") $$
209 nest 2 (vcat (ppr_trim (map show_con datacons)))
210 | otherwise = hang (pprTyConHdr tyCon)
211 2 (add_bars (ppr_trim (map show_con datacons)))
212 where
213 datacons = tyConDataCons tyCon
214 gadt = any (not . isVanillaDataCon) datacons
215
216 ok_con dc = showSub ss dc || any (showSub ss) (dataConFieldLabels dc)
217 show_con dc
218 | ok_con dc = Just (pprDataConDecl ss gadt dc)
219 | otherwise = Nothing
220
221 pprDataConDecl :: ShowSub -> Bool -> DataCon -> SDoc
222 pprDataConDecl ss gadt_style dataCon
223 | not gadt_style = ppr_fields tys_w_strs
224 | otherwise = ppr_bndr dataCon <+> dcolon <+>
225 sep [ pp_foralls, pprThetaArrowTy theta, pp_tau ]
226 -- Printing out the dataCon as a type signature, in GADT style
227 where
228 (forall_tvs, theta, tau) = tcSplitSigmaTy (dataConUserType dataCon)
229 (arg_tys, res_ty) = tcSplitFunTys tau
230 labels = dataConFieldLabels dataCon
231 stricts = dataConStrictMarks dataCon
232 tys_w_strs = zip (map user_ify stricts) arg_tys
233 pp_foralls = sdocWithDynFlags $ \dflags ->
234 ppWhen (gopt Opt_PrintExplicitForalls dflags)
235 (pprForAll forall_tvs)
236
237 pp_tau = foldr add (ppr res_ty) tys_w_strs
238 add str_ty pp_ty = pprParendBangTy str_ty <+> arrow <+> pp_ty
239
240 pprParendBangTy (bang,ty) = ppr bang <> pprParendType ty
241 pprBangTy (bang,ty) = ppr bang <> ppr ty
242
243 -- See Note [Printing bangs on data constructors]
244 user_ify :: HsBang -> HsBang
245 user_ify bang | opt_PprStyle_Debug = bang
246 user_ify HsStrict = HsUserBang Nothing True
247 user_ify (HsUnpack {}) = HsUserBang (Just True) True
248 user_ify bang = bang
249
250 maybe_show_label (lbl,bty)
251 | showSub ss lbl = Just (ppr_bndr lbl <+> dcolon <+> pprBangTy bty)
252 | otherwise = Nothing
253
254 ppr_fields [ty1, ty2]
255 | dataConIsInfix dataCon && null labels
256 = sep [pprParendBangTy ty1, pprInfixName dataCon, pprParendBangTy ty2]
257 ppr_fields fields
258 | null labels
259 = ppr_bndr dataCon <+> sep (map pprParendBangTy fields)
260 | otherwise
261 = ppr_bndr dataCon
262 <+> (braces $ sep $ punctuate comma $ ppr_trim $
263 map maybe_show_label (zip labels fields))
264
265 pprClass :: ShowSub -> Class -> SDoc
266 pprClass ss cls
267 | null methods && null assoc_ts
268 = pprClassHdr cls
269 | otherwise
270 = vcat [ pprClassHdr cls <+> ptext (sLit "where")
271 , nest 2 (vcat $ ppr_trim $
272 map show_at assoc_ts ++ map show_meth methods)]
273 where
274 methods = classMethods cls
275 assoc_ts = classATs cls
276 show_meth id | showSub ss id = Just (pprClassMethod id)
277 | otherwise = Nothing
278 show_at tc = case showSub_maybe ss tc of
279 Just ss' -> Just (pprTyCon ss' tc)
280 Nothing -> Nothing
281
282 pprClassMethod :: Id -> SDoc
283 pprClassMethod id
284 = hang (ppr_bndr id <+> dcolon) 2 (pprTypeForUser op_ty)
285 where
286 -- Here's the magic incantation to strip off the dictionary
287 -- from the class op type. Stolen from IfaceSyn.tyThingToIfaceDecl.
288 --
289 -- It's important to tidy it *before* splitting it up, so that if
290 -- we have class C a b where
291 -- op :: forall a. a -> b
292 -- then the inner forall on op gets renamed to a1, and we print
293 -- (when dropping foralls)
294 -- class C a b where
295 -- op :: a1 -> b
296
297 tidy_sel_ty = tidyTopType (idType id)
298 (_sel_tyvars, rho_ty) = splitForAllTys tidy_sel_ty
299 op_ty = funResultTy rho_ty
300
301 ppr_trim :: [Maybe SDoc] -> [SDoc]
302 -- Collapse a group of Nothings to a single "..."
303 ppr_trim xs
304 = snd (foldr go (False, []) xs)
305 where
306 go (Just doc) (_, so_far) = (False, doc : so_far)
307 go Nothing (True, so_far) = (True, so_far)
308 go Nothing (False, so_far) = (True, ptext (sLit "...") : so_far)
309
310 add_bars :: [SDoc] -> SDoc
311 add_bars [] = empty
312 add_bars [c] = equals <+> c
313 add_bars (c:cs) = sep ((equals <+> c) : map (char '|' <+>) cs)
314
315 -- Wrap operators in ()
316 ppr_bndr :: NamedThing a => a -> SDoc
317 ppr_bndr a = parenSymOcc (getOccName a) (ppr (getName a))
318
319 showWithLoc :: SDoc -> SDoc -> SDoc
320 showWithLoc loc doc
321 = hang doc 2 (char '\t' <> comment <+> loc)
322 -- The tab tries to make them line up a bit
323 where
324 comment = ptext (sLit "--")
325
326 {-
327 Note [Printing bangs on data constructors]
328 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
329 For imported data constructors the dataConStrictMarks are the
330 representation choices (see Note [Bangs on data constructor arguments]
331 in DataCon.lhs). So we have to fiddle a little bit here to turn them
332 back into user-printable form.
333 -}