Outputable.hs 39.2 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,
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, 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
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 )
114
#if __GLASGOW_HASKELL__ > 710
115 116
import GHC.Stack
import GHC.Exception
117
#endif
118

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

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

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

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

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

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

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


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

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

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

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

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

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

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

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

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

207
neverQualifyModules :: QueryQualifyModule
208 209
neverQualifyModules _ = False

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

228 229
defaultUserStyle, defaultDumpStyle :: PprStyle

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

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

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

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

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

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

Austin Seipp's avatar
Austin Seipp committed
259
{-
sof's avatar
sof committed
260 261 262 263
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
264

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

Austin Seipp's avatar
Austin Seipp committed
268 269
************************************************************************
*                                                                      *
270
\subsection{The @SDoc@ data type}
Austin Seipp's avatar
Austin Seipp committed
271 272 273
*                                                                      *
************************************************************************
-}
274

275
newtype SDoc = SDoc { runSDoc :: SDocContext -> Doc }
276 277 278 279 280

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

Ian Lynagh's avatar
Ian Lynagh committed
284 285
initSDocContext :: DynFlags -> PprStyle -> SDocContext
initSDocContext dflags sty = SDC
286 287
  { sdocStyle = sty
  , sdocLastColour = colReset
Ian Lynagh's avatar
Ian Lynagh committed
288
  , sdocDynFlags = dflags
289
  }
290 291

withPprStyle :: PprStyle -> SDoc -> SDoc
292
withPprStyle sty d = SDoc $ \ctxt -> runSDoc d ctxt{sdocStyle=sty}
293

Ian Lynagh's avatar
Ian Lynagh committed
294 295
withPprStyleDoc :: DynFlags -> PprStyle -> SDoc -> Doc
withPprStyleDoc dflags sty d = runSDoc d (initSDocContext dflags sty)
296

297
pprDeeper :: SDoc -> SDoc
298 299 300 301 302
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
303

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

320
pprSetDepth :: Depth -> SDoc -> SDoc
dterei's avatar
dterei committed
321 322 323 324 325 326
pprSetDepth depth doc = SDoc $ \ctx ->
    case ctx of
        SDC{sdocStyle=PprUser q _} ->
            runSDoc doc ctx{sdocStyle = PprUser q depth}
        _ ->
            runSDoc doc ctx
327

328
getPprStyle :: (PprStyle -> SDoc) -> SDoc
329
getPprStyle df = SDoc $ \ctx -> runSDoc (df (sdocStyle ctx)) ctx
Ian Lynagh's avatar
Ian Lynagh committed
330 331 332 333 334 335

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

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

337
qualName :: PprStyle -> QueryQualifyName
338
qualName (PprUser q _)  mod occ = queryQualifyName q mod occ
339
qualName (PprDump q)    mod occ = queryQualifyName q mod occ
340
qualName _other         mod _   = NameQual (moduleName mod)
Simon Marlow's avatar
Simon Marlow committed
341

342
qualModule :: PprStyle -> QueryQualifyModule
343
qualModule (PprUser q _)  m = queryQualifyModule q m
344 345
qualModule (PprDump q)    m = queryQualifyModule q m
qualModule _other        _m = True
346

347 348
qualPackage :: PprStyle -> QueryQualifyPackage
qualPackage (PprUser q _)  m = queryQualifyPackage q m
349 350
qualPackage (PprDump q)    m = queryQualifyPackage q m
qualPackage _other        _m = True
351 352 353 354 355 356

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

sof's avatar
sof committed
357
codeStyle :: PprStyle -> Bool
dterei's avatar
dterei committed
358 359
codeStyle (PprCode _)     = True
codeStyle _               = False
sof's avatar
sof committed
360

361 362
asmStyle :: PprStyle -> Bool
asmStyle (PprCode AsmStyle)  = True
363
asmStyle _other              = False
364

365
dumpStyle :: PprStyle -> Bool
366 367
dumpStyle (PprDump {}) = True
dumpStyle _other       = False
368

369
debugStyle :: PprStyle -> Bool
dterei's avatar
dterei committed
370 371
debugStyle PprDebug = True
debugStyle _other   = False
372

sof's avatar
sof committed
373
userStyle ::  PprStyle -> Bool
374
userStyle (PprUser _ _) = True
375
userStyle _other        = False
sof's avatar
sof committed
376

dterei's avatar
dterei committed
377 378 379 380 381
ifPprDebug :: SDoc -> SDoc        -- Empty for non-debug style
ifPprDebug d = SDoc $ \ctx ->
    case ctx of
        SDC{sdocStyle=PprDebug} -> runSDoc d ctx
        _                       -> Pretty.empty
