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