compiler/utils/Outputable.lhs

   1 %
   2 % (c) The University of Glasgow 2006
   3 % (c) The GRASP Project, Glasgow University, 1992-1998
   4 %
   5
   6 \begin{code}
   7 -- | This module defines classes and functions for pretty-printing. It also
   8 -- exports a number of helpful debugging and other utilities such as 'trace' and 'panic'.
   9 --
  10 -- The interface to this module is very similar to the standard Hughes-PJ pretty printing
  11 -- module, except that it exports a number of additional functions that are rarely used,
  12 -- and works over the 'SDoc' type.
  13 module Outputable (
  14         -- * Type classes
  15         Outputable(..), OutputableBndr(..),
  16
  17         -- * Pretty printing combinators
  18         SDoc,
  19         docToSDoc,
  20         interppSP, interpp'SP, pprQuotedList, pprWithCommas,
  21         empty, nest,
  22         char,
  23         text, ftext, ptext,
  24         int, integer, float, double, rational,
  25         parens, cparen, brackets, braces, quotes, doubleQuotes, angleBrackets,
  26         semi, comma, colon, dcolon, space, equals, dot, arrow,
  27         lparen, rparen, lbrack, rbrack, lbrace, rbrace, underscore,
  28         (<>), (<+>), hcat, hsep,
  29         ($$), ($+$), vcat,
  30         sep, cat,
  31         fsep, fcat,
  32         hang, punctuate,
  33         speakNth, speakNTimes, speakN, speakNOf, plural,
  34
  35         -- * Converting 'SDoc' into strings and outputing it
  36         printSDoc, printErrs, hPrintDump, printDump,
  37         printForC, printForAsm, printForUser, printForUserPartWay,
  38         pprCode, mkCodeStyle,
  39         showSDoc, showSDocForUser, showSDocDebug, showSDocDump,
  40         showSDocUnqual, showsPrecSDoc,
  41
  42         pprInfixVar, pprPrefixVar,
  43         pprHsChar, pprHsString, pprHsInfix, pprHsVar,
  44
  45         -- * Controlling the style in which output is printed
  46         BindingSite(..),
  47
  48         PprStyle, CodeStyle(..), PrintUnqualified, alwaysQualify, neverQualify,
  49         QualifyName(..),
  50         getPprStyle, withPprStyle, withPprStyleDoc,
  51         pprDeeper, pprDeeperList, pprSetDepth,
  52         codeStyle, userStyle, debugStyle, dumpStyle, asmStyle,
  53         ifPprDebug, qualName, qualModule,
  54         mkErrStyle, defaultErrStyle, defaultDumpStyle, defaultUserStyle,
  55         mkUserStyle, Depth(..),
  56
  57         -- * Error handling and debugging utilities
  58         pprPanic, assertPprPanic, pprPanicFastInt, pprPgmError,
  59         pprTrace, warnPprTrace,
  60         trace, pgmError, panic, panicFastInt, assertPanic
  61     ) where
  62
  63 import {-# SOURCE #-}   Module( Module, ModuleName, moduleName )
  64 import {-# SOURCE #-}   OccName( OccName )
  65
  66 import StaticFlags
  67 import FastString
  68 import FastTypes
  69 import qualified Pretty
  70 import Pretty           ( Doc, Mode(..) )
  71 import Char             ( isAlpha )
  72 import Panic
  73
  74 import Data.Word        ( Word32 )
  75 import System.IO        ( Handle, stderr, stdout, hFlush )
  76 import Data.Char        ( ord )
  77 \end{code}
  78
  79
  80 %************************************************************************
  81 %*                                                                      *
  82 \subsection{The @PprStyle@ data type}
  83 %*                                                                      *
  84 %************************************************************************
  85
  86 \begin{code}
  87
  88 data PprStyle
  89   = PprUser PrintUnqualified Depth
  90                 -- Pretty-print in a way that will make sense to the
  91                 -- ordinary user; must be very close to Haskell
  92                 -- syntax, etc.
  93                 -- Assumes printing tidied code: non-system names are
  94                 -- printed without uniques.
  95
  96   | PprCode CodeStyle
  97                 -- Print code; either C or assembler
  98
  99   | PprDump     -- For -ddump-foo; less verbose than PprDebug.
 100                 -- Does not assume tidied code: non-external names
 101                 -- are printed with uniques.
 102
 103   | PprDebug    -- Full debugging output
 104
 105 data CodeStyle = CStyle         -- The format of labels differs for C and assembler
 106                | AsmStyle
 107
 108 data Depth = AllTheWay
 109            | PartWay Int        -- 0 => stop
 110
 111
 112 -- -----------------------------------------------------------------------------
 113 -- Printing original names
 114
 115 -- When printing code that contains original names, we need to map the
 116 -- original names back to something the user understands.  This is the
 117 -- purpose of the pair of functions that gets passed around
 118 -- when rendering 'SDoc'.
 119
 120 -- | given an /original/ name, this function tells you which module
 121 -- name it should be qualified with when printing for the user, if
 122 -- any.  For example, given @Control.Exception.catch@, which is in scope
 123 -- as @Exception.catch@, this fuction will return @Just "Exception"@.
 124 -- Note that the return value is a ModuleName, not a Module, because
 125 -- in source code, names are qualified by ModuleNames.
 126 type QueryQualifyName = Module -> OccName -> QualifyName
 127
 128 data QualifyName                        -- given P:M.T
 129         = NameUnqual                    -- refer to it as "T"
 130         | NameQual ModuleName           -- refer to it as "X.T" for the supplied X
 131         | NameNotInScope1
 132                 -- it is not in scope at all, but M.T is not bound in the current
 133                 -- scope, so we can refer to it as "M.T"
 134         | NameNotInScope2
 135                 -- it is not in scope at all, and M.T is already bound in the
 136                 -- current scope, so we must refer to it as "P:M.T"
 137
 138
 139 -- | For a given module, we need to know whether to print it with
 140 -- a package name to disambiguate it.
 141 type QueryQualifyModule = Module -> Bool
 142
 143 type PrintUnqualified = (QueryQualifyName, QueryQualifyModule)
 144
 145 alwaysQualifyNames :: QueryQualifyName
 146 alwaysQualifyNames m _ = NameQual (moduleName m)
 147
 148 neverQualifyNames :: QueryQualifyName
 149 neverQualifyNames _ _ = NameUnqual
 150
 151 alwaysQualifyModules :: QueryQualifyModule
 152 alwaysQualifyModules _ = True
 153
 154 neverQualifyModules :: QueryQualifyModule
 155 neverQualifyModules _ = False
 156
 157 alwaysQualify, neverQualify :: PrintUnqualified
 158 alwaysQualify = (alwaysQualifyNames, alwaysQualifyModules)
 159 neverQualify  = (neverQualifyNames,  neverQualifyModules)
 160
 161 defaultUserStyle, defaultDumpStyle :: PprStyle
 162
 163 defaultUserStyle = mkUserStyle alwaysQualify AllTheWay
 164
 165 defaultDumpStyle |  opt_PprStyle_Debug = PprDebug
 166                  |  otherwise          = PprDump
 167
 168 -- | Style for printing error messages
 169 mkErrStyle :: PrintUnqualified -> PprStyle
 170 mkErrStyle qual = mkUserStyle qual (PartWay opt_PprUserLength)
 171
 172 defaultErrStyle :: PprStyle
 173 -- Default style for error messages
 174 -- It's a bit of a hack because it doesn't take into account what's in scope
 175 -- Only used for desugarer warnings, and typechecker errors in interface sigs
 176 defaultErrStyle
 177   | opt_PprStyle_Debug   = mkUserStyle alwaysQualify AllTheWay
 178   | otherwise            = mkUserStyle alwaysQualify (PartWay opt_PprUserLength)
 179
 180 mkUserStyle :: PrintUnqualified -> Depth -> PprStyle
 181 mkUserStyle unqual depth
 182    | opt_PprStyle_Debug = PprDebug
 183    | otherwise          = PprUser unqual depth
 184 \end{code}
 185
 186 Orthogonal to the above printing styles are (possibly) some
 187 command-line flags that affect printing (often carried with the
 188 style).  The most likely ones are variations on how much type info is
 189 shown.
 190
 191 The following test decides whether or not we are actually generating
 192 code (either C or assembly), or generating interface files.
 193
 194 %************************************************************************
 195 %*                                                                      *
 196 \subsection{The @SDoc@ data type}
 197 %*                                                                      *
 198 %************************************************************************
 199
 200 \begin{code}
 201 type SDoc = PprStyle -> Doc
 202
 203 withPprStyle :: PprStyle -> SDoc -> SDoc
 204 withPprStyle sty d _sty' = d sty
 205
 206 withPprStyleDoc :: PprStyle -> SDoc -> Doc
 207 withPprStyleDoc sty d = d sty
 208
 209 pprDeeper :: SDoc -> SDoc
 210 pprDeeper _ (PprUser _ (PartWay 0)) = Pretty.text "..."
 211 pprDeeper d (PprUser q (PartWay n)) = d (PprUser q (PartWay (n-1)))
 212 pprDeeper d other_sty               = d other_sty
 213
 214 pprDeeperList :: ([SDoc] -> SDoc) -> [SDoc] -> SDoc
 215 -- Truncate a list that list that is longer than the current depth
 216 pprDeeperList f ds (PprUser q (PartWay n))
 217   | n==0      = Pretty.text "..."
 218   | otherwise = f (go 0 ds) (PprUser q (PartWay (n-1)))
 219   where
 220     go _ [] = []
 221     go i (d:ds) | i >= n    = [text "...."]
 222                 | otherwise = d : go (i+1) ds
 223
 224 pprDeeperList f ds other_sty
 225   = f ds other_sty
 226
 227 pprSetDepth :: Int -> SDoc -> SDoc
 228 pprSetDepth  n d (PprUser q _) = d (PprUser q (PartWay n))
 229 pprSetDepth _n d other_sty     = d other_sty
 230
 231 getPprStyle :: (PprStyle -> SDoc) -> SDoc
 232 getPprStyle df sty = df sty sty
 233 \end{code}
 234
 235 \begin{code}
 236 qualName :: PprStyle -> QueryQualifyName
 237 qualName (PprUser (qual_name,_) _) m  n = qual_name m n
 238 qualName _other                    m _n = NameQual (moduleName m)
 239
 240 qualModule :: PprStyle -> QueryQualifyModule
 241 qualModule (PprUser (_,qual_mod) _)  m = qual_mod m
 242 qualModule _other                   _m = True
 243
 244 codeStyle :: PprStyle -> Bool
 245 codeStyle (PprCode _)     = True
 246 codeStyle _               = False
 247
 248 asmStyle :: PprStyle -> Bool
 249 asmStyle (PprCode AsmStyle)  = True
 250 asmStyle _other              = False
 251
 252 dumpStyle :: PprStyle -> Bool
 253 dumpStyle PprDump = True
 254 dumpStyle _other  = False
 255
 256 debugStyle :: PprStyle -> Bool
 257 debugStyle PprDebug       = True
 258 debugStyle _other         = False
 259
 260 userStyle ::  PprStyle -> Bool
 261 userStyle (PprUser _ _) = True
 262 userStyle _other        = False
 263
 264 ifPprDebug :: SDoc -> SDoc        -- Empty for non-debug style
 265 ifPprDebug d sty@PprDebug = d sty
 266 ifPprDebug _ _            = Pretty.empty
 267 \end{code}
 268
 269 \begin{code}
 270 -- Unused [7/02 sof]
 271 printSDoc :: SDoc -> PprStyle -> IO ()
 272 printSDoc d sty = do
 273   Pretty.printDoc PageMode stdout (d sty)
 274   hFlush stdout
 275
 276 -- I'm not sure whether the direct-IO approach of Pretty.printDoc
 277 -- above is better or worse than the put-big-string approach here
 278 printErrs :: Doc -> IO ()
 279 printErrs doc = do Pretty.printDoc PageMode stderr doc
 280                    hFlush stderr
 281
 282 printDump :: SDoc -> IO ()
 283 printDump doc = hPrintDump stdout doc
 284
 285 hPrintDump :: Handle -> SDoc -> IO ()
 286 hPrintDump h doc = do
 287    Pretty.printDoc PageMode h (better_doc defaultDumpStyle)
 288    hFlush h
 289  where
 290    better_doc = doc $$ text ""
 291
 292 printForUser :: Handle -> PrintUnqualified -> SDoc -> IO ()
 293 printForUser handle unqual doc
 294   = Pretty.printDoc PageMode handle (doc (mkUserStyle unqual AllTheWay))
 295
 296 printForUserPartWay :: Handle -> Int -> PrintUnqualified -> SDoc -> IO ()
 297 printForUserPartWay handle d unqual doc
 298   = Pretty.printDoc PageMode handle (doc (mkUserStyle unqual (PartWay d)))
 299
 300 -- printForC, printForAsm do what they sound like
 301 printForC :: Handle -> SDoc -> IO ()
 302 printForC handle doc = Pretty.printDoc LeftMode handle (doc (PprCode CStyle))
 303
 304 printForAsm :: Handle -> SDoc -> IO ()
 305 printForAsm handle doc = Pretty.printDoc LeftMode handle (doc (PprCode AsmStyle))
 306
 307 pprCode :: CodeStyle -> SDoc -> SDoc
 308 pprCode cs d = withPprStyle (PprCode cs) d
 309
 310 mkCodeStyle :: CodeStyle -> PprStyle
 311 mkCodeStyle = PprCode
 312
 313 -- Can't make SDoc an instance of Show because SDoc is just a function type
 314 -- However, Doc *is* an instance of Show
 315 -- showSDoc just blasts it out as a string
 316 showSDoc :: SDoc -> String
 317 showSDoc d = show (d defaultUserStyle)
 318
 319 showSDocForUser :: PrintUnqualified -> SDoc -> String
 320 showSDocForUser unqual doc = show (doc (mkUserStyle unqual AllTheWay))
 321
 322 showSDocUnqual :: SDoc -> String
 323 -- Only used in the gruesome isOperator
 324 showSDocUnqual d = show (d (mkUserStyle neverQualify AllTheWay))
 325
 326 showsPrecSDoc :: Int -> SDoc -> ShowS
 327 showsPrecSDoc p d = showsPrec p (d defaultUserStyle)
 328
 329 showSDocDump :: SDoc -> String
 330 showSDocDump d = show (d PprDump)
 331
 332 showSDocDebug :: SDoc -> String
 333 showSDocDebug d = show (d PprDebug)
 334 \end{code}
 335
 336 \begin{code}
 337 docToSDoc :: Doc -> SDoc
 338 docToSDoc d = \_ -> d
 339
 340 empty    :: SDoc
 341 char     :: Char       -> SDoc
 342 text     :: String     -> SDoc
 343 ftext    :: FastString -> SDoc
 344 ptext    :: LitString  -> SDoc
 345 int      :: Int        -> SDoc
 346 integer  :: Integer    -> SDoc
 347 float    :: Float      -> SDoc
 348 double   :: Double     -> SDoc
 349 rational :: Rational   -> SDoc
 350
 351 empty _sty      = Pretty.empty
 352 char c _sty     = Pretty.char c
 353 text s _sty     = Pretty.text s
 354 ftext s _sty    = Pretty.ftext s
 355 ptext s _sty    = Pretty.ptext s
 356 int n _sty      = Pretty.int n
 357 integer n _sty  = Pretty.integer n
 358 float n _sty    = Pretty.float n
 359 double n _sty   = Pretty.double n
 360 rational n _sty = Pretty.rational n
 361
 362 parens, braces, brackets, quotes, doubleQuotes, angleBrackets :: SDoc -> SDoc
 363
 364 parens d sty       = Pretty.parens (d sty)
 365 braces d sty       = Pretty.braces (d sty)
 366 brackets d sty     = Pretty.brackets (d sty)
 367 doubleQuotes d sty = Pretty.doubleQuotes (d sty)
 368 angleBrackets d    = char '<' <> d <> char '>'
 369
 370 cparen :: Bool -> SDoc -> SDoc
 371
 372 cparen b d sty       = Pretty.cparen b (d sty)
 373
 374 -- quotes encloses something in single quotes...
 375 -- but it omits them if the thing ends in a single quote
 376 -- so that we don't get `foo''.  Instead we just have foo'.
 377 quotes d sty = case show pp_d of
 378                  ('\'' : _) -> pp_d
 379                  _other     -> Pretty.quotes pp_d
 380              where
 381                pp_d = d sty
 382
 383 semi, comma, colon, equals, space, dcolon, arrow, underscore, dot :: SDoc
 384 lparen, rparen, lbrack, rbrack, lbrace, rbrace :: SDoc
 385
 386 semi _sty   = Pretty.semi
 387 comma _sty  = Pretty.comma
 388 colon _sty  = Pretty.colon
 389 equals _sty = Pretty.equals
 390 space _sty  = Pretty.space
 391 dcolon _sty = Pretty.ptext (sLit "::")
 392 arrow  _sty = Pretty.ptext (sLit "->")
 393 underscore  = char '_'
 394 dot         = char '.'
 395 lparen _sty = Pretty.lparen
 396 rparen _sty = Pretty.rparen
 397 lbrack _sty = Pretty.lbrack
 398 rbrack _sty = Pretty.rbrack
 399 lbrace _sty = Pretty.lbrace
 400 rbrace _sty = Pretty.rbrace
 401
 402 nest :: Int -> SDoc -> SDoc
 403 -- ^ Indent 'SDoc' some specified amount
 404 (<>) :: SDoc -> SDoc -> SDoc
 405 -- ^ Join two 'SDoc' together horizontally without a gap
 406 (<+>) :: SDoc -> SDoc -> SDoc
 407 -- ^ Join two 'SDoc' together horizontally with a gap between them
 408 ($$) :: SDoc -> SDoc -> SDoc
 409 -- ^ Join two 'SDoc' together vertically; if there is
 410 -- no vertical overlap it "dovetails" the two onto one line
 411 ($+$) :: SDoc -> SDoc -> SDoc
 412 -- ^ Join two 'SDoc' together vertically
 413
 414 nest n d sty    = Pretty.nest n (d sty)
 415 (<>) d1 d2 sty  = (Pretty.<>)  (d1 sty) (d2 sty)
 416 (<+>) d1 d2 sty = (Pretty.<+>) (d1 sty) (d2 sty)
 417 ($$) d1 d2 sty  = (Pretty.$$)  (d1 sty) (d2 sty)
 418 ($+$) d1 d2 sty = (Pretty.$+$) (d1 sty) (d2 sty)
 419
 420 hcat :: [SDoc] -> SDoc
 421 -- ^ Concatenate 'SDoc' horizontally
 422 hsep :: [SDoc] -> SDoc
 423 -- ^ Concatenate 'SDoc' horizontally with a space between each one
 424 vcat :: [SDoc] -> SDoc
 425 -- ^ Concatenate 'SDoc' vertically with dovetailing
 426 sep :: [SDoc] -> SDoc
 427 -- ^ Separate: is either like 'hsep' or like 'vcat', depending on what fits
 428 cat :: [SDoc] -> SDoc
 429 -- ^ Catenate: is either like 'hcat' or like 'vcat', depending on what fits
 430 fsep :: [SDoc] -> SDoc
 431 -- ^ A paragraph-fill combinator. It's much like sep, only it
 432 -- keeps fitting things on one line until it can't fit any more.
 433 fcat :: [SDoc] -> SDoc
 434 -- ^ This behaves like 'fsep', but it uses '<>' for horizontal conposition rather than '<+>'
 435
 436
 437 hcat ds sty = Pretty.hcat [d sty | d <- ds]
 438 hsep ds sty = Pretty.hsep [d sty | d <- ds]
 439 vcat ds sty = Pretty.vcat [d sty | d <- ds]
 440 sep ds sty  = Pretty.sep  [d sty | d <- ds]
 441 cat ds sty  = Pretty.cat  [d sty | d <- ds]
 442 fsep ds sty = Pretty.fsep [d sty | d <- ds]
 443 fcat ds sty = Pretty.fcat [d sty | d <- ds]
 444
 445 hang :: SDoc  -- ^ The header
 446       -> Int  -- ^ Amount to indent the hung body
 447       -> SDoc -- ^ The hung body, indented and placed below the header
 448       -> SDoc
 449 hang d1 n d2 sty   = Pretty.hang (d1 sty) n (d2 sty)
 450
 451 punctuate :: SDoc   -- ^ The punctuation
 452           -> [SDoc] -- ^ The list that will have punctuation added between every adjacent pair of elements
 453           -> [SDoc] -- ^ Punctuated list
 454 punctuate _ []     = []
 455 punctuate p (d:ds) = go d ds
 456                    where
 457                      go d [] = [d]
 458                      go d (e:es) = (d <> p) : go e es
 459 \end{code}
 460
 461
 462 %************************************************************************
 463 %*                                                                      *
 464 \subsection[Outputable-class]{The @Outputable@ class}
 465 %*                                                                      *
 466 %************************************************************************
 467
 468 \begin{code}
 469 -- | Class designating that some type has an 'SDoc' representation
 470 class Outputable a where
 471         ppr :: a -> SDoc
 472 \end{code}
 473
 474 \begin{code}
 475 instance Outputable Bool where
 476     ppr True  = ptext (sLit "True")
 477     ppr False = ptext (sLit "False")
 478
 479 instance Outputable Int where
 480    ppr n = int n
 481
 482 instance Outputable Word32 where
 483    ppr n = integer $ fromIntegral n
 484
 485 instance Outputable () where
 486    ppr _ = text "()"
 487
 488 instance (Outputable a) => Outputable [a] where
 489     ppr xs = brackets (fsep (punctuate comma (map ppr xs)))
 490
 491 instance (Outputable a, Outputable b) => Outputable (a, b) where
 492     ppr (x,y) = parens (sep [ppr x <> comma, ppr y])
 493
 494 instance Outputable a => Outputable (Maybe a) where
 495   ppr Nothing = ptext (sLit "Nothing")
 496   ppr (Just x) = ptext (sLit "Just") <+> ppr x
 497
 498 instance (Outputable a, Outputable b) => Outputable (Either a b) where
 499   ppr (Left x)  = ptext (sLit "Left")  <+> ppr x
 500   ppr (Right y) = ptext (sLit "Right") <+> ppr y
 501
 502 -- ToDo: may not be used
 503 instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c) where
 504     ppr (x,y,z) =
 505       parens (sep [ppr x <> comma,
 506                    ppr y <> comma,
 507                    ppr z ])
 508
 509 instance (Outputable a, Outputable b, Outputable c, Outputable d) =>
 510          Outputable (a, b, c, d) where
 511     ppr (a,b,c,d) =
 512       parens (sep [ppr a <> comma,
 513                    ppr b <> comma,
 514                    ppr c <> comma,
 515                    ppr d])
 516
 517 instance (Outputable a, Outputable b, Outputable c, Outputable d, Outputable e) =>
 518          Outputable (a, b, c, d, e) where
 519     ppr (a,b,c,d,e) =
 520       parens (sep [ppr a <> comma,
 521                    ppr b <> comma,
 522                    ppr c <> comma,
 523                    ppr d <> comma,
 524                    ppr e])
 525
 526 instance Outputable FastString where
 527     ppr fs = ftext fs           -- Prints an unadorned string,
 528                                 -- no double quotes or anything
 529 \end{code}
 530
 531 %************************************************************************
 532 %*                                                                      *
 533 \subsection{The @OutputableBndr@ class}
 534 %*                                                                      *
 535 %************************************************************************
 536
 537 \begin{code}
 538 -- | 'BindingSite' is used to tell the thing that prints binder what
 539 -- language construct is binding the identifier.  This can be used
 540 -- to decide how much info to print.
 541 data BindingSite = LambdaBind | CaseBind | LetBind
 542
 543 -- | When we print a binder, we often want to print its type too.
 544 -- The @OutputableBndr@ class encapsulates this idea.
 545 class Outputable a => OutputableBndr a where
 546    pprBndr :: BindingSite -> a -> SDoc
 547    pprBndr _b x = ppr x
 548 \end{code}
 549
 550 %************************************************************************
 551 %*                                                                      *
 552 \subsection{Random printing helpers}
 553 %*                                                                      *
 554 %************************************************************************
 555
 556 \begin{code}
 557 -- We have 31-bit Chars and will simply use Show instances of Char and String.
 558
 559 -- | Special combinator for showing character literals.
 560 pprHsChar :: Char -> SDoc
 561 pprHsChar c | c > '\x10ffff' = char '\\' <> text (show (fromIntegral (ord c) :: Word32))
 562             | otherwise      = text (show c)
 563
 564 -- | Special combinator for showing string literals.
 565 pprHsString :: FastString -> SDoc
 566 pprHsString fs = text (show (unpackFS fs))
 567
 568 ---------------------
 569 -- Put a name in parens if it's an operator
 570 pprPrefixVar :: Bool -> SDoc -> SDoc
 571 pprPrefixVar is_operator pp_v
 572   | is_operator = parens pp_v
 573   | otherwise   = pp_v
 574
 575 -- Put a name in backquotes if it's not an operator
 576 pprInfixVar :: Bool -> SDoc -> SDoc
 577 pprInfixVar is_operator pp_v
 578   | is_operator = pp_v
 579   | otherwise   = char '`' <> pp_v <> char '`'
 580
 581 ---------------------
 582 -- pprHsVar and pprHsInfix use the gruesome isOperator, which
 583 -- in turn uses (showSDoc (ppr v)), rather than isSymOcc (getOccName v).
 584 -- Reason: it means that pprHsVar doesn't need a NamedThing context,
 585 --         which none of the HsSyn printing functions do
 586 pprHsVar, pprHsInfix :: Outputable name => name -> SDoc
 587 pprHsVar   v = pprPrefixVar (isOperator pp_v) pp_v
 588              where pp_v = ppr v
 589 pprHsInfix v = pprInfixVar  (isOperator pp_v) pp_v
 590              where pp_v = ppr v
 591
 592 isOperator :: SDoc -> Bool
 593 isOperator ppr_v
 594   = case showSDocUnqual ppr_v of
 595         ('(':_)   -> False              -- (), (,) etc
 596         ('[':_)   -> False              -- []
 597         ('$':c:_) -> not (isAlpha c)    -- Don't treat $d as an operator
 598         (':':c:_) -> not (isAlpha c)    -- Don't treat :T as an operator
 599         ('_':_)   -> False              -- Not an operator
 600         (c:_)     -> not (isAlpha c)    -- Starts with non-alpha
 601         _         -> False
 602 \end{code}
 603
 604 %************************************************************************
 605 %*                                                                      *
 606 \subsection{Other helper functions}
 607 %*                                                                      *
 608 %************************************************************************
 609
 610 \begin{code}
 611 pprWithCommas :: (a -> SDoc) -- ^ The pretty printing function to use
 612               -> [a]         -- ^ The things to be pretty printed
 613               -> SDoc        -- ^ 'SDoc' where the things have been pretty printed,
 614                              -- comma-separated and finally packed into a paragraph.
 615 pprWithCommas pp xs = fsep (punctuate comma (map pp xs))
 616
 617 -- | Returns the seperated concatenation of the pretty printed things.
 618 interppSP  :: Outputable a => [a] -> SDoc
 619 interppSP  xs = sep (map ppr xs)
 620
 621 -- | Returns the comma-seperated concatenation of the pretty printed things.
 622 interpp'SP :: Outputable a => [a] -> SDoc
 623 interpp'SP xs = sep (punctuate comma (map ppr xs))
 624
 625 -- | Returns the comma-seperated concatenation of the quoted pretty printed things.
 626 --
 627 -- > [x,y,z]  ==>  `x', `y', `z'
 628 pprQuotedList :: Outputable a => [a] -> SDoc
 629 pprQuotedList xs = hsep (punctuate comma (map (quotes . ppr) xs))
 630 \end{code}
 631
 632
 633 %************************************************************************
 634 %*                                                                      *
 635 \subsection{Printing numbers verbally}
 636 %*                                                                      *
 637 %************************************************************************
 638
 639 \begin{code}
 640 -- | Converts an integer to a verbal index:
 641 --
 642 -- > speakNth 1 = text "first"
 643 -- > speakNth 5 = text "fifth"
 644 -- > speakNth 21 = text "21st"
 645 speakNth :: Int -> SDoc
 646 speakNth 1 = ptext (sLit "first")
 647 speakNth 2 = ptext (sLit "second")
 648 speakNth 3 = ptext (sLit "third")
 649 speakNth 4 = ptext (sLit "fourth")
 650 speakNth 5 = ptext (sLit "fifth")
 651 speakNth 6 = ptext (sLit "sixth")
 652 speakNth n = hcat [ int n, text suffix ]
 653   where
 654     suffix | n <= 20       = "th"       -- 11,12,13 are non-std
 655            | last_dig == 1 = "st"
 656            | last_dig == 2 = "nd"
 657            | last_dig == 3 = "rd"
 658            | otherwise     = "th"
 659
 660     last_dig = n `rem` 10
 661
 662 -- | Converts an integer to a verbal multiplicity:
 663 --
 664 -- > speakN 0 = text "none"
 665 -- > speakN 5 = text "five"
 666 -- > speakN 10 = text "10"
 667 speakN :: Int -> SDoc
 668 speakN 0 = ptext (sLit "none")  -- E.g.  "he has none"
 669 speakN 1 = ptext (sLit "one")   -- E.g.  "he has one"
 670 speakN 2 = ptext (sLit "two")
 671 speakN 3 = ptext (sLit "three")
 672 speakN 4 = ptext (sLit "four")
 673 speakN 5 = ptext (sLit "five")
 674 speakN 6 = ptext (sLit "six")
 675 speakN n = int n
 676
 677 -- | Converts an integer and object description to a statement about the
 678 -- multiplicity of those objects:
 679 --
 680 -- > speakNOf 0 (text "melon") = text "no melons"
 681 -- > speakNOf 1 (text "melon") = text "one melon"
 682 -- > speakNOf 3 (text "melon") = text "three melons"
 683 speakNOf :: Int -> SDoc -> SDoc
 684 speakNOf 0 d = ptext (sLit "no") <+> d <> char 's'
 685 speakNOf 1 d = ptext (sLit "one") <+> d                 -- E.g. "one argument"
 686 speakNOf n d = speakN n <+> d <> char 's'               -- E.g. "three arguments"
 687
 688 -- | Converts a strictly positive integer into a number of times:
 689 --
 690 -- > speakNTimes 1 = text "once"
 691 -- > speakNTimes 2 = text "twice"
 692 -- > speakNTimes 4 = text "4 times"
 693 speakNTimes :: Int {- >=1 -} -> SDoc
 694 speakNTimes t | t == 1     = ptext (sLit "once")
 695               | t == 2     = ptext (sLit "twice")
 696               | otherwise  = speakN t <+> ptext (sLit "times")
 697
 698 -- | Determines the pluralisation suffix appropriate for the length of a list:
 699 --
 700 -- > plural [] = char 's'
 701 -- > plural ["Hello"] = empty
 702 -- > plural ["Hello", "World"] = char 's'
 703 plural :: [a] -> SDoc
 704 plural [_] = empty  -- a bit frightening, but there you are
 705 plural _   = char 's'
 706 \end{code}
 707
 708
 709 %************************************************************************
 710 %*                                                                      *
 711 \subsection{Error handling}
 712 %*                                                                      *
 713 %************************************************************************
 714
 715 \begin{code}
 716 pprPanic :: String -> SDoc -> a
 717 -- ^ Throw an exception saying "bug in GHC"
 718 pprPgmError :: String -> SDoc -> a
 719 -- ^ Throw an exception saying "bug in pgm being compiled" (used for unusual program errors)
 720 pprTrace :: String -> SDoc -> a -> a
 721 -- ^ If debug output is on, show some 'SDoc' on the screen
 722
 723 pprPanic    = pprAndThen panic
 724
 725 pprPgmError = pprAndThen pgmError
 726
 727 pprTrace str doc x
 728    | opt_NoDebugOutput = x
 729    | otherwise         = pprAndThen trace str doc x
 730
 731 pprPanicFastInt :: String -> SDoc -> FastInt
 732 -- ^ Specialization of pprPanic that can be safely used with 'FastInt'
 733 pprPanicFastInt heading pretty_msg = panicFastInt (show (doc PprDebug))
 734                              where
 735                                doc = text heading <+> pretty_msg
 736
 737 pprAndThen :: (String -> a) -> String -> SDoc -> a
 738 pprAndThen cont heading pretty_msg = cont (show (doc PprDebug))
 739     where
 740      doc = sep [text heading, nest 4 pretty_msg]
 741
 742 assertPprPanic :: String -> Int -> SDoc -> a
 743 -- ^ Panic with an assertation failure, recording the given file and line number.
 744 -- Should typically be accessed with the ASSERT family of macros
 745 assertPprPanic file line msg
 746   = panic (show (doc PprDebug))
 747   where
 748     doc = sep [hsep[text "ASSERT failed! file",
 749                            text file,
 750                            text "line", int line],
 751                     msg]
 752
 753 warnPprTrace :: Bool -> String -> Int -> SDoc -> a -> a
 754 -- ^ Just warn about an assertion failure, recording the given file and line number.
 755 -- Should typically be accessed with the WARN macros
 756 warnPprTrace _     _file _line _msg x | opt_NoDebugOutput = x
 757 warnPprTrace False _file _line _msg x = x
 758 warnPprTrace True   file  line  msg x
 759   = trace (show (doc PprDebug)) x
 760   where
 761     doc = sep [hsep [text "WARNING: file", text file, text "line", int line],
 762                msg]
 763 \end{code}