382

383
printForUser :: DynFlags -> Handle -> PrintUnqualified -> SDoc -> IO ()
Ian Lynagh's avatar
Ian Lynagh committed
384
printForUser dflags handle unqual doc
Ian Lynagh's avatar
Ian Lynagh committed
385
  = Pretty.printDoc PageMode (pprCols dflags) handle
Ian Lynagh's avatar
Ian Lynagh committed
386
      (runSDoc doc (initSDocContext dflags (mkUserStyle unqual AllTheWay)))
387

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

394
-- printForC, printForAsm do what they sound like
395
printForC :: DynFlags -> Handle -> SDoc -> IO ()
Ian Lynagh's avatar
Ian Lynagh committed
396
printForC dflags handle doc =
Ian Lynagh's avatar
Ian Lynagh committed
397
  Pretty.printDoc LeftMode (pprCols dflags) handle
Ian Lynagh's avatar
Ian Lynagh committed
398
    (runSDoc doc (initSDocContext dflags (PprCode CStyle)))
399

400
printForAsm :: DynFlags -> Handle -> SDoc -> IO ()
Ian Lynagh's avatar
Ian Lynagh committed
401
printForAsm 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 AsmStyle)))
404

sof's avatar
sof committed
405 406
pprCode :: CodeStyle -> SDoc -> SDoc
pprCode cs d = withPprStyle (PprCode cs) d
407

408 409 410
mkCodeStyle :: CodeStyle -> PprStyle
mkCodeStyle = PprCode

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

417 418 419 420
-- showSDocUnsafe is unsafe, because `unsafeGlobalDynFlags` might not be
-- initialised yet.
showSDocUnsafe :: SDoc -> String
showSDocUnsafe sdoc = showSDoc unsafeGlobalDynFlags sdoc
421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439

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

440
renderWithStyle :: DynFlags -> SDoc -> PprStyle -> String
441
renderWithStyle dflags sdoc sty
442 443 444
  = let s = Pretty.style{ Pretty.mode = PageMode,
                          Pretty.lineLength = pprCols dflags }
    in Pretty.renderStyle s $ runSDoc sdoc (initSDocContext dflags sty)
445

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

455
showSDocDumpOneLine :: DynFlags -> SDoc -> String
Ian Lynagh's avatar
Ian Lynagh committed
456
showSDocDumpOneLine dflags d
457 458 459
 = let s = Pretty.style{ Pretty.mode = OneLineMode,
                         Pretty.lineLength = irrelevantNCols } in
   Pretty.renderStyle s $ runSDoc d (initSDocContext dflags defaultDumpStyle)
460 461 462 463

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

465 466 467 468
isEmpty :: DynFlags -> SDoc -> Bool
isEmpty dflags sdoc = Pretty.isEmpty $ runSDoc sdoc dummySDocContext
   where dummySDocContext = initSDocContext dflags PprDebug

469
docToSDoc :: Doc -> SDoc
470
docToSDoc d = SDoc (\_ -> d)
471

472 473
empty    :: SDoc
char     :: Char       -> SDoc
batterseapower's avatar
batterseapower committed
474
text     :: String     -> SDoc
475
ftext    :: FastString -> SDoc
476
ptext    :: LitString  -> SDoc
Ian Lynagh's avatar
Ian Lynagh committed
477
ztext    :: FastZString -> SDoc
478 479 480 481 482 483
int      :: Int        -> SDoc
integer  :: Integer    -> SDoc
float    :: Float      -> SDoc
double   :: Double     -> SDoc
rational :: Rational   -> SDoc

484 485
empty       = docToSDoc $ Pretty.empty
char c      = docToSDoc $ Pretty.char c
486

