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

41 42 43
        coloured, bold, keyword, PprColour, colReset, colBold, colBlackFg,
        colRedFg, colGreenFg, colYellowFg, colBlueFg, colMagentaFg, colCyanFg,
        colWhiteFg, colBinder, colCoerc, colDataCon, colType,
44

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

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

Alan Zimmerman's avatar
Alan Zimmerman committed
57 58 59
        primFloatSuffix, primCharSuffix, primWordSuffix, primDoubleSuffix,
        primInt64Suffix, primWord64Suffix, primIntSuffix,

60 61
        pprPrimChar, pprPrimInt, pprPrimWord, pprPrimInt64, pprPrimWord64,

62
        pprFastFilePath,
63

batterseapower's avatar
batterseapower committed
64
        -- * Controlling the style in which output is printed
dterei's avatar
dterei committed
65
        BindingSite(..),
batterseapower's avatar
batterseapower committed
66

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

        -- * Error handling and debugging utilities
83
        pprPanic, pprSorry, assertPprPanic, pprPgmError,
Sylvain Henry's avatar
Sylvain Henry committed
84
        pprTrace, pprTraceDebug, pprTraceIt, warnPprTrace, pprSTrace,
85
        trace, pgmError, panic, sorry, assertPanic,
Ben Gamari's avatar
Ben Gamari committed
86
        pprDebugAndThen, callStackDoc
87 88
    ) where

Sylvain Henry's avatar
Sylvain Henry committed
89
import {-# SOURCE #-}   DynFlags( DynFlags, hasPprDebug, hasNoDebugOutput,
90
                                  targetPlatform, pprUserLength, pprCols,
91
                                  useUnicode, useUnicodeSyntax,
92
                                  useColor, canUseColor, overrideWith,
93
                                  unsafeGlobalDynFlags )
