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