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

batterseapower's avatar
batterseapower committed
6 7 8 9 10 11
-- | 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.
12
module Outputable (
dterei's avatar
dterei committed
13 14
        -- * Type classes
        Outputable(..), OutputableBndr(..),
15

batterseapower's avatar
batterseapower committed
16
        -- * Pretty printing combinators
dterei's avatar
dterei committed
17
        SDoc, runSDoc, initSDocContext,
Simon Peyton Jones's avatar
Simon Peyton Jones committed
18
        docToSDoc,
19 20
        interppSP, interpp'SP,
        pprQuotedList, pprWithCommas, quotedListWithOr, quotedListWithNor,
21
        pprWithBars,
22
        empty, isEmpty, nest,
dterei's avatar
dterei committed
23
        char,
Ian Lynagh's avatar
Ian Lynagh committed
24
        text, ftext, ptext, ztext,
Andrew Martin's avatar
Andrew Martin committed
25
        int, intWithCommas, integer, word, float, double, rational, doublePrec,
26
        parens, cparen, brackets, braces, quotes, quote,
27
        doubleQuotes, angleBrackets,
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, kindType, bullet,
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

Rufflewind's avatar
Rufflewind committed
40
        coloured, keyword,
41

batterseapower's avatar
batterseapower committed
42
        -- * Converting 'SDoc' into strings and outputing it
43 44
        printSDoc, printSDocLn, printForUser, printForUserPartWay,
        printForC, bufLeftRenderSDoc,
dterei's avatar
dterei committed
45
        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

Alan Zimmerman's avatar
Alan Zimmerman committed
54 55 56
        primFloatSuffix, primCharSuffix, primWordSuffix, primDoubleSuffix,
        primInt64Suffix, primWord64Suffix, primIntSuffix,

57 58
        pprPrimChar, pprPrimInt, pprPrimWord, pprPrimInt64, pprPrimWord64,

59
        pprFastFilePath, pprFilePathString,
60

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

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

Simon Peyton Jones's avatar
Simon Peyton Jones committed
80 81
        ifPprDebug, whenPprDebug, getPprDebug,

dterei's avatar
dterei committed
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
        pprTraceException, pprTraceM,
86
        trace, pgmError, panic, sorry, assertPanic,
Ben Gamari's avatar
Ben Gamari committed
87
        pprDebugAndThen, callStackDoc,
88 89
    ) where

90 91
import GhcPrelude

Sylvain Henry's avatar
Sylvain Henry committed
92
import {-# SOURCE #-}   DynFlags( DynFlags, hasPprDebug, hasNoDebugOutput,
93
                                  targetPlatform, pprUserLength, pprCols,
94
                                  useUnicode, useUnicodeSyntax, useStarIsType,
Andrew Martin's avatar
Andrew Martin committed
95 96
                                  shouldUseColor, unsafeGlobalDynFlags,
                                  shouldUseHexWordLiterals )