94
import {-# SOURCE #-}   Module( UnitId, Module, ModuleName, moduleName )
95
import {-# SOURCE #-}   OccName( OccName )
96

97
import BufWrite (BufHandle)
dterei's avatar
dterei committed
98
import FastString
99
import qualified Pretty
100
import Util
Ian Lynagh's avatar
Ian Lynagh committed
101
import Platform
dterei's avatar
dterei committed
102
import Pretty           ( Doc, Mode(..) )
103
import Panic
104
import GHC.Serialized
Oleg Grenrus's avatar
Oleg Grenrus committed
105
import GHC.LanguageExtensions (Extension)
106

107
import Control.Exception (finally)
108
import Data.ByteString (ByteString)
109
import qualified Data.ByteString as BS
Ian Lynagh's avatar
Ian Lynagh committed
110
import Data.Char
111
import qualified Data.Map as M
112
import Data.Int
113
import qualified Data.IntMap as IM
114 115
import Data.Set (Set)
import qualified Data.Set as Set
116
import Data.Monoid (Monoid, mappend, mempty)
117
import Data.String
118
import Data.Word
119
import System.IO        ( Handle )
120
import System.FilePath
121
import Text.Printf
122
import Numeric (showFFloat)
123
import Data.Graph (SCC(..))
124
import Data.List (intersperse)
125

126
import GHC.Fingerprint
127
import GHC.Show         ( showMultiLineString )
128

Austin Seipp's avatar
Austin Seipp committed
129 130 131
{-
************************************************************************
*                                                                      *
sof's avatar
sof committed
132
\subsection{The @PprStyle@ data type}
Austin Seipp's avatar
Austin Seipp committed
133 134 135
*                                                                      *
************************************************************************
-}
136

sof's avatar
sof committed
137
data PprStyle
138
  = PprUser PrintUnqualified Depth Coloured
dterei's avatar
dterei committed
139 140 141 142 143
                -- 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
144

145 146
  | PprDump PrintUnqualified
                -- For -ddump-foo; less verbose than PprDebug, but more than PprUser
dterei's avatar
dterei committed
147 148
                -- Does not assume tidied code: non-external names
                -- are printed with uniques.
149

dterei's avatar
dterei committed
150
  | PprDebug    -- Full debugging output
151

152 153 154
  | PprCode CodeStyle
                -- Print code; either C or assembler

dterei's avatar
dterei committed
155 156
data CodeStyle = CStyle         -- The format of labels differs for C and assembler
               | AsmStyle
157 158

data Depth = AllTheWay
dterei's avatar
dterei committed
159
           | PartWay Int        -- 0 => stop
160

161 162 163
data Coloured
  = Uncoloured
  | Coloured
164

Simon Marlow's avatar
Simon Marlow committed
165 166
-- -----------------------------------------------------------------------------
-- Printing original names
167

168
-- | When printing code that contains original names, we need to map the
Simon Marlow's avatar
Simon Marlow committed
169
-- original names back to something the user understands.  This is the
170
-- purpose of the triple of functions that gets passed around
Simon Marlow's avatar
Simon Marlow committed
171
-- when rendering 'SDoc'.
172 173 174 175 176
data PrintUnqualified = QueryQualify {
    queryQualifyName    :: QueryQualifyName,
    queryQualifyModule  :: QueryQualifyModule,
    queryQualifyPackage :: QueryQualifyPackage
}
177

Simon Marlow's avatar
Simon Marlow committed
178 179 180
-- | 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
181
-- as @Exception.catch@, this function will return @Just "Exception"@.
Simon Marlow's avatar
Simon Marlow committed
182 183
-- Note that the return value is a ModuleName, not a Module, because
-- in source code, names are qualified by ModuleNames.
184 185 186 187 188 189
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

190
-- | For a given package, we need to know whether to print it with
Edward Z. Yang's avatar
Edward Z. Yang committed
191
-- the component id to disambiguate it.
192
type QueryQualifyPackage = UnitId -> Bool
193

194
-- See Note [Printing original names] in HscTypes
195 196 197 198 199 200 201 202 203 204 205
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"
206

Richard Eisenberg's avatar
Richard Eisenberg committed
207 208 209 210 211 212
instance Outputable QualifyName where
  ppr NameUnqual      = text "NameUnqual"
  ppr (NameQual _mod) = text "NameQual"  -- can't print the mod without module loops :(
  ppr NameNotInScope1 = text "NameNotInScope1"
  ppr NameNotInScope2 = text "NameNotInScope2"

213 214 215 216
reallyAlwaysQualifyNames :: QueryQualifyName
reallyAlwaysQualifyNames _ _ = NameNotInScope2

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

220
neverQualifyNames :: QueryQualifyName
221
neverQualifyNames _ _ = NameUnqual
Simon Marlow's avatar
Simon Marlow committed
222

223
alwaysQualifyModules :: QueryQualifyModule
224
alwaysQualifyModules _ = True
Simon Marlow's avatar
Simon Marlow committed
225

226
neverQualifyModules :: QueryQualifyModule
227 228
neverQualifyModules _ = False

229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245
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
246

Sylvain Henry's avatar
Sylvain Henry committed
247 248
defaultUserStyle :: DynFlags -> PprStyle
defaultUserStyle dflags = mkUserStyle dflags neverQualify AllTheWay
249

Sylvain Henry's avatar
Sylvain Henry committed
250
defaultDumpStyle :: DynFlags -> PprStyle
251
 -- Print without qualifiers to reduce verbosity, unless -dppr-debug
Sylvain Henry's avatar
Sylvain Henry committed
252 253 254
defaultDumpStyle dflags
   |  hasPprDebug dflags = PprDebug
   |  otherwise          = PprDump neverQualify
255

Sylvain Henry's avatar
Sylvain Henry committed
256 257 258 259
mkDumpStyle :: DynFlags -> PrintUnqualified -> PprStyle
mkDumpStyle dflags print_unqual
   | hasPprDebug dflags = PprDebug
   | otherwise          = PprDump print_unqual
260

261 262 263 264 265 266 267
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
268
-- | Style for printing error messages
269
mkErrStyle :: DynFlags -> PrintUnqualified -> PprStyle
Sylvain Henry's avatar
Sylvain Henry committed
270 271
mkErrStyle dflags qual =
   mkUserStyle dflags qual (PartWay (pprUserLength dflags))
272

Sylvain Henry's avatar
Sylvain Henry committed
273 274
cmdlineParserStyle :: DynFlags -> PprStyle
cmdlineParserStyle dflags = mkUserStyle dflags alwaysQualify AllTheWay
275

Sylvain Henry's avatar
Sylvain Henry committed
276 277 278
mkUserStyle :: DynFlags -> PrintUnqualified -> Depth -> PprStyle
mkUserStyle dflags unqual depth
   | hasPprDebug dflags = PprDebug
279 280 281 282 283 284 285 286 287 288
   | otherwise          = PprUser unqual depth Uncoloured

setStyleColoured :: Bool -> PprStyle -> PprStyle
setStyleColoured col style =
  case style of
    PprUser q d _ -> PprUser q d c
    _             -> style
  where
    c | col       = Coloured
      | otherwise = Uncoloured
289

290 291 292 293 294 295
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
296
{-
sof's avatar
sof committed
297 298 299 300
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
301

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

Austin Seipp's avatar
Austin Seipp committed
305 306
************************************************************************
*                                                                      *
307
\subsection{The @SDoc@ data type}
Austin Seipp's avatar
Austin Seipp committed
308 309 310
*                                                                      *
************************************************************************
-}
311

312 313 314 315 316
-- | Represents a pretty-printable document.
--
-- To display an 'SDoc', use 'printSDoc', 'printSDocLn', 'bufLeftRenderSDoc',
-- or 'renderWithStyle'.  Avoid calling 'runSDoc' directly as it breaks the
-- abstraction layer.
Thomas Schilling's avatar
Thomas Schilling committed
317
newtype SDoc = SDoc { runSDoc :: SDocContext -> Doc }
318 319 320 321 322

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

326 327 328
instance IsString SDoc where
  fromString = text

Ian Lynagh's avatar
Ian Lynagh committed
329 330
initSDocContext :: DynFlags -> PprStyle -> SDocContext
initSDocContext dflags sty = SDC
331 332
  { sdocStyle = sty
  , sdocLastColour = colReset
Ian Lynagh's avatar
Ian Lynagh committed
333
  , sdocDynFlags = dflags
334
  }
335 336

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

339 340 341
-- | This is not a recommended way to render 'SDoc', since it breaks the
-- abstraction layer of 'SDoc'.  Prefer to use 'printSDoc', 'printSDocLn',
-- 'bufLeftRenderSDoc', or 'renderWithStyle' instead.
Ian Lynagh's avatar
Ian Lynagh committed
342 343
withPprStyleDoc :: DynFlags -> PprStyle -> SDoc -> Doc
withPprStyleDoc dflags sty d = runSDoc d (initSDocContext dflags sty)
344

Sylvain Henry's avatar
Sylvain Henry committed
345 346 347
sdocWithPprDebug :: (Bool -> SDoc) -> SDoc
sdocWithPprDebug f = sdocWithDynFlags $ \dflags -> f (hasPprDebug dflags)

348
pprDeeper :: SDoc -> SDoc
Thomas Schilling's avatar
Thomas Schilling committed
349
pprDeeper d = SDoc $ \ctx -> case ctx of
350 351 352
  SDC{sdocStyle=PprUser _ (PartWay 0) _} -> Pretty.text "..."
  SDC{sdocStyle=PprUser q (PartWay n) c} ->
    runSDoc d ctx{sdocStyle = PprUser q (PartWay (n-1)) c}
Thomas Schilling's avatar
Thomas Schilling committed
353
  _ -> runSDoc d ctx
354

355
-- | Truncate a list that is longer than the current depth.
356
pprDeeperList :: ([SDoc] -> SDoc) -> [SDoc] -> SDoc
Austin Seipp's avatar
Austin Seipp committed
357
pprDeeperList f ds
358 359
  | null ds   = f []
  | otherwise = SDoc work
Thomas Schilling's avatar
Thomas Schilling committed
360
 where
361
  work ctx@SDC{sdocStyle=PprUser q (PartWay n) c}
Thomas Schilling's avatar
Thomas Schilling committed
362 363
   | n==0      = Pretty.text "..."
   | otherwise =
364
      runSDoc (f (go 0 ds)) ctx{sdocStyle = PprUser q (PartWay (n-1)) c}
Thomas Schilling's avatar
Thomas Schilling committed
365 366 367 368 369
   where
     go _ [] = []
     go i (d:ds) | i >= n    = [text "...."]
                 | otherwise = d : go (i+1) ds
  work other_ctx = runSDoc (f ds) other_ctx
370

371
pprSetDepth :: Depth -> SDoc -> SDoc
dterei's avatar
dterei committed
372 373
pprSetDepth depth doc = SDoc $ \ctx ->
    case ctx of
374 375
        SDC{sdocStyle=PprUser q _ c} ->
            runSDoc doc ctx{sdocStyle = PprUser q depth c}
dterei's avatar
dterei committed
376 377
        _ ->
            runSDoc doc ctx
378

379
getPprStyle :: (PprStyle -> SDoc) -> SDoc
Thomas Schilling's avatar
Thomas Schilling committed
380
getPprStyle df = SDoc $ \ctx -> runSDoc (df (sdocStyle ctx)) ctx
Ian Lynagh's avatar
Ian Lynagh committed
381 382 383 384 385 386

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

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

388
qualName :: PprStyle -> QueryQualifyName
389 390 391
qualName (PprUser q _ _) mod occ = queryQualifyName q mod occ
qualName (PprDump q)     mod occ = queryQualifyName q mod occ
qualName _other          mod _   = NameQual (moduleName mod)
Simon Marlow's avatar
Simon Marlow committed
392

393
qualModule :: PprStyle -> QueryQualifyModule
394 395 396
qualModule (PprUser q _ _)  m = queryQualifyModule q m
qualModule (PprDump q)      m = queryQualifyModule q m
qualModule _other          _m = True
397

398
qualPackage :: PprStyle -> QueryQualifyPackage
399 400 401
qualPackage (PprUser q _ _)  m = queryQualifyPackage q m
qualPackage (PprDump q)      m = queryQualifyPackage q m
qualPackage _other          _m = True
402 403 404 405 406 407

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

sof's avatar
sof committed
408
codeStyle :: PprStyle -> Bool
dterei's avatar
dterei committed
409 410
codeStyle (PprCode _)     = True
codeStyle _               = False
sof's avatar
sof committed
411

412 413
asmStyle :: PprStyle -> Bool
asmStyle (PprCode AsmStyle)  = True
414
asmStyle _other              = False
415

416
dumpStyle :: PprStyle -> Bool
417 418
dumpStyle (PprDump {}) = True
dumpStyle _other       = False
419

420
debugStyle :: PprStyle -> Bool
dterei's avatar
dterei committed
421 422
debugStyle PprDebug = True
debugStyle _other   = False
423

sof's avatar
sof committed
424
userStyle ::  PprStyle -> Bool
425 426
userStyle (PprUser {}) = True
userStyle _other       = False
sof's avatar
sof committed
427

dterei's avatar
dterei committed
428 429 430 431 432
ifPprDebug :: SDoc -> SDoc        -- Empty for non-debug style
ifPprDebug d = SDoc $ \ctx ->
    case ctx of
        SDC{sdocStyle=PprDebug} -> runSDoc d ctx
        _                       -> Pretty.empty
433

434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450
-- | The analog of 'Pretty.printDoc_' for 'SDoc', which tries to make sure the
--   terminal doesn't get screwed up by the ANSI color codes if an exception
--   is thrown during pretty-printing.
printSDoc :: Mode -> DynFlags -> Handle -> PprStyle -> SDoc -> IO ()
printSDoc mode dflags handle sty doc =
  Pretty.printDoc_ mode cols handle (runSDoc doc ctx)
    `finally`
      Pretty.printDoc_ mode cols handle (runSDoc (coloured colReset empty) ctx)
  where
    cols = pprCols dflags
    ctx = initSDocContext dflags sty

-- | Like 'printSDoc' but appends an extra newline.
printSDocLn :: Mode -> DynFlags -> Handle -> PprStyle -> SDoc -> IO ()
printSDocLn mode dflags handle sty doc =
  printSDoc mode dflags handle sty (doc $$ text "")

451
printForUser :: DynFlags -> Handle -> PrintUnqualified -> SDoc -> IO ()
Ian Lynagh's avatar
Ian Lynagh committed
452
printForUser dflags handle unqual doc
Sylvain Henry's avatar
Sylvain Henry committed
453 454
  = printSDocLn PageMode dflags handle
               (mkUserStyle dflags unqual AllTheWay) doc
455

456 457
printForUserPartWay :: DynFlags -> Handle -> Int -> PrintUnqualified -> SDoc
                    -> IO ()
Ian Lynagh's avatar
Ian Lynagh committed
458
printForUserPartWay dflags handle d unqual doc
Sylvain Henry's avatar
Sylvain Henry committed
459 460
  = printSDocLn PageMode dflags handle
                (mkUserStyle dflags unqual (PartWay d)) doc
461

462 463
-- | Like 'printSDocLn' but specialized with 'LeftMode' and
-- @'PprCode' 'CStyle'@.  This is typically used to output C-- code.
464
printForC :: DynFlags -> Handle -> SDoc -> IO ()
Ian Lynagh's avatar
Ian Lynagh committed
465
printForC dflags handle doc =
466
  printSDocLn LeftMode dflags handle (PprCode CStyle) doc
467

468 469 470 471 472
-- | An efficient variant of 'printSDoc' specialized for 'LeftMode' that
-- outputs to a 'BufHandle'.
bufLeftRenderSDoc :: DynFlags -> BufHandle -> PprStyle -> SDoc -> IO ()
bufLeftRenderSDoc dflags bufHandle sty doc =
  Pretty.bufLeftRender bufHandle (runSDoc doc (initSDocContext dflags sty))
473

sof's avatar
sof committed
474 475
pprCode :: CodeStyle -> SDoc -> SDoc
pprCode cs d = withPprStyle (PprCode cs) d
476

477 478 479
mkCodeStyle :: CodeStyle -> PprStyle
mkCodeStyle = PprCode

480 481
-- Can't make SDoc an instance of Show because SDoc is just a function type
-- However, Doc *is* an instance of Show
482
-- showSDoc just blasts it out as a string
Ian Lynagh's avatar
Ian Lynagh committed
483
showSDoc :: DynFlags -> SDoc -> String
Sylvain Henry's avatar
Sylvain Henry committed
484
showSDoc dflags sdoc = renderWithStyle dflags sdoc (defaultUserStyle dflags)
485

486 487 488 489
-- showSDocUnsafe is unsafe, because `unsafeGlobalDynFlags` might not be
-- initialised yet.
showSDocUnsafe :: SDoc -> String
showSDocUnsafe sdoc = showSDoc unsafeGlobalDynFlags sdoc
490 491 492 493 494 495 496 497 498 499 500

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
Sylvain Henry's avatar
Sylvain Henry committed
501
 = renderWithStyle dflags doc (mkUserStyle dflags unqual AllTheWay)
502 503

showSDocDump :: DynFlags -> SDoc -> String
Sylvain Henry's avatar
Sylvain Henry committed
504
showSDocDump dflags d = renderWithStyle dflags d (defaultDumpStyle dflags)
505 506 507 508

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

Ian Lynagh's avatar
Ian Lynagh committed
509
renderWithStyle :: DynFlags -> SDoc -> PprStyle -> String
510
renderWithStyle dflags sdoc sty
511 512 513
  = let s = Pretty.style{ Pretty.mode = PageMode,
                          Pretty.lineLength = pprCols dflags }
    in Pretty.renderStyle s $ runSDoc sdoc (initSDocContext dflags sty)
514

515 516 517
-- 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.
518
showSDocOneLine :: DynFlags -> SDoc -> String
Ian Lynagh's avatar
Ian Lynagh committed
519
showSDocOneLine dflags d
520 521
 = let s = Pretty.style{ Pretty.mode = OneLineMode,
                         Pretty.lineLength = pprCols dflags } in
Sylvain Henry's avatar
Sylvain Henry committed
522 523
   Pretty.renderStyle s $
      runSDoc d (initSDocContext dflags (defaultUserStyle dflags))
524

525
showSDocDumpOneLine :: DynFlags -> SDoc -> String
Ian Lynagh's avatar
Ian Lynagh committed
526
showSDocDumpOneLine dflags d
527 528
 = let s = Pretty.style{ Pretty.mode = OneLineMode,
                         Pretty.lineLength = irrelevantNCols } in
Sylvain Henry's avatar
Sylvain Henry committed
529 530
   Pretty.renderStyle s $
      runSDoc d (initSDocContext dflags (defaultDumpStyle dflags))
531 532 533 534

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

536 537 538 539
isEmpty :: DynFlags -> SDoc -> Bool
isEmpty dflags sdoc = Pretty.isEmpty $ runSDoc sdoc dummySDocContext
   where dummySDocContext = initSDocContext dflags PprDebug

540
docToSDoc :: Doc -> SDoc
Thomas Schilling's avatar
Thomas Schilling committed
541
docToSDoc d = SDoc (\_ -> d)
542

543 544
empty    :: SDoc
char     :: Char       -> SDoc
batterseapower's avatar
batterseapower committed
545
text     :: String     -> SDoc
546
ftext    :: FastString -> SDoc
547
ptext    :: LitString  -> SDoc
Ian Lynagh's avatar
Ian Lynagh committed
548
ztext    :: FastZString -> SDoc
549 550 551 552 553 554
int      :: Int        -> SDoc
integer  :: Integer    -> SDoc
float    :: Float      -> SDoc
double   :: Double     -> SDoc
rational :: Rational   -> SDoc

Thomas Schilling's avatar
Thomas Schilling committed
555 556
empty       = docToSDoc $ Pretty.empty
char c      = docToSDoc $ Pretty.char c
557

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

Thomas Schilling's avatar
Thomas Schilling committed
561 562
ftext s     = docToSDoc $ Pretty.ftext s
ptext s     = docToSDoc $ Pretty.ptext s
Ian Lynagh's avatar
Ian Lynagh committed
563
ztext s     = docToSDoc $ Pretty.ztext s
Thomas Schilling's avatar
Thomas Schilling committed
564 565 566 567 568
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
569

570 571 572 573 574
-- | @doublePrec p n@ shows a floating point number @n@ with @p@
-- digits of precision after the decimal point.
doublePrec :: Int -> Double -> SDoc
doublePrec p n = text (showFFloat (Just p) n "")

Austin Seipp's avatar
Austin Seipp committed
575
parens, braces, brackets, quotes, quote,
576
        paBrackets, doubleQuotes, angleBrackets :: SDoc -> SDoc
577

578 579 580 581 582
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
583
angleBrackets d = char '<' <> d <> char '>'
584
paBrackets d    = text "[:" <> d <> text ":]"
585

586
cparen :: Bool -> SDoc -> SDoc
587
cparen b d = SDoc $ Pretty.maybeParens b . runSDoc d
mnislaih's avatar
mnislaih committed
588

589
-- 'quotes' encloses something in single quotes...
590
-- but it omits them if the thing begins or ends in a single quote
591
-- so that we don't get `foo''.  Instead we just have foo'.
592 593
quotes d =
      sdocWithDynFlags $ \dflags ->
594
      if useUnicode dflags
595
      then char '‘' <> d <> char '’'
596
      else SDoc $ \sty ->
597 598 599 600 601 602
           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
603

604
semi, comma, colon, equals, space, dcolon, underscore, dot, vbar :: SDoc
605 606
arrow, larrow, darrow, arrowt, larrowt, arrowtt, larrowtt :: SDoc
lparen, rparen, lbrack, rbrack, lbrace, rbrace, blankLine :: SDoc
607

608 609 610 611 612 613 614 615 616
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
617 618 619 620 621 622 623
semi       = docToSDoc $ Pretty.semi
comma      = docToSDoc $ Pretty.comma
colon      = docToSDoc $ Pretty.colon
equals     = docToSDoc $ Pretty.equals
space      = docToSDoc $ Pretty.space
underscore = char '_'
dot        = char '.'
624
vbar       = char '|'
Thomas Schilling's avatar
Thomas Schilling committed
625 626 627 628 629 630
lparen     = docToSDoc $ Pretty.lparen
rparen     = docToSDoc $ Pretty.rparen
lbrack     = docToSDoc $ Pretty.lbrack
rbrack     = docToSDoc $ Pretty.rbrack
lbrace     = docToSDoc $ Pretty.lbrace
rbrace     = docToSDoc $ Pretty.rbrace
631

632
forAllLit :: SDoc
633
forAllLit = unicodeSyntax (char '∀') (text "forall")
634

635 636 637
kindStar :: SDoc
kindStar = unicodeSyntax (char '★') (char '*')

638 639 640
bullet :: SDoc
bullet = unicode (char '•') (char '*')

641 642
unicodeSyntax :: SDoc -> SDoc -> SDoc
unicodeSyntax unicode plain = sdocWithDynFlags $ \dflags ->
643 644 645
    if useUnicode dflags && useUnicodeSyntax dflags
    then unicode
    else plain
646

647 648 649 650 651 652
unicode :: SDoc -> SDoc -> SDoc
unicode unicode plain = sdocWithDynFlags $ \dflags ->
    if useUnicode dflags
    then unicode
    else plain

653
nest :: Int -> SDoc -> SDoc
batterseapower's avatar
batterseapower committed
654 655 656 657 658 659
-- ^ 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
660
-- ^ Join two 'SDoc' together vertically; if there is
batterseapower's avatar
batterseapower committed
661 662 663
-- no vertical overlap it "dovetails" the two onto one line
($+$) :: SDoc -> SDoc -> SDoc
-- ^ Join two 'SDoc' together vertically
664

Thomas Schilling's avatar
Thomas Schilling committed
665 666 667 668 669
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)
670

batterseapower's avatar
batterseapower committed
671 672 673 674 675 676 677 678 679 680 681 682 683 684 685
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 '<+>'
686 687


Thomas Schilling's avatar
Thomas Schilling committed
688 689 690 691 692 693 694
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]
695

