Outputable.hs 39.9 KB
Newer Older
1
{-# LANGUAGE CPP, ImplicitParams #-}
Austin Seipp's avatar
Austin Seipp committed
2 3 4 5
{-
(c) The University of Glasgow 2006-2012
(c) The GRASP Project, Glasgow University, 1992-1998
-}
6

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
        SDoc, runSDoc, initSDocContext,
        docToSDoc,
20 21
        interppSP, interpp'SP,
        pprQuotedList, pprWithCommas, quotedListWithOr, quotedListWithNor,
22
        empty, isEmpty, nest,
dterei's avatar
dterei committed
23
        char,
Ian Lynagh's avatar
Ian Lynagh committed
24
        text, ftext, ptext, ztext,
25
        int, intWithCommas, integer, float, double, rational,
26
        parens, cparen, brackets, braces, quotes, quote,
27
        doubleQuotes, angleBrackets, paBrackets,
28
        semi, comma, colon, dcolon, space, equals, dot, vbar,
29
        arrow, larrow, darrow, arrowt, larrowt, arrowtt, larrowtt,
dterei's avatar
dterei committed
30
        lparen, rparen, lbrack, rbrack, lbrace, rbrace, underscore,
31
        blankLine, forAllLit,
dterei's avatar
dterei committed
32 33 34 35
        (<>), (<+>), hcat, hsep,
        ($$), ($+$), vcat,
        sep, cat,
        fsep, fcat,
36
        hang, hangNotEmpty, punctuate, ppWhen, ppUnless,
37
        speakNth, speakN, speakNOf, plural, isOrAre, doOrDoes,
38
        unicodeSyntax,
39

40
        coloured, PprColour, colType, colCoerc, colDataCon,
Thomas Schilling's avatar
Thomas Schilling committed
41
        colBinder, bold, keyword,
42

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

dterei's avatar
dterei committed
51
        pprInfixVar, pprPrefixVar,
52
        pprHsChar, pprHsString, pprHsBytes,
53 54 55 56

        primFloatSuffix, primDoubleSuffix,
        pprPrimChar, pprPrimInt, pprPrimWord, pprPrimInt64, pprPrimWord64,

57
        pprFastFilePath,
58

batterseapower's avatar
batterseapower committed
59
        -- * Controlling the style in which output is printed
dterei's avatar
dterei committed
60
        BindingSite(..),
batterseapower's avatar
batterseapower committed
61

62 63 64
        PprStyle, CodeStyle(..), PrintUnqualified(..),
        QueryQualifyName, QueryQualifyModule, QueryQualifyPackage,
        reallyAlwaysQualify, reallyAlwaysQualifyNames,
65 66
        alwaysQualify, alwaysQualifyNames, alwaysQualifyModules,
        neverQualify, neverQualifyNames, neverQualifyModules,
67
        alwaysQualifyPackages, neverQualifyPackages,
68
        QualifyName(..), queryQual,
Ian Lynagh's avatar
Ian Lynagh committed
69
        sdocWithDynFlags, sdocWithPlatform,
dterei's avatar
dterei committed
70 71 72
        getPprStyle, withPprStyle, withPprStyleDoc,
        pprDeeper, pprDeeperList, pprSetDepth,
        codeStyle, userStyle, debugStyle, dumpStyle, asmStyle,
73
        ifPprDebug, qualName, qualModule, qualPackage,
74
        mkErrStyle, defaultErrStyle, defaultDumpStyle, mkDumpStyle, defaultUserStyle,
75
        mkUserStyle, cmdlineParserStyle, Depth(..),
dterei's avatar
dterei committed
76 77

        -- * Error handling and debugging utilities
78
        pprPanic, pprSorry, assertPprPanic, pprPgmError,
79
        pprTrace, pprTraceIt, warnPprTrace, pprSTrace,
80
        trace, pgmError, panic, sorry, assertPanic,
Ian Lynagh's avatar
Ian Lynagh committed
81
        pprDebugAndThen,
82 83
    ) where

84
import {-# SOURCE #-}   DynFlags( DynFlags,
85
                                  targetPlatform, pprUserLength, pprCols,
86
                                  useUnicode, useUnicodeSyntax,
87
                                  unsafeGlobalDynFlags )
