Outputable.hs 39.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 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

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

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

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

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

56
        pprFastFilePath,
57

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

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

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

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

dterei's avatar
dterei committed
91
import FastString
92
import qualified Pretty
93
import Util
Ian Lynagh's avatar
Ian Lynagh committed
94
import Platform
dterei's avatar
dterei committed
95
import Pretty           ( Doc, Mode(..) )
96
import Panic
97

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

112
import GHC.Fingerprint
113
import GHC.Show         ( showMultiLineString )
Ben Gamari's avatar
Ben Gamari committed
114
#if __GLASGOW_HASKELL__ > 710
115
import GHC.Stack
Ben Gamari's avatar
Ben Gamari committed
116
#endif
117

Austin Seipp's avatar
Austin Seipp committed
118 119 120
{-
************************************************************************
*                                                                      *
sof's avatar
sof committed
121
\subsection{The @PprStyle@ data type}
Austin Seipp's avatar
Austin Seipp committed
122 123 124
*                                                                      *
************************************************************************
-}
125

sof's avatar
sof committed
126
data PprStyle
127
  = PprUser PrintUnqualified Depth
dterei's avatar
dterei committed
128 129 130 131 132
                -- 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
133

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

dterei's avatar
dterei committed
139
  | PprDebug    -- Full debugging output
140

141 142 143
  | PprCode CodeStyle
                -- Print code; either C or assembler

dterei's avatar
dterei committed
144 145
data CodeStyle = CStyle         -- The format of labels differs for C and assembler
               | AsmStyle
146 147

data Depth = AllTheWay
dterei's avatar
dterei committed
148
           | PartWay Int        -- 0 => stop
149 150


Simon Marlow's avatar
Simon Marlow committed
151 152
-- -----------------------------------------------------------------------------
-- Printing original names
153

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

Simon Marlow's avatar
Simon Marlow committed
164 165 166
-- | 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
167
-- as @Exception.catch@, this function will return @Just "Exception"@.
Simon Marlow's avatar
Simon Marlow committed
168 169
-- Note that the return value is a ModuleName, not a Module, because
-- in source code, names are qualified by ModuleNames.
170 171 172 173 174 175
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

176
-- | For a given package, we need to know whether to print it with
177 178
-- the unit id to disambiguate it.
type QueryQualifyPackage = UnitId -> Bool
179

180
-- See Note [Printing original names] in HscTypes
181 182 183 184 185 186 187 188 189 190 191
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"
192

193 194 195 196
reallyAlwaysQualifyNames :: QueryQualifyName
reallyAlwaysQualifyNames _ _ = NameNotInScope2

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

200
neverQualifyNames :: QueryQualifyName
201
neverQualifyNames _ _ = NameUnqual
Simon Marlow's avatar
Simon Marlow committed
202

203
alwaysQualifyModules :: QueryQualifyModule
204
alwaysQualifyModules _ = True
Simon Marlow's avatar
Simon Marlow committed
205

206
neverQualifyModules :: QueryQualifyModule
207 208
neverQualifyModules _ = False

209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225
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
226

227 228
defaultUserStyle, defaultDumpStyle :: PprStyle

229 230
defaultUserStyle = mkUserStyle neverQualify AllTheWay
 -- Print without qualifiers to reduce verbosity, unless -dppr-debug
231

232
defaultDumpStyle |  opt_PprStyle_Debug = PprDebug
233 234 235 236 237
                 |  otherwise          = PprDump neverQualify

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

239 240 241 242 243 244 245
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
246
-- | Style for printing error messages
247 248
mkErrStyle :: DynFlags -> PrintUnqualified -> PprStyle
mkErrStyle dflags qual = mkUserStyle qual (PartWay (pprUserLength dflags))
249

250 251
cmdlineParserStyle :: PprStyle
cmdlineParserStyle = mkUserStyle alwaysQualify AllTheWay
252

253
mkUserStyle :: PrintUnqualified -> Depth -> PprStyle
Simon Marlow's avatar
Simon Marlow committed
254 255 256
mkUserStyle unqual depth
   | opt_PprStyle_Debug = PprDebug
   | otherwise          = PprUser unqual depth
257