batterseapower's avatar
batterseapower committed
696 697 698 699
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
700
hang d1 n d2   = SDoc $ \sty -> Pretty.hang (runSDoc d1 sty) n (runSDoc d2 sty)
701

702 703 704 705 706 707
-- | 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
708 709 710
punctuate :: SDoc   -- ^ The punctuation
          -> [SDoc] -- ^ The list that will have punctuation added between every adjacent pair of elements
          -> [SDoc] -- ^ Punctuated list
711
punctuate _ []     = []
712
punctuate p (d:ds) = go d ds
dterei's avatar
dterei committed
713 714 715
                   where
                     go d [] = [d]
                     go d (e:es) = (d <> p) : go e es
716 717 718 719 720 721 722

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

ppUnless True  _   = empty
ppUnless False doc = doc
723 724 725 726

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

727 728 729 730 731 732
-- | Allow colours to be combined (e.g. bold + red);
--   In case of conflict, right side takes precedence.
instance Monoid PprColour where
  mempty = PprColour mempty
  PprColour s1 `mappend` PprColour s2 = PprColour (s1 `mappend` s2)

733 734
-- Colours

735 736
colReset :: PprColour
colReset = PprColour "\27[0m"
737 738 739 740

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

741 742
colBlackFg :: PprColour
colBlackFg = PprColour "\27[30m"
743