487
text s      = docToSDoc $ Pretty.text s
488 489
{-# INLINE text #-}   -- Inline so that the RULE Pretty.text will fire

490 491
ftext s     = docToSDoc $ Pretty.ftext s
ptext s     = docToSDoc $ Pretty.ptext s
Ian Lynagh's avatar
Ian Lynagh committed
492
ztext s     = docToSDoc $ Pretty.ztext s
493 494 495 496 497
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
498

Austin Seipp's avatar
Austin Seipp committed
499
parens, braces, brackets, quotes, quote,
500
        paBrackets, doubleQuotes, angleBrackets :: SDoc -> SDoc
501

502 503 504 505 506
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
507
angleBrackets d = char '<' <> d <> char '>'
508
paBrackets d    = ptext (sLit "[:") <> d <> ptext (sLit ":]")
509

510
cparen :: Bool -> SDoc -> SDoc
511
cparen b d = SDoc $ Pretty.maybeParens b . runSDoc d
mnislaih's avatar
mnislaih committed
512

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

528
semi, comma, colon, equals, space, dcolon, underscore, dot, vbar :: SDoc
529 530
arrow, larrow, darrow, arrowt, larrowt, arrowtt, larrowtt :: SDoc
lparen, rparen, lbrack, rbrack, lbrace, rbrace, blankLine :: SDoc
531

532
blankLine  = docToSDoc $ Pretty.ptext (sLit "")
533 534 535 536
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 "=>"))
537 538
arrowt     = unicodeSyntax (char '⤚') (docToSDoc $ Pretty.ptext (sLit ">-"))
larrowt    = unicodeSyntax (char '⤙') (docToSDoc $ Pretty.ptext (sLit "-<"))
539 540
arrowtt    = unicodeSyntax (char '⤜') (docToSDoc $ Pretty.ptext (sLit ">>-"))
larrowtt   = unicodeSyntax (char '⤛') (docToSDoc $ Pretty.ptext (sLit "-<<"))
541 542 543 544 545 546 547
semi       = docToSDoc $ Pretty.semi
comma      = docToSDoc $ Pretty.comma
colon      = docToSDoc $ Pretty.colon
equals     = docToSDoc $ Pretty.equals
space      = docToSDoc $ Pretty.space
underscore = char '_'
dot        = char '.'
548
vbar       = char '|'
549 550 551 552 553 554
lparen     = docToSDoc $ Pretty.lparen
rparen     = docToSDoc $ Pretty.rparen
lbrack     = docToSDoc $ Pretty.lbrack
rbrack     = docToSDoc $ Pretty.rbrack
lbrace     = docToSDoc $ Pretty.lbrace
rbrace     = docToSDoc $ Pretty.rbrace
555

556 557 558 559 560
forAllLit :: SDoc
forAllLit = unicodeSyntax (char '∀') (ptext (sLit "forall"))

unicodeSyntax :: SDoc -> SDoc -> SDoc
unicodeSyntax unicode plain = sdocWithDynFlags $ \dflags ->
561 562 563
    if useUnicode dflags && useUnicodeSyntax dflags
    then unicode
    else plain
564

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

577 578 579 580 581
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)
582

batterseapower's avatar
batterseapower committed
583 584 585 586 587 588 589 590 591 592 593 594 595 596 597
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 '<+>'
598 599


600 601 602 603 604 605 606
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]
607

batterseapower's avatar
batterseapower committed
608 609 610 611
hang :: SDoc  -- ^ The header
      -> Int  -- ^ Amount to indent the hung body
      -> SDoc -- ^ The hung body, indented and placed below the header
      -> SDoc
612
hang d1 n d2   = SDoc $ \sty -> Pretty.hang (runSDoc d1 sty) n (runSDoc d2 sty)
613

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

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

ppUnless True  _   = empty
ppUnless False doc = doc
635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650

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

653 654
colBinder :: PprColour
colBinder = PprColour "\27[32m"
655 656 657 658 659 660 661 662 663

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
664 665 666 667
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
668 669 670 671 672 673 674

bold :: SDoc -> SDoc
bold = coloured colBold

keyword :: SDoc -> SDoc
keyword = bold

Austin Seipp's avatar
Austin Seipp committed
675 676 677
{-
************************************************************************
*                                                                      *
sof's avatar
sof committed
678
\subsection[Outputable-class]{The @Outputable@ class}
Austin Seipp's avatar
Austin Seipp committed
679 680 681
*                                                                      *
************************************************************************
-}
sof's avatar
sof committed
682

batterseapower's avatar
batterseapower committed
683
-- | Class designating that some type has an 'SDoc' representation
sof's avatar
sof committed
684
class Outputable a where
dterei's avatar
dterei committed
685 686 687 688 689
        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
690

dterei's avatar
dterei committed
691 692
        ppr = pprPrec 0
        pprPrec _ = ppr
sof's avatar
sof committed
693

694 695 696
instance Outputable Char where
    ppr c = text [c]

697
instance Outputable Bool where
698 699
    ppr True  = ptext (sLit "True")
    ppr False = ptext (sLit "False")
700

701 702 703 704 705 706
instance Outputable Int32 where
   ppr n = integer $ fromIntegral n

