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 23
        SDoc, runSDoc, initSDocContext,
        docToSDoc,
        interppSP, interpp'SP, pprQuotedList, pprWithCommas, quotedListWithOr,
        empty, nest,
        char,
        text, ftext, ptext,
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,
Thomas Schilling's avatar
Thomas Schilling committed
38
        colBinder, bold, keyword,
39

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

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

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

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

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

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

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

Ian Lynagh's avatar
Ian Lynagh committed
88
import Data.Char
89
import qualified Data.Map as M
90
import qualified Data.IntMap as IM
91 92
import Data.Set (Set)
import qualified Data.Set as Set
93
import Data.Word
94
import System.IO        ( Handle, hFlush )
95
import System.FilePath
96 97


Ian Lynagh's avatar
Ian Lynagh committed
98
#if __GLASGOW_HASKELL__ >= 701
99
import GHC.Show         ( showMultiLineString )
100 101 102
#else
showMultiLineString :: String -> [String]
-- Crude version
103
showMultiLineString s = [ showList s "" ]
104
#endif
105 106
\end{code}

sof's avatar
sof committed
107

108

109
%************************************************************************
dterei's avatar
dterei committed
110
%*                                                                      *
sof's avatar
sof committed
111
\subsection{The @PprStyle@ data type}
dterei's avatar
dterei committed
112
%*                                                                      *
113 114 115
%************************************************************************

\begin{code}
116

sof's avatar
sof committed
117
data PprStyle
118
  = PprUser PrintUnqualified Depth
dterei's avatar
dterei committed
119 120 121 122 123
                -- 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
124

125
  | PprCode CodeStyle
dterei's avatar
dterei committed
126
                -- Print code; either C or assembler
sof's avatar
sof committed
127

dterei's avatar
dterei committed
128 129 130
  | PprDump     -- For -ddump-foo; less verbose than PprDebug.
                -- Does not assume tidied code: non-external names
                -- are printed with uniques.
131

dterei's avatar
dterei committed
132
  | PprDebug    -- Full debugging output
133

dterei's avatar
dterei committed
134 135
data CodeStyle = CStyle         -- The format of labels differs for C and assembler
               | AsmStyle
136 137

data Depth = AllTheWay
dterei's avatar
dterei committed
138
           | PartWay Int        -- 0 => stop
139 140


Simon Marlow's avatar
Simon Marlow committed
141 142
-- -----------------------------------------------------------------------------
-- Printing original names
143

Simon Marlow's avatar
Simon Marlow committed
144 145 146 147 148 149 150 151 152 153 154
-- 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.
155
type QueryQualifyName = Name -> QualifyName
156

157
-- See Note [Printing original names] in HscTypes
158 159 160
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
161
        | NameNotInScope1
162 163 164 165 166 167
                -- 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
168 169

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

173
type PrintUnqualified = (QueryQualifyName, QueryQualifyModule)
Simon Marlow's avatar
Simon Marlow committed
174

175
alwaysQualifyNames :: QueryQualifyName
176
alwaysQualifyNames n = NameQual (moduleName (nameModule n))
Simon Marlow's avatar
Simon Marlow committed
177

178
neverQualifyNames :: QueryQualifyName
179
neverQualifyNames _ = NameUnqual
Simon Marlow's avatar
Simon Marlow committed
180

181
alwaysQualifyModules :: QueryQualifyModule
182
alwaysQualifyModules _ = True
Simon Marlow's avatar
Simon Marlow committed
183

184
neverQualifyModules :: QueryQualifyModule
185 186
neverQualifyModules _ = False

187
alwaysQualify, neverQualify :: PrintUnqualified
Simon Marlow's avatar
Simon Marlow committed
188 189
alwaysQualify = (alwaysQualifyNames, alwaysQualifyModules)
neverQualify  = (neverQualifyNames,  neverQualifyModules)
190

191 192
defaultUserStyle, defaultDumpStyle :: PprStyle

193 194
defaultUserStyle = mkUserStyle alwaysQualify AllTheWay