97
import {-# SOURCE #-}   Module( UnitId, Module, ModuleName, moduleName )
98
import {-# SOURCE #-}   OccName( OccName )
99

100
import BufWrite (BufHandle)
dterei's avatar
dterei committed
101
import FastString
102
import qualified Pretty
103
import Util
Ian Lynagh's avatar
Ian Lynagh committed
104
import Platform
Rufflewind's avatar
Rufflewind committed
105
import qualified PprColour as Col
dterei's avatar
dterei committed
106
import Pretty           ( Doc, Mode(..) )
107
import Panic
108
import GHC.Serialized
Oleg Grenrus's avatar
Oleg Grenrus committed
109
import GHC.LanguageExtensions (Extension)
110

111
import Data.ByteString (ByteString)
112
import qualified Data.ByteString as BS
Ian Lynagh's avatar
Ian Lynagh committed
113
import Data.Char
114
import qualified Data.Map as M
115
import Data.Int
116
import qualified Data.IntMap as IM
117 118
import Data.Set (Set)
import qualified Data.Set as Set
119
import Data.String
120
import Data.Word
121
import System.IO        ( Handle )
122
import System.FilePath
123
import Text.Printf
124
import Numeric (showFFloat)
125
import Data.Graph (SCC(..))
126
import Data.List (intersperse)
127

128
import GHC.Fingerprint
129
import GHC.Show         ( showMultiLineString )
Ryan Scott's avatar
Ryan Scott committed
130
import GHC.Stack        ( callStack, prettyCallStack )
Ben Gamari's avatar
Ben Gamari committed
131 132
import Control.Monad.IO.Class
import Exception
133

Austin Seipp's avatar
Austin Seipp committed
134 135 136
{-
************************************************************************
*                                                                      *
sof's avatar
sof committed
137
\subsection{The @PprStyle@ data type}
Austin Seipp's avatar
Austin Seipp committed
138 139 140
*                                                                      *
************************************************************************
-}
141

sof's avatar
sof committed
142
data PprStyle
143
  = PprUser PrintUnqualified Depth Coloured
dterei's avatar
dterei committed
144 145 146 147 148
                -- 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
149

150 151
  | PprDump PrintUnqualified
                -- For -ddump-foo; less verbose than PprDebug, but more than PprUser
dterei's avatar
dterei committed
152 153
                -- Does not assume tidied code: non-external names
                -- are printed with uniques.
154

dterei's avatar
dterei committed
155
  | PprDebug    -- Full debugging output
156

157 158 159
  | PprCode CodeStyle
                -- Print code; either C or assembler

dterei's avatar
dterei committed
160 161
data CodeStyle = CStyle         -- The format of labels differs for C and assembler
               | AsmStyle
162 163

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

166 167 168
data Coloured
  = Uncoloured
  | Coloured
169

Simon Marlow's avatar
Simon Marlow committed
170 171
-- -----------------------------------------------------------------------------
-- Printing original names
172

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

183 184
-- | Given a `Name`'s `Module` and `OccName`, decide whether and how to qualify
-- it.
185 186 187 188 189 190
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

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

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

Richard Eisenberg's avatar
Richard Eisenberg committed
208 209 210 211 212 213
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"

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

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

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

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

227
neverQualifyModules :: QueryQualifyModule
228 229
neverQualifyModules _ = False

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

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

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

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

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

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

Sylvain Henry's avatar
Sylvain Henry committed
277 278 279
mkUserStyle :: DynFlags -> PrintUnqualified -> Depth -> PprStyle
mkUserStyle dflags unqual depth
   | hasPprDebug dflags = PprDebug
280 281 282 283 284 285 286 287 288 289
   | 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
290

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

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

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

313 314 315 316 317
-- | 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
318
newtype SDoc = SDoc { runSDoc :: SDocContext -> Doc }
319 320 321

data SDocContext = SDC
  { sdocStyle      :: !PprStyle
Rufflewind's avatar
Rufflewind committed
322
  , sdocLastColour :: !Col.PprColour
323
    -- ^ The most recently used colour.  This allows nesting colours.
324
  , sdocDynFlags   :: !DynFlags
325 326
  }

327 328 329
instance IsString SDoc where
  fromString = text

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

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

340 341 342
-- | 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
343 344
withPprStyleDoc :: DynFlags -> PprStyle -> SDoc -> Doc
withPprStyleDoc dflags sty d = runSDoc d (initSDocContext dflags sty)
345

346
pprDeeper :: SDoc -> SDoc
Thomas Schilling's avatar
Thomas Schilling committed
347
pprDeeper d = SDoc $ \ctx -> case ctx of
348 349 350
  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
351
  _ -> runSDoc d ctx
352

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

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

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

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

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

386 387 388 389
updSDocDynFlags :: (DynFlags -> DynFlags) -> SDoc -> SDoc
updSDocDynFlags upd doc
  = SDoc $ \ctx -> runSDoc doc (ctx { sdocDynFlags = upd (sdocDynFlags ctx) })

390
qualName :: PprStyle -> QueryQualifyName
391 392 393
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
394

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

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

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

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

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

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

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

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

Simon Peyton Jones's avatar
Simon Peyton Jones committed
430 431 432 433 434 435 436 437 438 439
getPprDebug :: (Bool -> SDoc) -> SDoc
getPprDebug d = getPprStyle $ \ sty -> d (debugStyle sty)

ifPprDebug :: SDoc -> SDoc -> SDoc
-- ^ Says what to do with and without -dppr-debug
ifPprDebug yes no = getPprDebug $ \ dbg -> if dbg then yes else no

whenPprDebug :: SDoc -> SDoc        -- Empty for non-debug style
-- ^ Says what to do with -dppr-debug; without, return empty
whenPprDebug d = ifPprDebug d empty
440

441 442 443 444 445 446 447
-- | 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`
Rufflewind's avatar
Rufflewind committed
448 449
      Pretty.printDoc_ mode cols handle
        (runSDoc (coloured Col.colReset empty) ctx)
450 451 452 453 454 455 456 457 458
  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 "")

459
printForUser :: DynFlags -> Handle -> PrintUnqualified -> SDoc -> IO ()
Ian Lynagh's avatar
Ian Lynagh committed
460
printForUser dflags handle unqual doc
Sylvain Henry's avatar
Sylvain Henry committed
461 462
  = printSDocLn PageMode dflags handle
               (mkUserStyle dflags unqual AllTheWay) doc
463

464 465
printForUserPartWay :: DynFlags -> Handle -> Int -> PrintUnqualified -> SDoc
                    -> IO ()
Ian Lynagh's avatar
Ian Lynagh committed
466
printForUserPartWay dflags handle d unqual doc
Sylvain Henry's avatar
Sylvain Henry committed
467 468
  = printSDocLn PageMode dflags handle
                (mkUserStyle dflags unqual (PartWay d)) doc
469

470 471
-- | Like 'printSDocLn' but specialized with 'LeftMode' and
-- @'PprCode' 'CStyle'@.  This is typically used to output C-- code.
472
printForC :: DynFlags -> Handle -> SDoc -> IO ()
Ian Lynagh's avatar
Ian Lynagh committed
473
printForC dflags handle doc =
474
  printSDocLn LeftMode dflags handle (PprCode CStyle) doc
475

476 477 478 479 480
-- | 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))
481

sof's avatar
sof committed
482 483
pprCode :: CodeStyle -> SDoc -> SDoc
pprCode cs d = withPprStyle (PprCode cs) d
484

485 486 487
mkCodeStyle :: CodeStyle -> PprStyle
mkCodeStyle = PprCode

488 489
-- Can't make SDoc an instance of Show because SDoc is just a function type
-- However, Doc *is* an instance of Show
490
-- showSDoc just blasts it out as a string
Ian Lynagh's avatar
Ian Lynagh committed
491
showSDoc :: DynFlags -> SDoc -> String
Sylvain Henry's avatar
Sylvain Henry committed
492
showSDoc dflags sdoc = renderWithStyle dflags sdoc (defaultUserStyle dflags)
493

494 495 496 497
-- showSDocUnsafe is unsafe, because `unsafeGlobalDynFlags` might not be
-- initialised yet.
showSDocUnsafe :: SDoc -> String
showSDocUnsafe sdoc = showSDoc unsafeGlobalDynFlags sdoc
498 499 500 501 502 503 504 505 506 507 508

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
509
 = renderWithStyle dflags doc (mkUserStyle dflags unqual AllTheWay)
510 511

showSDocDump :: DynFlags -> SDoc -> String
Sylvain Henry's avatar
Sylvain Henry committed
512
showSDocDump dflags d = renderWithStyle dflags d (defaultDumpStyle dflags)
513 514 515 516

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

Ian Lynagh's avatar
Ian Lynagh committed
517
renderWithStyle :: DynFlags -> SDoc -> PprStyle -> String
518
renderWithStyle dflags sdoc sty
519 520 521
  = let s = Pretty.style{ Pretty.mode = PageMode,
                          Pretty.lineLength = pprCols dflags }
    in Pretty.renderStyle s $ runSDoc sdoc (initSDocContext dflags sty)
522

523 524 525
-- 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.
526
showSDocOneLine :: DynFlags -> SDoc -> String
Ian Lynagh's avatar
Ian Lynagh committed
527
showSDocOneLine dflags d
528 529
 = let s = Pretty.style{ Pretty.mode = OneLineMode,
                         Pretty.lineLength = pprCols dflags } in
Sylvain Henry's avatar
Sylvain Henry committed
530 531
   Pretty.renderStyle s $
      runSDoc d (initSDocContext dflags (defaultUserStyle dflags))
532

533
showSDocDumpOneLine :: DynFlags -> SDoc -> String
Ian Lynagh's avatar
Ian Lynagh committed
534
showSDocDumpOneLine dflags d
535 536
 = let s = Pretty.style{ Pretty.mode = OneLineMode,
                         Pretty.lineLength = irrelevantNCols } in
Sylvain Henry's avatar
Sylvain Henry committed
537 538
   Pretty.renderStyle s $
      runSDoc d (initSDocContext dflags (defaultDumpStyle dflags))
539 540 541 542

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

544 545 546 547
isEmpty :: DynFlags -> SDoc -> Bool
isEmpty dflags sdoc = Pretty.isEmpty $ runSDoc sdoc dummySDocContext
   where dummySDocContext = initSDocContext dflags PprDebug

548
docToSDoc :: Doc -> SDoc
Thomas Schilling's avatar
Thomas Schilling committed
549
docToSDoc d = SDoc (\_ -> d)
550

551 552
empty    :: SDoc
char     :: Char       -> SDoc
batterseapower's avatar
batterseapower committed
553
text     :: String     -> SDoc
554
ftext    :: FastString -> SDoc
Sylvain Henry's avatar
Sylvain Henry committed
555
ptext    :: PtrString  -> SDoc
Ian Lynagh's avatar
Ian Lynagh committed
556
ztext    :: FastZString -> SDoc
557 558
int      :: Int        -> SDoc
integer  :: Integer    -> SDoc
Andrew Martin's avatar
Andrew Martin committed
559
word     :: Integer    -> SDoc
560 561 562 563
float    :: Float      -> SDoc
double   :: Double     -> SDoc
rational :: Rational   -> SDoc

Thomas Schilling's avatar
Thomas Schilling committed
564 565
empty       = docToSDoc $ Pretty.empty
char c      = docToSDoc $ Pretty.char c
566

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

Thomas Schilling's avatar
Thomas Schilling committed
570 571
ftext s     = docToSDoc $ Pretty.ftext s
ptext s     = docToSDoc $ Pretty.ptext s
Ian Lynagh's avatar
Ian Lynagh committed
572
ztext s     = docToSDoc $ Pretty.ztext s
Thomas Schilling's avatar
Thomas Schilling committed
573 574 575 576 577
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
Andrew Martin's avatar
Andrew Martin committed
578 579 580 581 582
word n      = sdocWithDynFlags $ \dflags ->
    -- See Note [Print Hexadecimal Literals] in Pretty.hs
    if shouldUseHexWordLiterals dflags
        then docToSDoc $ Pretty.hex n
        else docToSDoc $ Pretty.integer n
583

584 585 586 587 588
-- | @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
589
parens, braces, brackets, quotes, quote,
590
        doubleQuotes, angleBrackets :: SDoc -> SDoc
591

592 593 594 595 596
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
597
angleBrackets d = char '<' <> d <> char '>'
598

599
cparen :: Bool -> SDoc -> SDoc
600
cparen b d = SDoc $ Pretty.maybeParens b . runSDoc d
mnislaih's avatar
mnislaih committed
601

602
-- 'quotes' encloses something in single quotes...
603
-- but it omits them if the thing begins or ends in a single quote
604
-- so that we don't get `foo''.  Instead we just have foo'.
605 606
quotes d =
      sdocWithDynFlags $ \dflags ->
607
      if useUnicode dflags
608
      then char '‘' <> d <> char '’'
609
      else SDoc $ \sty ->
610 611
           let pp_d = runSDoc d sty
               str  = show pp_d
612 613
           in case (str, lastMaybe str) of
             (_, Just '\'') -> pp_d
614 615
             ('\'' : _, _)       -> pp_d
             _other              -> Pretty.quotes pp_d
616

617
semi, comma, colon, equals, space, dcolon, underscore, dot, vbar :: SDoc
618 619
arrow, larrow, darrow, arrowt, larrowt, arrowtt, larrowtt :: SDoc
lparen, rparen, lbrack, rbrack, lbrace, rbrace, blankLine :: SDoc
620

621 622 623 624 625 626 627 628 629
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
630 631 632 633 634 635 636
semi       = docToSDoc $ Pretty.semi
comma      = docToSDoc $ Pretty.comma
colon      = docToSDoc $ Pretty.colon
equals     = docToSDoc $ Pretty.equals
space      = docToSDoc $ Pretty.space
underscore = char '_'
dot        = char '.'
637
vbar       = char '|'
Thomas Schilling's avatar
Thomas Schilling committed
638 639 640 641 642 643
lparen     = docToSDoc $ Pretty.lparen
rparen     = docToSDoc $ Pretty.rparen
lbrack     = docToSDoc $ Pretty.lbrack
rbrack     = docToSDoc $ Pretty.rbrack
lbrace     = docToSDoc $ Pretty.lbrace
rbrace     = docToSDoc $ Pretty.rbrace
644

645
forAllLit :: SDoc
646
forAllLit = unicodeSyntax (char '∀') (text "forall")
647

648 649 650 651 652
kindType :: SDoc
kindType = sdocWithDynFlags $ \dflags ->
    if useStarIsType dflags
    then unicodeSyntax (char '★') (char '*')
    else text "Type"
653

654 655 656
bullet :: SDoc
bullet = unicode (char '•') (char '*')

657 658
unicodeSyntax :: SDoc -> SDoc -> SDoc
unicodeSyntax unicode plain = sdocWithDynFlags $ \dflags ->
659 660 661
    if useUnicode dflags && useUnicodeSyntax dflags
    then unicode
    else plain
662

663 664 665 666 667 668
unicode :: SDoc -> SDoc -> SDoc
unicode unicode plain = sdocWithDynFlags $ \dflags ->
    if useUnicode dflags
    then unicode
    else plain

669
nest :: Int -> SDoc -> SDoc
batterseapower's avatar
batterseapower committed
670 671 672 673 674 675
-- ^ 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
676
-- ^ Join two 'SDoc' together vertically; if there is
batterseapower's avatar
batterseapower committed
677 678 679
-- no vertical overlap it "dovetails" the two onto one line
($+$) :: SDoc -> SDoc -> SDoc
-- ^ Join two 'SDoc' together vertically
680

Thomas Schilling's avatar
Thomas Schilling committed
681 682 683 684 685
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)
686

batterseapower's avatar
batterseapower committed
687 688 689 690 691 692 693 694 695 696 697 698 699 700 701
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 '<+>'
702 703


Thomas Schilling's avatar
Thomas Schilling committed
704 705 706 707 708 709 710
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]
711

