Outputable.lhs 33.2 KB
Newer Older
1
%
Simon Marlow's avatar
Simon Marlow committed
2
% (c) The University of Glasgow 2006
3
% (c) The GRASP Project, Glasgow University, 1992-1998
4 5 6
%

\begin{code}
batterseapower's avatar
batterseapower committed
7 8 9 10 11 12
-- | This module defines classes and functions for pretty-printing. It also
-- exports a number of helpful debugging and other utilities such as 'trace' and 'panic'.
--
-- The interface to this module is very similar to the standard Hughes-PJ pretty printing
-- module, except that it exports a number of additional functions that are rarely used,
-- and works over the 'SDoc' type.
13
module Outputable (
dterei's avatar
dterei committed
14 15
        -- * Type classes
        Outputable(..), OutputableBndr(..),
16

batterseapower's avatar
batterseapower committed
17
        -- * Pretty printing combinators
dterei's avatar
dterei committed
18 19 20 21 22
        SDoc, runSDoc, initSDocContext,
        docToSDoc,
        interppSP, interpp'SP, pprQuotedList, pprWithCommas, quotedListWithOr,
        empty, nest,
        char,
Ian Lynagh's avatar
Ian Lynagh committed
23
        text, ftext, ptext, ztext,
24
        int, intWithCommas, integer, float, double, rational,
25 26
        parens, cparen, brackets, braces, quotes, quote, 
        doubleQuotes, angleBrackets, paBrackets,
dterei's avatar
dterei committed
27 28 29 30 31 32 33 34 35
        semi, comma, colon, dcolon, space, equals, dot, arrow, darrow,
        lparen, rparen, lbrack, rbrack, lbrace, rbrace, underscore,
        blankLine,
        (<>), (<+>), hcat, hsep,
        ($$), ($+$), vcat,
        sep, cat,
        fsep, fcat,
        hang, punctuate, ppWhen, ppUnless,
        speakNth, speakNTimes, speakN, speakNOf, plural,
36

37
        coloured, PprColour, colType, colCoerc, colDataCon,
38
        colBinder, bold, keyword,
39

batterseapower's avatar
batterseapower committed
40
        -- * Converting 'SDoc' into strings and outputing it
dterei's avatar
dterei committed
41 42 43
        printForC, printForAsm, printForUser, printForUserPartWay,
        pprCode, mkCodeStyle,
        showSDoc, showSDocOneLine,
44 45
        showSDocForUser, showSDocDebug, showSDocDump, showSDocDumpOneLine,
        showPpr,
Ian Lynagh's avatar
Ian Lynagh committed
46
        showSDocUnqual,
47
        renderWithStyle,
48

dterei's avatar
dterei committed
49
        pprInfixVar, pprPrefixVar,
50
        pprHsChar, pprHsString, pprHsBytes,
51
        pprFastFilePath,
52

batterseapower's avatar
batterseapower committed
53
        -- * Controlling the style in which output is printed
dterei's avatar
dterei committed
54
        BindingSite(..),
batterseapower's avatar
batterseapower committed
55

dterei's avatar
dterei committed
56
        PprStyle, CodeStyle(..), PrintUnqualified, alwaysQualify, neverQualify,
batterseapower's avatar
batterseapower committed
57
        QualifyName(..),
Ian Lynagh's avatar
Ian Lynagh committed
58
        sdocWithDynFlags, sdocWithPlatform,
dterei's avatar
dterei committed
59 60 61 62 63
        getPprStyle, withPprStyle, withPprStyleDoc,
        pprDeeper, pprDeeperList, pprSetDepth,
        codeStyle, userStyle, debugStyle, dumpStyle, asmStyle,
        ifPprDebug, qualName, qualModule,
        mkErrStyle, defaultErrStyle, defaultDumpStyle, defaultUserStyle,
64
        mkUserStyle, cmdlineParserStyle, Depth(..),
dterei's avatar
dterei committed
65 66 67 68

        -- * Error handling and debugging utilities
        pprPanic, pprSorry, assertPprPanic, pprPanicFastInt, pprPgmError,
        pprTrace, pprDefiniteTrace, warnPprTrace,
Ian Lynagh's avatar
Ian Lynagh committed
69 70
        trace, pgmError, panic, sorry, panicFastInt, assertPanic,
        pprDebugAndThen,
71 72
    ) where

73
import {-# SOURCE #-}   DynFlags( DynFlags, tracingDynFlags,
Ian Lynagh's avatar
Ian Lynagh committed
74
                                  targetPlatform, pprUserLength, pprCols )
