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