744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763
colRedFg :: PprColour
colRedFg = PprColour "\27[31m"

colGreenFg :: PprColour
colGreenFg = PprColour "\27[32m"

colYellowFg :: PprColour
colYellowFg = PprColour "\27[33m"

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

colMagentaFg :: PprColour
colMagentaFg = PprColour "\27[35m"

colCyanFg :: PprColour
colCyanFg = PprColour "\27[36m"

colWhiteFg :: PprColour
colWhiteFg = PprColour "\27[37m"
764

Thomas Schilling's avatar
Thomas Schilling committed
765
colBinder :: PprColour
766
colBinder = colGreenFg
767

768 769 770 771 772 773 774 775
colCoerc :: PprColour
colCoerc = colBlueFg

colDataCon :: PprColour
colDataCon = colRedFg

colType :: PprColour
colType = colBlueFg
776 777 778 779 780

-- | Apply the given colour\/style for the argument.
--
-- Only takes effect if colours are enabled.
coloured :: PprColour -> SDoc -> SDoc
Thomas Schilling's avatar
Thomas Schilling committed
781
coloured col@(PprColour c) sdoc =
782 783 784
  sdocWithDynFlags $ \dflags ->
    if overrideWith (canUseColor dflags) (useColor dflags)
    then SDoc $ \ctx@SDC{ sdocLastColour = PprColour lc } ->
785 786 787 788 789 790 791
         case ctx of
           SDC{ sdocStyle = PprUser _ _ Coloured } ->
             let ctx' = ctx{ sdocLastColour = col } in
             Pretty.zeroWidthText c
               Pretty.<> runSDoc sdoc ctx'
               Pretty.<> Pretty.zeroWidthText lc
           _ -> runSDoc sdoc ctx
792
    else sdoc
793 794 795 796 797 798 799

bold :: SDoc -> SDoc
bold = coloured colBold

keyword :: SDoc -> SDoc
keyword = bold

Austin Seipp's avatar
Austin Seipp committed
800 801 802
{-
************************************************************************
*                                                                      *
sof's avatar
sof committed
803
\subsection[Outputable-class]{The @Outputable@ class}
Austin Seipp's avatar
Austin Seipp committed
804 805 806
*                                                                      *
************************************************************************
-}
sof's avatar
sof committed
807

batterseapower's avatar
batterseapower committed
808
-- | Class designating that some type has an 'SDoc' representation
sof's avatar
sof committed
809
class Outputable a where
dterei's avatar
dterei committed
810 811 812 813 814
        ppr :: a -> SDoc
        pprPrec :: Rational ->