195
defaultDumpStyle |  opt_PprStyle_Debug = PprDebug
dterei's avatar
dterei committed
196
                 |  otherwise          = PprDump
197

Simon Marlow's avatar
Simon Marlow committed
198
-- | Style for printing error messages
199 200
mkErrStyle :: DynFlags -> PrintUnqualified -> PprStyle
mkErrStyle dflags qual = mkUserStyle qual (PartWay (pprUserLength dflags))
201

202
defaultErrStyle :: DynFlags -> PprStyle
203 204 205
-- 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
206 207 208 209
defaultErrStyle dflags = mkUserStyle alwaysQualify depth
    where depth = if opt_PprStyle_Debug
                  then AllTheWay
                  else PartWay (pprUserLength dflags)
210

211
mkUserStyle :: PrintUnqualified -> Depth -> PprStyle
Simon Marlow's avatar
Simon Marlow committed
212 213 214
mkUserStyle unqual depth
   | opt_PprStyle_Debug = PprDebug
   | otherwise          = PprUser unqual depth
215 216 217

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

sof's avatar
sof committed
220 221 222 223
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
224

sof's avatar
sof committed
225 226
The following test decides whether or not we are actually generating
code (either C or assembly), or generating interface files.
227 228

%************************************************************************
dterei's avatar
dterei committed
229
%*                                                                      *
230
\subsection{The @SDoc@ data type}
dterei's avatar
dterei committed
231
%*                                                                      *
232 233 234
%************************************************************************

\begin{code}
Thomas Schilling's avatar
Thomas Schilling committed
235
newtype SDoc = SDoc { runSDoc :: SDocContext -> Doc }
236 237 238 239 240

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

Ian Lynagh's avatar
Ian Lynagh committed
244 245
initSDocContext :: DynFlags -> PprStyle -> SDocContext
initSDocContext dflags sty = SDC
246 247
  { sdocStyle = sty
  , sdocLastColour = colReset
Ian Lynagh's avatar
Ian Lynagh committed
248
  , sdocDynFlags = dflags
249
  }
250 251

withPprStyle :: PprStyle -> SDoc -> SDoc
Thomas Schilling's avatar
Thomas Schilling committed
252
withPprStyle sty d = SDoc $ \ctxt -> runSDoc d ctxt{sdocStyle=sty}
253

Ian Lynagh's avatar
Ian Lynagh committed
254 255
withPprStyleDoc :: DynFlags -> PprStyle -> SDoc -> Doc
withPprStyleDoc dflags sty d = runSDoc d (initSDocContext dflags sty)
256

257
pprDeeper :: SDoc -> SDoc
Thomas Schilling's avatar
Thomas Schilling committed
258 259 260 261 262
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
263

264 265
pprDeeperList :: ([SDoc] -> SDoc) -> [SDoc] -> SDoc
-- Truncate a list that list that is longer than the current depth
Thomas Schilling's avatar
Thomas Schilling committed
266 267 268 269 270 271 272 273 274 275 276
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
277

278
pprSetDepth :: Depth -> SDoc -> SDoc
dterei's avatar
dterei committed
279 280 281 282 283 284
pprSetDepth depth doc = SDoc $ \ctx ->
    case ctx of
        SDC{sdocStyle=PprUser q _} ->
            runSDoc doc ctx{sdocStyle = PprUser q depth}
        _ ->
            runSDoc doc ctx
285

286
getPprStyle :: (PprStyle -> SDoc) -> SDoc
Thomas Schilling's avatar
Thomas Schilling committed
287
getPprStyle df = SDoc $ \ctx -> runSDoc (df (sdocStyle ctx)) ctx
Ian Lynagh's avatar
Ian Lynagh committed
288 289 290 291 292 293

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

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

sof's avatar
sof committed
296
\begin{code}
297
qualName :: PprStyle -> QueryQualifyName
298 299
qualName (PprUser (qual_name,_) _)  n = qual_name n
qualName _other                     n = NameQual (moduleName (nameModule n))
Simon Marlow's avatar
Simon Marlow committed
300

