PprTyThing.hs 12.2 KB
Newer Older
1 2 3 4 5 6 7
-----------------------------------------------------------------------------
--
-- Pretty-printing TyThings
--
-- (c) The GHC Team 2005
--
-----------------------------------------------------------------------------
8

Ian Lynagh's avatar
Ian Lynagh committed
9 10 11 12
{-# 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
13
--     http://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
Ian Lynagh's avatar
Ian Lynagh committed
14 15
-- for details

16
module PprTyThing (
17
	PrintExplicitForalls,
18
	pprTyThing,
19
	pprTyThingInContext, 
20 21
	pprTyThingLoc,
	pprTyThingInContextLoc,
22 23
	pprTyThingHdr,
  	pprTypeForUser
24 25 26
  ) where

import qualified GHC
27

Ian Lynagh's avatar
Ian Lynagh committed
28
import GHC ( TyThing(..) )
29 30
import DataCon
import Id
Ian Lynagh's avatar
Ian Lynagh committed
31
import TyCon
32 33
import Coercion( pprCoAxiom, pprCoAxBranch )
import CoAxiom( CoAxiom(..), brListMap )
34
import HscTypes( tyThingParent_maybe )
Simon Peyton Jones's avatar
Simon Peyton Jones committed
35
import Type( tidyTopType, tidyOpenType )
36
import TypeRep( pprTvBndrs )
Ian Lynagh's avatar
Ian Lynagh committed
37
import TcType
38
import Name
39
import VarEnv( emptyTidyEnv )
40
import StaticFlags( opt_PprStyle_Debug )
41
import Outputable
42
import FastString
43 44 45 46 47 48 49

-- -----------------------------------------------------------------------------
-- 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.

50 51
type PrintExplicitForalls = Bool

52 53 54 55 56 57 58 59 60 61 62 63 64 65 66
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 = []

showSub :: NamedThing n => ShowSub -> n -> Bool
showSub []    _     = True
showSub (n:_) thing = n == getName thing

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
67 68

----------------------------
69
-- | Pretty-prints a 'TyThing' with its defining location.
70
pprTyThingLoc :: PrintExplicitForalls -> TyThing -> SDoc
71
pprTyThingLoc pefas tyThing
72
  = showWithLoc (pprDefinedAt (GHC.getName tyThing)) (pprTyThing pefas tyThing)
73 74

-- | Pretty-prints a 'TyThing'.
75
pprTyThing :: PrintExplicitForalls -> TyThing -> SDoc
76
pprTyThing pefas thing = ppr_ty_thing pefas showAll thing
77

78
-- | Pretty-prints a 'TyThing' in context: that is, if the entity
79
-- is a data constructor, record selector, or class method, then
80 81
-- the entity's parent declaration is pretty-printed with irrelevant
-- parts omitted.
82
pprTyThingInContext :: PrintExplicitForalls -> TyThing -> SDoc
83
pprTyThingInContext pefas thing
84 85 86 87 88
  = go [] thing
  where
    go ss thing = case tyThingParent_maybe thing of
                    Just parent -> go (getName thing : ss) parent
                    Nothing     -> ppr_ty_thing pefas ss thing
89 90 91 92

-- | Like 'pprTyThingInContext', but adds the defining location.
pprTyThingInContextLoc :: PrintExplicitForalls -> TyThing -> SDoc
pprTyThingInContextLoc pefas tyThing
93
  = showWithLoc (pprDefinedAt (GHC.getName tyThing))
94 95
                (pprTyThingInContext pefas tyThing)

96 97 98
-- | 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.
99 100 101 102
pprTyThingHdr :: PrintExplicitForalls -> TyThing -> SDoc
pprTyThingHdr pefas (AnId id)          = pprId         pefas id
pprTyThingHdr pefas (ADataCon dataCon) = pprDataConSig pefas dataCon
pprTyThingHdr pefas (ATyCon tyCon)     = pprTyConHdr   pefas tyCon
103
pprTyThingHdr _     (ACoAxiom ax)      = pprCoAxiom ax
Ian Lynagh's avatar
Ian Lynagh committed
104

105 106 107 108 109 110
------------------------
ppr_ty_thing :: PrintExplicitForalls -> ShowSub -> TyThing -> SDoc
ppr_ty_thing pefas _  (AnId id)          = pprId         pefas id
ppr_ty_thing pefas _  (ADataCon dataCon) = pprDataConSig pefas dataCon
ppr_ty_thing pefas ss (ATyCon tyCon)   	 = pprTyCon      pefas ss tyCon
ppr_ty_thing _     _  (ACoAxiom ax)    	 = pprCoAxiom    ax
111

Ian Lynagh's avatar
Ian Lynagh committed
112
pprTyConHdr :: PrintExplicitForalls -> TyCon -> SDoc
batterseapower's avatar
batterseapower committed
113
pprTyConHdr pefas tyCon
114 115
  | Just (fam_tc, tys) <- tyConFamInst_maybe tyCon
  = ptext keyword <+> ptext (sLit "instance") <+> pprTypeApp fam_tc tys
batterseapower's avatar
batterseapower committed
116 117
  | Just cls <- tyConClass_maybe tyCon
  = pprClassHdr pefas cls
118
  | otherwise
119
  = ptext keyword <+> opt_family <+> opt_stupid <+> ppr_bndr tyCon <+> pprTvBndrs vars
120
  where
121
    vars | GHC.isPrimTyCon tyCon ||
122
	   GHC.isFunTyCon tyCon = take (GHC.tyConArity tyCon) GHC.alphaTyVars
123 124
	 | otherwise = GHC.tyConTyVars tyCon

Ian Lynagh's avatar
Ian Lynagh committed
125 126 127
    keyword | GHC.isSynTyCon tyCon = sLit "type"
            | GHC.isNewTyCon tyCon = sLit "newtype"
            | otherwise            = sLit "data"
128

129
    opt_family
130
      | GHC.isFamilyTyCon tyCon = ptext (sLit "family")
131
      | otherwise             = empty
132

133
    opt_stupid 	-- The "stupid theta" part of the declaration
134
	| isAlgTyCon tyCon = GHC.pprThetaArrowTy (tyConStupidTheta tyCon)
135 136
	| otherwise	   = empty	-- Returns 'empty' if null theta

Ian Lynagh's avatar
Ian Lynagh committed
137
pprDataConSig :: PrintExplicitForalls -> GHC.DataCon -> SDoc
138 139
pprDataConSig pefas dataCon
  = ppr_bndr dataCon <+> dcolon <+> pprTypeForUser pefas (GHC.dataConType dataCon)
140

Ian Lynagh's avatar
Ian Lynagh committed
141
pprClassHdr :: PrintExplicitForalls -> GHC.Class -> SDoc
142
pprClassHdr _ cls
143
  = ptext (sLit "class") <+>
144 145 146
    sep [ GHC.pprThetaArrowTy (GHC.classSCTheta cls)
        , ppr_bndr cls <+> pprTvBndrs tyVars
        , GHC.pprFundeps funDeps ]
147
  where
148
     (tyVars, funDeps) = GHC.classTvsFds cls
149

150 151
pprId :: PrintExplicitForalls -> Var -> SDoc
pprId pefas ident
152 153 154 155 156 157 158 159 160 161 162 163
  = hang (ppr_bndr ident <+> dcolon)
	 2 (pprTypeForUser pefas (GHC.idType ident))

pprTypeForUser :: PrintExplicitForalls -> GHC.Type -> SDoc
-- We do two things here.
-- a) We tidy the type, regardless
-- b) If PrintExplicitForAlls is True, we discard the foralls
-- 	but we do so `deeply'
-- Prime example: a class op might have type
--	forall a. C a => forall b. Ord b => stuff
-- Then we want to display
--	(C a, Ord b) => stuff
164
pprTypeForUser print_foralls ty
165
  | print_foralls = ppr tidy_ty
166
  | otherwise     = ppr (mkPhiTy ctxt ty')
167
  where
168
    (_, ctxt, ty') = tcSplitSigmaTy tidy_ty
169 170 171 172 173
    (_, 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
174

175 176
pprTyCon :: PrintExplicitForalls -> ShowSub -> TyCon -> SDoc
pprTyCon pefas ss tyCon
177 178
  | Just syn_rhs <- GHC.synTyConRhs_maybe tyCon
  = case syn_rhs of
179 180 181
      OpenSynFamilyTyCon -> pprTyConHdr pefas tyCon <+> dcolon <+> 
                                 pprTypeForUser pefas (GHC.synTyConResKind tyCon)
      ClosedSynFamilyTyCon (CoAxiom { co_ax_branches = branches }) ->
182
        hang closed_family_header
183
           2 (vcat (brListMap (pprCoAxBranch tyCon) branches))
184
      AbstractClosedSynFamilyTyCon -> closed_family_header <+> ptext (sLit "..")
185
      SynonymTyCon rhs_ty -> hang (pprTyConHdr pefas tyCon <+> equals) 
186
                                     2 (ppr rhs_ty)   -- Don't suppress foralls on RHS type!
187 188 189
      BuiltInSynFamTyCon {} -> pprTyConHdr pefas tyCon <+> dcolon <+> 
                             pprTypeForUser pefas (GHC.synTyConResKind tyCon)

190
                                                 -- e.g. type T = forall a. a->a
batterseapower's avatar
batterseapower committed
191 192
  | Just cls <- GHC.tyConClass_maybe tyCon
  = pprClass pefas ss cls
193
  | otherwise
194
  = pprAlgTyCon pefas ss tyCon
195

196 197 198 199 200
  where
    closed_family_header
      = pprTyConHdr pefas tyCon <+> dcolon <+>
        pprTypeForUser pefas (GHC.synTyConResKind tyCon) <+> ptext (sLit "where")

201 202
pprAlgTyCon :: PrintExplicitForalls -> ShowSub -> TyCon -> SDoc
pprAlgTyCon pefas ss tyCon
203
  | gadt      = pprTyConHdr pefas tyCon <+> ptext (sLit "where") $$
204
		   nest 2 (vcat (ppr_trim (map show_con datacons)))
205
  | otherwise = hang (pprTyConHdr pefas tyCon)
206
    		   2 (add_bars (ppr_trim (map show_con datacons)))
207 208 209 210
  where
    datacons = GHC.tyConDataCons tyCon
    gadt = any (not . GHC.isVanillaDataCon) datacons

211
    ok_con dc = showSub ss dc || any (showSub ss) (dataConFieldLabels dc)
212
    show_con dc
213
      | ok_con dc = Just (pprDataConDecl pefas ss gadt dc)
214
      | otherwise = Nothing
215

216 217
pprDataConDecl :: PrintExplicitForalls -> ShowSub -> Bool -> GHC.DataCon -> SDoc
pprDataConDecl pefas ss gadt_style dataCon
218
  | not gadt_style = ppr_fields tys_w_strs
219 220
  | otherwise      = ppr_bndr dataCon <+> dcolon <+>
			sep [ pp_foralls, GHC.pprThetaArrowTy theta, pp_tau ]
221
	-- Printing out the dataCon as a type signature, in GADT style
222
  where
223 224 225 226
    (forall_tvs, theta, tau) = tcSplitSigmaTy (GHC.dataConUserType dataCon)
    (arg_tys, res_ty)        = tcSplitFunTys tau
    labels     = GHC.dataConFieldLabels dataCon
    stricts    = GHC.dataConStrictMarks dataCon
227
    tys_w_strs = zip (map user_ify stricts) arg_tys
228 229
    pp_foralls | pefas     = GHC.pprForAll forall_tvs
               | otherwise = empty
230

231
    pp_tau = foldr add (ppr res_ty) tys_w_strs
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
232
    add str_ty pp_ty = pprParendBangTy str_ty <+> arrow <+> pp_ty
233

234
    pprParendBangTy (bang,ty) = ppr bang <> GHC.pprParendType ty
235
    pprBangTy       (bang,ty) = ppr bang <> ppr ty
236

237 238 239
    -- See Note [Printing bangs on data constructors]
    user_ify :: HsBang -> HsBang
    user_ify bang | opt_PprStyle_Debug = bang
240 241
    user_ify HsStrict                  = HsUserBang Nothing     True
    user_ify (HsUnpack {})             = HsUserBang (Just True) True
242
    user_ify bang                      = bang
243

244
    maybe_show_label (lbl,bty)
245
	| showSub ss lbl = Just (ppr_bndr lbl <+> dcolon <+> pprBangTy bty)
246
	| otherwise      = Nothing
247 248 249

    ppr_fields [ty1, ty2]
	| GHC.dataConIsInfix dataCon && null labels
250
	= sep [pprParendBangTy ty1, pprInfixName dataCon, pprParendBangTy ty2]
251 252 253 254
    ppr_fields fields
	| null labels
	= ppr_bndr dataCon <+> sep (map pprParendBangTy fields)
	| otherwise
255 256 257
	= ppr_bndr dataCon
	  <+> (braces $ sep $ punctuate comma $ ppr_trim $
               map maybe_show_label (zip labels fields))
258

259 260
pprClass :: PrintExplicitForalls -> ShowSub -> GHC.Class -> SDoc
pprClass pefas ss cls
261
  | null methods && null assoc_ts
262
  = pprClassHdr pefas cls
263
  | otherwise
264 265 266
  = vcat [ pprClassHdr pefas cls <+> ptext (sLit "where")
         , nest 2 (vcat $ ppr_trim $ 
                   map show_at assoc_ts ++ map show_meth methods)]
267
  where
268
    methods  = GHC.classMethods cls
269 270 271 272 273 274
    assoc_ts = GHC.classATs cls
    show_meth id | showSub ss id  = Just (pprClassMethod pefas id)
	         | otherwise      = Nothing
    show_at tc = case showSub_maybe ss tc of
                      Just ss' -> Just (pprTyCon pefas ss' tc)
                      Nothing  -> Nothing
275

Ian Lynagh's avatar
Ian Lynagh committed
276
pprClassMethod :: PrintExplicitForalls -> Id -> SDoc
277 278
pprClassMethod pefas id
  = hang (ppr_bndr id <+> dcolon) 2 (pprTypeForUser pefas op_ty)
279 280 281
  where
  -- Here's the magic incantation to strip off the dictionary
  -- from the class op type.  Stolen from IfaceSyn.tyThingToIfaceDecl.
282
  --
283
  -- It's important to tidy it *before* splitting it up, so that if
284 285 286 287 288 289 290 291 292 293
  -- 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 (GHC.idType id)
  (_sel_tyvars, rho_ty) = GHC.splitForAllTys tidy_sel_ty
  op_ty = GHC.funResultTy rho_ty
294

295 296 297
ppr_trim :: [Maybe SDoc] -> [SDoc]
-- Collapse a group of Nothings to a single "..."
ppr_trim xs
298 299
  = snd (foldr go (False, []) xs)
  where
300 301 302
    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)
303

Ian Lynagh's avatar
Ian Lynagh committed
304
add_bars :: [SDoc] -> SDoc
305 306 307 308 309 310 311 312
add_bars []      = empty
add_bars [c]     = equals <+> c
add_bars (c:cs)  = sep ((equals <+> c) : map (char '|' <+>) cs)

-- Wrap operators in ()
ppr_bndr :: GHC.NamedThing a => a -> SDoc
ppr_bndr a = GHC.pprParenSymName a

313
showWithLoc :: SDoc -> SDoc -> SDoc
314
showWithLoc loc doc
315
    = hang doc 2 (char '\t' <> comment <+> loc)
316 317
		-- The tab tries to make them line up a bit
  where
Ian Lynagh's avatar
Ian Lynagh committed
318
    comment = ptext (sLit "--")
319

320 321 322 323 324 325 326 327
{- 
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.
-}