ghc/compiler/coreSyn/PprCore.lhs

   1 %
   2 % (c) The AQUA Project, Glasgow University, 1996-1998
   3 %
   4 %************************************************************************
   5 %*                                                                      *
   6 \section[PprCore]{Printing of Core syntax, including for interfaces}
   7 %*                                                                      *
   8 %************************************************************************
   9
  10 \begin{code}
  11 module PprCore (
  12         pprCoreExpr, pprParendExpr,
  13         pprCoreBinding, pprCoreBindings, pprIdBndr,
  14         pprCoreBinding, pprCoreBindings, pprCoreAlt,
  15         pprIdRules, pprCoreRule
  16     ) where
  17
  18 #include "HsVersions.h"
  19
  20 import CoreSyn
  21 import CostCentre       ( pprCostCentreCore )
  22 import Id               ( Id, idType, isDataConId_maybe, idLBVarInfo, idArity,
  23                           idInfo, idInlinePragma, idOccInfo,
  24 #ifdef OLD_STRICTNESS
  25                           idDemandInfo,
  26 #endif
  27                           globalIdDetails, isGlobalId, isExportedId,
  28                           isSpecPragmaId, idNewDemandInfo
  29                         )
  30 import Var              ( isTyVar )
  31 import IdInfo           ( IdInfo, megaSeqIdInfo,
  32                           arityInfo, ppArityInfo,
  33                           specInfo, ppStrictnessInfo,
  34                           workerInfo, ppWorkerInfo,
  35                           newStrictnessInfo,
  36 #ifdef OLD_STRICTNESS
  37                           cprInfo, ppCprInfo,
  38                           strictnessInfo,
  39 #endif
  40                         )
  41 import DataCon          ( dataConTyCon )
  42 import TyCon            ( tupleTyConBoxity, isTupleTyCon )
  43 import PprType          ( pprParendType, pprTyVarBndr )
  44 import BasicTypes       ( tupleParens )
  45 import PprEnv
  46 import Util             ( lengthIs )
  47 import Outputable
  48 \end{code}
  49
  50 %************************************************************************
  51 %*                                                                      *
  52 \subsection{Public interfaces for Core printing (excluding instances)}
  53 %*                                                                      *
  54 %************************************************************************
  55
  56 @pprCoreBinding@ and @pprCoreExpr@ let you give special printing
  57 function for ``major'' val_bdrs (those next to equal signs :-),
  58 ``minor'' ones (lambda-bound, case-bound), and bindees.  They would
  59 usually be called through some intermediary.
  60
  61 The binder/occ printers take the default ``homogenized'' (see
  62 @PprEnv@...) @Doc@ and the binder/occ.  They can either use the
  63 homogenized one, or they can ignore it completely.  In other words,
  64 the things passed in act as ``hooks'', getting the last word on how to
  65 print something.
  66
  67 @pprParendCoreExpr@ puts parens around non-atomic Core expressions.
  68
  69 Un-annotated core dumps
  70 ~~~~~~~~~~~~~~~~~~~~~~~
  71 \begin{code}
  72 pprCoreBindings :: [CoreBind] -> SDoc
  73 pprCoreBinding  :: CoreBind   -> SDoc
  74 pprCoreExpr     :: CoreExpr   -> SDoc
  75 pprParendExpr   :: CoreExpr   -> SDoc
  76
  77 pprCoreBindings = pprTopBinds pprCoreEnv
  78 pprCoreBinding  = pprTopBind pprCoreEnv
  79 pprCoreExpr     = ppr_noparend_expr pprCoreEnv
  80 pprParendExpr   = ppr_parend_expr   pprCoreEnv
  81 pprArg          = ppr_arg pprCoreEnv
  82 pprCoreAlt      = ppr_alt pprCoreEnv
  83
  84 pprCoreEnv = initCoreEnv pprCoreBinder
  85 \end{code}
  86
  87 Printer for unfoldings in interfaces
  88 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  89 \begin{code}
  90 instance Outputable b => Outputable (Bind b) where
  91     ppr bind = ppr_bind pprGenericEnv bind
  92
  93 instance Outputable b => Outputable (Expr b) where
  94     ppr expr = ppr_noparend_expr pprGenericEnv expr
  95
  96 pprGenericEnv :: Outputable b => PprEnv b
  97 pprGenericEnv = initCoreEnv (\site -> ppr)
  98 \end{code}
  99
 100 %************************************************************************
 101 %*                                                                      *
 102 \subsection{Instance declarations for Core printing}
 103 %*                                                                      *
 104 %************************************************************************
 105
 106
 107 \begin{code}
 108 initCoreEnv pbdr
 109   = initPprEnv
 110         (Just pprCostCentreCore)        -- Cost centres
 111
 112         (Just ppr)              -- tyvar occs
 113         (Just pprParendType)    -- types
 114
 115         (Just pbdr) (Just ppr) -- value vars
 116         -- Use pprIdBndr for this last one as a debugging device.
 117 \end{code}
 118
 119 %************************************************************************
 120 %*                                                                      *
 121 \subsection{The guts}
 122 %*                                                                      *
 123 %************************************************************************
 124
 125 \begin{code}
 126 pprTopBinds pe binds = vcat (map (pprTopBind pe) binds)
 127
 128 pprTopBind pe (NonRec binder expr)
 129  = ppr_binding_pe pe (binder,expr) $$ text ""
 130
 131 pprTopBind pe (Rec binds)
 132   = vcat [ptext SLIT("Rec {"),
 133           vcat (map (ppr_binding_pe pe) binds),
 134           ptext SLIT("end Rec }"),
 135           text ""]
 136 \end{code}
 137
 138 \begin{code}
 139 ppr_bind :: PprEnv b -> Bind b -> SDoc
 140
 141 ppr_bind pe (NonRec val_bdr expr) = ppr_binding_pe pe (val_bdr, expr)
 142 ppr_bind pe (Rec binds)           = vcat (map pp binds)
 143                                   where
 144                                     pp bind = ppr_binding_pe pe bind <> semi
 145
 146 ppr_binding_pe :: PprEnv b -> (b, Expr b) -> SDoc
 147 ppr_binding_pe pe (val_bdr, expr)
 148   = sep [pBndr pe LetBind val_bdr,
 149          nest 2 (equals <+> ppr_noparend_expr pe expr)]
 150 \end{code}
 151
 152 \begin{code}
 153 ppr_parend_expr   pe expr = ppr_expr parens pe expr
 154 ppr_noparend_expr pe expr = ppr_expr noParens pe expr
 155
 156 noParens :: SDoc -> SDoc
 157 noParens pp = pp
 158 \end{code}
 159
 160 \begin{code}
 161 ppr_expr :: (SDoc -> SDoc) -> PprEnv b -> Expr b -> SDoc
 162         -- The function adds parens in context that need
 163         -- an atomic value (e.g. function args)
 164
 165 ppr_expr add_par pe (Type ty)  = add_par (ptext SLIT("TYPE") <+> ppr ty)        -- Wierd
 166
 167 ppr_expr add_par pe (Var name) = pOcc pe name
 168 ppr_expr add_par pe (Lit lit)  = ppr lit
 169
 170 ppr_expr add_par pe expr@(Lam _ _)
 171   = let
 172         (bndrs, body) = collectBinders expr
 173     in
 174     add_par $
 175     hang (ptext SLIT("\\") <+> sep (map (pBndr pe LambdaBind) bndrs) <+> arrow)
 176          2 (ppr_noparend_expr pe body)
 177
 178 ppr_expr add_par pe expr@(App fun arg)
 179   = case collectArgs expr of { (fun, args) ->
 180     let
 181         pp_args     = sep (map (ppr_arg pe) args)
 182         val_args    = dropWhile isTypeArg args   -- Drop the type arguments for tuples
 183         pp_tup_args = sep (punctuate comma (map (ppr_arg pe) val_args))
 184     in
 185     case fun of
 186         Var f -> case isDataConId_maybe f of
 187                         -- Notice that we print the *worker*
 188                         -- for tuples in paren'd format.
 189                    Just dc | saturated && isTupleTyCon tc
 190                            -> tupleParens (tupleTyConBoxity tc) pp_tup_args
 191                            where
 192                              tc        = dataConTyCon dc
 193                              saturated = val_args `lengthIs` idArity f
 194
 195                    other -> add_par (hang (pOcc pe f) 2 pp_args)
 196
 197         other -> add_par (hang (ppr_parend_expr pe fun) 2 pp_args)
 198     }
 199
 200 ppr_expr add_par pe (Case expr var [(con,args,rhs)])
 201   = add_par $
 202     sep [sep [ptext SLIT("case") <+> ppr_noparend_expr pe expr,
 203               hsep [ptext SLIT("of"),
 204                     ppr_bndr var,
 205                     char '{',
 206                     ppr_case_pat pe con args
 207           ]],
 208          ppr_noparend_expr pe rhs,
 209          char '}'
 210     ]
 211   where
 212     ppr_bndr = pBndr pe CaseBind
 213
 214 ppr_expr add_par pe (Case expr var alts)
 215   = add_par $
 216     sep [sep [ptext SLIT("case") <+> ppr_noparend_expr pe expr,
 217               ptext SLIT("of") <+> ppr_bndr var <+> char '{'],
 218          nest 2 (sep (punctuate semi (map (ppr_alt pe) alts))),
 219          char '}'
 220     ]
 221   where
 222     ppr_bndr = pBndr pe CaseBind
 223
 224
 225 -- special cases: let ... in let ...
 226 -- ("disgusting" SLPJ)
 227
 228 ppr_expr add_par pe (Let bind@(NonRec val_bdr rhs@(Let _ _)) body)
 229   = add_par $
 230     vcat [
 231       hsep [ptext SLIT("let {"), pBndr pe LetBind val_bdr, equals],
 232       nest 2 (ppr_noparend_expr pe rhs),
 233       ptext SLIT("} in"),
 234       ppr_noparend_expr pe body ]
 235
 236 ppr_expr add_par pe (Let bind@(NonRec val_bdr rhs) expr@(Let _ _))
 237   = add_par
 238     (hang (ptext SLIT("let {"))
 239           2 (hsep [hang (hsep [pBndr pe LetBind val_bdr, equals])
 240                            2 (ppr_noparend_expr pe rhs),
 241        ptext SLIT("} in")])
 242      $$
 243      ppr_noparend_expr pe expr)
 244
 245 -- general case (recursive case, too)
 246 ppr_expr add_par pe (Let bind expr)
 247   = add_par $
 248     sep [hang (ptext keyword) 2 (ppr_bind pe bind),
 249          hang (ptext SLIT("} in ")) 2 (ppr_noparend_expr pe expr)]
 250   where
 251     keyword = case bind of
 252                 Rec _      -> SLIT("__letrec {")
 253                 NonRec _ _ -> SLIT("let {")
 254
 255 ppr_expr add_par pe (Note (SCC cc) expr)
 256   = add_par (sep [pSCC pe cc, ppr_noparend_expr pe expr])
 257
 258 #ifdef DEBUG
 259 ppr_expr add_par pe (Note (Coerce to_ty from_ty) expr)
 260  = add_par $
 261    getPprStyle $ \ sty ->
 262    if debugStyle sty then
 263       sep [ptext SLIT("__coerce") <+> sep [pTy pe to_ty, pTy pe from_ty],
 264            ppr_parend_expr pe expr]
 265    else
 266       sep [hsep [ptext SLIT("__coerce"), pTy pe to_ty],
 267                   ppr_parend_expr pe expr]
 268 #else
 269 ppr_expr add_par pe (Note (Coerce to_ty from_ty) expr)
 270   = add_par $
 271     sep [sep [ptext SLIT("__coerce"), nest 2 (pTy pe to_ty)],
 272          ppr_parend_expr pe expr]
 273 #endif
 274
 275 ppr_expr add_par pe (Note InlineCall expr)
 276   = add_par (ptext SLIT("__inline_call") <+> ppr_parend_expr pe expr)
 277
 278 ppr_expr add_par pe (Note InlineMe expr)
 279   = add_par $ ptext SLIT("__inline_me") <+> ppr_parend_expr pe expr
 280
 281 ppr_alt pe (con, args, rhs)
 282   = hang (ppr_case_pat pe con args) 2 (ppr_noparend_expr pe rhs)
 283
 284 ppr_case_pat pe con@(DataAlt dc) args
 285   | isTupleTyCon tc
 286   = tupleParens (tupleTyConBoxity tc) (hsep (punctuate comma (map ppr_bndr args))) <+> arrow
 287   where
 288     ppr_bndr = pBndr pe CaseBind
 289     tc = dataConTyCon dc
 290
 291 ppr_case_pat pe con args
 292   = ppr con <+> hsep (map ppr_bndr args) <+> arrow
 293   where
 294     ppr_bndr = pBndr pe CaseBind
 295
 296 ppr_arg pe (Type ty) = ptext SLIT("@") <+> pTy pe ty
 297 ppr_arg pe expr      = ppr_parend_expr pe expr
 298
 299 arrow = ptext SLIT("->")
 300 \end{code}
 301
 302 Other printing bits-and-bobs used with the general @pprCoreBinding@
 303 and @pprCoreExpr@ functions.
 304
 305 \begin{code}
 306 -- Used for printing dump info
 307 pprCoreBinder LetBind binder
 308   = vcat [sig, pprIdDetails binder, pragmas, ppr binder]
 309   where
 310     sig     = pprTypedBinder binder
 311     pragmas = ppIdInfo binder (idInfo binder)
 312
 313 -- Lambda bound type variables are preceded by "@"
 314 pprCoreBinder LambdaBind bndr = pprTypedBinder bndr
 315
 316 -- Case bound things don't get a signature or a herald
 317 pprCoreBinder CaseBind bndr = pprUntypedBinder bndr
 318
 319 pprUntypedBinder binder
 320   | isTyVar binder = ptext SLIT("@") <+> ppr binder     -- NB: don't print kind
 321   | otherwise      = pprIdBndr binder
 322
 323 pprTypedBinder binder
 324   | isTyVar binder  = ptext SLIT("@") <+> pprTyVarBndr binder
 325   | otherwise       = pprIdBndr binder <+> dcolon <+> pprParendType (idType binder)
 326         -- The space before the :: is important; it helps the lexer
 327         -- when reading inferfaces.  Otherwise it would lex "a::b" as one thing.
 328         --
 329         -- It's important that the type is parenthesised too, at least when
 330         -- printing interfaces, because we get \ x::(a->b) y::(c->d) -> ...
 331
 332 -- pprIdBndr does *not* print the type
 333 -- When printing any Id binder in debug mode, we print its inline pragma and one-shot-ness
 334 pprIdBndr id = ppr id <+>
 335                (megaSeqIdInfo (idInfo id) `seq`
 336                         -- Useful for poking on black holes
 337                 ifPprDebug (ppr (idInlinePragma id) <+> ppr (idOccInfo id) <+>
 338 #ifdef OLD_STRICTNESS
 339                             ppr (idDemandInfo id) <+>
 340 #endif
 341                             ppr (idNewDemandInfo id) <+>
 342                             ppr (idLBVarInfo id)))
 343 \end{code}
 344
 345
 346 \begin{code}
 347 pprIdDetails :: Id -> SDoc
 348 pprIdDetails id | isGlobalId id     = ppr (globalIdDetails id)
 349                 | isExportedId id   = ptext SLIT("[Exported]")
 350                 | isSpecPragmaId id = ptext SLIT("[SpecPrag]")
 351                 | otherwise         = empty
 352
 353 ppIdInfo :: Id -> IdInfo -> SDoc
 354 ppIdInfo b info
 355   = hsep [  ppArityInfo a,
 356             ppWorkerInfo (workerInfo info),
 357 #ifdef OLD_STRICTNESS
 358             ppStrictnessInfo s,
 359             ppCprInfo m,
 360 #endif
 361             ppr (newStrictnessInfo info),
 362             vcat (map (pprCoreRule (ppr b)) (rulesRules p))
 363         -- Inline pragma, occ, demand, lbvar info
 364         -- printed out with all binders (when debug is on);
 365         -- see PprCore.pprIdBndr
 366         ]
 367   where
 368     a = arityInfo info
 369 #ifdef OLD_STRICTNESS
 370     s = strictnessInfo info
 371     m = cprInfo info
 372 #endif
 373     p = specInfo info
 374 \end{code}
 375
 376
 377 \begin{code}
 378 pprIdRules :: [IdCoreRule] -> SDoc
 379 pprIdRules rules = vcat (map pprIdRule rules)
 380
 381 pprIdRule :: IdCoreRule -> SDoc
 382 pprIdRule (id,rule) = pprCoreRule (ppr id) rule
 383
 384 pprCoreRule :: SDoc -> CoreRule -> SDoc
 385 pprCoreRule pp_fn (BuiltinRule name _)
 386   = ifPprDebug (ptext SLIT("Built in rule for") <+> pp_fn <> colon
 387                  <+> doubleQuotes (ftext name))
 388
 389 pprCoreRule pp_fn (Rule name act tpl_vars tpl_args rhs)
 390   = doubleQuotes (ftext name) <+> ppr act <+>
 391     sep [
 392           ptext SLIT("__forall") <+> braces (sep (map pprTypedBinder tpl_vars)),
 393           nest 2 (pp_fn <+> sep (map pprArg tpl_args)),
 394           nest 2 (ptext SLIT("=") <+> pprCoreExpr rhs)
 395     ] <+> semi
 396 \end{code}