instance Outputable Int64 where
   ppr n = integer $ fromIntegral n

sof's avatar
sof committed
707
instance Outputable Int where
708
    ppr n = int n
sof's avatar
sof committed
709

710
instance Outputable Word16 where
711
    ppr n = integer $ fromIntegral n
712

713
instance Outputable Word32 where
714
    ppr n = integer $ fromIntegral n
715

716
instance Outputable Word where
717
    ppr n = integer $ fromIntegral n
718

719
instance Outputable () where
720
    ppr _ = text "()"
721

722
instance (Outputable a) => Outputable [a] where
723
    ppr xs = brackets (fsep (punctuate comma (map ppr xs)))
724

725 726 727
instance (Outputable a) => Outputable (Set a) where
    ppr s = braces (fsep (punctuate comma (map ppr (Set.toList s))))

728
instance (Outputable a, Outputable b) => Outputable (a, b) where
729
    ppr (x,y) = parens (sep [ppr x <> comma, ppr y])
730

731
instance Outputable a => Outputable (Maybe a) where
732 733
    ppr Nothing = ptext (sLit "Nothing")
    ppr (Just x) = ptext (sLit "Just") <+> ppr x
734

735
instance (Outputable a, Outputable b) => Outputable (Either a b) where
736 737
    ppr (Left x)  = ptext (sLit "Left")  <+> ppr x
    ppr (Right y) = ptext (sLit "Right") <+> ppr y
738

739 740
-- ToDo: may not be used
instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c) where
741
    ppr (x,y,z) =
742
      parens (sep [ppr x <> comma,
dterei's avatar
dterei committed
743 744
                   ppr y <> comma,
                   ppr z ])
745

746
instance (Outputable a, Outputable b, Outputable c, Outputable d) =>
dterei's avatar
dterei committed
747
         Outputable (a, b, c, d) where
748 749
    ppr (a,b,c,d) =
      parens (sep [ppr a <> comma,
dterei's avatar
dterei committed
750 751 752
                   ppr b <> comma,
                   ppr c <> comma,
                   ppr d])
753 754

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

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

instance (Outputable a, Outputable b, Outputable c, Outputable d, Outputable e, Outputable f, Outputable g) =>
dterei's avatar
dterei committed
774
         Outputable (a, b, c, d, e, f, g) where
775 776
    ppr (a,b,c,d,e,f,g) =
      parens (sep [ppr a <> comma,
dterei's avatar
dterei committed
777 778 779 780 781 782
                   ppr b <> comma,
                   ppr c <> comma,
                   ppr d <> comma,
                   ppr e <> comma,
                   ppr f <> comma,
                   ppr g])
783

784
instance Outputable FastString where
dterei's avatar
dterei committed
785 786
    ppr fs = ftext fs           -- Prints an unadorned string,
                                -- no double quotes or anything
787

788
instance (Outputable key, Outputable elt) => Outputable (M.Map key elt) where
789
    ppr m = ppr (M.toList m)
790 791
instance (Outputable elt) => Outputable (IM.IntMap elt) where
    ppr m = ppr (IM.toList m)
792 793 794

instance Outputable Fingerprint where
    ppr (Fingerprint w1 w2) = text (printf "%016x%016x" w1 w2)
795

796 797 798 799
instance Outputable a => Outputable (SCC a) where
   ppr (AcyclicSCC v) = text "NONREC" $$ (nest 3 (ppr v))
   ppr (CyclicSCC vs) = text "REC" $$ (nest 3 (vcat (map ppr vs)))

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

batterseapower's avatar
batterseapower committed
808 809 810
-- | 'BindingSite' is used to tell the thing that prints binder what
-- language construct is binding the identifier.  This can be used
-- to decide how much info to print.
811 812
data BindingSite = LambdaBind | CaseBind | LetBind

batterseapower's avatar
batterseapower committed
813 814
-- | When we print a binder, we often want to print its type too.
-- The @OutputableBndr@ class encapsulates this idea.
815 816
class Outputable a => OutputableBndr a where
   pprBndr :: BindingSite -> a -> SDoc
817
   pprBndr _b x = ppr x
818 819

   pprPrefixOcc, pprInfixOcc :: a -> SDoc
Austin Seipp's avatar
Austin Seipp committed
820
      -- Print an occurrence of the name, suitable either in the
821 822
      -- prefix position of an application, thus   (f a b) or  ((+) x)
      -- or infix position,                 thus   (a `f` b) or  (x + y)
823

