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     pprFastFilePath,
  45
  46         -- * Controlling the style in which output is printed
  47         BindingSite(..),
  48
  49         PprStyle, CodeStyle(..), PrintUnqualified, alwaysQualify, neverQualify,
  50         QualifyName(..),
  51         getPprStyle, withPprStyle, withPprStyleDoc,
  52         pprDeeper, pprDeeperList, pprSetDepth,
  53         codeStyle, userStyle, debugStyle, dumpStyle, asmStyle,
  54         ifPprDebug, qualName, qualModule,
  55         mkErrStyle, defaultErrStyle, defaultDumpStyle, defaultUserStyle,
  56         mkUserStyle, Depth(..),
  57
  58         -- * Error handling and debugging utilities
  59         pprPanic, assertPprPanic, pprPanicFastInt, pprPgmError,
  60         pprTrace, warnPprTrace,
  61         trace, pgmError, panic, panicFastInt, assertPanic
  62     ) where
  63
  64 import {-# SOURCE #-}   Module( Module, ModuleName, moduleName )
  65 import {-# SOURCE #-}   OccName( OccName )
  66
  67 import StaticFlags
  68 import FastString
  69 import FastTypes
  70 import qualified Pretty
  71 import Pretty           ( Doc, Mode(..) )
  72 import Char             ( isAlpha )
  73 import Panic
  74
  75 import Data.Word        ( Word32 )
  76 import System.IO        ( Handle, stderr, stdout, hFlush )
  77 import Data.Char        ( ord )
  78 import System.FilePath
  79 \end{code}
  80
  81
  82 %************************************************************************
  83 %*                                                                      *
  84 \subsection{The @PprStyle@ data type}
  85 %*                                                                      *
  86 %************************************************************************
  87
  88 \begin{code}
  89
  90 data PprStyle
  91   = PprUser PrintUnqualified Depth
  92                 -- Pretty-print in a way that will make sense to the
  93                 -- ordinary user; must be very close to Haskell
  94                 -- syntax, etc.
  95                 -- Assumes printing tidied code: non-system names are
  96                 -- printed without uniques.
  97
  98   | PprCode CodeStyle
  99                 -- Print code; either C or assembler
 100
 101   | PprDump     -- For -ddump-foo; less verbose than PprDebug.
 102                 -- Does not assume tidied code: non-external names
 103                 -- are printed with uniques.
 104
 105   | PprDebug    -- Full debugging output
 106
 107 data CodeStyle = CStyle         -- The format of labels differs for C and assembler
 108                | AsmStyle
 109
 110 data Depth = AllTheWay
 111            | PartWay Int        -- 0 => stop
 112
 113
 114 -- -----------------------------------------------------------------------------
 115 -- Printing original names
 116
 117 -- When printing code that contains original names, we need to map the
 118 -- original names back to something the user understands.  This is the
 119 -- purpose of the pair of functions that gets passed around
 120 -- when rendering 'SDoc'.
 121
 122 -- | given an /original/ name, this function tells you which module
 123 -- name it should be qualified with when printing for the user, if
 124 -- any.  For example, given @Control.Exception.catch@, which is in scope
 125 -- as @Exception.catch@, this fuction will return @Just "Exception"@.
 126 -- Note that the return value is a ModuleName, not a Module, because
 127 -- in source code, names are qualified by ModuleNames.
 128 type QueryQualifyName = Module -> OccName -> QualifyName
 129
 130 data QualifyName                        -- given P:M.T
 131         = NameUnqual                    -- refer to it as "T"
 132         | NameQual ModuleName           -- refer to it as "X.T" for the supplied X
 133         | NameNotInScope1
 134                 -- it is not in scope at all, but M.T is not bound in the current
 135                 -- scope, so we can refer to it as "M.T"
 136         | NameNotInScope2
 137                 -- it is not in scope at all, and M.T is already bound in the
 138                 -- current scope, so we must refer to it as "P:M.T"
 139
 140
 141 -- | For a given module, we need to know whether to print it with
 142 -- a package name to disambiguate it.
 143 type QueryQualifyModule = Module -> Bool
 144
 145 type PrintUnqualified = (QueryQualifyName, QueryQualifyModule)
 146
 147 alwaysQualifyNames :: QueryQualifyName
 148 alwaysQualifyNames m _ = NameQual (moduleName m)
 149
 150 neverQualifyNames :: QueryQualifyName
 151 neverQualifyNames _ _ = NameUnqual
 152
 153 alwaysQualifyModules :: QueryQualifyModule
 154 alwaysQualifyModules _ = True
 155
 156 neverQualifyModules :: QueryQualifyModule
 157 neverQualifyModules _ = False
 158
 159 alwaysQualify, neverQualify :: PrintUnqualified
 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 :: PrintUnqualified -> 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
 605 pprFastFilePath :: FastString -> SDoc
 606 pprFastFilePath path = text $ normalise $ unpackFS path
 607 \end{code}
 608
 609 %************************************************************************
 610 %*                                                                      *
 611 \subsection{Other helper functions}
 612 %*                                                                      *
 613 %************************************************************************
 614
 615 \begin{code}
 616 pprWithCommas :: (a -> SDoc) -- ^ The pretty printing function to use
 617               -> [a]         -- ^ The things to be pretty printed
 618               -> SDoc        -- ^ 'SDoc' where the things have been pretty printed,
 619                              -- comma-separated and finally packed into a paragraph.
 620 pprWithCommas pp xs = fsep (punctuate comma (map pp xs))
 621
 622 -- | Returns the seperated concatenation of the pretty printed things.
 623 interppSP  :: Outputable a => [a] -> SDoc
 624 interppSP  xs = sep (map ppr xs)
 625
 626 -- | Returns the comma-seperated concatenation of the pretty printed things.
 627 interpp'SP :: Outputable a => [a] -> SDoc
 628 interpp'SP xs = sep (punctuate comma (map ppr xs))
 629
 630 -- | Returns the comma-seperated concatenation of the quoted pretty printed things.
 631 --
 632 -- > [x,y,z]  ==>  `x', `y', `z'
 633 pprQuotedList :: Outputable a => [a] -> SDoc
 634 pprQuotedList xs = hsep (punctuate comma (map (quotes . ppr) xs))
 635 \end{code}
 636
 637
 638 %************************************************************************
 639 %*                                                                      *
 640 \subsection{Printing numbers verbally}
 641 %*                                                                      *
 642 %************************************************************************
 643
 644 \begin{code}
 645 -- | Converts an integer to a verbal index:
 646 --
 647 -- > speakNth 1 = text "first"
 648 -- > speakNth 5 = text "fifth"
 649 -- > speakNth 21 = text "21st"
 650 speakNth :: Int -> SDoc
 651 speakNth 1 = ptext (sLit "first")
 652 speakNth 2 = ptext (sLit "second")
 653 speakNth 3 = ptext (sLit "third")
 654 speakNth 4 = ptext (sLit "fourth")
 655 speakNth 5 = ptext (sLit "fifth")
 656 speakNth 6 = ptext (sLit "sixth")
 657 speakNth n = hcat [ int n, text suffix ]
 658   where
 659     suffix | n <= 20       = "th"       -- 11,12,13 are non-std
 660            | last_dig == 1 = "st"
 661            | last_dig == 2 = "nd"
 662            | last_dig == 3 = "rd"
 663            | otherwise     = "th"
 664
 665     last_dig = n `rem` 10
 666
 667 -- | Converts an integer to a verbal multiplicity:
 668 --
 669 -- > speakN 0 = text "none"
 670 -- > speakN 5 = text "five"
 671 -- > speakN 10 = text "10"
 672 speakN :: Int -> SDoc
 673 speakN 0 = ptext (sLit "none")  -- E.g.  "he has none"
 674 speakN 1 = ptext (sLit "one")   -- E.g.  "he has one"
 675 speakN 2 = ptext (sLit "two")
 676 speakN 3 = ptext (sLit "three")
 677 speakN 4 = ptext (sLit "four")
 678 speakN 5 = ptext (sLit "five")
 679 speakN 6 = ptext (sLit "six")
 680 speakN n = int n
 681
 682 -- | Converts an integer and object description to a statement about the
 683 -- multiplicity of those objects:
 684 --
 685 -- > speakNOf 0 (text "melon") = text "no melons"
 686 -- > speakNOf 1 (text "melon") = text "one melon"
 687 -- > speakNOf 3 (text "melon") = text "three melons"
 688 speakNOf :: Int -> SDoc -> SDoc
 689 speakNOf 0 d = ptext (sLit "no") <+> d <> char 's'
 690 speakNOf 1 d = ptext (sLit "one") <+> d                 -- E.g. "one argument"
 691 speakNOf n d = speakN n <+> d <> char 's'               -- E.g. "three arguments"
 692
 693 -- | Converts a strictly positive integer into a number of times:
 694 --
 695 -- > speakNTimes 1 = text "once"
 696 -- > speakNTimes 2 = text "twice"
 697 -- > speakNTimes 4 = text "4 times"
 698 speakNTimes :: Int {- >=1 -} -> SDoc
 699 speakNTimes t | t == 1     = ptext (sLit "once")
 700               | t == 2     = ptext (sLit "twice")
 701               | otherwise  = speakN t <+> ptext (sLit "times")
 702
 703 -- | Determines the pluralisation suffix appropriate for the length of a list:
 704 --
 705 -- > plural [] = char 's'
 706 -- > plural ["Hello"] = empty
 707 -- > plural ["Hello", "World"] = char 's'
 708 plural :: [a] -> SDoc
 709 plural [_] = empty  -- a bit frightening, but there you are
 710 plural _   = char 's'
 711 \end{code}
 712
 713
 714 %************************************************************************
 715 %*                                                                      *
 716 \subsection{Error handling}
 717 %*                                                                      *
 718 %************************************************************************
 719
 720 \begin{code}
 721 pprPanic :: String -> SDoc -> a
 722 -- ^ Throw an exception saying "bug in GHC"
 723 pprPgmError :: String -> SDoc -> a
 724 -- ^ Throw an exception saying "bug in pgm being compiled" (used for unusual program errors)
 725 pprTrace :: String -> SDoc -> a -> a
 726 -- ^ If debug output is on, show some 'SDoc' on the screen
 727
 728 pprPanic    = pprAndThen panic
 729
 730 pprPgmError = pprAndThen pgmError
 731
 732 pprTrace str doc x
 733    | opt_NoDebugOutput = x
 734    | otherwise         = pprAndThen trace str doc x
 735
 736 pprPanicFastInt :: String -> SDoc -> FastInt
 737 -- ^ Specialization of pprPanic that can be safely used with 'FastInt'
 738 pprPanicFastInt heading pretty_msg = panicFastInt (show (doc PprDebug))
 739                              where
 740                                doc = text heading <+> pretty_msg
 741
 742 pprAndThen :: (String -> a) -> String -> SDoc -> a
 743 pprAndThen cont heading pretty_msg = cont (show (doc PprDebug))
 744     where
 745      doc = sep [text heading, nest 4 pretty_msg]
 746
 747 assertPprPanic :: String -> Int -> SDoc -> a
 748 -- ^ Panic with an assertation failure, recording the given file and line number.
 749 -- Should typically be accessed with the ASSERT family of macros
 750 assertPprPanic file line msg
 751   = panic (show (doc PprDebug))
 752   where
 753     doc = sep [hsep[text "ASSERT failed! file",
 754                            text file,
 755                            text "line", int line],
 756                     msg]
 757
 758 warnPprTrace :: Bool -> String -> Int -> SDoc -> a -> a
 759 -- ^ Just warn about an assertion failure, recording the given file and line number.
 760 -- Should typically be accessed with the WARN macros
 761 warnPprTrace _     _file _line _msg x | opt_NoDebugOutput = x
 762 warnPprTrace False _file _line _msg x = x
 763 warnPprTrace True   file  line  msg x
 764   = trace (show (doc PprDebug)) x
 765   where
 766     doc = sep [hsep [text "WARNING: file", text file, text "line", int line],
 767                msg]
 768 \end{code}