batterseapower's avatar
batterseapower committed
712 713 714 715
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
716
hang d1 n d2   = SDoc $ \sty -> Pretty.hang (runSDoc d1 sty) n (runSDoc d2 sty)
717

718 719 720 721 722 723
-- | 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
724 725 726
punctuate :: SDoc   -- ^ The punctuation
          -> [SDoc] -- ^ The list that will have punctuation added between every adjacent pair of elements
          -> [SDoc] -- ^ Punctuated list
727
punctuate _ []     = []
728
punctuate p (d:ds) = go d ds
dterei's avatar
dterei committed
729 730 731
                   where
                     go d [] = [d]
                     go d (e:es) = (d <> p) : go e es
732 733 734 735 736 737 738

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

ppUnless True  _   = empty
ppUnless False doc = doc
739 740 741 742

-- | Apply the given colour\/style for the argument.
--
-- Only takes effect if colours are enabled.
Rufflewind's avatar
Rufflewind committed
743
coloured :: Col.PprColour -> SDoc -> SDoc
Rufflewind's avatar
Rufflewind committed
744
coloured col sdoc =
745
  sdocWithDynFlags $ \dflags ->
Rufflewind's avatar
Rufflewind committed
746
    if shouldUseColor dflags
Rufflewind's avatar
Rufflewind committed
747
    then SDoc $ \ctx@SDC{ sdocLastColour = lastCol } ->
