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, showPpr,
  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
 337 showPpr :: Outputable a => a -> String
 338 showPpr = showSDoc . ppr
 339 \end{code}
 340
 341 \begin{code}
 342 docToSDoc :: Doc -> SDoc
 343 docToSDoc d = \_ -> d
 344
 345 empty    :: SDoc
 346 char     :: Char       -> SDoc
 347 text     :: String     -> SDoc
 348 ftext    :: FastString -> SDoc
 349 ptext    :: LitString  -> SDoc
 350 int      :: Int        -> SDoc
 351 integer  :: Integer    -> SDoc
 352 float    :: Float      -> SDoc
 353 double   :: Double     -> SDoc
 354 rational :: Rational   -> SDoc
 355
 356 empty _sty      = Pretty.empty
 357 char c _sty     = Pretty.char c
 358 text s _sty     = Pretty.text s
 359 ftext s _sty    = Pretty.ftext s
 360 ptext s _sty    = Pretty.ptext s
 361 int n _sty      = Pretty.int n
 362 integer n _sty  = Pretty.integer n
 363 float n _sty    = Pretty.float n
 364 double n _sty   = Pretty.double n
 365 rational n _sty = Pretty.rational n
 366
 367 parens, braces, brackets, quotes, doubleQuotes, angleBrackets :: SDoc -> SDoc
 368
 369 parens d sty       = Pretty.parens (d sty)
 370 braces d sty       = Pretty.braces (d sty)
 371 brackets d sty     = Pretty.brackets (d sty)
 372 doubleQuotes d sty = Pretty.doubleQuotes (d sty)
 373 angleBrackets d    = char '<' <> d <> char '>'
 374
 375 cparen :: Bool -> SDoc -> SDoc
 376
 377 cparen b d sty       = Pretty.cparen b (d sty)
 378
 379 -- quotes encloses something in single quotes...
 380 -- but it omits them if the thing ends in a single quote
 381 -- so that we don't get `foo''.  Instead we just have foo'.
 382 quotes d sty = case show pp_d of
 383                  ('\'' : _) -> pp_d
 384                  _other     -> Pretty.quotes pp_d
 385              where
 386                pp_d = d sty
 387
 388 semi, comma, colon, equals, space, dcolon, arrow, underscore, dot :: SDoc
 389 lparen, rparen, lbrack, rbrack, lbrace, rbrace :: SDoc
 390
 391 semi _sty   = Pretty.semi
 392 comma _sty  = Pretty.comma
 393 colon _sty  = Pretty.colon
 394 equals _sty = Pretty.equals
 395 space _sty  = Pretty.space
 396 dcolon _sty = Pretty.ptext (sLit "::")
 397 arrow  _sty = Pretty.ptext (sLit "->")
 398 underscore  = char '_'
 399 dot         = char '.'
 400 lparen _sty = Pretty.lparen
 401 rparen _sty = Pretty.rparen
 402 lbrack _sty = Pretty.lbrack
 403 rbrack _sty = Pretty.rbrack
 404 lbrace _sty = Pretty.lbrace
 405 rbrace _sty = Pretty.rbrace
 406
 407 nest :: Int -> SDoc -> SDoc
 408 -- ^ Indent 'SDoc' some specified amount
 409 (<>) :: SDoc -> SDoc -> SDoc
 410 -- ^ Join two 'SDoc' together horizontally without a gap
 411 (<+>) :: SDoc -> SDoc -> SDoc
 412 -- ^ Join two 'SDoc' together horizontally with a gap between them
 413 ($$) :: SDoc -> SDoc -> SDoc
 414 -- ^ Join two 'SDoc' together vertically; if there is
 415 -- no vertical overlap it "dovetails" the two onto one line
 416 ($+$) :: SDoc -> SDoc -> SDoc
 417 -- ^ Join two 'SDoc' together vertically
 418
 419 nest n d sty    = Pretty.nest n (d sty)
 420 (<>) d1 d2 sty  = (Pretty.<>)  (d1 sty) (d2 sty)
 421 (<+>) d1 d2 sty = (Pretty.<+>) (d1 sty) (d2 sty)
 422 ($$) d1 d2 sty  = (Pretty.$$)  (d1 sty) (d2 sty)
 423 ($+$) d1 d2 sty = (Pretty.$+$) (d1 sty) (d2 sty)
 424
 425 hcat :: [SDoc] -> SDoc
 426 -- ^ Concatenate 'SDoc' horizontally
 427 hsep :: [SDoc] -> SDoc
 428 -- ^ Concatenate 'SDoc' horizontally with a space between each one
 429 vcat :: [SDoc] -> SDoc
 430 -- ^ Concatenate 'SDoc' vertically with dovetailing
 431 sep :: [SDoc] -> SDoc
 432 -- ^ Separate: is either like 'hsep' or like 'vcat', depending on what fits
 433 cat :: [SDoc] -> SDoc
 434 -- ^ Catenate: is either like 'hcat' or like 'vcat', depending on what fits
 435 fsep :: [SDoc] -> SDoc
 436 -- ^ A paragraph-fill combinator. It's much like sep, only it
 437 -- keeps fitting things on one line until it can't fit any more.
 438 fcat :: [SDoc] -> SDoc
 439 -- ^ This behaves like 'fsep', but it uses '<>' for horizontal conposition rather than '<+>'
 440
 441
 442 hcat ds sty = Pretty.hcat [d sty | d <- ds]
 443 hsep ds sty = Pretty.hsep [d sty | d <- ds]
 444 vcat ds sty = Pretty.vcat [d sty | d <- ds]
 445 sep ds sty  = Pretty.sep  [d sty | d <- ds]
 446 cat ds sty  = Pretty.cat  [d sty | d <- ds]
 447 fsep ds sty = Pretty.fsep [d sty | d <- ds]
 448 fcat ds sty = Pretty.fcat [d sty | d <- ds]
 449
 450 hang :: SDoc  -- ^ The header
 451       -> Int  -- ^ Amount to indent the hung body
 452       -> SDoc -- ^ The hung body, indented and placed below the header
 453       -> SDoc
 454 hang d1 n d2 sty   = Pretty.hang (d1 sty) n (d2 sty)
 455
 456 punctuate :: SDoc   -- ^ The punctuation
 457           -> [SDoc] -- ^ The list that will have punctuation added between every adjacent pair of elements
 458           -> [SDoc] -- ^ Punctuated list
 459 punctuate _ []     = []
 460 punctuate p (d:ds) = go d ds
 461                    where
 462                      go d [] = [d]
 463                      go d (e:es) = (d <> p) : go e es
 464 \end{code}
 465
 466
 467 %************************************************************************
 468 %*                                                                      *
 469 \subsection[Outputable-class]{The @Outputable@ class}
 470 %*                                                                      *
 471 %************************************************************************
 472
 473 \begin{code}
 474 -- | Class designating that some type has an 'SDoc' representation
 475 class Outputable a where
 476         ppr :: a -> SDoc
 477 \end{code}
 478
 479 \begin{code}
 480 instance Outputable Bool where
 481     ppr True  = ptext (sLit "True")
 482     ppr False = ptext (sLit "False")
 483
 484 instance Outputable Int where
 485    ppr n = int n
 486
 487 instance Outputable Word32 where
 488    ppr n = integer $ fromIntegral n
 489
 490 instance Outputable () where
 491    ppr _ = text "()"
 492
 493 instance (Outputable a) => Outputable [a] where
 494     ppr xs = brackets (fsep (punctuate comma (map ppr xs)))
 495
 496 instance (Outputable a, Outputable b) => Outputable (a, b) where
 497     ppr (x,y) = parens (sep [ppr x <> comma, ppr y])
 498
 499 instance Outputable a => Outputable (Maybe a) where
 500   ppr Nothing = ptext (sLit "Nothing")
 501   ppr (Just x) = ptext (sLit "Just") <+> ppr x
 502
 503 instance (Outputable a, Outputable b) => Outputable (Either a b) where
 504   ppr (Left x)  = ptext (sLit "Left")  <+> ppr x
 505   ppr (Right y) = ptext (sLit "Right") <+> ppr y
 506
 507 -- ToDo: may not be used
 508 instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c) where
 509     ppr (x,y,z) =
 510       parens (sep [ppr x <> comma,
 511                    ppr y <> comma,
 512                    ppr z ])
 513
 514 instance (Outputable a, Outputable b, Outputable c, Outputable d) =>
 515          Outputable (a, b, c, d) where
 516     ppr (a,b,c,d) =
 517       parens (sep [ppr a <> comma,
 518                    ppr b <> comma,
 519                    ppr c <> comma,
 520                    ppr d])
 521
 522 instance (Outputable a, Outputable b, Outputable c, Outputable d, Outputable e) =>
 523          Outputable (a, b, c, d, e) where
 524     ppr (a,b,c,d,e) =
 525       parens (sep [ppr a <> comma,
 526                    ppr b <> comma,
 527                    ppr c <> comma,
 528                    ppr d <> comma,
 529                    ppr e])
 530
 531 instance Outputable FastString where
 532     ppr fs = ftext fs           -- Prints an unadorned string,
 533                                 -- no double quotes or anything
 534 \end{code}
 535
 536 %************************************************************************
 537 %*                                                                      *
 538 \subsection{The @OutputableBndr@ class}
 539 %*                                                                      *
 540 %************************************************************************
 541
 542 \begin{code}
 543 -- | 'BindingSite' is used to tell the thing that prints binder what
 544 -- language construct is binding the identifier.  This can be used
 545 -- to decide how much info to print.
 546 data BindingSite = LambdaBind | CaseBind | LetBind
 547
 548 -- | When we print a binder, we often want to print its type too.
 549 -- The @OutputableBndr@ class encapsulates this idea.
 550 class Outputable a => OutputableBndr a where
 551    pprBndr :: BindingSite -> a -> SDoc
 552    pprBndr _b x = ppr x
 553 \end{code}
 554
 555 %************************************************************************
 556 %*                                                                      *
 557 \subsection{Random printing helpers}
 558 %*                                                                      *
 559 %************************************************************************
 560
 561 \begin{code}
 562 -- We have 31-bit Chars and will simply use Show instances of Char and String.
 563
 564 -- | Special combinator for showing character literals.
 565 pprHsChar :: Char -> SDoc
 566 pprHsChar c | c > '\x10ffff' = char '\\' <> text (show (fromIntegral (ord c) :: Word32))
 567             | otherwise      = text (show c)
 568
 569 -- | Special combinator for showing string literals.
 570 pprHsString :: FastString -> SDoc
 571 pprHsString fs = text (show (unpackFS fs))
 572
 573 ---------------------
 574 -- Put a name in parens if it's an operator
 575 pprPrefixVar :: Bool -> SDoc -> SDoc
 576 pprPrefixVar is_operator pp_v
 577   | is_operator = parens pp_v
 578   | otherwise   = pp_v
 579
 580 -- Put a name in backquotes if it's not an operator
 581 pprInfixVar :: Bool -> SDoc -> SDoc
 582 pprInfixVar is_operator pp_v
 583   | is_operator = pp_v
 584   | otherwise   = char '`' <> pp_v <> char '`'
 585
 586 ---------------------
 587 -- pprHsVar and pprHsInfix use the gruesome isOperator, which
 588 -- in turn uses (showSDoc (ppr v)), rather than isSymOcc (getOccName v).
 589 -- Reason: it means that pprHsVar doesn't need a NamedThing context,
 590 --         which none of the HsSyn printing functions do
 591 pprHsVar, pprHsInfix :: Outputable name => name -> SDoc
 592 pprHsVar   v = pprPrefixVar (isOperator pp_v) pp_v
 593              where pp_v = ppr v
 594 pprHsInfix v = pprInfixVar  (isOperator pp_v) pp_v
 595              where pp_v = ppr v
 596
 597 isOperator :: SDoc -> Bool
 598 isOperator ppr_v
 599   = case showSDocUnqual ppr_v of
 600         ('(':_)   -> False              -- (), (,) etc
 601         ('[':_)   -> False              -- []
 602         ('$':c:_) -> not (isAlpha c)    -- Don't treat $d as an operator
 603         (':':c:_) -> not (isAlpha c)    -- Don't treat :T as an operator
 604         ('_':_)   -> False              -- Not an operator
 605         (c:_)     -> not (isAlpha c)    -- Starts with non-alpha
 606         _         -> False
 607
 608 pprFastFilePath :: FastString -> SDoc
 609 pprFastFilePath path = text $ normalise $ unpackFS path
 610 \end{code}
 611
 612 %************************************************************************
 613 %*                                                                      *
 614 \subsection{Other helper functions}
 615 %*                                                                      *
 616 %************************************************************************
 617
 618 \begin{code}
 619 pprWithCommas :: (a -> SDoc) -- ^ The pretty printing function to use
 620               -> [a]         -- ^ The things to be pretty printed
 621               -> SDoc        -- ^ 'SDoc' where the things have been pretty printed,
 622                              -- comma-separated and finally packed into a paragraph.
 623 pprWithCommas pp xs = fsep (punctuate comma (map pp xs))
 624
 625 -- | Returns the seperated concatenation of the pretty printed things.
 626 interppSP  :: Outputable a => [a] -> SDoc
 627 interppSP  xs = sep (map ppr xs)
 628
 629 -- | Returns the comma-seperated concatenation of the pretty printed things.
 630 interpp'SP :: Outputable a => [a] -> SDoc
 631 interpp'SP xs = sep (punctuate comma (map ppr xs))
 632
 633 -- | Returns the comma-seperated concatenation of the quoted pretty printed things.
 634 --
 635 -- > [x,y,z]  ==>  `x', `y', `z'
 636 pprQuotedList :: Outputable a => [a] -> SDoc
 637 pprQuotedList xs = hsep (punctuate comma (map (quotes . ppr) xs))
 638 \end{code}
 639
 640
 641 %************************************************************************
 642 %*                                                                      *
 643 \subsection{Printing numbers verbally}
 644 %*                                                                      *
 645 %************************************************************************
 646
 647 \begin{code}
 648 -- | Converts an integer to a verbal index:
 649 --
 650 -- > speakNth 1 = text "first"
 651 -- > speakNth 5 = text "fifth"
 652 -- > speakNth 21 = text "21st"
 653 speakNth :: Int -> SDoc
 654 speakNth 1 = ptext (sLit "first")
 655 speakNth 2 = ptext (sLit "second")
 656 speakNth 3 = ptext (sLit "third")
 657 speakNth 4 = ptext (sLit "fourth")
 658 speakNth 5 = ptext (sLit "fifth")
 659 speakNth 6 = ptext (sLit "sixth")
 660 speakNth n = hcat [ int n, text suffix ]
 661   where
 662     suffix | n <= 20       = "th"       -- 11,12,13 are non-std
 663            | last_dig == 1 = "st"
 664            | last_dig == 2 = "nd"
 665            | last_dig == 3 = "rd"
 666            | otherwise     = "th"
 667
 668     last_dig = n `rem` 10
 669
 670 -- | Converts an integer to a verbal multiplicity:
 671 --
 672 -- > speakN 0 = text "none"
 673 -- > speakN 5 = text "five"
 674 -- > speakN 10 = text "10"
 675 speakN :: Int -> SDoc
 676 speakN 0 = ptext (sLit "none")  -- E.g.  "he has none"
 677 speakN 1 = ptext (sLit "one")   -- E.g.  "he has one"
 678 speakN 2 = ptext (sLit "two")
 679 speakN 3 = ptext (sLit "three")
 680 speakN 4 = ptext (sLit "four")
 681 speakN 5 = ptext (sLit "five")
 682 speakN 6 = ptext (sLit "six")
 683 speakN n = int n
 684
 685 -- | Converts an integer and object description to a statement about the
 686 -- multiplicity of those objects:
 687 --
 688 -- > speakNOf 0 (text "melon") = text "no melons"
 689 -- > speakNOf 1 (text "melon") = text "one melon"
 690 -- > speakNOf 3 (text "melon") = text "three melons"
 691 speakNOf :: Int -> SDoc -> SDoc
 692 speakNOf 0 d = ptext (sLit "no") <+> d <> char 's'
 693 speakNOf 1 d = ptext (sLit "one") <+> d                 -- E.g. "one argument"
 694 speakNOf n d = speakN n <+> d <> char 's'               -- E.g. "three arguments"
 695
 696 -- | Converts a strictly positive integer into a number of times:
 697 --
 698 -- > speakNTimes 1 = text "once"
 699 -- > speakNTimes 2 = text "twice"
 700 -- > speakNTimes 4 = text "4 times"
 701 speakNTimes :: Int {- >=1 -} -> SDoc
 702 speakNTimes t | t == 1     = ptext (sLit "once")
 703               | t == 2     = ptext (sLit "twice")
 704               | otherwise  = speakN t <+> ptext (sLit "times")
 705
 706 -- | Determines the pluralisation suffix appropriate for the length of a list:
 707 --
 708 -- > plural [] = char 's'
 709 -- > plural ["Hello"] = empty
 710 -- > plural ["Hello", "World"] = char 's'
 711 plural :: [a] -> SDoc
 712 plural [_] = empty  -- a bit frightening, but there you are
 713 plural _   = char 's'
 714 \end{code}
 715
 716
 717 %************************************************************************
 718 %*                                                                      *
 719 \subsection{Error handling}
 720 %*                                                                      *
 721 %************************************************************************
 722
 723 \begin{code}
 724 pprPanic :: String -> SDoc -> a
 725 -- ^ Throw an exception saying "bug in GHC"
 726 pprPgmError :: String -> SDoc -> a
 727 -- ^ Throw an exception saying "bug in pgm being compiled" (used for unusual program errors)
 728 pprTrace :: String -> SDoc -> a -> a
 729 -- ^ If debug output is on, show some 'SDoc' on the screen
 730
 731 pprPanic    = pprAndThen panic
 732
 733 pprPgmError = pprAndThen pgmError
 734
 735 pprTrace str doc x
 736    | opt_NoDebugOutput = x
 737    | otherwise         = pprAndThen trace str doc x
 738
 739 pprPanicFastInt :: String -> SDoc -> FastInt
 740 -- ^ Specialization of pprPanic that can be safely used with 'FastInt'
 741 pprPanicFastInt heading pretty_msg = panicFastInt (show (doc PprDebug))
 742                              where
 743                                doc = text heading <+> pretty_msg
 744
 745 pprAndThen :: (String -> a) -> String -> SDoc -> a
 746 pprAndThen cont heading pretty_msg = cont (show (doc PprDebug))
 747     where
 748      doc = sep [text heading, nest 4 pretty_msg]
 749
 750 assertPprPanic :: String -> Int -> SDoc -> a
 751 -- ^ Panic with an assertation failure, recording the given file and line number.
 752 -- Should typically be accessed with the ASSERT family of macros
 753 assertPprPanic file line msg
 754   = panic (show (doc PprDebug))
 755   where
 756     doc = sep [hsep[text "ASSERT failed! file",
 757                            text file,
 758                            text "line", int line],
 759                     msg]
 760
 761 warnPprTrace :: Bool -> String -> Int -> SDoc -> a -> a
 762 -- ^ Just warn about an assertion failure, recording the given file and line number.
 763 -- Should typically be accessed with the WARN macros
 764 warnPprTrace _     _file _line _msg x | opt_NoDebugOutput = x
 765 warnPprTrace False _file _line _msg x = x
 766 warnPprTrace True   file  line  msg x
 767   = trace (show (doc PprDebug)) x
 768   where
 769     doc = sep [hsep [text "WARNING: file", text file, text "line", int line],
 770                msg]
 771 \end{code}