258 259 260 261 262 263
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
264
{-
sof's avatar
sof committed
265 266 267 268
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
269

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

Austin Seipp's avatar
Austin Seipp committed
273 274
************************************************************************
*                                                                      *
275
\subsection{The @SDoc@ data type}
Austin Seipp's avatar
Austin Seipp committed
276 277 278
*                                                                      *
************************************************************************
-}
279

Thomas Schilling's avatar
Thomas Schilling committed
280
newtype SDoc = SDoc { runSDoc :: SDocContext -> Doc }
281 282 283 284 285

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

Ian Lynagh's avatar
Ian Lynagh committed
289 290
initSDocContext :: DynFlags -> PprStyle -> SDocContext
initSDocContext dflags sty = SDC
291 292
  { sdocStyle = sty
  , sdocLastColour = colReset
Ian Lynagh's avatar
Ian Lynagh committed
293
  , sdocDynFlags = dflags
294
  }
295 296

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

Ian Lynagh's avatar
Ian Lynagh committed
299 300
withPprStyleDoc :: DynFlags -> PprStyle -> SDoc -> Doc
withPprStyleDoc dflags sty d = runSDoc d (initSDocContext dflags sty)
301

302
pprDeeper :: SDoc -> SDoc
Thomas Schilling's avatar
Thomas Schilling committed
303 304 305 306 307
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
308

309
-- | Truncate a list that is longer than the current depth.
310
pprDeeperList :: ([SDoc] -> SDoc) -> [SDoc] -> SDoc
Austin Seipp's avatar
Austin Seipp committed
311
pprDeeperList f ds
312 313
  | null ds   = f []
  | otherwise = SDoc work
Thomas Schilling's avatar
Thomas Schilling committed
314 315 316 317 318 319 320 321 322 323
 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
324

325
pprSetDepth :: Depth -> SDoc -> SDoc
dterei's avatar
dterei committed
326 327 328 329 330 331
pprSetDepth depth doc = SDoc $ \ctx ->
    case ctx of
        SDC{sdocStyle=PprUser q _} ->
            runSDoc doc ctx{sdocStyle = PprUser q depth}
        _ ->
            runSDoc doc ctx
332

333
getPprStyle :: (PprStyle -> SDoc) -> SDoc
Thomas Schilling's avatar
Thomas Schilling committed
334
getPprStyle df = SDoc $ \ctx -> runSDoc (df (sdocStyle ctx)) ctx
Ian Lynagh's avatar
Ian Lynagh committed
335 336 337 338 339 340

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

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

342
qualName :: PprStyle -> QueryQualifyName
343
qualName (PprUser q _)  mod occ = queryQualifyName q mod occ
344
qualName (PprDump q)    mod occ = queryQualifyName q mod occ
345
qualName _other         mod _   = NameQual (moduleName mod)
Simon Marlow's avatar
Simon Marlow committed
346

347
qualModule :: PprStyle -> QueryQualifyModule
348
qualModule (PprUser q _)  m = queryQualifyModule q m
349 350
qualModule (PprDump q)    m = queryQualifyModule q m
qualModule _other        _m = True
351

352 353
qualPackage :: PprStyle -> QueryQualifyPackage
qualPackage (PprUser q _)  m = queryQualifyPackage q m
354 355
qualPackage (PprDump q)    m = queryQualifyPackage q m
qualPackage _other        _m = True
356 357 358 359 360 361

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

sof's avatar
sof committed
362
codeStyle :: PprStyle -> Bool
dterei's avatar
dterei committed
363 364
codeStyle (PprCode _)     = True
codeStyle _               = False
sof's avatar
sof committed
365

366 367
asmStyle :: PprStyle -> Bool
asmStyle (PprCode AsmStyle)  = True
368
asmStyle _other              = False
369

370
dumpStyle :: PprStyle -> Bool
371 372
dumpStyle (PprDump {}) = True
dumpStyle _other       = False
373

374
debugStyle :: PprStyle -> Bool
dterei's avatar
dterei committed
375 376
debugStyle PprDebug = True
debugStyle _other   = False
377

sof's avatar
sof committed
378
userStyle ::  PprStyle -> Bool
379
userStyle (PprUser _ _) = True
380
userStyle _other        = False
sof's avatar
sof committed
381