dterei's avatar
dterei committed
75
import {-# SOURCE #-}   Module( Module, ModuleName, moduleName )
76
import {-# SOURCE #-}   Name( Name, nameModule )
77

Simon Marlow's avatar
Simon Marlow committed
78
import StaticFlags
dterei's avatar
dterei committed
79
import FastString
80
import FastTypes
81
import qualified Pretty
82
import Util
Ian Lynagh's avatar
Ian Lynagh committed
83
import Platform
dterei's avatar
dterei committed
84
import Pretty           ( Doc, Mode(..) )
85
import Panic
86

87
import Data.Char
88
import qualified Data.Map as M
89
import qualified Data.IntMap as IM
90 91
import Data.Set (Set)
import qualified Data.Set as Set
92
import Data.Word
93
import System.IO        ( Handle )
94
import System.FilePath
95

96
import GHC.Show         ( showMultiLineString )
97 98
\end{code}

sof's avatar
sof committed
99

100

101
%************************************************************************
dterei's avatar
dterei committed
102
%*                                                                      *
sof's avatar
sof committed
103
\subsection{The @PprStyle@ data type}
dterei's avatar
dterei committed
104
%*                                                                      *
105 106 107
%************************************************************************

\begin{code}
108

sof's avatar
sof committed
109
data PprStyle
110
  = PprUser PrintUnqualified Depth
dterei's avatar
dterei committed
111 112 113 114 115
                -- Pretty-print in a way that will make sense to the
                -- ordinary user; must be very close to Haskell
                -- syntax, etc.
                -- Assumes printing tidied code: non-system names are
                -- printed without uniques.
sof's avatar
sof committed
116

117
  | PprCode CodeStyle
dterei's avatar
dterei committed
118
                -- Print code; either C or assembler
sof's avatar
sof committed
119

dterei's avatar
dterei committed
120 121 122
  | PprDump     -- For -ddump-foo; less verbose than PprDebug.
                -- Does not assume tidied code: non-external names
                -- are printed with uniques.
123

dterei's avatar
dterei committed
124
  | PprDebug    -- Full debugging output
125

dterei's avatar
dterei committed
126 127
data CodeStyle = CStyle         -- The format of labels differs for C and assembler
               | AsmStyle
128 129

data Depth = AllTheWay
dterei's avatar
dterei committed
130
           | PartWay Int        -- 0 => stop
131 132


Simon Marlow's avatar
Simon Marlow committed
133 134
-- -----------------------------------------------------------------------------
-- Printing original names
135

Simon Marlow's avatar
Simon Marlow committed
136 137 138 139 140 141 142 143 144 145 146
-- When printing code that contains original names, we need to map the
-- original names back to something the user understands.  This is the
-- purpose of the pair of functions that gets passed around
-- when rendering 'SDoc'.

-- | given an /original/ name, this function tells you which module
-- name it should be qualified with when printing for the user, if
-- any.  For example, given @Control.Exception.catch@, which is in scope
-- as @Exception.catch@, this fuction will return @Just "Exception"@.
-- Note that the return value is a ModuleName, not a Module, because
-- in source code, names are qualified by ModuleNames.
147
type QueryQualifyName = Name -> QualifyName
148

149
-- See Note [Printing original names] in HscTypes
150 151 152
data QualifyName                        -- given P:M.T
        = NameUnqual                    -- refer to it as "T"
        | NameQual ModuleName           -- refer to it as "X.T" for the supplied X
dterei's avatar
dterei committed
153
        | NameNotInScope1
154 155 156 157 158 159
                -- it is not in scope at all, but M.T is not bound in the current
                -- scope, so we can refer to it as "M.T"
        | NameNotInScope2
                -- it is not in scope at all, and M.T is already bound in the
                -- current scope, so we must refer to it as "P:M.T"

Simon Marlow's avatar
Simon Marlow committed
160 161

-- | For a given module, we need to know whether to print it with
162 163
-- a package name to disambiguate it.
type QueryQualifyModule = Module -> Bool
Simon Marlow's avatar
Simon Marlow committed
164

165
type PrintUnqualified = (QueryQualifyName, QueryQualifyModule)
Simon Marlow's avatar
Simon Marlow committed
166

167
alwaysQualifyNames :: QueryQualifyName
168
alwaysQualifyNames n = NameQual (moduleName (nameModule n))
Simon Marlow's avatar
Simon Marlow committed
169

170
neverQualifyNames :: QueryQualifyName
171
neverQualifyNames _ = NameUnqual
Simon Marlow's avatar
Simon Marlow committed
172

173
alwaysQualifyModules :: QueryQualifyModule
174
alwaysQualifyModules _ = True
Simon Marlow's avatar
Simon Marlow committed
175

176
neverQualifyModules :: QueryQualifyModule
177 178
neverQualifyModules _ = False

179
alwaysQualify, neverQualify :: PrintUnqualified
Simon Marlow's avatar
Simon Marlow committed
180 181
alwaysQualify = (alwaysQualifyNames, alwaysQualifyModules)
neverQualify  = (neverQualifyNames,  neverQualifyModules)
182

183 184
defaultUserStyle, defaultDumpStyle :: PprStyle

185 186
defaultUserStyle = mkUserStyle alwaysQualify AllTheWay

187
defaultDumpStyle |  opt_PprStyle_Debug = PprDebug
dterei's avatar
dterei committed
188
                 |  otherwise          = PprDump
189

Simon Marlow's avatar
Simon Marlow committed
190
-- | Style for printing error messages
191 192
mkErrStyle :: DynFlags -> PrintUnqualified -> PprStyle
mkErrStyle dflags qual = mkUserStyle qual (PartWay (pprUserLength dflags))
193

194
defaultErrStyle :: DynFlags -> PprStyle
195 196 197
-- Default style for error messages
-- It's a bit of a hack because it doesn't take into account what's in scope
-- Only used for desugarer warnings, and typechecker errors in interface sigs
198 199 200 201
defaultErrStyle dflags = mkUserStyle alwaysQualify depth
    where depth = if opt_PprStyle_Debug
                  then AllTheWay
                  else PartWay (pprUserLength dflags)
202

203
mkUserStyle :: PrintUnqualified -> Depth -> PprStyle
Simon Marlow's avatar
Simon Marlow committed
204 205 206
mkUserStyle unqual depth
   | opt_PprStyle_Debug = PprDebug
   | otherwise          = PprUser unqual depth
207 208 209

cmdlineParserStyle :: PprStyle
cmdlineParserStyle = PprUser alwaysQualify AllTheWay
sof's avatar
sof committed
210
\end{code}
211

sof's avatar
sof committed
212 213 214 215
Orthogonal to the above printing styles are (possibly) some
command-line flags that affect printing (often carried with the
style).  The most likely ones are variations on how much type info is
shown.
sof's avatar
sof committed
216

sof's avatar
sof committed
217 218
The following test decides whether or not we are actually generating
code (either C or assembly), or generating interface files.
219 220

%************************************************************************
dterei's avatar
dterei committed
221
%*                                                                      *
222
\subsection{The @SDoc@ data type}
dterei's avatar
dterei committed
223
%*                                                                      *
224 225 226
%************************************************************************

\begin{code}
227
newtype SDoc = SDoc { runSDoc :: SDocContext -> Doc }
228 229 230 231 232

data SDocContext = SDC
  { sdocStyle      :: !PprStyle
  , sdocLastColour :: !PprColour
    -- ^ The most recently used colour.  This allows nesting colours.
233
  , sdocDynFlags   :: !DynFlags
234 235
  }

Ian Lynagh's avatar
Ian Lynagh committed
236 237
initSDocContext :: DynFlags -> PprStyle -> SDocContext
initSDocContext dflags sty = SDC
238 239
  { sdocStyle = sty
  , sdocLastColour = colReset
Ian Lynagh's avatar
Ian Lynagh committed
240
  , sdocDynFlags = dflags
241
  }
242 243

withPprStyle :: PprStyle -> SDoc -> SDoc
244
withPprStyle sty d = SDoc $ \ctxt -> runSDoc d ctxt{sdocStyle=sty}
245

Ian Lynagh's avatar
Ian Lynagh committed
246 247
withPprStyleDoc :: DynFlags -> PprStyle -> SDoc -> Doc
withPprStyleDoc dflags sty d = runSDoc d (initSDocContext dflags sty)
248

249
pprDeeper :: SDoc -> SDoc
250 251 252 253 254
pprDeeper d = SDoc $ \ctx -> case ctx of
  SDC{sdocStyle=PprUser _ (PartWay 0)} -> Pretty.text "..."
  SDC{sdocStyle=PprUser q (PartWay n)} ->
    runSDoc d ctx{sdocStyle = PprUser q (PartWay (n-1))}
  _ -> runSDoc d ctx
255

256 257
pprDeeperList :: ([SDoc] -> SDoc) -> [SDoc] -> SDoc
-- Truncate a list that list that is longer than the current depth
258 259 260 261 262 263 264 265 266 267 268
pprDeeperList f ds = SDoc work
 where
  work ctx@SDC{sdocStyle=PprUser q (PartWay n)}
   | n==0      = Pretty.text "..."
   | otherwise =
      runSDoc (f (go 0 ds)) ctx{sdocStyle = PprUser q (PartWay (n-1))}
   where
     go _ [] = []
     go i (d:ds) | i >= n    = [text "...."]
                 | otherwise = d : go (i+1) ds
  work other_ctx = runSDoc (f ds) other_ctx
269

270
pprSetDepth :: Depth -> SDoc -> SDoc
dterei's avatar
dterei committed
271 272 273 274 275 276
pprSetDepth depth doc = SDoc $ \ctx ->
    case ctx of
        SDC{sdocStyle=PprUser q _} ->
            runSDoc doc ctx{sdocStyle = PprUser q depth}
        _ ->
            runSDoc doc ctx
277

278
getPprStyle :: (PprStyle -> SDoc) -> SDoc
279
getPprStyle df = SDoc $ \ctx -> runSDoc (df (sdocStyle ctx)) ctx
Ian Lynagh's avatar
Ian Lynagh committed
280 281 282 283 284 285

sdocWithDynFlags :: (DynFlags -> SDoc) -> SDoc
sdocWithDynFlags f = SDoc $ \ctx -> runSDoc (f (sdocDynFlags ctx)) ctx

sdocWithPlatform :: (Platform -> SDoc) -> SDoc
sdocWithPlatform f = sdocWithDynFlags (f . targetPlatform)
286 287
\end{code}

sof's avatar
sof committed
288
\begin{code}
289
qualName :: PprStyle -> QueryQualifyName
290 291
qualName (PprUser (qual_name,_) _)  n = qual_name n
qualName _other                     n = NameQual (moduleName (nameModule n))
Simon Marlow's avatar
Simon Marlow committed
292

293
qualModule :: PprStyle -> QueryQualifyModule
294 295
qualModule (PprUser (_,qual_mod) _)  m = qual_mod m
qualModule _other                   _m = True
296

sof's avatar
sof committed
297
codeStyle :: PprStyle -> Bool
dterei's avatar
dterei committed
298 299
codeStyle (PprCode _)     = True
codeStyle _               = False
sof's avatar
sof committed
300

301 302
asmStyle :: PprStyle -> Bool
asmStyle (PprCode AsmStyle)  = True
303
asmStyle _other              = False
304

305 306
dumpStyle :: PprStyle -> Bool
dumpStyle PprDump = True
307
dumpStyle _other  = False
308

309
debugStyle :: PprStyle -> Bool
dterei's avatar
dterei committed
310 311
debugStyle PprDebug = True
debugStyle _other   = False
312

sof's avatar
sof committed
313
userStyle ::  PprStyle -> Bool
314
userStyle (PprUser _ _) = True
315
userStyle _other        = False
sof's avatar
sof committed
316

dterei's avatar
dterei committed
317 318 319 320 321
ifPprDebug :: SDoc -> SDoc        -- Empty for non-debug style
ifPprDebug d = SDoc $ \ctx ->
    case ctx of
        SDC{sdocStyle=PprDebug} -> runSDoc d ctx
        _                       -> Pretty.empty
sof's avatar
sof committed
322
\end{code}
323

sof's avatar
sof committed
324
\begin{code}
325

326
printForUser :: DynFlags -> Handle -> PrintUnqualified -> SDoc -> IO ()
Ian Lynagh's avatar
Ian Lynagh committed
327
printForUser dflags handle unqual doc
Ian Lynagh's avatar
Ian Lynagh committed
328
  = Pretty.printDoc PageMode (pprCols dflags) handle
Ian Lynagh's avatar
Ian Lynagh committed
329
      (runSDoc doc (initSDocContext dflags (mkUserStyle unqual AllTheWay)))
330

331 332
printForUserPartWay :: DynFlags -> Handle -> Int -> PrintUnqualified -> SDoc
                    -> IO ()
Ian Lynagh's avatar
Ian Lynagh committed
333
printForUserPartWay dflags handle d unqual doc
Ian Lynagh's avatar
Ian Lynagh committed
334
  = Pretty.printDoc PageMode (pprCols dflags) handle
Ian Lynagh's avatar
Ian Lynagh committed
335
      (runSDoc doc (initSDocContext dflags (mkUserStyle unqual (PartWay d))))
336

337
-- printForC, printForAsm do what they sound like
338
printForC :: DynFlags -> Handle -> SDoc -> IO ()
Ian Lynagh's avatar
Ian Lynagh committed
339
printForC dflags handle doc =
Ian Lynagh's avatar
Ian Lynagh committed
340
  Pretty.printDoc LeftMode (pprCols dflags) handle
Ian Lynagh's avatar
Ian Lynagh committed
341
    (runSDoc doc (initSDocContext dflags (PprCode CStyle)))
342

343
printForAsm :: DynFlags -> Handle -> SDoc -> IO ()
Ian Lynagh's avatar
Ian Lynagh committed
344
printForAsm dflags handle doc =
Ian Lynagh's avatar
Ian Lynagh committed
345
  Pretty.printDoc LeftMode (pprCols dflags) handle
Ian Lynagh's avatar
Ian Lynagh committed
346
    (runSDoc doc (initSDocContext dflags (PprCode AsmStyle)))
347

sof's avatar
sof committed
348 349
pprCode :: CodeStyle -> SDoc -> SDoc
pprCode cs d = withPprStyle (PprCode cs) d
350

351 352 353
mkCodeStyle :: CodeStyle -> PprStyle
mkCodeStyle = PprCode

354 355
-- Can't make SDoc an instance of Show because SDoc is just a function type
-- However, Doc *is* an instance of Show
356
-- showSDoc just blasts it out as a string
Ian Lynagh's avatar
Ian Lynagh committed
357
showSDoc :: DynFlags -> SDoc -> String
Ian Lynagh's avatar
Ian Lynagh committed
358
showSDoc dflags d =
359
  Pretty.showDocWith PageMode
Ian Lynagh's avatar
Ian Lynagh committed
360
    (runSDoc d (initSDocContext dflags defaultUserStyle))
361

362
renderWithStyle :: DynFlags -> SDoc -> PprStyle -> String
Ian Lynagh's avatar
Ian Lynagh committed
363 364
renderWithStyle dflags sdoc sty =
  Pretty.render (runSDoc sdoc (initSDocContext dflags sty))
365

366 367 368
-- This shows an SDoc, but on one line only. It's cheaper than a full
-- showSDoc, designed for when we're getting results like "Foo.bar"
-- and "foo{uniq strictness}" so we don't want fancy layout anyway.
369
showSDocOneLine :: DynFlags -> SDoc -> String
Ian Lynagh's avatar
Ian Lynagh committed
370
showSDocOneLine dflags d
371
 = Pretty.showDocWith PageMode
Ian Lynagh's avatar
Ian Lynagh committed
372
    (runSDoc d (initSDocContext dflags defaultUserStyle))
373

374
showSDocForUser :: DynFlags -> PrintUnqualified -> SDoc -> String
Ian Lynagh's avatar
Ian Lynagh committed
375 376
showSDocForUser dflags unqual doc
 = show (runSDoc doc (initSDocContext dflags (mkUserStyle unqual AllTheWay)))
377

378
showSDocUnqual :: DynFlags -> SDoc -> String
379
-- Only used in the gruesome isOperator
Ian Lynagh's avatar
Ian Lynagh committed
380 381
showSDocUnqual dflags d
 = show (runSDoc d (initSDocContext dflags (mkUserStyle neverQualify AllTheWay)))
382

383
showSDocDump :: DynFlags -> SDoc -> String
Ian Lynagh's avatar
Ian Lynagh committed
384 385
showSDocDump dflags d
 = Pretty.showDocWith PageMode (runSDoc d (initSDocContext dflags defaultDumpStyle))
386

387
showSDocDumpOneLine :: DynFlags -> SDoc -> String
Ian Lynagh's avatar
Ian Lynagh committed
388 389
showSDocDumpOneLine dflags d
 = Pretty.showDocWith OneLineMode (runSDoc d (initSDocContext dflags PprDump))
390

391
showSDocDebug :: DynFlags -> SDoc -> String
Ian Lynagh's avatar
Ian Lynagh committed
392
showSDocDebug dflags d = show (runSDoc d (initSDocContext dflags PprDebug))
393

Ian Lynagh's avatar
Ian Lynagh committed
394
showPpr :: Outputable a => DynFlags -> a -> String
Ian Lynagh's avatar
Ian Lynagh committed
395
showPpr dflags = showSDoc dflags . ppr
396 397
\end{code}

398
\begin{code}
399
docToSDoc :: Doc -> SDoc
400
docToSDoc d = SDoc (\_ -> d)
401

402 403
empty    :: SDoc
char     :: Char       -> SDoc
batterseapower's avatar
batterseapower committed
404
text     :: String     -> SDoc
405
ftext    :: FastString -> SDoc
406
ptext    :: LitString  -> SDoc
Ian Lynagh's avatar
Ian Lynagh committed
407
ztext    :: FastZString -> SDoc
408 409 410 411 412 413
int      :: Int        -> SDoc
integer  :: Integer    -> SDoc
float    :: Float      -> SDoc
double   :: Double     -> SDoc
rational :: Rational   -> SDoc

414 415 416 417 418
empty       = docToSDoc $ Pretty.empty
char c      = docToSDoc $ Pretty.char c
text s      = docToSDoc $ Pretty.text s
ftext s     = docToSDoc $ Pretty.ftext s
ptext s     = docToSDoc $ Pretty.ptext s
Ian Lynagh's avatar
Ian Lynagh committed
419
ztext s     = docToSDoc $ Pretty.ztext s
420 421 422 423 424
int n       = docToSDoc $ Pretty.int n
integer n   = docToSDoc $ Pretty.integer n
float n     = docToSDoc $ Pretty.float n
double n    = docToSDoc $ Pretty.double n
rational n  = docToSDoc $ Pretty.rational n
425

426 427
parens, braces, brackets, quotes, quote, 
        paBrackets, doubleQuotes, angleBrackets :: SDoc -> SDoc
428

429 430 431 432 433
parens d        = SDoc $ Pretty.parens . runSDoc d
braces d        = SDoc $ Pretty.braces . runSDoc d
brackets d      = SDoc $ Pretty.brackets . runSDoc d
quote d         = SDoc $ Pretty.quote . runSDoc d
doubleQuotes d  = SDoc $ Pretty.doubleQuotes . runSDoc d
434
angleBrackets d = char '<' <> d <> char '>'
435
paBrackets d    = ptext (sLit "[:") <> d <> ptext (sLit ":]")
436

437 438
cparen :: Bool -> SDoc -> SDoc

439
cparen b d     = SDoc $ Pretty.cparen b . runSDoc d
mnislaih's avatar
mnislaih committed
440

441
-- 'quotes' encloses something in single quotes...
442
-- but it omits them if the thing begins or ends in a single quote
443
-- so that we don't get `foo''.  Instead we just have foo'.
dterei's avatar
dterei committed
444
quotes d = SDoc $ \sty ->
445 446 447 448 449 450
           let pp_d = runSDoc d sty
               str  = show pp_d
           in case (str, snocView str) of
             (_, Just (_, '\'')) -> pp_d
             ('\'' : _, _)       -> pp_d
             _other              -> Pretty.quotes pp_d
451

452
semi, comma, colon, equals, space, dcolon, arrow, underscore, dot :: SDoc
453
darrow, lparen, rparen, lbrack, rbrack, lbrace, rbrace, blankLine :: SDoc
454

455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471
blankLine  = docToSDoc $ Pretty.ptext (sLit "")
dcolon     = docToSDoc $ Pretty.ptext (sLit "::")
arrow      = docToSDoc $ Pretty.ptext (sLit "->")
darrow     = docToSDoc $ Pretty.ptext (sLit "=>")
semi       = docToSDoc $ Pretty.semi
comma      = docToSDoc $ Pretty.comma
colon      = docToSDoc $ Pretty.colon
equals     = docToSDoc $ Pretty.equals
space      = docToSDoc $ Pretty.space
underscore = char '_'
dot        = char '.'
lparen     = docToSDoc $ Pretty.lparen
rparen     = docToSDoc $ Pretty.rparen
lbrack     = docToSDoc $ Pretty.lbrack
rbrack     = docToSDoc $ Pretty.rbrack
lbrace     = docToSDoc $ Pretty.lbrace
rbrace     = docToSDoc $ Pretty.rbrace
472 473

nest :: Int -> SDoc -> SDoc
batterseapower's avatar
batterseapower committed
474 475 476 477 478 479
-- ^ Indent 'SDoc' some specified amount
(<>) :: SDoc -> SDoc -> SDoc
-- ^ Join two 'SDoc' together horizontally without a gap
(<+>) :: SDoc -> SDoc -> SDoc
-- ^ Join two 'SDoc' together horizontally with a gap between them
($$) :: SDoc -> SDoc -> SDoc
dterei's avatar
dterei committed
480
-- ^ Join two 'SDoc' together vertically; if there is
batterseapower's avatar
batterseapower committed
481 482 483
-- no vertical overlap it "dovetails" the two onto one line
($+$) :: SDoc -> SDoc -> SDoc
-- ^ Join two 'SDoc' together vertically
484

485 486 487 488 489
nest n d    = SDoc $ Pretty.nest n . runSDoc d
(<>) d1 d2  = SDoc $ \sty -> (Pretty.<>)  (runSDoc d1 sty) (runSDoc d2 sty)
(<+>) d1 d2 = SDoc $ \sty -> (Pretty.<+>) (runSDoc d1 sty) (runSDoc d2 sty)
($$) d1 d2  = SDoc $ \sty -> (Pretty.$$)  (runSDoc d1 sty) (runSDoc d2 sty)
($+$) d1 d2 = SDoc $ \sty -> (Pretty.$+$) (runSDoc d1 sty) (runSDoc d2 sty)
490

batterseapower's avatar
batterseapower committed
491 492 493 494 495 496 497 498 499 500 501 502 503 504 505
hcat :: [SDoc] -> SDoc
-- ^ Concatenate 'SDoc' horizontally
hsep :: [SDoc] -> SDoc
-- ^ Concatenate 'SDoc' horizontally with a space between each one
vcat :: [SDoc] -> SDoc
-- ^ Concatenate 'SDoc' vertically with dovetailing
sep :: [SDoc] -> SDoc
-- ^ Separate: is either like 'hsep' or like 'vcat', depending on what fits
cat :: [SDoc] -> SDoc
-- ^ Catenate: is either like 'hcat' or like 'vcat', depending on what fits
fsep :: [SDoc] -> SDoc
-- ^ A paragraph-fill combinator. It's much like sep, only it
-- keeps fitting things on one line until it can't fit any more.
fcat :: [SDoc] -> SDoc
-- ^ This behaves like 'fsep', but it uses '<>' for horizontal conposition rather than '<+>'
506 507


508 509 510 511 512 513 514
hcat ds = SDoc $ \sty -> Pretty.hcat [runSDoc d sty | d <- ds]
hsep ds = SDoc $ \sty -> Pretty.hsep [runSDoc d sty | d <- ds]
vcat ds = SDoc $ \sty -> Pretty.vcat [runSDoc d sty | d <- ds]
sep ds  = SDoc $ \sty -> Pretty.sep  [runSDoc d sty | d <- ds]
cat ds  = SDoc $ \sty -> Pretty.cat  [runSDoc d sty | d <- ds]
fsep ds = SDoc $ \sty -> Pretty.fsep [runSDoc d sty | d <- ds]
fcat ds = SDoc $ \sty -> Pretty.fcat [runSDoc d sty | d <- ds]
515

batterseapower's avatar
batterseapower committed
516 517 518 519
hang :: SDoc  -- ^ The header
      -> Int  -- ^ Amount to indent the hung body
      -> SDoc -- ^ The hung body, indented and placed below the header
      -> SDoc
520
hang d1 n d2   = SDoc $ \sty -> Pretty.hang (runSDoc d1 sty) n (runSDoc d2 sty)
521

batterseapower's avatar
batterseapower committed
522 523 524
punctuate :: SDoc   -- ^ The punctuation
          -> [SDoc] -- ^ The list that will have punctuation added between every adjacent pair of elements
          -> [SDoc] -- ^ Punctuated list
525
punctuate _ []     = []
526
punctuate p (d:ds) = go d ds
dterei's avatar
dterei committed
527 528 529
                   where
                     go d [] = [d]
                     go d (e:es) = (d <> p) : go e es
530 531 532 533 534 535 536

ppWhen, ppUnless :: Bool -> SDoc -> SDoc
ppWhen True  doc = doc
ppWhen False _   = empty

ppUnless True  _   = empty
ppUnless False doc = doc
537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552

-- | A colour\/style for use with 'coloured'.
newtype PprColour = PprColour String

-- Colours

colType :: PprColour
colType = PprColour "\27[34m"

colBold :: PprColour
colBold = PprColour "\27[;1m"

colCoerc :: PprColour
colCoerc = PprColour "\27[34m"

colDataCon :: PprColour
553
colDataCon = PprColour "\27[31m"
554

555 556
colBinder :: PprColour
colBinder = PprColour "\27[32m"
557 558 559 560 561 562 563 564 565

colReset :: PprColour
colReset = PprColour "\27[0m"

-- | Apply the given colour\/style for the argument.
--
-- Only takes effect if colours are enabled.
coloured :: PprColour -> SDoc -> SDoc
-- TODO: coloured _ sdoc ctxt | coloursDisabled = sdoc ctxt
566 567 568 569
coloured col@(PprColour c) sdoc =
  SDoc $ \ctx@SDC{ sdocLastColour = PprColour lc } ->
    let ctx' = ctx{ sdocLastColour = col } in
    Pretty.zeroWidthText c Pretty.<> runSDoc sdoc ctx' Pretty.<> Pretty.zeroWidthText lc
570 571 572 573 574 575 576

bold :: SDoc -> SDoc
bold = coloured colBold

keyword :: SDoc -> SDoc
keyword = bold

577
\end{code}
sof's avatar
sof committed
578

sof's avatar
sof committed
579 580

%************************************************************************
dterei's avatar
dterei committed
581
%*                                                                      *
sof's avatar
sof committed
582
\subsection[Outputable-class]{The @Outputable@ class}
dterei's avatar
dterei committed
583
%*                                                                      *
sof's avatar
sof committed
584 585 586
%************************************************************************

\begin{code}
batterseapower's avatar
batterseapower committed
587
-- | Class designating that some type has an 'SDoc' representation
sof's avatar
sof committed
588
class Outputable a where
dterei's avatar
dterei committed
589 590 591 592 593
        ppr :: a -> SDoc
        pprPrec :: Rational -> a -> SDoc
                -- 0 binds least tightly
                -- We use Rational because there is always a
                -- Rational between any other two Rationals
594

dterei's avatar
dterei committed
595 596
        ppr = pprPrec 0
        pprPrec _ = ppr
sof's avatar
sof committed
597 598
\end{code}

599 600
\begin{code}
instance Outputable Bool where
601 602
    ppr True  = ptext (sLit "True")
    ppr False = ptext (sLit "False")
603

sof's avatar
sof committed
604
instance Outputable Int where
605
   ppr n = int n
sof's avatar
sof committed
606

607 608 609
instance Outputable Word16 where
   ppr n = integer $ fromIntegral n

610 611 612
instance Outputable Word32 where
   ppr n = integer $ fromIntegral n

613 614 615
instance Outputable Word where
   ppr n = integer $ fromIntegral n

616 617 618
instance Outputable () where
   ppr _ = text "()"

619
instance (Outputable a) => Outputable [a] where
620
    ppr xs = brackets (fsep (punctuate comma (map ppr xs)))
621

622 623 624
instance (Outputable a) => Outputable (Set a) where
    ppr s = braces (fsep (punctuate comma (map ppr (Set.toList s))))

625
instance (Outputable a, Outputable b) => Outputable (a, b) where
626
    ppr (x,y) = parens (sep [ppr x <> comma, ppr y])
627

628
instance Outputable a => Outputable (Maybe a) where
629 630
  ppr Nothing = ptext (sLit "Nothing")
  ppr (Just x) = ptext (sLit "Just") <+> ppr x
631

632
instance (Outputable a, Outputable b) => Outputable (Either a b) where
633 634
  ppr (Left x)  = ptext (sLit "Left")  <+> ppr x
  ppr (Right y) = ptext (sLit "Right") <+> ppr y
635

636 637
-- ToDo: may not be used
instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c) where
638
    ppr (x,y,z) =
639
      parens (sep [ppr x <> comma,
dterei's avatar
dterei committed
640 641
                   ppr y <> comma,
                   ppr z ])
642

643
instance (Outputable a, Outputable b, Outputable c, Outputable d) =>
dterei's avatar
dterei committed
644
         Outputable (a, b, c, d) where
645 646
    ppr (a,b,c,d) =
      parens (sep [ppr a <> comma,
dterei's avatar
dterei committed
647 648 649
                   ppr b <> comma,
                   ppr c <> comma,
                   ppr d])
650 651

instance (Outputable a, Outputable b, Outputable c, Outputable d, Outputable e) =>
dterei's avatar
dterei committed
652
         Outputable (a, b, c, d, e) where
653 654
    ppr (a,b,c,d,e) =
      parens (sep [ppr a <> comma,
dterei's avatar
dterei committed
655 656 657 658
                   ppr b <> comma,
                   ppr c <> comma,
                   ppr d <> comma,
                   ppr e])
659

660
instance (Outputable a, Outputable b, Outputable c, Outputable d, Outputable e, Outputable f) =>
dterei's avatar
dterei committed
661
         Outputable (a, b, c, d, e, f) where
662 663
    ppr (a,b,c,d,e,f) =
      parens (sep [ppr a <> comma,
dterei's avatar
dterei committed
664 665 666 667 668
                   ppr b <> comma,
                   ppr c <> comma,
                   ppr d <> comma,
                   ppr e <> comma,
                   ppr f])
669 670

instance (Outputable a, Outputable b, Outputable c, Outputable d, Outputable e, Outputable f, Outputable g) =>
dterei's avatar
dterei committed
671
         Outputable (a, b, c, d, e, f, g) where
672 673
    ppr (a,b,c,d,e,f,g) =
      parens (sep [ppr a <> comma,
dterei's avatar
dterei committed
674 675 676 677 678 679
                   ppr b <> comma,
                   ppr c <> comma,
                   ppr d <> comma,
                   ppr e <> comma,
                   ppr f <> comma,
                   ppr g])
680

681
instance Outputable FastString where
dterei's avatar
dterei committed
682 683
    ppr fs = ftext fs           -- Prints an unadorned string,
                                -- no double quotes or anything
684

685
instance (Outputable key, Outputable elt) => Outputable (M.Map key elt) where
686
    ppr m = ppr (M.toList m)
687 688
instance (Outputable elt) => Outputable (IM.IntMap elt) where
    ppr m = ppr (IM.toList m)
689 690 691
\end{code}

%************************************************************************
dterei's avatar
dterei committed
692
%*                                                                      *
693
\subsection{The @OutputableBndr@ class}
dterei's avatar
dterei committed
694
%*                                                                      *
695 696 697
%************************************************************************

\begin{code}
batterseapower's avatar
batterseapower committed
698 699 700
-- | 'BindingSite' is used to tell the thing that prints binder what
-- language construct is binding the identifier.  This can be used
-- to decide how much info to print.
701 702
data BindingSite = LambdaBind | CaseBind | LetBind

batterseapower's avatar
batterseapower committed
703 704
-- | When we print a binder, we often want to print its type too.
-- The @OutputableBndr@ class encapsulates this idea.
705 706
class Outputable a => OutputableBndr a where
   pprBndr :: BindingSite -> a -> SDoc
707
   pprBndr _b x = ppr x
708 709 710 711 712

   pprPrefixOcc, pprInfixOcc :: a -> SDoc
      -- Print an occurrence of the name, suitable either in the 
      -- prefix position of an application, thus   (f a b) or  ((+) x)
      -- or infix position,                 thus   (a `f` b) or  (x + y)
713 714 715
\end{code}

%************************************************************************
dterei's avatar
dterei committed
716
%*                                                                      *
717
\subsection{Random printing helpers}
dterei's avatar
dterei committed
718
%*                                                                      *
719 720 721
%************************************************************************

\begin{code}
722
-- We have 31-bit Chars and will simply use Show instances of Char and String.
batterseapower's avatar
batterseapower committed
723 724

-- | Special combinator for showing character literals.
725 726 727
pprHsChar :: Char -> SDoc
pprHsChar c | c > '\x10ffff' = char '\\' <> text (show (fromIntegral (ord c) :: Word32))
            | otherwise      = text (show c)
728

batterseapower's avatar
batterseapower committed
729
-- | Special combinator for showing string literals.
730
pprHsString :: FastString -> SDoc
731
pprHsString fs = vcat (map text (showMultiLineString (unpackFS fs)))
732

733 734 735 736 737 738 739 740 741 742
-- | Special combinator for showing string literals.
pprHsBytes :: FastBytes -> SDoc
pprHsBytes fb = let escaped = concatMap escape $ bytesFB fb
                in vcat (map text (showMultiLineString escaped)) <> char '#'
    where escape :: Word8 -> String
          escape w = let c = chr (fromIntegral w)
                     in if isAscii c
                        then [c]
                        else '\\' : show w

743 744 745 746 747
---------------------
-- Put a name in parens if it's an operator
pprPrefixVar :: Bool -> SDoc -> SDoc
pprPrefixVar is_operator pp_v
  | is_operator = parens pp_v
dterei's avatar
dterei committed
748
  | otherwise   = pp_v
749 750 751

-- Put a name in backquotes if it's not an operator
pprInfixVar :: Bool -> SDoc -> SDoc
dterei's avatar
dterei committed
752
pprInfixVar is_operator pp_v
753 754 755 756
  | is_operator = pp_v
  | otherwise   = char '`' <> pp_v <> char '`'

---------------------
757 758
pprFastFilePath :: FastString -> SDoc
pprFastFilePath path = text $ normalise $ unpackFS path
sof's avatar
sof committed
759 760
\end{code}

sof's avatar
sof committed
761
%************************************************************************
dterei's avatar
dterei committed
762
%*                                                                      *
sof's avatar
sof committed
763
\subsection{Other helper functions}
dterei's avatar
dterei committed
764
%*                                                                      *
sof's avatar
sof committed
765 766 767
%************************************************************************

\begin{code}
batterseapower's avatar
batterseapower committed
768 769 770 771
pprWithCommas :: (a -> SDoc) -- ^ The pretty printing function to use
              -> [a]         -- ^ The things to be pretty printed
              -> SDoc        -- ^ 'SDoc' where the things have been pretty printed,
                             -- comma-separated and finally packed into a paragraph.
772
pprWithCommas pp xs = fsep (punctuate comma (map pp xs))
773

batterseapower's avatar
batterseapower committed
774
-- | Returns the seperated concatenation of the pretty printed things.
775
interppSP  :: Outputable a => [a] -> SDoc
776
interppSP  xs = sep (map ppr xs)
sof's avatar
sof committed
777

batterseapower's avatar
batterseapower committed
778
-- | Returns the comma-seperated concatenation of the pretty printed things.
779
interpp'SP :: Outputable a => [a] -> SDoc
780
interpp'SP xs = sep (punctuate comma (map ppr xs))
781

batterseapower's avatar
batterseapower committed
782 783 784
-- | Returns the comma-seperated concatenation of the quoted pretty printed things.
--
-- > [x,y,z]  ==>  `x', `y', `z'
785
pprQuotedList :: Outputable a => [a] -> SDoc
786 787 788 789 790 791 792 793 794
pprQuotedList = quotedList . map ppr

quotedList :: [SDoc] -> SDoc
quotedList xs = hsep (punctuate comma (map quotes xs))

quotedListWithOr :: [SDoc] -> SDoc
-- [x,y,z]  ==>  `x', `y' or `z'
quotedListWithOr xs@(_:_:_) = quotedList (init xs) <+> ptext (sLit "or") <+> quotes (last xs)
quotedListWithOr xs = quotedList xs
sof's avatar
sof committed
795 796 797 798
\end{code}


%************************************************************************
dterei's avatar
dterei committed
799
%*                                                                      *
sof's avatar
sof committed
800
\subsection{Printing numbers verbally}
dterei's avatar
dterei committed
801
%*                                                                      *
sof's avatar
sof committed
802
%************************************************************************
sof's avatar
sof committed
803 804

\begin{code}
805 806 807 808 809 810 811 812 813
intWithCommas :: Integral a => a -> SDoc
-- Prints a big integer with commas, eg 345,821
intWithCommas n
  | n < 0     = char '-' <> intWithCommas (-n)
  | q == 0    = int (fromIntegral r)
  | otherwise = intWithCommas q <> comma <> int (fromIntegral r)
  where
    (q,r) = n `quotRem` 1000

batterseapower's avatar
batterseapower committed
814 815 816 817 818
-- | Converts an integer to a verbal index:
--
-- > speakNth 1 = text "first"
-- > speakNth 5 = text "fifth"
-- > speakNth 21 = text "21st"
819
speakNth :: Int -> SDoc
820 821 822 823 824 825
speakNth 1 = ptext (sLit "first")
speakNth 2 = ptext (sLit "second")
speakNth 3 = ptext (sLit "third")
speakNth 4 = ptext (sLit "fourth")
speakNth 5 = ptext (sLit "fifth")
speakNth 6 = ptext (sLit "sixth")
826
speakNth n = hcat [ int n, text suffix ]
sof's avatar
sof committed
827
  where
dterei's avatar
dterei committed
828 829 830 831 832
    suffix | n <= 20       = "th"       -- 11,12,13 are non-std
           | last_dig == 1 = "st"
           | last_dig == 2 = "nd"
           | last_dig == 3 = "rd"
           | otherwise     = "th"
sof's avatar
sof committed
833

834
    last_dig = n `rem` 10
835

batterseapower's avatar
batterseapower committed
836
-- | Converts an integer to a verbal multiplicity:
dterei's avatar
dterei committed
837
--
batterseapower's avatar
batterseapower committed
838 839 840
-- > speakN 0 = text "none"
-- > speakN 5 = text "five"
-- > speakN 10 = text "10"
841
speakN :: Int -> SDoc
dterei's avatar
dterei committed
842 843
speakN 0 = ptext (sLit "none")  -- E.g.  "he has none"
speakN 1 = ptext (sLit "one")   -- E.g.  "he has one"
844 845 846 847 848
speakN 2 = ptext (sLit "two")
speakN 3 = ptext (sLit "three")
speakN 4 = ptext (sLit "four")
speakN 5 = ptext (sLit "five")
speakN 6 = ptext (sLit "six")
849 850
speakN n = int n

batterseapower's avatar
batterseapower committed
851 852 853 854 855 856
-- | Converts an integer and object description to a statement about the
-- multiplicity of those objects:
--
-- > speakNOf 0 (text "melon") = text "no melons"
-- > speakNOf 1 (text "melon") = text "one melon"
-- > speakNOf 3 (text "melon") = text "three melons"
857
speakNOf :: Int -> SDoc -> SDoc
batterseapower's avatar
batterseapower committed
858
speakNOf 0 d = ptext (sLit "no") <+> d <> char 's'
dterei's avatar
dterei committed
859 860
speakNOf 1 d = ptext (sLit "one") <+> d                 -- E.g. "one argument"
speakNOf n d = speakN n <+> d <> char 's'               -- E.g. "three arguments"
861

batterseapower's avatar
batterseapower committed
862 863 864 865 866
-- | Converts a strictly positive integer into a number of times:
--
-- > speakNTimes 1 = text "once"
-- > speakNTimes 2 = text "twice"
-- > speakNTimes 4 = text "4 times"
867
speakNTimes :: Int {- >=1 -} -> SDoc
dterei's avatar
dterei committed
868 869
speakNTimes t | t == 1     = ptext (sLit "once")
              | t == 2     = ptext (sLit "twice")
870
              | otherwise  = speakN t <+> ptext (sLit "times")
871

batterseapower's avatar
batterseapower committed
872 873 874 875 876
-- | Determines the pluralisation suffix appropriate for the length of a list:
--
-- > plural [] = char 's'
-- > plural ["Hello"] = empty
-- > plural ["Hello", "World"] = char 's'
877 878 879
plural :: [a] -> SDoc
plural [_] = empty  -- a bit frightening, but there you are
plural _   = char 's'
880 881
\end{code}

882

883
%************************************************************************
dterei's avatar
dterei committed
884
%*                                                                      *
885
\subsection{Error handling}
dterei's avatar
dterei committed
886
%*                                                                      *
887 888 889
%************************************************************************

\begin{code}
890

batterseapower's avatar
batterseapower committed
891 892
pprPanic :: String -> SDoc -> a
-- ^ Throw an exception saying "bug in GHC"
Ian Lynagh's avatar
Ian Lynagh committed
893
pprPanic    = panicDoc
batterseapower's avatar
batterseapower committed
894

895
pprSorry :: String -> SDoc -> a
Ian Lynagh's avatar
Ian Lynagh committed
896
-- ^ Throw an exception saying "this isn't finished yet"
897
pprSorry    = sorryDoc
898 899 900 901


pprPgmError :: String -> SDoc -> a
-- ^ Throw an exception saying "bug in pgm being compiled" (used for unusual program errors)
902
pprPgmError = pgmErrorDoc
903

904 905 906

pprTrace :: String -> SDoc -> a -> a
-- ^ If debug output is on, show some 'SDoc' on the screen
Simon Marlow's avatar
Simon Marlow committed
907 908
pprTrace str doc x
   | opt_NoDebugOutput = x
909
   | otherwise         = pprDebugAndThen tracingDynFlags trace str doc x
910

911
pprDefiniteTrace :: DynFlags -> String -> SDoc -> a -> a
912
-- ^ Same as pprTrace, but show even if -dno-debug-output is on
913
pprDefiniteTrace dflags str doc x = pprDebugAndThen dflags trace str doc x
914

915
pprPanicFastInt :: String -> SDoc -> FastInt
batterseapower's avatar
batterseapower committed
916
-- ^ Specialization of pprPanic that can be safely used with 'FastInt'
917
pprPanicFastInt heading pretty_msg = panicDocFastInt heading pretty_msg
918

919
warnPprTrace :: Bool -> String -> Int -> SDoc -> a -> a
batterseapower's avatar
batterseapower committed
920 921
-- ^ Just warn about an assertion failure, recording the given file and line number.
-- Should typically be accessed with the WARN macros
922
warnPprTrace _     _     _     _    x | not debugIsOn     = x
Simon Marlow's avatar
Simon Marlow committed
923
warnPprTrace _     _file _line _msg x | opt_NoDebugOutput = x
924 925
warnPprTrace False _file _line _msg x = x
warnPprTrace True   file  line  msg x
926
  = pprDebugAndThen tracingDynFlags trace str msg x
927
  where
Ian Lynagh's avatar
Ian Lynagh committed
928
    str = showSDoc tracingDynFlags (hsep [text "WARNING: file", text file <> comma, text "line", int line])
929 930 931 932 933

assertPprPanic :: String -> Int -> SDoc -> a
-- ^ Panic with an assertation failure, recording the given file and line number.
-- Should typically be accessed with the ASSERT family of macros
assertPprPanic file line msg
934
  = pprPanic "ASSERT failed!" doc
935 936 937 938 939
  where
    doc = sep [ hsep [ text "file", text file
                     , text "line", int line ]
              , msg ]

940
pprDebugAndThen :: DynFlags -> (String -> a) -> String -> SDoc -> a
Ian Lynagh's avatar
Ian Lynagh committed
941
pprDebugAndThen dflags cont heading pretty_msg
Ian Lynagh's avatar
Ian Lynagh committed
942
 = cont (showSDocDebug dflags doc)
943 944
 where
     doc = sep [text heading, nest 4 pretty_msg]
945
\end{code}
dterei's avatar
dterei committed
946