748 749
         case ctx of
           SDC{ sdocStyle = PprUser _ _ Coloured } ->
Rufflewind's avatar
Rufflewind committed
750 751
             let ctx' = ctx{ sdocLastColour = lastCol `mappend` col } in
             Pretty.zeroWidthText (Col.renderColour col)
752
               Pretty.<> runSDoc sdoc ctx'
Rufflewind's avatar
Rufflewind committed
753
               Pretty.<> Pretty.zeroWidthText (Col.renderColourAfresh lastCol)
754
           _ -> runSDoc sdoc ctx
755
    else sdoc
756 757

keyword :: SDoc -> SDoc
Rufflewind's avatar
Rufflewind committed
758
keyword = coloured Col.colBold
759

Austin Seipp's avatar
Austin Seipp committed
760 761 762
{-
************************************************************************
*                                                                      *
sof's avatar
sof committed
763
\subsection[Outputable-class]{The @Outputable@ class}
Austin Seipp's avatar
Austin Seipp committed
764 765 766
*                                                                      *
************************************************************************
-}
sof's avatar
sof committed
767

batterseapower's avatar
batterseapower committed
768
-- | Class designating that some type has an 'SDoc' representation
sof's avatar
sof committed
769
class Outputable a where
dterei's avatar
dterei committed
770 771 772 773 774
        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
