compiler/main/PprTyThing.hs

   1 -----------------------------------------------------------------------------
   2 --
   3 -- Pretty-printing TyThings
   4 --
   5 -- (c) The GHC Team 2005
   6 --
   7 -----------------------------------------------------------------------------
   8
   9 {-# OPTIONS_GHC -w #-}
  10 -- The above warning supression flag is a temporary kludge.
  11 -- While working on this module you are encouraged to remove it and fix
  12 -- any warnings in the module. See
  13 --     http://hackage.haskell.org/trac/ghc/wiki/WorkingConventions#Warnings
  14 -- for details
  15
  16 module PprTyThing (
  17         PrintExplicitForalls,
  18         pprTyThing,
  19         pprTyThingInContext,
  20         pprTyThingLoc,
  21         pprTyThingInContextLoc,
  22         pprTyThingHdr
  23   ) where
  24
  25 #include "HsVersions.h"
  26
  27 import qualified GHC
  28
  29 import TyCon    ( tyConFamInst_maybe )
  30 import Type     ( pprTypeApp )
  31 import GHC      ( TyThing(..), SrcSpan )
  32 import Var
  33 import Outputable
  34
  35 -- -----------------------------------------------------------------------------
  36 -- Pretty-printing entities that we get from the GHC API
  37
  38 -- This should be a good source of sample code for using the GHC API to
  39 -- inspect source code entities.
  40
  41 type PrintExplicitForalls = Bool
  42
  43 -- | Pretty-prints a 'TyThing' with its defining location.
  44 pprTyThingLoc :: PrintExplicitForalls -> TyThing -> SDoc
  45 pprTyThingLoc pefas tyThing
  46   = showWithLoc loc (pprTyThing pefas tyThing)
  47   where loc = GHC.nameSrcSpan (GHC.getName tyThing)
  48
  49 -- | Pretty-prints a 'TyThing'.
  50 pprTyThing :: PrintExplicitForalls -> TyThing -> SDoc
  51 pprTyThing pefas (AnId id)          = pprId         pefas id
  52 pprTyThing pefas (ADataCon dataCon) = pprDataConSig pefas dataCon
  53 pprTyThing pefas (ATyCon tyCon)     = pprTyCon      pefas tyCon
  54 pprTyThing pefas (AClass cls)       = pprClass      pefas cls
  55
  56 -- | Like 'pprTyThingInContext', but adds the defining location.
  57 pprTyThingInContextLoc :: PrintExplicitForalls -> TyThing -> SDoc
  58 pprTyThingInContextLoc pefas tyThing
  59   = showWithLoc loc (pprTyThingInContext pefas tyThing)
  60   where loc = GHC.nameSrcSpan (GHC.getName tyThing)
  61
  62 -- | Pretty-prints a 'TyThing' in context: that is, if the entity
  63 -- is a data constructor, record selector, or class method, then
  64 -- the entity's parent declaration is pretty-printed with irrelevant
  65 -- parts omitted.
  66 pprTyThingInContext :: PrintExplicitForalls -> TyThing -> SDoc
  67 pprTyThingInContext pefas (AnId id)          = pprIdInContext pefas id
  68 pprTyThingInContext pefas (ADataCon dataCon) = pprDataCon pefas dataCon
  69 pprTyThingInContext pefas (ATyCon tyCon)     = pprTyCon   pefas tyCon
  70 pprTyThingInContext pefas (AClass cls)       = pprClass   pefas cls
  71
  72 -- | Pretty-prints the 'TyThing' header. For functions and data constructors
  73 -- the function is equivalent to 'pprTyThing' but for type constructors
  74 -- and classes it prints only the header part of the declaration.
  75 pprTyThingHdr :: PrintExplicitForalls -> TyThing -> SDoc
  76 pprTyThingHdr pefas (AnId id)          = pprId         pefas id
  77 pprTyThingHdr pefas (ADataCon dataCon) = pprDataConSig pefas dataCon
  78 pprTyThingHdr pefas (ATyCon tyCon)     = pprTyConHdr   pefas tyCon
  79 pprTyThingHdr pefas (AClass cls)       = pprClassHdr   pefas cls
  80
  81 pprTyConHdr pefas tyCon
  82   | Just (fam_tc, tys) <- tyConFamInst_maybe tyCon
  83   = ptext keyword <+> ptext SLIT("instance") <+> pprTypeApp tyCon (ppr_bndr tyCon) tys
  84   | otherwise
  85   = ptext keyword <+> opt_family <+> ppr_bndr tyCon <+> hsep (map ppr vars)
  86   where
  87     vars | GHC.isPrimTyCon tyCon ||
  88            GHC.isFunTyCon tyCon = take (GHC.tyConArity tyCon) GHC.alphaTyVars
  89          | otherwise = GHC.tyConTyVars tyCon
  90
  91     keyword | GHC.isSynTyCon tyCon = SLIT("type")
  92             | GHC.isNewTyCon tyCon = SLIT("newtype")
  93             | otherwise            = SLIT("data")
  94
  95     opt_family
  96       | GHC.isOpenTyCon tyCon = ptext SLIT("family")
  97       | otherwise             = empty
  98
  99 pprDataConSig pefas dataCon =
 100   ppr_bndr dataCon <+> dcolon <+> pprType pefas (GHC.dataConType dataCon)
 101
 102 pprClassHdr pefas cls =
 103   let (tyVars, funDeps) = GHC.classTvsFds cls
 104   in ptext SLIT("class") <+>
 105      GHC.pprThetaArrow (GHC.classSCTheta cls) <+>
 106      ppr_bndr cls <+>
 107      hsep (map ppr tyVars) <+>
 108      GHC.pprFundeps funDeps
 109
 110 pprIdInContext pefas id
 111   | GHC.isRecordSelector id               = pprRecordSelector pefas id
 112   | Just cls <- GHC.isClassOpId_maybe id  = pprClassOneMethod pefas cls id
 113   | otherwise                             = pprId pefas id
 114
 115 pprRecordSelector pefas id
 116   = pprAlgTyCon pefas tyCon show_con show_label
 117   where
 118         (tyCon,label) = GHC.recordSelectorFieldLabel id
 119         show_con dataCon  = label `elem` GHC.dataConFieldLabels dataCon
 120         show_label label' = label == label'
 121
 122 pprId :: PrintExplicitForalls -> Var -> SDoc
 123 pprId pefas ident
 124   = hang (ppr_bndr ident <+> dcolon) 2
 125         (pprType pefas (GHC.idType ident))
 126
 127 pprType :: PrintExplicitForalls -> GHC.Type -> SDoc
 128 pprType True  ty = ppr ty
 129 pprType False ty = ppr (GHC.dropForAlls ty)
 130
 131 pprTyCon pefas tyCon
 132   | GHC.isSynTyCon tyCon
 133   = if GHC.isOpenTyCon tyCon
 134     then pprTyConHdr pefas tyCon <+> dcolon <+>
 135          pprType pefas (GHC.synTyConResKind tyCon)
 136     else
 137       let rhs_type = GHC.synTyConType tyCon
 138       in hang (pprTyConHdr pefas tyCon <+> equals) 2 (pprType pefas rhs_type)
 139   | otherwise
 140   = pprAlgTyCon pefas tyCon (const True) (const True)
 141
 142 pprAlgTyCon pefas tyCon ok_con ok_label
 143   | gadt      = pprTyConHdr pefas tyCon <+> ptext SLIT("where") $$
 144                    nest 2 (vcat (ppr_trim show_con datacons))
 145   | otherwise = hang (pprTyConHdr pefas tyCon)
 146                    2 (add_bars (ppr_trim show_con datacons))
 147   where
 148     datacons = GHC.tyConDataCons tyCon
 149     gadt = any (not . GHC.isVanillaDataCon) datacons
 150
 151     show_con dataCon
 152       | ok_con dataCon = Just (pprDataConDecl pefas gadt ok_label dataCon)
 153       | otherwise      = Nothing
 154
 155 pprDataCon pefas dataCon = pprAlgTyCon pefas tyCon (== dataCon) (const True)
 156   where tyCon = GHC.dataConTyCon dataCon
 157
 158 pprDataConDecl pefas gadt_style show_label dataCon
 159   | not gadt_style = ppr_fields tys_w_strs
 160   | otherwise      = ppr_bndr dataCon <+> dcolon <+>
 161                         sep [ ppr_tvs, GHC.pprThetaArrow theta, pp_tau ]
 162   where
 163     (tyvars, theta, argTypes, res_ty) = GHC.dataConSig dataCon
 164     tyCon = GHC.dataConTyCon dataCon
 165     labels = GHC.dataConFieldLabels dataCon
 166     qualVars = filter (flip notElem (GHC.tyConTyVars tyCon)) tyvars
 167     stricts = GHC.dataConStrictMarks dataCon
 168     tys_w_strs = zip stricts argTypes
 169
 170     ppr_tvs
 171         | null qualVars = empty
 172         | otherwise     = ptext SLIT("forall") <+>
 173                                 hsep (map ppr qualVars) <> dot
 174
 175         -- printing out the dataCon as a type signature, in GADT style
 176     pp_tau = foldr add (ppr res_ty) tys_w_strs
 177     add (str,ty) pp_ty = pprBangTy str ty <+> arrow <+> pp_ty
 178
 179     pprParendBangTy (strict,ty)
 180         | GHC.isMarkedStrict strict = char '!' <> GHC.pprParendType ty
 181         | otherwise                 = GHC.pprParendType ty
 182
 183     pprBangTy strict ty
 184         | GHC.isMarkedStrict strict = char '!' <> ppr ty
 185         | otherwise                 = ppr ty
 186
 187     maybe_show_label (lbl,(strict,tp))
 188         | show_label lbl = Just (ppr lbl <+> dcolon <+> pprBangTy strict tp)
 189         | otherwise      = Nothing
 190
 191     ppr_fields [ty1, ty2]
 192         | GHC.dataConIsInfix dataCon && null labels
 193         = sep [pprParendBangTy ty1, ppr dataCon, pprParendBangTy ty2]
 194     ppr_fields fields
 195         | null labels
 196         = ppr_bndr dataCon <+> sep (map pprParendBangTy fields)
 197         | otherwise
 198         = ppr_bndr dataCon <+>
 199                 braces (sep (punctuate comma (ppr_trim maybe_show_label
 200                                         (zip labels fields))))
 201
 202 pprClass pefas cls
 203   | null methods =
 204         pprClassHdr pefas cls
 205   | otherwise =
 206         hang (pprClassHdr pefas cls <+> ptext SLIT("where"))
 207             2 (vcat (map (pprClassMethod pefas) methods))
 208   where
 209         methods = GHC.classMethods cls
 210
 211 pprClassOneMethod pefas cls this_one =
 212   hang (pprClassHdr pefas cls <+> ptext SLIT("where"))
 213         2 (vcat (ppr_trim show_meth methods))
 214   where
 215         methods = GHC.classMethods cls
 216         show_meth id | id == this_one = Just (pprClassMethod pefas id)
 217                      | otherwise      = Nothing
 218
 219 pprClassMethod pefas id =
 220   hang (ppr_bndr id <+> dcolon) 2 (pprType pefas (classOpType id))
 221   where
 222   -- Here's the magic incantation to strip off the dictionary
 223   -- from the class op type.  Stolen from IfaceSyn.tyThingToIfaceDecl.
 224   classOpType id = GHC.funResultTy rho_ty
 225      where (_sel_tyvars, rho_ty) = GHC.splitForAllTys (GHC.idType id)
 226
 227 ppr_trim :: (a -> Maybe SDoc) -> [a] -> [SDoc]
 228 ppr_trim show xs
 229   = snd (foldr go (False, []) xs)
 230   where
 231     go x (eliding, so_far)
 232         | Just doc <- show x = (False, doc : so_far)
 233         | otherwise = if eliding then (True, so_far)
 234                                  else (True, ptext SLIT("...") : so_far)
 235
 236 add_bars []      = empty
 237 add_bars [c]     = equals <+> c
 238 add_bars (c:cs)  = sep ((equals <+> c) : map (char '|' <+>) cs)
 239
 240 -- Wrap operators in ()
 241 ppr_bndr :: GHC.NamedThing a => a -> SDoc
 242 ppr_bndr a = GHC.pprParenSymName a
 243
 244 showWithLoc :: SrcSpan -> SDoc -> SDoc
 245 showWithLoc loc doc
 246     = hang doc 2 (char '\t' <> comment <+> GHC.pprDefnLoc loc)
 247                 -- The tab tries to make them line up a bit
 248   where
 249     comment = ptext SLIT("--")
 250