88
import {-# SOURCE #-}   Module( UnitId, Module, ModuleName, moduleName )
89
import {-# SOURCE #-}   OccName( OccName )
90
import {-# SOURCE #-}   StaticFlags( opt_PprStyle_Debug, opt_NoDebugOutput )
91

dterei's avatar
dterei committed
92
import FastString
93
import qualified Pretty
94
import Util
Ian Lynagh's avatar
Ian Lynagh committed
95
import Platform
dterei's avatar
dterei committed
96
import Pretty           ( Doc, Mode(..) )
97
import Panic
98
import GHC.Serialized
Oleg Grenrus's avatar
Oleg Grenrus committed
99
import GHC.LanguageExtensions (Extension)
100

101
import Data.ByteString (ByteString)
102
import qualified Data.ByteString as BS
Ian Lynagh's avatar
Ian Lynagh committed
103
import Data.Char
104
import qualified Data.Map as M
105
import Data.Int
106
import qualified Data.IntMap as IM
107 108
import Data.Set (Set)
import qualified Data.Set as Set
109
import Data.String
110
import Data.Word
111
import System.IO        ( Handle )
112
import System.FilePath
113
import Text.Printf
114
import Data.Graph (SCC(..))
115

116
import GHC.Fingerprint
117
import GHC.Show         ( showMultiLineString )
Ben Gamari's avatar
Ben Gamari committed
118
#if __GLASGOW_HASKELL__ > 710
119
import GHC.Stack
Ben Gamari's avatar
Ben Gamari committed
120
#endif
121

Austin Seipp's avatar
Austin Seipp committed
122 123 124
{-
************************************************************************
*                                                                      *
sof's avatar
sof committed
125
\subsection{The @PprStyle@ data type}
Austin Seipp's avatar
Austin Seipp committed
126 127 128
*                                                                      *
************************************************************************
-}
129

sof's avatar
sof committed
130
data PprStyle
131
  = PprUser PrintUnqualified Depth
dterei's avatar
dterei committed
132 133 134 135 136
                -- 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
137

138 139
  | PprDump PrintUnqualified
                -- For -ddump-foo; less verbose than PprDebug, but more than PprUser
dterei's avatar
dterei committed
140 141
                -- Does not assume tidied code: non-external names
                -- are printed with uniques.
142

dterei's avatar
dterei committed
143
  | PprDebug    -- Full debugging output
144

145 146 147
  | PprCode CodeStyle
                -- Print code; either C or assembler

dterei's avatar
dterei committed
148 149
data CodeStyle = CStyle         -- The format of labels differs for C and assembler
               | AsmStyle
150 151

data Depth = AllTheWay
dterei's avatar
dterei committed
152
           | PartWay Int        -- 0 => stop
153 154


Simon Marlow's avatar
Simon Marlow committed
155 156
-- -----------------------------------------------------------------------------
-- Printing original names
157

158
-- | When printing code that contains original names, we need to map the
Simon Marlow's avatar
Simon Marlow committed
159
-- original names back to something the user understands.  This is the
160
-- purpose of the triple of functions that gets passed around
Simon Marlow's avatar
Simon Marlow committed
161
-- when rendering 'SDoc'.
162 163 164 165 166
data PrintUnqualified = QueryQualify {
    queryQualifyName    :: QueryQualifyName,
    queryQualifyModule  :: QueryQualifyModule,
    queryQualifyPackage :: QueryQualifyPackage
}
167

Simon Marlow's avatar
Simon Marlow committed
168 169 170
-- | 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
Gabor Greif's avatar
Gabor Greif committed
171
-- as @Exception.catch@, this function will return @Just "Exception"@.
Simon Marlow's avatar
Simon Marlow committed
172 173
-- Note that the return value is a ModuleName, not a Module, because
-- in source code, names are qualified by ModuleNames.
174 175 176 177 178 179
type QueryQualifyName = Module -> OccName -> QualifyName

-- | For a given module, we need to know whether to print it with
-- a package name to disambiguate it.
type QueryQualifyModule = Module -> Bool

180
-- | For a given package, we need to know whether to print it with
181 182
-- the unit id to disambiguate it.
type QueryQualifyPackage = UnitId -> Bool
183

184
-- See Note [Printing original names] in HscTypes
185 186 187 188 189 190 191 192 193 194 195
data QualifyName   -- Given P:M.T
  = NameUnqual           -- It's in scope unqualified as "T"
                         -- OR nothing called "T" is in scope

  | NameQual ModuleName  -- It's in scope qualified as "X.T"

  | NameNotInScope1      -- It's 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's 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"
196

197 198 199 200
reallyAlwaysQualifyNames :: QueryQualifyName
reallyAlwaysQualifyNames _ _ = NameNotInScope2

-- | NB: This won't ever show package IDs
201
alwaysQualifyNames :: QueryQualifyName
202
alwaysQualifyNames m _ = NameQual (moduleName m)
Simon Marlow's avatar
Simon Marlow committed
203

204
neverQualifyNames :: QueryQualifyName
205
neverQualifyNames _ _ = NameUnqual
Simon Marlow's avatar
Simon Marlow committed
206

207
alwaysQualifyModules :: QueryQualifyModule
208
alwaysQualifyModules _ = True
Simon Marlow's avatar
Simon Marlow committed
209

210
neverQualifyModules :: QueryQualifyModule
211 212
neverQualifyModules _ = False

213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229
alwaysQualifyPackages :: QueryQualifyPackage
alwaysQualifyPackages _ = True

neverQualifyPackages :: QueryQualifyPackage
neverQualifyPackages _ = False

reallyAlwaysQualify, alwaysQualify, neverQualify :: PrintUnqualified
reallyAlwaysQualify
              = QueryQualify reallyAlwaysQualifyNames
                             alwaysQualifyModules
                             alwaysQualifyPackages
alwaysQualify = QueryQualify alwaysQualifyNames
                             alwaysQualifyModules
                             alwaysQualifyPackages
neverQualify  = QueryQualify neverQualifyNames
                             neverQualifyModules
                             neverQualifyPackages
230

231 232
defaultUserStyle, defaultDumpStyle :: PprStyle

233 234
defaultUserStyle = mkUserStyle neverQualify AllTheWay
 -- Print without qualifiers to reduce verbosity, unless -dppr-debug
235

236
defaultDumpStyle |  opt_PprStyle_Debug = PprDebug
237 238 239 240 241
                 |  otherwise          = PprDump neverQualify

mkDumpStyle :: PrintUnqualified -> PprStyle
mkDumpStyle print_unqual | opt_PprStyle_Debug = PprDebug
                         | otherwise          = PprDump print_unqual
242

243 244 245 246 247 248 249
defaultErrStyle :: DynFlags -> PprStyle
-- Default style for error messages, when we don't know PrintUnqualified
-- 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
-- NB that -dppr-debug will still get into PprDebug style
defaultErrStyle dflags = mkErrStyle dflags neverQualify

Simon Marlow's avatar
Simon Marlow committed
250
-- | Style for printing error messages
251 252
mkErrStyle :: DynFlags -> PrintUnqualified -> PprStyle
mkErrStyle dflags qual = mkUserStyle qual (PartWay (pprUserLength dflags))
253

254 255
cmdlineParserStyle :: PprStyle
cmdlineParserStyle = mkUserStyle alwaysQualify AllTheWay
256

257
mkUserStyle :: PrintUnqualified -> Depth -> PprStyle
Simon Marlow's avatar
Simon Marlow committed
258 259 260
mkUserStyle unqual depth
   | opt_PprStyle_Debug = PprDebug
   | otherwise          = PprUser unqual depth
261

262 263 264 265 266 267
instance Outputable PprStyle where
  ppr (PprUser {})  = text "user-style"
  ppr (PprCode {})  = text "code-style"
  ppr (PprDump {})  = text "dump-style"
  ppr (PprDebug {}) = text "debug-style"

Austin Seipp's avatar
Austin Seipp committed
268
{-
sof's avatar
sof committed
269 270 271 272
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
273

sof's avatar
sof committed
274 275
The following test decides whether or not we are actually generating
code (either C or assembly), or generating interface files.
276

Austin Seipp's avatar
Austin Seipp committed
277 278
************************************************************************
*                                                                      *
279
\subsection{The @SDoc@ data type}
Austin Seipp's avatar
Austin Seipp committed
280 281 282
*                                                                      *
************************************************************************
-}
283

Thomas Schilling's avatar
Thomas Schilling committed
284
newtype SDoc = SDoc { runSDoc :: SDocContext -> Doc }
285 286 287 288 289

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

293 294 295
instance IsString SDoc where
  fromString = text

Ian Lynagh's avatar
Ian Lynagh committed
296 297
initSDocContext :: DynFlags -> PprStyle -> SDocContext
initSDocContext dflags sty = SDC
298 299
  { sdocStyle = sty
  , sdocLastColour = colReset
Ian Lynagh's avatar
Ian Lynagh committed
300
  , sdocDynFlags = dflags
301
  }
302 303

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

Ian Lynagh's avatar
Ian Lynagh committed
306 307
withPprStyleDoc :: DynFlags -> PprStyle -> SDoc -> Doc
withPprStyleDoc dflags sty d = runSDoc d (initSDocContext dflags sty)
308

309
pprDeeper :: SDoc -> SDoc
Thomas Schilling's avatar
Thomas Schilling committed
310 311 312 313 314
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
315

316
-- | Truncate a list that is longer than the current depth.
317
pprDeeperList :: ([SDoc] -> SDoc) -> [SDoc] -> SDoc
Austin Seipp's avatar
Austin Seipp committed
318
pprDeeperList f ds
319 320
  | null ds   = f []
  | otherwise = SDoc work
Thomas Schilling's avatar
Thomas Schilling committed
321 322 323 324 325 326 327 328 329 330
 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
331

332
pprSetDepth :: Depth -> SDoc -> SDoc
dterei's avatar
dterei committed
333 334 335 336 337 338
pprSetDepth depth doc = SDoc $ \ctx ->
    case ctx of
        SDC{sdocStyle=PprUser q _} ->
            runSDoc doc ctx{sdocStyle = PprUser q depth}
        _ ->
            runSDoc doc ctx
339

340
getPprStyle :: (PprStyle -> SDoc) -> SDoc
Thomas Schilling's avatar
Thomas Schilling committed
341
getPprStyle df = SDoc $ \ctx -> runSDoc (df (sdocStyle ctx)) ctx
Ian Lynagh's avatar
Ian Lynagh committed
342 343 344 345 346 347

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

sdocWithPlatform :: (Platform -> SDoc) -> SDoc
sdocWithPlatform f = sdocWithDynFlags (f . targetPlatform)
348

349
qualName :: PprStyle -> QueryQualifyName
350
qualName (PprUser q _)  mod occ = queryQualifyName q mod occ
351
qualName (PprDump q)    mod occ = queryQualifyName q mod occ
352
qualName _other         mod _   = NameQual (moduleName mod)
Simon Marlow's avatar
Simon Marlow committed
353

354
qualModule :: PprStyle -> QueryQualifyModule
355
qualModule (PprUser q _)  m = queryQualifyModule q m
356 357
qualModule (PprDump q)    m = queryQualifyModule q m
qualModule _other        _m = True
358

359 360
qualPackage :: PprStyle -> QueryQualifyPackage
qualPackage (PprUser q _)  m = queryQualifyPackage q m
361 362
qualPackage (PprDump q)    m = queryQualifyPackage q m
qualPackage _other        _m = True
363 364 365 366 367 368

queryQual :: PprStyle -> PrintUnqualified
queryQual s = QueryQualify (qualName s)
                           (qualModule s)
                           (qualPackage s)

sof's avatar
sof committed
369
codeStyle :: PprStyle -> Bool
dterei's avatar
dterei committed
370 371
codeStyle (PprCode _)     = True
codeStyle _               = False
sof's avatar
sof committed
372

373 374
asmStyle :: PprStyle -> Bool
asmStyle (PprCode AsmStyle)  = True
375
asmStyle _other              = False
376

377
dumpStyle :: PprStyle -> Bool
378 379
dumpStyle (PprDump {}) = True
dumpStyle _other       = False
380

381
debugStyle :: PprStyle -> Bool
dterei's avatar
dterei committed
382 383
debugStyle PprDebug = True
debugStyle _other   = False
384

sof's avatar
sof committed
385
userStyle ::  PprStyle -> Bool
386
userStyle (PprUser _ _) = True
387
userStyle _other        = False
sof's avatar
sof committed
388

dterei's avatar
dterei committed
389 390 391 392 393
ifPprDebug :: SDoc -> SDoc        -- Empty for non-debug style
ifPprDebug d = SDoc $ \ctx ->
    case ctx of
        SDC{sdocStyle=PprDebug} -> runSDoc d ctx
        _                       -> Pretty.empty
394

395
printForUser :: DynFlags -> Handle -> PrintUnqualified -> SDoc -> IO ()
Ian Lynagh's avatar
Ian Lynagh committed
396
printForUser dflags handle unqual doc
Ian Lynagh's avatar
Ian Lynagh committed
397
  = Pretty.printDoc PageMode (pprCols dflags) handle
Ian Lynagh's avatar
Ian Lynagh committed
398
      (runSDoc doc (initSDocContext dflags (mkUserStyle unqual AllTheWay)))
399

400 401
printForUserPartWay :: DynFlags -> Handle -> Int -> PrintUnqualified -> SDoc
                    -> IO ()
Ian Lynagh's avatar
Ian Lynagh committed
402
printForUserPartWay dflags handle d unqual doc
Ian Lynagh's avatar
Ian Lynagh committed
403
  = Pretty.printDoc PageMode (pprCols dflags) handle
Ian Lynagh's avatar
Ian Lynagh committed
404
      (runSDoc doc (initSDocContext dflags (mkUserStyle unqual (PartWay d))))
405

406
-- printForC, printForAsm do what they sound like
407
printForC :: DynFlags -> Handle -> SDoc -> IO ()
Ian Lynagh's avatar
Ian Lynagh committed
408
printForC dflags handle doc =
Ian Lynagh's avatar
Ian Lynagh committed
409
  Pretty.printDoc LeftMode (pprCols dflags) handle
Ian Lynagh's avatar
Ian Lynagh committed
410
    (runSDoc doc (initSDocContext dflags (PprCode CStyle)))
411

412
printForAsm :: DynFlags -> Handle -> SDoc -> IO ()
Ian Lynagh's avatar
Ian Lynagh committed
413
printForAsm dflags handle doc =
Ian Lynagh's avatar
Ian Lynagh committed
414
  Pretty.printDoc LeftMode (pprCols dflags) handle
Ian Lynagh's avatar
Ian Lynagh committed
415
    (runSDoc doc (initSDocContext dflags (PprCode AsmStyle)))
416

sof's avatar
sof committed
417 418
pprCode :: CodeStyle -> SDoc -> SDoc
pprCode cs d = withPprStyle (PprCode cs) d
419

420 421 422
mkCodeStyle :: CodeStyle -> PprStyle
mkCodeStyle = PprCode

423 424
-- Can't make SDoc an instance of Show because SDoc is just a function type
-- However, Doc *is* an instance of Show
425
-- showSDoc just blasts it out as a string
Ian Lynagh's avatar
Ian Lynagh committed
426
showSDoc :: DynFlags -> SDoc -> String
427
showSDoc dflags sdoc = renderWithStyle dflags sdoc defaultUserStyle
428

429 430 431 432
-- showSDocUnsafe is unsafe, because `unsafeGlobalDynFlags` might not be
-- initialised yet.
showSDocUnsafe :: SDoc -> String
showSDocUnsafe sdoc = showSDoc unsafeGlobalDynFlags sdoc
433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451

showPpr :: Outputable a => DynFlags -> a -> String
showPpr dflags thing = showSDoc dflags (ppr thing)

showSDocUnqual :: DynFlags -> SDoc -> String
-- Only used by Haddock
showSDocUnqual dflags sdoc = showSDoc dflags sdoc

showSDocForUser :: DynFlags -> PrintUnqualified -> SDoc -> String
-- Allows caller to specify the PrintUnqualified to use
showSDocForUser dflags unqual doc
 = renderWithStyle dflags doc (mkUserStyle unqual AllTheWay)

showSDocDump :: DynFlags -> SDoc -> String
showSDocDump dflags d = renderWithStyle dflags d defaultDumpStyle

showSDocDebug :: DynFlags -> SDoc -> String
showSDocDebug dflags d = renderWithStyle dflags d PprDebug

Ian Lynagh's avatar
Ian Lynagh committed
452
renderWithStyle :: DynFlags -> SDoc -> PprStyle -> String
453
renderWithStyle dflags sdoc sty
454 455 456
  = let s = Pretty.style{ Pretty.mode = PageMode,
                          Pretty.lineLength = pprCols dflags }
    in Pretty.renderStyle s $ runSDoc sdoc (initSDocContext dflags sty)
457

458 459 460
-- 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.
461
showSDocOneLine :: DynFlags -> SDoc -> String
Ian Lynagh's avatar
Ian Lynagh committed
462
showSDocOneLine dflags d
463 464 465
 = let s = Pretty.style{ Pretty.mode = OneLineMode,
                         Pretty.lineLength = pprCols dflags } in
   Pretty.renderStyle s $ runSDoc d (initSDocContext dflags defaultUserStyle)
466

467
showSDocDumpOneLine :: DynFlags -> SDoc -> String
Ian Lynagh's avatar
Ian Lynagh committed
468
showSDocDumpOneLine dflags d
469 470 471
 = let s = Pretty.style{ Pretty.mode = OneLineMode,
                         Pretty.lineLength = irrelevantNCols } in
   Pretty.renderStyle s $ runSDoc d (initSDocContext dflags defaultDumpStyle)
472 473 474 475

irrelevantNCols :: Int
-- Used for OneLineMode and LeftMode when number of cols isn't used
irrelevantNCols = 1
476

477 478 479 480
isEmpty :: DynFlags -> SDoc -> Bool
isEmpty dflags sdoc = Pretty.isEmpty $ runSDoc sdoc dummySDocContext
   where dummySDocContext = initSDocContext dflags PprDebug

481
docToSDoc :: Doc -> SDoc
Thomas Schilling's avatar
Thomas Schilling committed
482
docToSDoc d = SDoc (\_ -> d)
483

484 485
empty    :: SDoc
char     :: Char       -> SDoc
batterseapower's avatar
batterseapower committed
486
text     :: String     -> SDoc
487
ftext    :: FastString -> SDoc
488
ptext    :: LitString  -> SDoc
Ian Lynagh's avatar
Ian Lynagh committed
489
ztext    :: FastZString -> SDoc
490 491 492 493 494 495
int      :: Int        -> SDoc
integer  :: Integer    -> SDoc
float    :: Float      -> SDoc
double   :: Double     -> SDoc
rational :: Rational   -> SDoc

Thomas Schilling's avatar
Thomas Schilling committed
496 497
empty       = docToSDoc $ Pretty.empty
char c      = docToSDoc $ Pretty.char c
498

Thomas Schilling's avatar
Thomas Schilling committed
499
text s      = docToSDoc $ Pretty.text s
500 501
{-# INLINE text #-}   -- Inline so that the RULE Pretty.text will fire

Thomas Schilling's avatar
Thomas Schilling committed
502 503
ftext s     = docToSDoc $ Pretty.ftext s
ptext s     = docToSDoc $ Pretty.ptext s
Ian Lynagh's avatar
Ian Lynagh committed
504
ztext s     = docToSDoc $ Pretty.ztext s
Thomas Schilling's avatar
Thomas Schilling committed
505 506 507 508 509
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
510

Austin Seipp's avatar
Austin Seipp committed
511
parens, braces, brackets, quotes, quote,
512
        paBrackets, doubleQuotes, angleBrackets :: SDoc -> SDoc
513

514 515 516 517 518
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
519
angleBrackets d = char '<' <> d <> char '>'
520
paBrackets d    = text "[:" <> d <> text ":]"
521

522
cparen :: Bool -> SDoc -> SDoc
523
cparen b d = SDoc $ Pretty.maybeParens b . runSDoc d
mnislaih's avatar
mnislaih committed
524

525
-- 'quotes' encloses something in single quotes...
526
-- but it omits them if the thing begins or ends in a single quote
527
-- so that we don't get `foo''.  Instead we just have foo'.
528 529
quotes d =
      sdocWithDynFlags $ \dflags ->
530
      if useUnicode dflags
531
      then char '‘' <> d <> char '’'
532
      else SDoc $ \sty ->
533 534 535 536 537 538
           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
539

540
semi, comma, colon, equals, space, dcolon, underscore, dot, vbar :: SDoc
541 542
arrow, larrow, darrow, arrowt, larrowt, arrowtt, larrowtt :: SDoc
lparen, rparen, lbrack, rbrack, lbrace, rbrace, blankLine :: SDoc
543

544 545 546 547 548 549 550 551 552
blankLine  = docToSDoc $ Pretty.text ""
dcolon     = unicodeSyntax (char '∷') (docToSDoc $ Pretty.text "::")
arrow      = unicodeSyntax (char '→') (docToSDoc $ Pretty.text "->")
larrow     = unicodeSyntax (char '←') (docToSDoc $ Pretty.text "<-")
darrow     = unicodeSyntax (char '⇒') (docToSDoc $ Pretty.text "=>")
arrowt     = unicodeSyntax (char '⤚') (docToSDoc $ Pretty.text ">-")
larrowt    = unicodeSyntax (char '⤙') (docToSDoc $ Pretty.text "-<")
arrowtt    = unicodeSyntax (char '⤜') (docToSDoc $ Pretty.text ">>-")
larrowtt   = unicodeSyntax (char '⤛') (docToSDoc $ Pretty.text "-<<")
Thomas Schilling's avatar
Thomas Schilling committed
553 554 555 556 557 558 559
semi       = docToSDoc $ Pretty.semi
comma      = docToSDoc $ Pretty.comma
colon      = docToSDoc $ Pretty.colon
equals     = docToSDoc $ Pretty.equals
space      = docToSDoc $ Pretty.space
underscore = char '_'
dot        = char '.'
560
vbar       = char '|'
Thomas Schilling's avatar
Thomas Schilling committed
561 562 563 564 565 566
lparen     = docToSDoc $ Pretty.lparen
rparen     = docToSDoc $ Pretty.rparen
lbrack     = docToSDoc $ Pretty.lbrack
rbrack     = docToSDoc $ Pretty.rbrack
lbrace     = docToSDoc $ Pretty.lbrace
rbrace     = docToSDoc $ Pretty.rbrace
567

568
forAllLit :: SDoc
569
forAllLit = unicodeSyntax (char '∀') (text "forall")
570 571 572

unicodeSyntax :: SDoc -> SDoc -> SDoc
unicodeSyntax unicode plain = sdocWithDynFlags $ \dflags ->
573 574 575
    if useUnicode dflags && useUnicodeSyntax dflags
    then unicode
    else plain
576

577
nest :: Int -> SDoc -> SDoc
batterseapower's avatar
batterseapower committed
578 579 580 581 582 583
-- ^ 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
584
-- ^ Join two 'SDoc' together vertically; if there is
batterseapower's avatar
batterseapower committed
585 586 587
-- no vertical overlap it "dovetails" the two onto one line
($+$) :: SDoc -> SDoc -> SDoc
-- ^ Join two 'SDoc' together vertically
588

Thomas Schilling's avatar
Thomas Schilling committed
589 590 591 592 593
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)
594

batterseapower's avatar
batterseapower committed
595 596 597 598 599 600 601 602 603 604 605 606 607 608 609
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 '<+>'
610 611


Thomas Schilling's avatar
Thomas Schilling committed
612 613 614 615 616 617 618
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]
619

batterseapower's avatar
batterseapower committed
620 621 622 623
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
624
hang d1 n d2   = SDoc $ \sty -> Pretty.hang (runSDoc d1 sty) n (runSDoc d2 sty)
625

626 627 628 629 630 631
-- | This behaves like 'hang', but does not indent the second document
-- when the header is empty.
hangNotEmpty :: SDoc -> Int -> SDoc -> SDoc
hangNotEmpty d1 n d2 =
    SDoc $ \sty -> Pretty.hangNotEmpty (runSDoc d1 sty) n (runSDoc d2 sty)

batterseapower's avatar
batterseapower committed
632 633 634
punctuate :: SDoc   -- ^ The punctuation
          -> [SDoc] -- ^ The list that will have punctuation added between every adjacent pair of elements
          -> [SDoc] -- ^ Punctuated list
635
punctuate _ []     = []
636
punctuate p (d:ds) = go d ds
dterei's avatar
dterei committed
637 638 639
                   where
                     go d [] = [d]
                     go d (e:es) = (d <> p) : go e es
640 641 642 643 644 645 646

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

ppUnless True  _   = empty
ppUnless False doc = doc
647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662

-- | 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
663
colDataCon = PprColour "\27[31m"
664

Thomas Schilling's avatar
Thomas Schilling committed
665 666
colBinder :: PprColour
colBinder = PprColour "\27[32m"
667 668 669 670 671 672 673 674 675

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
676 677 678 679
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
680 681 682 683 684 685 686

bold :: SDoc -> SDoc
bold = coloured colBold

keyword :: SDoc -> SDoc
keyword = bold

Austin Seipp's avatar
Austin Seipp committed
687 688 689
{-
************************************************************************
*                                                                      *
sof's avatar
sof committed
690
\subsection[Outputable-class]{The @Outputable@ class}
Austin Seipp's avatar
Austin Seipp committed
691 692 693
*                                                                      *
************************************************************************
-}
sof's avatar
sof committed
694

batterseapower's avatar
batterseapower committed
695
-- | Class designating that some type has an 'SDoc' representation
sof's avatar
sof committed
696
class Outputable a where
dterei's avatar
dterei committed
697 698 699 700 701
        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
702

dterei's avatar
dterei committed
703 704
        ppr = pprPrec 0
        pprPrec _ = ppr
sof's avatar
sof committed
705

706 707 708
instance Outputable Char where
    ppr c = text [c]

709
instance Outputable Bool where
710 711
    ppr True  = text "True"
    ppr False = text "False"
712

713 714 715 716 717
instance Outputable Ordering where
    ppr LT = text "LT"
    ppr EQ = text "EQ"
    ppr GT = text "GT"

718 719 720 721 722 723
instance Outputable Int32 where
   ppr n = integer $ fromIntegral n

instance Outputable Int64 where
   ppr n = integer $ fromIntegral n

sof's avatar
sof committed
724
instance Outputable Int where
725
    ppr n = int n
sof's avatar
sof committed
726

727
instance Outputable Word16 where
728
    ppr n = integer $ fromIntegral n
729

730
instance Outputable Word32 where
731
    ppr n = integer $ fromIntegral n
732

733
instance Outputable Word where
734
    ppr n = integer $ fromIntegral n
735

736
instance Outputable () where
737
    ppr _ = text "()"
738

739
instance (Outputable a) => Outputable [a] where
740
    ppr xs = brackets (fsep (punctuate comma (map ppr xs)))
741

742 743 744
instance (Outputable a) => Outputable (Set a) where
    ppr s = braces (fsep (punctuate comma (map ppr (Set.toList s))))

745
instance (Outputable a, Outputable b) => Outputable (a, b) where
746
    ppr (x,y) = parens (sep [ppr x <> comma, ppr y])
747

748
instance Outputable a => Outputable (Maybe a) where
749 750
    ppr Nothing  = text "Nothing"
    ppr (Just x) = text "Just" <+> ppr x
751

752
instance (Outputable a, Outputable b) => Outputable (Either a b) where
753 754
    ppr (Left x)  = text "Left"  <+> ppr x
    ppr (Right y) = text "Right" <+> ppr y
755

756 757
-- ToDo: may not be used
instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c) where
758
    ppr (x,y,z) =
759
      parens (sep [ppr x <> comma,
dterei's avatar
dterei committed
760 761
                   ppr y <> comma,
                   ppr z ])
762

763
instance (Outputable a, Outputable b, Outputable c, Outputable d) =>
dterei's avatar
dterei committed
764
         Outputable (a, b, c, d) where
765 766
    ppr (a,b,c,d) =
      parens (sep [ppr a <> comma,
dterei's avatar
dterei committed
767 768 769
                   ppr b <> comma,
                   ppr c <> comma,
                   ppr d])
770 771

instance (Outputable a, Outputable b, Outputable c, Outputable d, Outputable e) =>
dterei's avatar
dterei committed
772
         Outputable (a, b, c, d, e) where
773 774
    ppr (a,b,c,d,e) =
      parens (sep [ppr a <> comma,
dterei's avatar