301
qualModule :: PprStyle -> QueryQualifyModule
302 303
qualModule (PprUser (_,qual_mod) _)  m = qual_mod m
qualModule _other                   _m = True
304

sof's avatar
sof committed
305
codeStyle :: PprStyle -> Bool
dterei's avatar
dterei committed
306 307
codeStyle (PprCode _)     = True
codeStyle _               = False
sof's avatar
sof committed
308

309 310
asmStyle :: PprStyle -> Bool
asmStyle (PprCode AsmStyle)  = True
311
asmStyle _other              = False
312

313 314
dumpStyle :: PprStyle -> Bool
dumpStyle PprDump = True
315
dumpStyle _other  = False
316

317
debugStyle :: PprStyle -> Bool
dterei's avatar
dterei committed
318 319
debugStyle PprDebug = True
debugStyle _other   = False
320

sof's avatar
sof committed
321
userStyle ::  PprStyle -> Bool
322
userStyle (PprUser _ _) = True
323
userStyle _other        = False
sof's avatar
sof committed
324

dterei's avatar
dterei committed
325 326 327 328 329
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
330
\end{code}
331

sof's avatar
sof committed
332
\begin{code}
Ian Lynagh's avatar
Ian Lynagh committed
333
hPrintDump :: DynFlags -> Handle -> SDoc -> IO ()
Ian Lynagh's avatar
Ian Lynagh committed
334
hPrintDump dflags h doc = do
Ian Lynagh's avatar
Ian Lynagh committed
335
   Pretty.printDoc PageMode (pprCols dflags) h
Ian Lynagh's avatar
Ian Lynagh committed
336
     (runSDoc better_doc (initSDocContext dflags defaultDumpStyle))
337
   hFlush h
sof's avatar
sof committed
338
 where
339
   better_doc = doc $$ blankLine
340

341
printForUser :: DynFlags -> Handle -> PrintUnqualified -> SDoc -> IO ()
Ian Lynagh's avatar
Ian Lynagh committed
342
printForUser dflags handle unqual doc
Ian Lynagh's avatar
Ian Lynagh committed
343
  = Pretty.printDoc PageMode (pprCols dflags) handle
Ian Lynagh's avatar
Ian Lynagh committed
344
      (runSDoc doc (initSDocContext dflags (mkUserStyle unqual AllTheWay)))
345

346 347
printForUserPartWay :: DynFlags -> Handle -> Int -> PrintUnqualified -> SDoc
                    -> IO ()
Ian Lynagh's avatar
Ian Lynagh committed
348
printForUserPartWay dflags handle d unqual doc
Ian Lynagh's avatar
Ian Lynagh committed
349
  = Pretty.printDoc PageMode (pprCols dflags) handle
Ian Lynagh's avatar
Ian Lynagh committed
350
      (runSDoc doc (initSDocContext dflags (mkUserStyle unqual (PartWay d))))
351

352
-- printForC, printForAsm do what they sound like
353
printForC :: DynFlags -> Handle -> SDoc -> IO ()
Ian Lynagh's avatar
Ian Lynagh committed
354
printForC dflags handle doc =
Ian Lynagh's avatar
Ian Lynagh committed
355
  Pretty.printDoc LeftMode (pprCols dflags) handle
Ian Lynagh's avatar
Ian Lynagh committed
356
    (runSDoc doc (initSDocContext dflags (PprCode CStyle)))
357

358
printForAsm :: DynFlags -> Handle -> SDoc -> IO ()
Ian Lynagh's avatar
Ian Lynagh committed
359
printForAsm dflags handle doc =
Ian Lynagh's avatar
Ian Lynagh committed
360
  Pretty.printDoc LeftMode (pprCols dflags) handle
Ian Lynagh's avatar
Ian Lynagh committed
361
    (runSDoc doc (initSDocContext dflags (PprCode AsmStyle)))
362

sof's avatar
sof committed
363 364
pprCode :: CodeStyle -> SDoc -> SDoc
pprCode cs d = withPprStyle (PprCode cs) d
365

