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               ( idType, idInfo, getInlinePragma, getIdDemandInfo, Id )
  22 import Var              ( isTyVar )
  23 import IdInfo           ( IdInfo,
  24                           arityInfo, ppArityInfo, ppFlavourInfo, flavourInfo,
  25                           demandInfo, updateInfo, ppUpdateInfo, specInfo,
  26                           strictnessInfo, ppStrictnessInfo, cafInfo, ppCafInfo,
  27                           cprInfo, ppCprInfo, lbvarInfo,
  28                           workerInfo, ppWorkerInfo
  29                         )
  30 import Const            ( Con(..), DataCon )
  31 import DataCon          ( isTupleCon, isUnboxedTupleCon )
  32 import PprType          ( pprParendType, pprTyVarBndr )
  33 import PprEnv
  34 import Outputable
  35 \end{code}
  36
  37 %************************************************************************
  38 %*                                                                      *
  39 \subsection{Public interfaces for Core printing (excluding instances)}
  40 %*                                                                      *
  41 %************************************************************************
  42
  43 @pprCoreBinding@ and @pprCoreExpr@ let you give special printing
  44 function for ``major'' val_bdrs (those next to equal signs :-),
  45 ``minor'' ones (lambda-bound, case-bound), and bindees.  They would
  46 usually be called through some intermediary.
  47
  48 The binder/occ printers take the default ``homogenized'' (see
  49 @PprEnv@...) @Doc@ and the binder/occ.  They can either use the
  50 homogenized one, or they can ignore it completely.  In other words,
  51 the things passed in act as ``hooks'', getting the last word on how to
  52 print something.
  53
  54 @pprParendCoreExpr@ puts parens around non-atomic Core expressions.
  55
  56 Un-annotated core dumps
  57 ~~~~~~~~~~~~~~~~~~~~~~~
  58 \begin{code}
  59 pprCoreBindings :: [CoreBind] -> SDoc
  60 pprCoreBinding  :: CoreBind   -> SDoc
  61 pprCoreExpr     :: CoreExpr   -> SDoc
  62 pprParendExpr   :: CoreExpr   -> SDoc
  63
  64 pprCoreBindings = pprTopBinds pprCoreEnv
  65 pprCoreBinding  = pprTopBind pprCoreEnv
  66 pprCoreExpr     = ppr_expr pprCoreEnv
  67 pprParendExpr   = ppr_parend_expr pprCoreEnv
  68
  69 pprCoreEnv = initCoreEnv pprCoreBinder
  70 \end{code}
  71
  72 Printer for unfoldings in interfaces
  73 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  74 \begin{code}
  75 pprIfaceUnfolding :: CoreExpr -> SDoc
  76 pprIfaceUnfolding = ppr_parend_expr pprIfaceEnv
  77         -- Notice that it's parenthesised
  78
  79 pprIfaceArg = ppr_arg pprIfaceEnv
  80
  81 pprIfaceEnv = initCoreEnv pprIfaceBinder
  82 \end{code}
  83
  84 \begin{code}
  85 instance Outputable b => Outputable (Bind b) where
  86     ppr bind = ppr_bind pprGenericEnv bind
  87
  88 instance Outputable b => Outputable (Expr b) where
  89     ppr expr = ppr_expr pprGenericEnv expr
  90
  91 pprGenericEnv :: Outputable b => PprEnv b
  92 pprGenericEnv = initCoreEnv (\site -> ppr)
  93 \end{code}
  94
  95 %************************************************************************
  96 %*                                                                      *
  97 \subsection{Instance declarations for Core printing}
  98 %*                                                                      *
  99 %************************************************************************
 100
 101
 102 \begin{code}
 103 initCoreEnv pbdr
 104   = initPprEnv
 105         (Just ppr)                      -- Constants
 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  = sep [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_expr pe expr)]
 146 \end{code}
 147
 148 \begin{code}
 149 ppr_parend_expr pe expr
 150   | no_parens = ppr_expr pe expr
 151   | otherwise = parens (ppr_expr pe expr)
 152   where
 153     no_parens = case expr of
 154                   Var _              -> True
 155                   Con con []         -> True
 156                   Con (DataCon dc) _ -> isTupleCon dc
 157                   _                  -> False
 158 \end{code}
 159
 160 \begin{code}
 161 ppr_expr :: PprEnv b -> Expr b -> SDoc
 162
 163 ppr_expr pe (Type ty)  = ptext SLIT("TYPE") <+> ppr ty  -- Wierd
 164
 165 ppr_expr pe (Var name) = pOcc pe name
 166
 167 ppr_expr pe (Con con [])
 168   = ppr con     -- Nullary constructors too
 169
 170 ppr_expr pe (Con (DataCon dc) args)
 171         -- Drop the type arguments and print in (a,b,c) notation
 172   | isTupleCon dc
 173   = parens (sep (punctuate comma (map (ppr_arg pe) (dropWhile isTypeArg args))))
 174   | isUnboxedTupleCon dc
 175   = text "(# " <>
 176     hsep (punctuate comma (map (ppr_arg pe) (dropWhile isTypeArg args))) <>
 177     text " #)"
 178
 179 ppr_expr pe (Con con args)
 180   = pCon pe con <+> (braces $ sep (map (ppr_arg pe) args))
 181
 182 ppr_expr pe expr@(Lam _ _)
 183   = let
 184         (bndrs, body) = collectBinders expr
 185     in
 186     hang (ptext SLIT("\\") <+> sep (map (pBndr pe LambdaBind) bndrs) <+> arrow)
 187          4 (ppr_expr pe body)
 188
 189 ppr_expr pe expr@(App fun arg)
 190   = let
 191         (final_fun, final_args)      = go fun [arg]
 192         go (App fun arg) args_so_far = go fun (arg:args_so_far)
 193         go fun           args_so_far = (fun, args_so_far)
 194     in
 195     hang (ppr_parend_expr pe final_fun) 4 (sep (map (ppr_arg pe) final_args))
 196
 197 ppr_expr pe (Case expr var [(con,args,rhs)])
 198   = sep [sep [ptext SLIT("case") <+> ppr_expr pe expr,
 199               hsep [ptext SLIT("of"),
 200                     ppr_bndr var,
 201                     char '{',
 202                     ppr_case_pat pe con args
 203           ]],
 204          ppr_expr pe rhs,
 205          char '}'
 206     ]
 207   where
 208     ppr_bndr = pBndr pe CaseBind
 209
 210 ppr_expr pe (Case expr var alts)
 211   = sep [sep [ptext SLIT("case") <+> ppr_expr pe expr,
 212               ptext SLIT("of") <+> ppr_bndr var <+> char '{'],
 213          nest 4 (sep (punctuate semi (map ppr_alt alts))),
 214          char '}'
 215     ]
 216   where
 217     ppr_bndr = pBndr pe CaseBind
 218
 219     ppr_alt (con, args, rhs) = hang (ppr_case_pat pe con args)
 220                                     4 (ppr_expr pe rhs)
 221
 222 -- special cases: let ... in let ...
 223 -- ("disgusting" SLPJ)
 224
 225 ppr_expr pe (Let bind@(NonRec val_bdr rhs@(Let _ _)) body)
 226   = vcat [
 227       hsep [ptext SLIT("let {"), pBndr pe LetBind val_bdr, equals],
 228       nest 2 (ppr_expr pe rhs),
 229       ptext SLIT("} in"),
 230       ppr_expr pe body ]
 231
 232 ppr_expr pe (Let bind@(NonRec val_bdr rhs) expr@(Let _ _))
 233   = hang (ptext SLIT("let {"))
 234           2 (hsep [hang (hsep [pBndr pe LetBind val_bdr, equals])
 235                            4 (ppr_expr pe rhs),
 236        ptext SLIT("} in")])
 237     $$
 238     ppr_expr pe expr
 239
 240 -- general case (recursive case, too)
 241 ppr_expr pe (Let bind expr)
 242   = sep [hang (ptext keyword) 2 (ppr_bind pe bind),
 243          hang (ptext SLIT("} in ")) 2 (ppr_expr pe expr)]
 244   where
 245     keyword = case bind of
 246                 Rec _      -> SLIT("__letrec {")
 247                 NonRec _ _ -> SLIT("let {")
 248
 249 ppr_expr pe (Note (SCC cc) expr)
 250   = sep [pSCC pe cc, ppr_expr pe expr]
 251
 252 #ifdef DEBUG
 253 ppr_expr pe (Note (Coerce to_ty from_ty) expr)
 254  = getPprStyle $ \ sty ->
 255    if debugStyle sty && not (ifaceStyle sty) then
 256       sep [ptext SLIT("__coerce") <+> sep [pTy pe to_ty, pTy pe from_ty],
 257            ppr_parend_expr pe expr]
 258    else
 259       sep [hsep [ptext SLIT("__coerce"), pTy pe to_ty],
 260                   ppr_parend_expr pe expr]
 261 #else
 262 ppr_expr pe (Note (Coerce to_ty from_ty) expr)
 263   = sep [sep [ptext SLIT("__coerce"), nest 4 (pTy pe to_ty)],
 264          ppr_parend_expr pe expr]
 265 #endif
 266
 267 ppr_expr pe (Note InlineCall expr)
 268   = ptext SLIT("__inline_call") <+> ppr_parend_expr pe expr
 269
 270 ppr_expr pe (Note InlineMe expr)
 271   = ptext SLIT("__inline_me") <+> ppr_parend_expr pe expr
 272
 273 ppr_expr pe (Note (TermUsg u) expr)
 274   = \ sty ->
 275     if ifaceStyle sty then
 276       ppr_expr pe expr sty
 277     else
 278       (ppr u <+> ppr_expr pe expr) sty
 279
 280 ppr_case_pat pe con@(DataCon dc) args
 281   | isTupleCon dc
 282   = parens (hsep (punctuate comma (map ppr_bndr args))) <+> arrow
 283   | isUnboxedTupleCon dc
 284   = hsep [text "(# " <>
 285           hsep (punctuate comma (map ppr_bndr args)) <>
 286           text " #)",
 287           arrow]
 288   where
 289     ppr_bndr = pBndr pe CaseBind
 290
 291 ppr_case_pat pe con args
 292   = pCon pe 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, pragmas, ppr binder]
 309   where
 310     sig     = pprTypedBinder binder
 311     pragmas = ppIdInfo (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 -- Used for printing interface-file unfoldings
 320 pprIfaceBinder CaseBind binder = pprUntypedBinder binder
 321 pprIfaceBinder other    binder = pprTypedBinder binder
 322
 323 pprUntypedBinder binder
 324   | isTyVar binder = pprTyVarBndr binder
 325   | otherwise      = pprIdBndr binder
 326
 327 pprTypedBinder binder
 328   | isTyVar binder  = ptext SLIT("@") <+> pprTyVarBndr binder
 329   | otherwise       = pprIdBndr binder <+> dcolon <+> pprParendType (idType binder)
 330         -- The space before the :: is important; it helps the lexer
 331         -- when reading inferfaces.  Otherwise it would lex "a::b" as one thing.
 332         --
 333         -- It's important that the type is parenthesised too, at least when
 334         -- printing interfaces, because we get \ x::(a->b) y::(c->d) -> ...
 335
 336 -- When printing any Id binder in debug mode, we print its inline pragma and one-shot-ness
 337 pprIdBndr id = ppr id <+> ifPprDebug (ppr (getInlinePragma id) <+> ppr (getIdDemandInfo id)) <+> ppr (lbvarInfo (idInfo id))
 338 \end{code}
 339
 340
 341 \begin{code}
 342 ppIdInfo :: IdInfo -> SDoc
 343 ppIdInfo info
 344   = hsep [
 345             ppFlavourInfo (flavourInfo info),
 346             ppArityInfo a,
 347             ppUpdateInfo u,
 348             ppWorkerInfo (workerInfo info),
 349             ppStrictnessInfo s,
 350             ppr d,
 351             ppCafInfo c,
 352             ppCprInfo m,
 353             ppr (lbvarInfo info),
 354             pprIfaceCoreRules p
 355         -- Inline pragma printed out with all binders; see PprCore.pprIdBndr
 356         ]
 357   where
 358     a = arityInfo info
 359     d = demandInfo info
 360     s = strictnessInfo info
 361     u = updateInfo info
 362     c = cafInfo info
 363     m = cprInfo info
 364     p = specInfo info
 365 \end{code}
 366
 367
 368 \begin{code}
 369 pprCoreRules :: Id -> CoreRules -> SDoc
 370 pprCoreRules var (Rules rules _) = vcat (map (pprCoreRule (Just var)) rules)
 371
 372 pprIfaceCoreRules :: CoreRules -> SDoc
 373 pprIfaceCoreRules (Rules rules _) = vcat (map (pprCoreRule Nothing) rules)
 374
 375 pprCoreRule :: Maybe Id -> CoreRule -> SDoc
 376 pprCoreRule maybe_fn (Rule name tpl_vars tpl_args rhs)
 377   = doubleQuotes (ptext name) <+>
 378     sep [
 379           ptext SLIT("__forall") <+> braces (sep (map pprTypedBinder tpl_vars)),
 380           nest 4 (pp_fn <+> sep (map pprIfaceArg tpl_args)),
 381           nest 4 (ptext SLIT("=") <+> pprIfaceUnfolding rhs)
 382     ]
 383   where
 384     pp_fn = case maybe_fn of
 385                 Just id -> ppr id
 386                 Nothing -> empty                -- Interface file
 387 \end{code}