775

dterei's avatar
dterei committed
776 777
        ppr = pprPrec 0
        pprPrec _ = ppr
sof's avatar
sof committed
778

779 780 781
instance Outputable Char where
    ppr c = text [c]

782
instance Outputable Bool where
783 784
    ppr True  = text "True"
    ppr False = text "False"
785

786 787 788 789 790
instance Outputable Ordering where
    ppr LT = text "LT"
    ppr EQ = text "EQ"
    ppr GT = text "GT"

791 792 793 794 795 796
instance Outputable Int32 where
   ppr n = integer $ fromIntegral n

instance Outputable Int64 where
   ppr n = integer $ fromIntegral n

sof's avatar
sof committed
797
instance Outputable Int where
798
    ppr n = int n
sof's avatar
sof committed
799

800 801 802
instance Outputable Integer where
    ppr n = integer n

803
instance Outputable Word16 where
804
    ppr n = integer $ fromIntegral n
805

806
instance Outputable Word32 where
807
    ppr n = integer $ fromIntegral n
808

809
instance Outputable Word where
810
    ppr n = integer $ fromIntegral n
811

812
instance Outputable () where
813
    ppr _ = text "()"
814

815
instance (Outputable a) => Outputable [a] where
816
    ppr xs = brackets (fsep (punctuate comma (map ppr xs)))
817

818 819 820
instance (Outputable a) => Outputable (Set a) where
    ppr s = braces (fsep (punctuate comma (map ppr (Set.toList s))))

821
instance (Outputable a, Outputable b) => Outputable (a, b) where
822
    ppr (x,y) = parens (sep [ppr x <> comma, ppr y])
823

824
instance Outputable a => Outputable (Maybe a) where