366 367 368
mkCodeStyle :: CodeStyle -> PprStyle
mkCodeStyle = PprCode

369 370
-- Can't make SDoc an instance of Show because SDoc is just a function type
-- However, Doc *is* an instance of Show
371
-- showSDoc just blasts it out as a string
Ian Lynagh's avatar
Ian Lynagh committed
372
showSDoc :: DynFlags -> SDoc -> String
Ian Lynagh's avatar
Ian Lynagh committed
373
showSDoc dflags d =
Thomas Schilling's avatar
Thomas Schilling committed
374
  Pretty.showDocWith PageMode
Ian Lynagh's avatar
Ian Lynagh committed
375
    (runSDoc d (initSDocContext dflags defaultUserStyle))
376

Ian Lynagh's avatar
Ian Lynagh committed
377
renderWithStyle :: DynFlags -> SDoc -> PprStyle -> String
Ian Lynagh's avatar
Ian Lynagh committed
378 379
renderWithStyle dflags sdoc sty =
  Pretty.render (runSDoc sdoc (initSDocContext dflags sty))
380

381 382 383
-- 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.
384
showSDocOneLine :: DynFlags -> SDoc -> String
Ian Lynagh's avatar
Ian Lynagh committed
385
showSDocOneLine dflags d
386
 = Pretty.showDocWith PageMode
Ian Lynagh's avatar
Ian Lynagh committed
387
    (runSDoc d (initSDocContext dflags defaultUserStyle))
388

389
showSDocForUser :: DynFlags -> PrintUnqualified -> SDoc -> String
Ian Lynagh's avatar
Ian Lynagh committed
390 391
showSDocForUser dflags unqual doc
 = show (runSDoc doc (initSDocContext dflags (mkUserStyle unqual AllTheWay)))
392

393
showSDocUnqual :: DynFlags -> SDoc -> String
394
-- Only used in the gruesome isOperator
Ian Lynagh's avatar
Ian Lynagh committed
395 396
showSDocUnqual dflags d
 = show (runSDoc d (initSDocContext dflags (mkUserStyle neverQualify AllTheWay)))
397

398
showSDocDump :: DynFlags -> SDoc -> String
Ian Lynagh's avatar
Ian Lynagh committed
399 400
showSDocDump dflags d
 = Pretty.showDocWith PageMode (runSDoc d (initSDocContext dflags defaultDumpStyle))
401

402
showSDocDumpOneLine :: DynFlags -> SDoc -> String
Ian Lynagh's avatar
Ian Lynagh committed
403 404
showSDocDumpOneLine dflags d
 = Pretty.showDocWith OneLineMode (runSDoc d (initSDocContext dflags PprDump))
405

406
showSDocDebug :: DynFlags -> SDoc -> String
Ian Lynagh's avatar
Ian Lynagh committed
407
showSDocDebug dflags d = show (runSDoc d (initSDocContext dflags PprDebug))
408

Ian Lynagh's avatar
Ian Lynagh committed
409
showPpr :: Outputable a => DynFlags -> a -> String
Ian Lynagh's avatar
Ian Lynagh committed
410
showPpr dflags = showSDoc dflags . ppr
411 412
\end{code}

413
\begin{code}
414
docToSDoc :: Doc -> SDoc
Thomas Schilling's avatar
Thomas Schilling committed
415
docToSDoc d = SDoc (\_ -> d)
416

417 418
empty    :: SDoc
char     :: Char       -> SDoc
batterseapower's avatar
batterseapower committed
419
text     :: String     -> SDoc
420
ftext    :: FastString -> SDoc
421
ptext    :: LitString  -> SDoc
422 423 424 425 426 427
int      :: Int        -> SDoc
integer  :: Integer    -> SDoc
float    :: Float      -> SDoc
double   :: Double     -> SDoc
rational :: Rational   -> SDoc

Thomas Schilling's avatar
Thomas Schilling committed
428 429 430 431 432 433 434 435 436 437
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
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
438