dterei's avatar
dterei committed
382 383 384 385 386
ifPprDebug :: SDoc -> SDoc        -- Empty for non-debug style
ifPprDebug d = SDoc $ \ctx ->
    case ctx of
        SDC{sdocStyle=PprDebug} -> runSDoc d ctx
        _                       -> Pretty.empty
387

388
printForUser :: DynFlags -> Handle -> PrintUnqualified -> SDoc -> IO ()
Ian Lynagh's avatar
Ian Lynagh committed
389
printForUser dflags handle unqual doc
Ian Lynagh's avatar
Ian Lynagh committed
390
  = Pretty.printDoc PageMode (pprCols dflags) handle
Ian Lynagh's avatar
Ian Lynagh committed
391
      (runSDoc doc (initSDocContext dflags (mkUserStyle unqual AllTheWay)))
392

393 394
printForUserPartWay :: DynFlags -> Handle -> Int -> PrintUnqualified -> SDoc
                    -> IO ()
Ian Lynagh's avatar
Ian Lynagh committed
395
printForUserPartWay dflags handle d unqual doc
Ian Lynagh's avatar
Ian Lynagh committed
396
  = Pretty.printDoc PageMode (pprCols dflags) handle
Ian Lynagh's avatar
Ian Lynagh committed
397
      (runSDoc doc (initSDocContext dflags (mkUserStyle unqual (PartWay d))))
398

399
-- printForC, printForAsm do what they sound like
400
printForC :: DynFlags -> Handle -> SDoc -> IO ()
Ian Lynagh's avatar
Ian Lynagh committed
401
printForC dflags handle doc =
Ian Lynagh's avatar
Ian Lynagh committed
402
  Pretty.printDoc LeftMode (pprCols dflags) handle
Ian Lynagh's avatar
Ian Lynagh committed
403
    (runSDoc doc (initSDocContext dflags (PprCode CStyle)))
404

405
printForAsm :: DynFlags -> Handle -> SDoc -> IO ()
Ian Lynagh's avatar
Ian Lynagh committed
406
printForAsm dflags handle doc =
Ian Lynagh's avatar
Ian Lynagh committed
407
  Pretty.printDoc LeftMode (pprCols dflags) handle
Ian Lynagh's avatar
Ian Lynagh committed
408
    (runSDoc doc (initSDocContext dflags (PprCode AsmStyle)))
409

sof's avatar
sof committed
410 411
pprCode :: CodeStyle -> SDoc -> SDoc
pprCode cs d = withPprStyle (PprCode cs) d
412

413 414 415
mkCodeStyle :: CodeStyle -> PprStyle
mkCodeStyle = PprCode

416 417
-- Can't make SDoc an instance of Show because SDoc is just a function type
-- However, Doc *is* an instance of Show
418
-- showSDoc just blasts it out as a string
Ian Lynagh's avatar
Ian Lynagh committed
419
showSDoc :: DynFlags -> SDoc -> String
420
showSDoc dflags sdoc = renderWithStyle dflags sdoc defaultUserStyle
421

422 423 424 425
-- showSDocUnsafe is unsafe, because `unsafeGlobalDynFlags` might not be
-- initialised yet.
showSDocUnsafe :: SDoc -> String
showSDocUnsafe sdoc = showSDoc unsafeGlobalDynFlags sdoc
426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444

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
445
renderWithStyle :: DynFlags -> SDoc -> PprStyle -> String
446
renderWithStyle dflags sdoc sty
447 448 449
  = let s = Pretty.style{ Pretty.mode = PageMode,
                          Pretty.lineLength = pprCols dflags }
    in Pretty.renderStyle s $ runSDoc sdoc (initSDocContext dflags sty)
450

451 452 453
-- 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.
454
showSDocOneLine :: DynFlags -> SDoc -> String
Ian Lynagh's avatar
Ian Lynagh committed
455
showSDocOneLine dflags d
456 457 458
 = let s = Pretty.style{ Pretty.mode = OneLineMode,
                         Pretty.lineLength = pprCols dflags } in
   Pretty.renderStyle s $ runSDoc d (initSDocContext dflags defaultUserStyle)
459

