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, pprIdBndr,
  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,
  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             ppr d,
 359             ppCafInfo c,
 360             ppCprInfo m,
 361             ppr (lbvarInfo info),
 362             pprIfaceCoreRules p
 363         -- Inline pragma printed out with all binders; see PprCore.pprIdBndr
 364         ]
 365   where
 366     a = arityInfo info
 367     d = demandInfo info
 368     s = strictnessInfo info
 369     u = updateInfo info
 370     c = cafInfo info
 371     m = cprInfo info
 372     p = specInfo info
 373 \end{code}
 374
 375
 376 \begin{code}
 377 pprCoreRules :: Id -> CoreRules -> SDoc
 378 pprCoreRules var (Rules rules _) = vcat (map (pprCoreRule (Just var)) rules)
 379
 380 pprIfaceCoreRules :: CoreRules -> SDoc
 381 pprIfaceCoreRules (Rules rules _) = vcat (map (pprCoreRule Nothing) rules)
 382
 383 pprCoreRule :: Maybe Id -> CoreRule -> SDoc
 384 pprCoreRule maybe_fn (BuiltinRule _)
 385   = ifPprDebug (ptext SLIT("A built in rule"))
 386
 387 pprCoreRule maybe_fn (Rule name tpl_vars tpl_args rhs)
 388   = doubleQuotes (ptext name) <+>
 389     sep [
 390           ptext SLIT("__forall") <+> braces (sep (map pprTypedBinder tpl_vars)),
 391           nest 4 (pp_fn <+> sep (map pprIfaceArg tpl_args)),
 392           nest 4 (ptext SLIT("=") <+> pprIfaceUnfolding rhs)
 393     ] <+> semi
 394   where
 395     pp_fn = case maybe_fn of
 396                 Just id -> ppr id
 397                 Nothing -> empty                -- Interface file
 398 \end{code}