439 440
parens, braces, brackets, quotes, quote, 
        paBrackets, doubleQuotes, angleBrackets :: SDoc -> SDoc
441

442 443 444 445 446
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
Thomas Schilling's avatar
Thomas Schilling committed
447
angleBrackets d = char '<' <> d <> char '>'
448
paBrackets d    = ptext (sLit "[:") <> d <> ptext (sLit ":]")
449

450 451
cparen :: Bool -> SDoc -> SDoc

Thomas Schilling's avatar
Thomas Schilling committed
452
cparen b d     = SDoc $ Pretty.cparen b . runSDoc d
mnislaih's avatar
mnislaih committed
453

454
-- 'quotes' encloses something in single quotes...
455
-- but it omits them if the thing begins or ends in a single quote
456
-- so that we don't get `foo''.  Instead we just have foo'.
dterei's avatar
dterei committed
457
quotes d = SDoc $ \sty ->
458 459 460 461 462 463
           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
464

465
semi, comma, colon, equals, space, dcolon, arrow, underscore, dot :: SDoc
466
darrow, lparen, rparen, lbrack, rbrack, lbrace, rbrace, blankLine :: SDoc
467

Thomas Schilling's avatar
Thomas Schilling committed
468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484
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
485 486

nest :: Int -> SDoc -> SDoc
batterseapower's avatar
batterseapower committed
487 488 489 490 491 492
-- ^ 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
493
-- ^ Join two 'SDoc' together vertically; if there is
batterseapower's avatar
batterseapower committed
494 495 496
-- no vertical overlap it "dovetails" the two onto one line
($+$) :: SDoc -> SDoc -> SDoc
-- ^ Join two 'SDoc' together vertically
497

Thomas Schilling's avatar
Thomas Schilling committed
498 499 500 501 502
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)
503

batterseapower's avatar
batterseapower committed
504 505 506 507 508 509 510 511 512 513 514 515 516 517 518
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 '<+>'
519 520


Thomas Schilling's avatar
Thomas Schilling committed
521 522 523 524 525 526 527
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]
528

batterseapower's avatar
batterseapower committed
529 530 531 532
hang :: SDoc  -- ^ The header
      -> Int  -- ^ Amount to indent the hung body
      -> SDoc -- ^ The hung body, indented and placed below the header
      -> SDoc
Thomas Schilling's avatar
Thomas Schilling committed
533
hang d1 n d2   = SDoc $ \sty -> Pretty.hang (runSDoc d1 sty) n (runSDoc d2 sty)
534

batterseapower's avatar
batterseapower committed
535 536 537
punctuate :: SDoc   -- ^ The punctuation
          -> [SDoc] -- ^ The list that will have punctuation added between every adjacent pair of elements
          -> [SDoc] -- ^ Punctuated list
538
punctuate _ []     = []
539
punctuate p (d:ds) = go d ds
dterei's avatar
dterei committed
540 541 542
                   where
                     go d [] = [d]
                     go d (e:es) = (d <> p) : go e es
543 544 545 546 547 548 549

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

ppUnless True  _   = empty
ppUnless False doc = doc
550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565

-- | 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
Thomas Schilling's avatar
Thomas Schilling committed
566
colDataCon = PprColour "\27[31m"
567

Thomas Schilling's avatar
Thomas Schilling committed
568 569
colBinder :: PprColour
colBinder = PprColour "\27[32m"
570 571 572 573 574 575 576 577 578

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
Thomas Schilling's avatar
Thomas Schilling committed
579 580 581 582
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
583 584 585 586 587 588 589

bold :: SDoc -> SDoc
bold = coloured colBold

keyword :: SDoc -> SDoc
keyword = bold

590
\end{code}
sof's avatar
sof committed
591

sof's avatar
sof committed
592 593

%************************************************************************
dterei's avatar
dterei committed
594
%*                                                                      *
sof's avatar
sof committed
595
\subsection[Outputable-class]{The @Outputable@ class}
dterei's avatar
dterei committed
596
%*                                                                      *
sof's avatar
sof committed
597 598 599
%************************************************************************