460
showSDocDumpOneLine :: DynFlags -> SDoc -> String
Ian Lynagh's avatar
Ian Lynagh committed
461
showSDocDumpOneLine dflags d
462 463 464
 = let s = Pretty.style{ Pretty.mode = OneLineMode,
                         Pretty.lineLength = irrelevantNCols } in
   Pretty.renderStyle s $ runSDoc d (initSDocContext dflags defaultDumpStyle)
465 466 467 468

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

470 471 472 473
isEmpty :: DynFlags -> SDoc -> Bool
isEmpty dflags sdoc = Pretty.isEmpty $ runSDoc sdoc dummySDocContext
   where dummySDocContext = initSDocContext dflags PprDebug

474
docToSDoc :: Doc -> SDoc
Thomas Schilling's avatar
Thomas Schilling committed
475
docToSDoc d = SDoc (\_ -> d)
476

477 478
empty    :: SDoc
char     :: Char       -> SDoc
batterseapower's avatar
batterseapower committed
479
text     :: String     -> SDoc
480
ftext    :: FastString -> SDoc
481
ptext    :: LitString  -> SDoc
Ian Lynagh's avatar
Ian Lynagh committed
482
ztext    :: FastZString -> SDoc
483 484 485 486 487 488
int      :: Int        -> SDoc
integer  :: Integer    -> SDoc
float    :: Float      -> SDoc
double   :: Double     -> SDoc
rational :: Rational   -> SDoc

Thomas Schilling's avatar
Thomas Schilling committed
489 490
empty       = docToSDoc $ Pretty.empty
char c      = docToSDoc $ Pretty.char c
491

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

Thomas Schilling's avatar
Thomas Schilling committed
495 496
ftext s     = docToSDoc $ Pretty.ftext s
ptext s     = docToSDoc $ Pretty.ptext s
Ian Lynagh's avatar
Ian Lynagh committed
497
ztext s     = docToSDoc $ Pretty.ztext s
Thomas Schilling's avatar
Thomas Schilling committed
498 499 500 501 502
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
503

Austin Seipp's avatar
Austin Seipp committed
504
parens, braces, brackets, quotes, quote,
505
        paBrackets, doubleQuotes, angleBrackets :: SDoc -> SDoc
506

507 508 509 510 511
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
512
angleBrackets d = char '<' <> d <> char '>'
513
paBrackets d    = ptext (sLit "[:") <> d <> ptext (sLit ":]")
514

515
cparen :: Bool -> SDoc -> SDoc
516
cparen b d = SDoc $ Pretty.maybeParens b . runSDoc d
mnislaih's avatar
mnislaih committed
517

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

533
semi, comma, colon, equals, space, dcolon, underscore, dot, vbar :: SDoc
534 535
arrow, larrow, darrow, arrowt, larrowt, arrowtt, larrowtt :: SDoc
lparen, rparen, lbrack, rbrack, lbrace, rbrace, blankLine :: SDoc
536

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

561 562 563 564 565
forAllLit :: SDoc
forAllLit = unicodeSyntax (char '∀') (ptext (sLit "forall"))

unicodeSyntax :: SDoc -> SDoc -> SDoc
unicodeSyntax unicode plain = sdocWithDynFlags $ \dflags ->
566 567 568
    if useUnicode dflags && useUnicodeSyntax dflags
    then unicode
    else plain
569

570
nest :: Int -> SDoc -> SDoc
batterseapower's avatar
batterseapower committed
571 572 573 574 575 576
-- ^ 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
577
-- ^ Join two 'SDoc' together vertically; if there is
batterseapower's avatar
batterseapower committed
578 579 580
-- no vertical overlap it "dovetails" the two onto one line
($+$) :: SDoc -> SDoc -> SDoc
-- ^ Join two 'SDoc' together vertically
581

Thomas Schilling's avatar
Thomas Schilling committed
582 583 584 585 586
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)
587

batterseapower's avatar
batterseapower committed
588 589 590 591 592 593 594 595 596 597 598 599 600 601 602
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 '<+>'
603 604


Thomas Schilling's avatar
Thomas Schilling committed
605 606 607 608 609 610 611
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]
612

batterseapower's avatar
batterseapower committed
613 614 615 616
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
617
hang d1 n d2   = SDoc $ \sty -> Pretty.hang (runSDoc d1 sty) n (runSDoc d2 sty)
618