Austin Seipp's avatar
Austin Seipp committed
824 825 826
{-
************************************************************************
*                                                                      *
827
\subsection{Random printing helpers}
Austin Seipp's avatar
Austin Seipp committed
828 829 830
*                                                                      *
************************************************************************
-}
831

832
-- We have 31-bit Chars and will simply use Show instances of Char and String.
batterseapower's avatar
batterseapower committed
833 834

-- | Special combinator for showing character literals.
835 836 837
pprHsChar :: Char -> SDoc
pprHsChar c | c > '\x10ffff' = char '\\' <> text (show (fromIntegral (ord c) :: Word32))
            | otherwise      = text (show c)
838

batterseapower's avatar
batterseapower committed
839
-- | Special combinator for showing string literals.
840
pprHsString :: FastString -> SDoc
841
pprHsString fs = vcat (map text (showMultiLineString (unpackFS fs)))
842

843
-- | Special combinator for showing bytestring literals.
844 845
pprHsBytes :: ByteString -> SDoc
pprHsBytes bs = let escaped = concatMap escape $ BS.unpack bs
846 847 848 849 850 851 852
                in vcat (map text (showMultiLineString escaped)) <> char '#'
    where escape :: Word8 -> String
          escape w = let c = chr (fromIntegral w)
                     in if isAscii c
                        then [c]
                        else '\\' : show w

853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873
-- Postfix modifiers for unboxed literals.
-- See Note [Printing of literals in Core] in `basicTypes/Literal.hs`.
primCharSuffix, primFloatSuffix, primIntSuffix :: SDoc
primDoubleSuffix, primWordSuffix, primInt64Suffix, primWord64Suffix :: SDoc
primCharSuffix   = char '#'
primFloatSuffix  = char '#'
primIntSuffix    = char '#'
primDoubleSuffix = text "##"
primWordSuffix   = text "##"
primInt64Suffix  = text "L#"
primWord64Suffix = text "L##"

-- | Special combinator for showing unboxed literals.
pprPrimChar :: Char -> SDoc
pprPrimInt, pprPrimWord, pprPrimInt64, pprPrimWord64 :: Integer -> SDoc
pprPrimChar c   = pprHsChar c <> primCharSuffix
pprPrimInt i    = integer i   <> primIntSuffix
pprPrimWord w   = integer w   <> primWordSuffix
pprPrimInt64 i  = integer i   <> primInt64Suffix
pprPrimWord64 w = integer w   <> primWord64Suffix

874 875 876 877 878
---------------------
-- Put a name in parens if it's an operator
pprPrefixVar :: Bool -> SDoc -> SDoc
pprPrefixVar is_operator pp_v
  | is_operator = parens pp_v
dterei's avatar
dterei committed
879
  | otherwise   = pp_v
880 881 882

-- Put a name in backquotes if it's not an operator
pprInfixVar :: Bool -> SDoc -> SDoc
dterei's avatar
dterei committed
883
pprInfixVar is_operator pp_v
884 885 886 887
  | is_operator = pp_v
  | otherwise   = char '`' <> pp_v <> char '`'

---------------------
888 889
pprFastFilePath :: FastString -> SDoc
pprFastFilePath path = text $ normalise $ unpackFS path
sof's avatar
sof committed
890

Austin Seipp's avatar
Austin Seipp committed
891 892 893
{-
************************************************************************
*                                                                      *
sof's avatar
sof committed
894
\subsection{Other helper functions}
Austin Seipp's avatar
Austin Seipp committed
895 896 897
*                                                                      *
************************************************************************
-}
sof's avatar
sof committed
898

batterseapower's avatar
batterseapower committed
899 900 901 902
pprWithCommas :: (a -> SDoc) -- ^ The pretty printing function to use
              -> [a]         -- ^ The things to be pretty printed
              -> SDoc        -- ^ 'SDoc' where the things have been pretty printed,
                             -- comma-separated and finally packed into a paragraph.
903
pprWithCommas pp xs = fsep (punctuate comma (map pp xs))
904

Gabor Greif's avatar
Gabor Greif committed
905
-- | Returns the separated concatenation of the pretty printed things.
906
interppSP  :: Outputable a => [a] -> SDoc
907
interppSP  xs = sep (map ppr xs)
sof's avatar
sof committed
908

Gabor Greif's avatar
Gabor Greif committed
909
-- | Returns the comma-separated concatenation of the pretty printed things.
910
interpp'SP :: Outputable a => [a] -> SDoc
911
interpp'SP xs = sep (punctuate comma (map ppr xs))
912

Gabor Greif's avatar
Gabor Greif committed