\begin{code}
batterseapower's avatar
batterseapower committed
600
-- | Class designating that some type has an 'SDoc' representation
sof's avatar
sof committed
601
class Outputable a where
dterei's avatar
dterei committed
602 603 604 605 606
        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
Simon Peyton Jones's avatar
Simon Peyton Jones committed
607

dterei's avatar
dterei committed
608 609
        ppr = pprPrec 0
        pprPrec _ = ppr
sof's avatar
sof committed
610 611
\end{code}

612 613
\begin{code}
instance Outputable Bool where
Ian Lynagh's avatar
Ian Lynagh committed
614 615
    ppr True  = ptext (sLit "True")
    ppr False = ptext (sLit "False")
616

sof's avatar
sof committed
617
instance Outputable Int where
618
   ppr n = int n
sof's avatar
sof committed
619

620 621 622
instance Outputable Word16 where
   ppr n = integer $ fromIntegral n

623 624 625
instance Outputable Word32 where
   ppr n = integer $ fromIntegral n

626 627 628
instance Outputable Word where
   ppr n = integer $ fromIntegral n

629 630 631
instance Outputable () where
   ppr _ = text "()"

632
instance (Outputable a) => Outputable [a] where
633
    ppr xs = brackets (fsep (punctuate comma (map ppr xs)))
634

635 636 637
instance (Outputable a) => Outputable (Set a) where
    ppr s = braces (fsep (punctuate comma (map ppr (Set.toList s))))

638
instance (Outputable a, Outputable b) => Outputable (a, b) where
639
    ppr (x,y) = parens (sep [ppr x <> comma, ppr y])
640

641
instance Outputable a => Outputable (Maybe a) where
Ian Lynagh's avatar
Ian Lynagh committed
642 643
  ppr Nothing = ptext (sLit "Nothing")
  ppr (Just x) = ptext (sLit "Just") <+> ppr x
644

645
instance (Outputable a, Outputable b) => Outputable (Either a b) where
Ian Lynagh's avatar
Ian Lynagh committed
646 647
  ppr (Left x)  = ptext (sLit "Left")  <+> ppr x
  ppr (Right y) = ptext (sLit "Right") <+> ppr y
648

649 650
-- ToDo: may not be used
instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c) where
651
    ppr (x,y,z) =
652
      parens (sep [ppr x <> comma,
dterei's avatar
dterei committed
653 654
                   ppr y <> comma,
                   ppr z ])
655

656
instance (Outputable a, Outputable b, Outputable c, Outputable d) =>
dterei's avatar
dterei committed
657
         Outputable (a, b, c, d) where
658 659
    ppr (a,b,c,d) =
      parens (sep [ppr a <> comma,
dterei's avatar
dterei committed
660 661 662
                   ppr b <> comma,
                   ppr c <> comma,
                   ppr d])
663 664

instance (Outputable a, Outputable b, Outputable c, Outputable d, Outputable e) =>
dterei's avatar
dterei committed
665
         Outputable (a, b, c, d, e) where
666 667
    ppr (a,b,c,d,e) =
      parens (sep [ppr a <> comma,
dterei's avatar
dterei committed
668 669 670 671
                   ppr b <> comma,
                   ppr c <> comma,
                   ppr d <> comma,
                   ppr e])
672

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

instance (Outputable a, Outputable b, Outputable c, Outputable d, Outputable e, Outputable f, Outputable g) =>
dterei's avatar
dterei committed
684
         Outputable (a, b, c, d, e, f, g) where
685 686
    ppr (a,b,c,d,e,f,g) =
      parens (sep [ppr a <> comma,
dterei's avatar
dterei committed
687 688 689 690 691 692
                   ppr b <> comma,
                   ppr c <> comma,
                   ppr d <> comma,
                   ppr e <> comma,
                   ppr f <> comma,
                   ppr g])
693

694
instance Outputable FastString where
dterei's avatar
dterei committed
695 696
    ppr fs = ftext fs           -- Prints an unadorned string,
                                -- no double quotes or anything