619 620 621 622 623 624
-- | 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
625 626 627
punctuate :: SDoc   -- ^ The punctuation
          -> [SDoc] -- ^ The list that will have punctuation added between every adjacent pair of elements
          -> [SDoc] -- ^ Punctuated list
628
punctuate _ []     = []
629
punctuate p (d:ds) = go d ds
dterei's avatar
dterei committed
630 631 632
                   where
                     go d [] = [d]
                     go d (e:es) = (d <> p) : go e es
633 634 635 636 637 638 639

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

ppUnless True  _   = empty
ppUnless False doc = doc
640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655

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

Thomas Schilling's avatar
Thomas Schilling committed
658 659
colBinder :: PprColour
colBinder = PprColour "\27[32m"
660 661 662 663 664 665 666 667 668

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
669 670 671 672
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
673 674 675 676 677 678 679

bold :: SDoc -> SDoc
bold = coloured colBold

keyword :: SDoc -> SDoc
keyword = bold

Austin Seipp's avatar
Austin Seipp committed
680 681 682
{-
************************************************************************
*                                                                      *
sof's avatar
sof committed
683
\subsection[Outputable-class]{The @Outputable@ class}
Austin Seipp's avatar
Austin Seipp committed
684 685 686
*                                                                      *
************************************************************************
-}
sof's avatar
sof committed
687

batterseapower's avatar
batterseapower committed
688
-- | Class designating that some type has an 'SDoc' representation
sof's avatar
sof committed
689
class Outputable a where
dterei's avatar
dterei committed
690 691 692 693 694
        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
695

dterei's avatar
dterei committed
696 697
        ppr = pprPrec 0
        pprPrec _ = ppr
sof's avatar
sof committed
698

699 700 701
instance Outputable Char where
    ppr c = text [c]

702
instance Outputable Bool where
Ian Lynagh's avatar
Ian Lynagh committed
703 704
    ppr True  = ptext (sLit "True")
    ppr False = ptext (sLit "False")
705

706 707 708 709 710
instance Outputable Ordering where
    ppr LT = text "LT"
    ppr EQ = text "EQ"
    ppr GT = text "GT"

711 712 713 714 715 716
instance Outputable Int32 where
   ppr n = integer $ fromIntegral n

instance Outputable Int64 where
   ppr n = integer $ fromIntegral n

sof's avatar
sof committed
717
instance Outputable Int where
718
    ppr n = int n
sof's avatar
sof committed
719

720
instance Outputable Word16 where
721
    ppr n = integer $ fromIntegral n
722

723
instance Outputable Word32 where
724
    ppr n = integer $ fromIntegral n
725

726
instance Outputable Word where
727
    ppr n = integer $ fromIntegral n
728

729
instance Outputable () where
730
    ppr _ = text "()"
731

732
instance (Outputable a) => Outputable [a] where
733
    ppr xs = brackets (fsep (punctuate comma (map ppr xs)))
734

735 736 737
instance (Outputable a) => Outputable (Set a) where
    ppr s = braces (fsep (punctuate comma (map ppr (Set.toList s))))

738
instance (Outputable a, Outputable b) => Outputable (a, b) where
739
    ppr (x,y) = parens (sep [ppr x <> comma, ppr y])
740

741
instance Outputable a => Outputable (Maybe a) where
742 743
    ppr Nothing = ptext (sLit "Nothing")
    ppr (Just x) = ptext (sLit "Just") <+> ppr x
744

745
instance (Outputable a, Outputable b) => Outputable (Either a b) where
746 747
    ppr (Left x)  = ptext (sLit "Left")  <+> ppr x
    ppr (Right y) = ptext (sLit "Right") <+> ppr y
748

749 750
-- ToDo: may not be used
instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c) where
751
    ppr (x,y,z) =
752
      parens (sep [ppr x <> comma,
dterei's avatar
dterei committed
753 754
                   ppr y <> comma,
                   ppr z ])
755

756
instance (Outputable a, Outputable b, Outputable c, Outputable d) =>
dterei's avatar
dterei committed
757
         Outputable (a, b, c, d) where
758 759
    ppr (a,b,c,d) =
      parens (sep [ppr a <> comma,
dterei's avatar
dterei committed
760 761 762
                   ppr b <> comma,
                   ppr c <> comma,
                   ppr d])
763 764

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