Merge branch 'master' of http://darcs.haskell.org/ghc
[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://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
14 -- for details
15
16 module PprTyThing (
17 PrintExplicitForalls,
18 pprTyThing,
19 pprTyThingInContext,
20 pprTyThingLoc,
21 pprTyThingInContextLoc,
22 pprTyThingHdr,
23 pprTypeForUser
24 ) where
25
26 import qualified GHC
27
28 import GHC ( TyThing(..) )
29 import DataCon
30 import Id
31 import TyCon
32 import Coercion( pprCoAxiom )
33 import HscTypes( tyThingParent_maybe )
34 import TcType
35 import Name
36 import Outputable
37 import FastString
38
39 -- -----------------------------------------------------------------------------
40 -- Pretty-printing entities that we get from the GHC API
41
42 -- This should be a good source of sample code for using the GHC API to
43 -- inspect source code entities.
44
45 type PrintExplicitForalls = Bool
46
47 type ShowSub = [Name]
48 -- [] <=> print all sub-components of the current thing
49 -- (n:ns) <=> print sub-component 'n' with ShowSub=ns
50 -- elide other sub-components to "..."
51 showAll :: ShowSub
52 showAll = []
53
54 showSub :: NamedThing n => ShowSub -> n -> Bool
55 showSub [] _ = True
56 showSub (n:_) thing = n == getName thing
57
58 showSub_maybe :: NamedThing n => ShowSub -> n -> Maybe ShowSub
59 showSub_maybe [] _ = Just []
60 showSub_maybe (n:ns) thing = if n == getName thing then Just ns
61 else Nothing
62
63 ----------------------------
64 -- | Pretty-prints a 'TyThing' with its defining location.
65 pprTyThingLoc :: PrintExplicitForalls -> TyThing -> SDoc
66 pprTyThingLoc pefas tyThing
67 = showWithLoc (pprDefinedAt (GHC.getName tyThing)) (pprTyThing pefas tyThing)
68
69 -- | Pretty-prints a 'TyThing'.
70 pprTyThing :: PrintExplicitForalls -> TyThing -> SDoc
71 pprTyThing pefas thing = ppr_ty_thing pefas showAll thing
72
73 -- | Pretty-prints a 'TyThing' in context: that is, if the entity
74 -- is a data constructor, record selector, or class method, then
75 -- the entity's parent declaration is pretty-printed with irrelevant
76 -- parts omitted.
77 pprTyThingInContext :: PrintExplicitForalls -> TyThing -> SDoc
78 pprTyThingInContext pefas thing
79 = go [] thing
80 where
81 go ss thing = case tyThingParent_maybe thing of
82 Just parent -> go (getName thing : ss) parent
83 Nothing -> ppr_ty_thing pefas ss thing
84
85 -- | Like 'pprTyThingInContext', but adds the defining location.
86 pprTyThingInContextLoc :: PrintExplicitForalls -> TyThing -> SDoc
87 pprTyThingInContextLoc pefas tyThing
88 = showWithLoc (pprDefinedAt (GHC.getName tyThing))
89 (pprTyThingInContext pefas tyThing)
90
91 -- | Pretty-prints the 'TyThing' header. For functions and data constructors
92 -- the function is equivalent to 'pprTyThing' but for type constructors
93 -- and classes it prints only the header part of the declaration.
94 pprTyThingHdr :: PrintExplicitForalls -> TyThing -> SDoc
95 pprTyThingHdr pefas (AnId id) = pprId pefas id
96 pprTyThingHdr pefas (ADataCon dataCon) = pprDataConSig pefas dataCon
97 pprTyThingHdr pefas (ATyCon tyCon) = pprTyConHdr pefas tyCon
98 pprTyThingHdr _ (ACoAxiom ax) = pprCoAxiom ax
99
100 ------------------------
101 ppr_ty_thing :: PrintExplicitForalls -> ShowSub -> TyThing -> SDoc
102 ppr_ty_thing pefas _ (AnId id) = pprId pefas id
103 ppr_ty_thing pefas _ (ADataCon dataCon) = pprDataConSig pefas dataCon
104 ppr_ty_thing pefas ss (ATyCon tyCon) = pprTyCon pefas ss tyCon
105 ppr_ty_thing _ _ (ACoAxiom ax) = pprCoAxiom ax
106 pprTyConHdr :: PrintExplicitForalls -> TyCon -> SDoc
107 pprTyConHdr pefas tyCon
108 | Just (fam_tc, tys) <- tyConFamInst_maybe tyCon
109 = ptext keyword <+> ptext (sLit "instance") <+> pprTypeApp fam_tc tys
110 | Just cls <- tyConClass_maybe tyCon
111 = pprClassHdr pefas cls
112 | otherwise
113 = ptext keyword <+> opt_family <+> opt_stupid <+> ppr_bndr tyCon <+> hsep (map ppr vars)
114 where
115 vars | GHC.isPrimTyCon tyCon ||
116 GHC.isFunTyCon tyCon = take (GHC.tyConArity tyCon) GHC.alphaTyVars
117 | otherwise = GHC.tyConTyVars tyCon
118
119 keyword | GHC.isSynTyCon tyCon = sLit "type"
120 | GHC.isNewTyCon tyCon = sLit "newtype"
121 | otherwise = sLit "data"
122
123 opt_family
124 | GHC.isFamilyTyCon tyCon = ptext (sLit "family")
125 | otherwise = empty
126
127 opt_stupid -- The "stupid theta" part of the declaration
128 | isAlgTyCon tyCon = GHC.pprThetaArrowTy (tyConStupidTheta tyCon)
129 | otherwise = empty -- Returns 'empty' if null theta
130
131 pprDataConSig :: PrintExplicitForalls -> GHC.DataCon -> SDoc
132 pprDataConSig pefas dataCon
133 = ppr_bndr dataCon <+> dcolon <+> pprTypeForUser pefas (GHC.dataConType dataCon)
134
135 pprClassHdr :: PrintExplicitForalls -> GHC.Class -> SDoc
136 pprClassHdr _ cls
137 = ptext (sLit "class") <+>
138 GHC.pprThetaArrowTy (GHC.classSCTheta cls) <+>
139 ppr_bndr cls <+>
140 hsep (map ppr tyVars) <+>
141 GHC.pprFundeps funDeps
142 where
143 (tyVars, funDeps) = GHC.classTvsFds cls
144
145 pprId :: PrintExplicitForalls -> Var -> SDoc
146 pprId pefas ident
147 = hang (ppr_bndr ident <+> dcolon)
148 2 (pprTypeForUser pefas (GHC.idType ident))
149
150 pprTypeForUser :: PrintExplicitForalls -> GHC.Type -> SDoc
151 -- We do two things here.
152 -- a) We tidy the type, regardless
153 -- b) If PrintExplicitForAlls is True, we discard the foralls
154 -- but we do so `deeply'
155 -- Prime example: a class op might have type
156 -- forall a. C a => forall b. Ord b => stuff
157 -- Then we want to display
158 -- (C a, Ord b) => stuff
159 pprTypeForUser print_foralls ty
160 | print_foralls = ppr tidy_ty
161 | otherwise = ppr (mkPhiTy ctxt ty')
162 where
163 tidy_ty = tidyTopType ty
164 (_, ctxt, ty') = tcSplitSigmaTy tidy_ty
165
166 pprTyCon :: PrintExplicitForalls -> ShowSub -> TyCon -> SDoc
167 pprTyCon pefas ss tyCon
168 | GHC.isSynTyCon tyCon
169 = if GHC.isFamilyTyCon tyCon
170 then pprTyConHdr pefas tyCon <+> dcolon <+>
171 pprTypeForUser pefas (GHC.synTyConResKind tyCon)
172 else
173 let rhs_type = GHC.synTyConType tyCon
174 in hang (pprTyConHdr pefas tyCon <+> equals) 2 (pprTypeForUser pefas rhs_type)
175 | Just cls <- GHC.tyConClass_maybe tyCon
176 = pprClass pefas ss cls
177 | otherwise
178 = pprAlgTyCon pefas ss tyCon
179
180 pprAlgTyCon :: PrintExplicitForalls -> ShowSub -> TyCon -> SDoc
181 pprAlgTyCon pefas ss tyCon
182 | gadt = pprTyConHdr pefas tyCon <+> ptext (sLit "where") $$
183 nest 2 (vcat (ppr_trim (map show_con datacons)))
184 | otherwise = hang (pprTyConHdr pefas tyCon)
185 2 (add_bars (ppr_trim (map show_con datacons)))
186 where
187 datacons = GHC.tyConDataCons tyCon
188 gadt = any (not . GHC.isVanillaDataCon) datacons
189
190 ok_con dc = showSub ss dc || any (showSub ss) (dataConFieldLabels dc)
191 show_con dc
192 | ok_con dc = Just (pprDataConDecl pefas ss gadt dc)
193 | otherwise = Nothing
194
195 pprDataConDecl :: PrintExplicitForalls -> ShowSub -> Bool -> GHC.DataCon -> SDoc
196 pprDataConDecl pefas ss gadt_style dataCon
197 | not gadt_style = ppr_fields tys_w_strs
198 | otherwise = ppr_bndr dataCon <+> dcolon <+>
199 sep [ pp_foralls, GHC.pprThetaArrowTy theta, pp_tau ]
200 -- Printing out the dataCon as a type signature, in GADT style
201 where
202 (forall_tvs, theta, tau) = tcSplitSigmaTy (GHC.dataConUserType dataCon)
203 (arg_tys, res_ty) = tcSplitFunTys tau
204 labels = GHC.dataConFieldLabels dataCon
205 stricts = GHC.dataConStrictMarks dataCon
206 tys_w_strs = zip stricts arg_tys
207 pp_foralls | pefas = GHC.pprForAll forall_tvs
208 | otherwise = empty
209
210 pp_tau = foldr add (ppr res_ty) tys_w_strs
211 add str_ty pp_ty = pprParendBangTy str_ty <+> arrow <+> pp_ty
212
213 pprParendBangTy (bang,ty) = ppr bang <> GHC.pprParendType ty
214
215 pprBangTy bang ty = ppr bang <> ppr ty
216
217 maybe_show_label (lbl,(strict,tp))
218 | showSub ss lbl = Just (ppr lbl <+> dcolon <+> pprBangTy strict tp)
219 | otherwise = Nothing
220
221 ppr_fields [ty1, ty2]
222 | GHC.dataConIsInfix dataCon && null labels
223 = sep [pprParendBangTy ty1, pprInfixName dataCon, pprParendBangTy ty2]
224 ppr_fields fields
225 | null labels
226 = ppr_bndr dataCon <+> sep (map pprParendBangTy fields)
227 | otherwise
228 = ppr_bndr dataCon
229 <+> (braces $ sep $ punctuate comma $ ppr_trim $
230 map maybe_show_label (zip labels fields))
231
232 pprClass :: PrintExplicitForalls -> ShowSub -> GHC.Class -> SDoc
233 pprClass pefas ss cls
234 | null methods && null assoc_ts
235 = pprClassHdr pefas cls
236 | otherwise
237 = vcat [ pprClassHdr pefas cls <+> ptext (sLit "where")
238 , nest 2 (vcat $ ppr_trim $
239 map show_at assoc_ts ++ map show_meth methods)]
240 where
241 methods = GHC.classMethods cls
242 assoc_ts = GHC.classATs cls
243 show_meth id | showSub ss id = Just (pprClassMethod pefas id)
244 | otherwise = Nothing
245 show_at tc = case showSub_maybe ss tc of
246 Just ss' -> Just (pprTyCon pefas ss' tc)
247 Nothing -> Nothing
248
249 pprClassMethod :: PrintExplicitForalls -> Id -> SDoc
250 pprClassMethod pefas id
251 = hang (ppr_bndr id <+> dcolon) 2 (pprTypeForUser pefas op_ty)
252 where
253 -- Here's the magic incantation to strip off the dictionary
254 -- from the class op type. Stolen from IfaceSyn.tyThingToIfaceDecl.
255 --
256 -- It's important to tidy it *before* splitting it up, so that if
257 -- we have class C a b where
258 -- op :: forall a. a -> b
259 -- then the inner forall on op gets renamed to a1, and we print
260 -- (when dropping foralls)
261 -- class C a b where
262 -- op :: a1 -> b
263
264 tidy_sel_ty = tidyTopType (GHC.idType id)
265 (_sel_tyvars, rho_ty) = GHC.splitForAllTys tidy_sel_ty
266 op_ty = GHC.funResultTy rho_ty
267
268 ppr_trim :: [Maybe SDoc] -> [SDoc]
269 -- Collapse a group of Nothings to a single "..."
270 ppr_trim xs
271 = snd (foldr go (False, []) xs)
272 where
273 go (Just doc) (_, so_far) = (False, doc : so_far)
274 go Nothing (True, so_far) = (True, so_far)
275 go Nothing (False, so_far) = (True, ptext (sLit "...") : so_far)
276
277 add_bars :: [SDoc] -> SDoc
278 add_bars [] = empty
279 add_bars [c] = equals <+> c
280 add_bars (c:cs) = sep ((equals <+> c) : map (char '|' <+>) cs)
281
282 -- Wrap operators in ()
283 ppr_bndr :: GHC.NamedThing a => a -> SDoc
284 ppr_bndr a = GHC.pprParenSymName a
285
286 showWithLoc :: SDoc -> SDoc -> SDoc
287 showWithLoc loc doc
288 = hang doc 2 (char '\t' <> comment <+> loc)
289 -- The tab tries to make them line up a bit
290 where
291 comment = ptext (sLit "--")
292