697

698
instance (Outputable key, Outputable elt) => Outputable (M.Map key elt) where
699
    ppr m = ppr (M.toList m)
700 701
instance (Outputable elt) => Outputable (IM.IntMap elt) where
    ppr m = ppr (IM.toList m)
702 703 704
\end{code}

%************************************************************************
dterei's avatar
dterei committed
705
%*                                                                      *
706
\subsection{The @OutputableBndr@ class}
dterei's avatar
dterei committed
707
%*                                                                      *
708 709 710
%************************************************************************

\begin{code}
batterseapower's avatar
batterseapower committed
711 712 713
-- | '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.
714 715
data BindingSite = LambdaBind | CaseBind | LetBind

batterseapower's avatar
batterseapower committed
716 717
-- | When we print a binder, we often want to print its type too.
-- The @OutputableBndr@ class encapsulates this idea.
718 719
class Outputable a => OutputableBndr a where
   pprBndr :: BindingSite -> a -> SDoc
720
   pprBndr _b x = ppr x
721 722 723 724 725

   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)
726 727 728
\end{code}

%************************************************************************
dterei's avatar
dterei committed
729
%*                                                                      *
730
\subsection{Random printing helpers}
dterei's avatar
dterei committed
731
%*                                                                      *
732 733 734
%************************************************************************

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

-- | Special combinator for showing character literals.
738 739 740
pprHsChar :: Char -> SDoc
pprHsChar c | c > '\x10ffff' = char '\\' <> text (show (fromIntegral (ord c) :: Word32))
            | otherwise      = text (show c)
741

batterseapower's avatar
batterseapower committed
742
-- | Special combinator for showing string literals.
743
pprHsString :: FastString -> SDoc
744
pprHsString fs = vcat (map text (showMultiLineString (unpackFS fs)))
745 746 747 748 749 750

---------------------
-- 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
751
  | otherwise   = pp_v
752 753 754

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

---------------------
760 761
pprFastFilePath :: FastString -> SDoc
pprFastFilePath path = text $ normalise $ unpackFS path
sof's avatar
sof committed
762 763
\end{code}

sof's avatar
sof committed
764
%************************************************************************
dterei's avatar
dterei committed
765
%*                                                                      *
sof's avatar
sof committed
766
\subsection{Other helper functions}
dterei's avatar
dterei committed
767
%*                                                                      *
sof's avatar
sof committed
768 769 770
%************************************************************************

\begin{code}
batterseapower's avatar
batterseapower committed
771 772 773 774
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.
775
pprWithCommas pp xs = fsep (punctuate comma (map pp xs))
776

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

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

batterseapower's avatar
batterseapower committed
785 786 787
-- | Returns the comma-seperated concatenation of the quoted pretty printed things.
--
-- > [x,y,z]  ==>  `x', `y', `z'
788
pprQuotedList :: Outputable a => [a] -> SDoc
789 790 791 792 793 794 795 796 797
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
798 799 800 801
\end{code}


%************************************************************************
dterei's avatar
dterei committed
802
%*                                                                      *
sof's avatar
sof committed
803
\subsection{Printing numbers verbally}
dterei's avatar
dterei committed
804
%*                                                                      *
sof's avatar
sof committed
805
%************************************************************************
sof's avatar
sof committed
806 807

\begin{code}
808 809 810 811 812 813 814 815 816
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
817 818 819 820 821
-- | Converts an integer to a verbal index:
--
-- > speakNth 1 = text "first"
-- > speakNth 5 = text "fifth"
-- > speakNth 21 = text "21st"
822
speakNth :: Int -> SDoc
Ian Lynagh's avatar
Ian Lynagh committed
823 824 825 826 827 828
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")
829
speakNth n = hcat [ int n, text suffix ]
sof's avatar
sof committed
830
  where
dterei's avatar
dterei committed
831 832 833 834 835
    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
836

837
    last_dig = n `rem` 10
838

batterseapower's avatar
batterseapower committed