Export alwaysQualifyPackages and neverQualifyPackages.
[ghc.git] / compiler / utils / Outputable.hs
1 {-
2 (c) The University of Glasgow 2006-2012
3 (c) The GRASP Project, Glasgow University, 1992-1998
4 -}
5
6 -- | This module defines classes and functions for pretty-printing. It also
7 -- exports a number of helpful debugging and other utilities such as 'trace' and 'panic'.
8 --
9 -- The interface to this module is very similar to the standard Hughes-PJ pretty printing
10 -- module, except that it exports a number of additional functions that are rarely used,
11 -- and works over the 'SDoc' type.
12 module Outputable (
13 -- * Type classes
14 Outputable(..), OutputableBndr(..),
15
16 -- * Pretty printing combinators
17 SDoc, runSDoc, initSDocContext,
18 docToSDoc,
19 interppSP, interpp'SP, pprQuotedList, pprWithCommas, quotedListWithOr,
20 empty, nest,
21 char,
22 text, ftext, ptext, ztext,
23 int, intWithCommas, integer, float, double, rational,
24 parens, cparen, brackets, braces, quotes, quote,
25 doubleQuotes, angleBrackets, paBrackets,
26 semi, comma, colon, dcolon, space, equals, dot,
27 arrow, larrow, darrow, arrowt, larrowt, arrowtt, larrowtt,
28 lparen, rparen, lbrack, rbrack, lbrace, rbrace, underscore,
29 blankLine, forAllLit,
30 (<>), (<+>), hcat, hsep,
31 ($$), ($+$), vcat,
32 sep, cat,
33 fsep, fcat,
34 hang, punctuate, ppWhen, ppUnless,
35 speakNth, speakNTimes, speakN, speakNOf, plural, isOrAre,
36
37 coloured, PprColour, colType, colCoerc, colDataCon,
38 colBinder, bold, keyword,
39
40 -- * Converting 'SDoc' into strings and outputing it
41 printForC, printForAsm, printForUser, printForUserPartWay,
42 pprCode, mkCodeStyle,
43 showSDoc, showSDocUnsafe, showSDocOneLine,
44 showSDocForUser, showSDocDebug, showSDocDump, showSDocDumpOneLine,
45 showSDocUnqual, showPpr,
46 renderWithStyle,
47
48 pprInfixVar, pprPrefixVar,
49 pprHsChar, pprHsString, pprHsBytes,
50
51 primFloatSuffix, primDoubleSuffix,
52 pprPrimChar, pprPrimInt, pprPrimWord, pprPrimInt64, pprPrimWord64,
53
54 pprFastFilePath,
55
56 -- * Controlling the style in which output is printed
57 BindingSite(..),
58
59 PprStyle, CodeStyle(..), PrintUnqualified(..),
60 QueryQualifyName, QueryQualifyModule, QueryQualifyPackage,
61 reallyAlwaysQualify, reallyAlwaysQualifyNames,
62 alwaysQualify, alwaysQualifyNames, alwaysQualifyModules,
63 neverQualify, neverQualifyNames, neverQualifyModules,
64 alwaysQualifyPackages, neverQualifyPackages,
65 QualifyName(..), queryQual,
66 sdocWithDynFlags, sdocWithPlatform,
67 getPprStyle, withPprStyle, withPprStyleDoc,
68 pprDeeper, pprDeeperList, pprSetDepth,
69 codeStyle, userStyle, debugStyle, dumpStyle, asmStyle,
70 ifPprDebug, qualName, qualModule, qualPackage,
71 mkErrStyle, defaultErrStyle, defaultDumpStyle, mkDumpStyle, defaultUserStyle,
72 mkUserStyle, cmdlineParserStyle, Depth(..),
73
74 -- * Error handling and debugging utilities
75 pprPanic, pprSorry, assertPprPanic, pprPanicFastInt, pprPgmError,
76 pprTrace, warnPprTrace,
77 trace, pgmError, panic, sorry, panicFastInt, assertPanic,
78 pprDebugAndThen,
79 ) where
80
81 import {-# SOURCE #-} DynFlags( DynFlags,
82 targetPlatform, pprUserLength, pprCols,
83 useUnicode, useUnicodeSyntax,
84 unsafeGlobalDynFlags )
85 import {-# SOURCE #-} Module( PackageKey, Module, ModuleName, moduleName )
86 import {-# SOURCE #-} OccName( OccName )
87 import {-# SOURCE #-} StaticFlags( opt_PprStyle_Debug, opt_NoDebugOutput )
88
89 import FastString
90 import FastTypes
91 import qualified Pretty
92 import Util
93 import Platform
94 import Pretty ( Doc, Mode(..) )
95 import Panic
96
97 import Data.ByteString (ByteString)
98 import qualified Data.ByteString as BS
99 import Data.Char
100 import qualified Data.Map as M
101 import Data.Int
102 import qualified Data.IntMap as IM
103 import Data.Set (Set)
104 import qualified Data.Set as Set
105 import Data.Word
106 import System.IO ( Handle )
107 import System.FilePath
108 import Text.Printf
109 import Data.Graph (SCC(..))
110
111 import GHC.Fingerprint
112 import GHC.Show ( showMultiLineString )
113
114 {-
115 ************************************************************************
116 * *
117 \subsection{The @PprStyle@ data type}
118 * *
119 ************************************************************************
120 -}
121
122 data PprStyle
123 = PprUser PrintUnqualified Depth
124 -- Pretty-print in a way that will make sense to the
125 -- ordinary user; must be very close to Haskell
126 -- syntax, etc.
127 -- Assumes printing tidied code: non-system names are
128 -- printed without uniques.
129
130 | PprDump PrintUnqualified
131 -- For -ddump-foo; less verbose than PprDebug, but more than PprUser
132 -- Does not assume tidied code: non-external names
133 -- are printed with uniques.
134
135 | PprDebug -- Full debugging output
136
137 | PprCode CodeStyle
138 -- Print code; either C or assembler
139
140 data CodeStyle = CStyle -- The format of labels differs for C and assembler
141 | AsmStyle
142
143 data Depth = AllTheWay
144 | PartWay Int -- 0 => stop
145
146
147 -- -----------------------------------------------------------------------------
148 -- Printing original names
149
150 -- | When printing code that contains original names, we need to map the
151 -- original names back to something the user understands. This is the
152 -- purpose of the triple of functions that gets passed around
153 -- when rendering 'SDoc'.
154 data PrintUnqualified = QueryQualify {
155 queryQualifyName :: QueryQualifyName,
156 queryQualifyModule :: QueryQualifyModule,
157 queryQualifyPackage :: QueryQualifyPackage
158 }
159
160 -- | given an /original/ name, this function tells you which module
161 -- name it should be qualified with when printing for the user, if
162 -- any. For example, given @Control.Exception.catch@, which is in scope
163 -- as @Exception.catch@, this fuction will return @Just "Exception"@.
164 -- Note that the return value is a ModuleName, not a Module, because
165 -- in source code, names are qualified by ModuleNames.
166 type QueryQualifyName = Module -> OccName -> QualifyName
167
168 -- | For a given module, we need to know whether to print it with
169 -- a package name to disambiguate it.
170 type QueryQualifyModule = Module -> Bool
171
172 -- | For a given package, we need to know whether to print it with
173 -- the package key to disambiguate it.
174 type QueryQualifyPackage = PackageKey -> Bool
175
176 -- See Note [Printing original names] in HscTypes
177 data QualifyName -- Given P:M.T
178 = NameUnqual -- It's in scope unqualified as "T"
179 -- OR nothing called "T" is in scope
180
181 | NameQual ModuleName -- It's in scope qualified as "X.T"
182
183 | NameNotInScope1 -- It's not in scope at all, but M.T is not bound
184 -- in the current scope, so we can refer to it as "M.T"
185
186 | NameNotInScope2 -- It's not in scope at all, and M.T is already bound in
187 -- the current scope, so we must refer to it as "P:M.T"
188
189 reallyAlwaysQualifyNames :: QueryQualifyName
190 reallyAlwaysQualifyNames _ _ = NameNotInScope2
191
192 -- | NB: This won't ever show package IDs
193 alwaysQualifyNames :: QueryQualifyName
194 alwaysQualifyNames m _ = NameQual (moduleName m)
195
196 neverQualifyNames :: QueryQualifyName
197 neverQualifyNames _ _ = NameUnqual
198
199 alwaysQualifyModules :: QueryQualifyModule
200 alwaysQualifyModules _ = True
201
202 neverQualifyModules :: QueryQualifyModule
203 neverQualifyModules _ = False
204
205 alwaysQualifyPackages :: QueryQualifyPackage
206 alwaysQualifyPackages _ = True
207
208 neverQualifyPackages :: QueryQualifyPackage
209 neverQualifyPackages _ = False
210
211 reallyAlwaysQualify, alwaysQualify, neverQualify :: PrintUnqualified
212 reallyAlwaysQualify
213 = QueryQualify reallyAlwaysQualifyNames
214 alwaysQualifyModules
215 alwaysQualifyPackages
216 alwaysQualify = QueryQualify alwaysQualifyNames
217 alwaysQualifyModules
218 alwaysQualifyPackages
219 neverQualify = QueryQualify neverQualifyNames
220 neverQualifyModules
221 neverQualifyPackages
222
223 defaultUserStyle, defaultDumpStyle :: PprStyle
224
225 defaultUserStyle = mkUserStyle neverQualify AllTheWay
226 -- Print without qualifiers to reduce verbosity, unless -dppr-debug
227
228 defaultDumpStyle | opt_PprStyle_Debug = PprDebug
229 | otherwise = PprDump neverQualify
230
231 mkDumpStyle :: PrintUnqualified -> PprStyle
232 mkDumpStyle print_unqual | opt_PprStyle_Debug = PprDebug
233 | otherwise = PprDump print_unqual
234
235 defaultErrStyle :: DynFlags -> PprStyle
236 -- Default style for error messages, when we don't know PrintUnqualified
237 -- It's a bit of a hack because it doesn't take into account what's in scope
238 -- Only used for desugarer warnings, and typechecker errors in interface sigs
239 -- NB that -dppr-debug will still get into PprDebug style
240 defaultErrStyle dflags = mkErrStyle dflags neverQualify
241
242 -- | Style for printing error messages
243 mkErrStyle :: DynFlags -> PrintUnqualified -> PprStyle
244 mkErrStyle dflags qual = mkUserStyle qual (PartWay (pprUserLength dflags))
245
246 cmdlineParserStyle :: PprStyle
247 cmdlineParserStyle = mkUserStyle alwaysQualify AllTheWay
248
249 mkUserStyle :: PrintUnqualified -> Depth -> PprStyle
250 mkUserStyle unqual depth
251 | opt_PprStyle_Debug = PprDebug
252 | otherwise = PprUser unqual depth
253
254 {-
255 Orthogonal to the above printing styles are (possibly) some
256 command-line flags that affect printing (often carried with the
257 style). The most likely ones are variations on how much type info is
258 shown.
259
260 The following test decides whether or not we are actually generating
261 code (either C or assembly), or generating interface files.
262
263 ************************************************************************
264 * *
265 \subsection{The @SDoc@ data type}
266 * *
267 ************************************************************************
268 -}
269
270 newtype SDoc = SDoc { runSDoc :: SDocContext -> Doc }
271
272 data SDocContext = SDC
273 { sdocStyle :: !PprStyle
274 , sdocLastColour :: !PprColour
275 -- ^ The most recently used colour. This allows nesting colours.
276 , sdocDynFlags :: !DynFlags
277 }
278
279 initSDocContext :: DynFlags -> PprStyle -> SDocContext
280 initSDocContext dflags sty = SDC
281 { sdocStyle = sty
282 , sdocLastColour = colReset
283 , sdocDynFlags = dflags
284 }
285
286 withPprStyle :: PprStyle -> SDoc -> SDoc
287 withPprStyle sty d = SDoc $ \ctxt -> runSDoc d ctxt{sdocStyle=sty}
288
289 withPprStyleDoc :: DynFlags -> PprStyle -> SDoc -> Doc
290 withPprStyleDoc dflags sty d = runSDoc d (initSDocContext dflags sty)
291
292 pprDeeper :: SDoc -> SDoc
293 pprDeeper d = SDoc $ \ctx -> case ctx of
294 SDC{sdocStyle=PprUser _ (PartWay 0)} -> Pretty.text "..."
295 SDC{sdocStyle=PprUser q (PartWay n)} ->
296 runSDoc d ctx{sdocStyle = PprUser q (PartWay (n-1))}
297 _ -> runSDoc d ctx
298
299 pprDeeperList :: ([SDoc] -> SDoc) -> [SDoc] -> SDoc
300 -- Truncate a list that list that is longer than the current depth
301 pprDeeperList f ds
302 | null ds = f []
303 | otherwise = SDoc work
304 where
305 work ctx@SDC{sdocStyle=PprUser q (PartWay n)}
306 | n==0 = Pretty.text "..."
307 | otherwise =
308 runSDoc (f (go 0 ds)) ctx{sdocStyle = PprUser q (PartWay (n-1))}
309 where
310 go _ [] = []
311 go i (d:ds) | i >= n = [text "...."]
312 | otherwise = d : go (i+1) ds
313 work other_ctx = runSDoc (f ds) other_ctx
314
315 pprSetDepth :: Depth -> SDoc -> SDoc
316 pprSetDepth depth doc = SDoc $ \ctx ->
317 case ctx of
318 SDC{sdocStyle=PprUser q _} ->
319 runSDoc doc ctx{sdocStyle = PprUser q depth}
320 _ ->
321 runSDoc doc ctx
322
323 getPprStyle :: (PprStyle -> SDoc) -> SDoc
324 getPprStyle df = SDoc $ \ctx -> runSDoc (df (sdocStyle ctx)) ctx
325
326 sdocWithDynFlags :: (DynFlags -> SDoc) -> SDoc
327 sdocWithDynFlags f = SDoc $ \ctx -> runSDoc (f (sdocDynFlags ctx)) ctx
328
329 sdocWithPlatform :: (Platform -> SDoc) -> SDoc
330 sdocWithPlatform f = sdocWithDynFlags (f . targetPlatform)
331
332 qualName :: PprStyle -> QueryQualifyName
333 qualName (PprUser q _) mod occ = queryQualifyName q mod occ
334 qualName (PprDump q) mod occ = queryQualifyName q mod occ
335 qualName _other mod _ = NameQual (moduleName mod)
336
337 qualModule :: PprStyle -> QueryQualifyModule
338 qualModule (PprUser q _) m = queryQualifyModule q m
339 qualModule (PprDump q) m = queryQualifyModule q m
340 qualModule _other _m = True
341
342 qualPackage :: PprStyle -> QueryQualifyPackage
343 qualPackage (PprUser q _) m = queryQualifyPackage q m
344 qualPackage (PprDump q) m = queryQualifyPackage q m
345 qualPackage _other _m = True
346
347 queryQual :: PprStyle -> PrintUnqualified
348 queryQual s = QueryQualify (qualName s)
349 (qualModule s)
350 (qualPackage s)
351
352 codeStyle :: PprStyle -> Bool
353 codeStyle (PprCode _) = True
354 codeStyle _ = False
355
356 asmStyle :: PprStyle -> Bool
357 asmStyle (PprCode AsmStyle) = True
358 asmStyle _other = False
359
360 dumpStyle :: PprStyle -> Bool
361 dumpStyle (PprDump {}) = True
362 dumpStyle _other = False
363
364 debugStyle :: PprStyle -> Bool
365 debugStyle PprDebug = True
366 debugStyle _other = False
367
368 userStyle :: PprStyle -> Bool
369 userStyle (PprUser _ _) = True
370 userStyle _other = False
371
372 ifPprDebug :: SDoc -> SDoc -- Empty for non-debug style
373 ifPprDebug d = SDoc $ \ctx ->
374 case ctx of
375 SDC{sdocStyle=PprDebug} -> runSDoc d ctx
376 _ -> Pretty.empty
377
378 printForUser :: DynFlags -> Handle -> PrintUnqualified -> SDoc -> IO ()
379 printForUser dflags handle unqual doc
380 = Pretty.printDoc PageMode (pprCols dflags) handle
381 (runSDoc doc (initSDocContext dflags (mkUserStyle unqual AllTheWay)))
382
383 printForUserPartWay :: DynFlags -> Handle -> Int -> PrintUnqualified -> SDoc
384 -> IO ()
385 printForUserPartWay dflags handle d unqual doc
386 = Pretty.printDoc PageMode (pprCols dflags) handle
387 (runSDoc doc (initSDocContext dflags (mkUserStyle unqual (PartWay d))))
388
389 -- printForC, printForAsm do what they sound like
390 printForC :: DynFlags -> Handle -> SDoc -> IO ()
391 printForC dflags handle doc =
392 Pretty.printDoc LeftMode (pprCols dflags) handle
393 (runSDoc doc (initSDocContext dflags (PprCode CStyle)))
394
395 printForAsm :: DynFlags -> Handle -> SDoc -> IO ()
396 printForAsm dflags handle doc =
397 Pretty.printDoc LeftMode (pprCols dflags) handle
398 (runSDoc doc (initSDocContext dflags (PprCode AsmStyle)))
399
400 pprCode :: CodeStyle -> SDoc -> SDoc
401 pprCode cs d = withPprStyle (PprCode cs) d
402
403 mkCodeStyle :: CodeStyle -> PprStyle
404 mkCodeStyle = PprCode
405
406 -- Can't make SDoc an instance of Show because SDoc is just a function type
407 -- However, Doc *is* an instance of Show
408 -- showSDoc just blasts it out as a string
409 showSDoc :: DynFlags -> SDoc -> String
410 showSDoc dflags sdoc = renderWithStyle dflags sdoc defaultUserStyle
411
412 -- showSDocUnsafe is unsafe, because `unsafeGlobalDynFlags` might not be
413 -- initialised yet.
414 showSDocUnsafe :: SDoc -> String
415 showSDocUnsafe sdoc = showSDoc unsafeGlobalDynFlags sdoc
416
417 showPpr :: Outputable a => DynFlags -> a -> String
418 showPpr dflags thing = showSDoc dflags (ppr thing)
419
420 showSDocUnqual :: DynFlags -> SDoc -> String
421 -- Only used by Haddock
422 showSDocUnqual dflags sdoc = showSDoc dflags sdoc
423
424 showSDocForUser :: DynFlags -> PrintUnqualified -> SDoc -> String
425 -- Allows caller to specify the PrintUnqualified to use
426 showSDocForUser dflags unqual doc
427 = renderWithStyle dflags doc (mkUserStyle unqual AllTheWay)
428
429 showSDocDump :: DynFlags -> SDoc -> String
430 showSDocDump dflags d = renderWithStyle dflags d defaultDumpStyle
431
432 showSDocDebug :: DynFlags -> SDoc -> String
433 showSDocDebug dflags d = renderWithStyle dflags d PprDebug
434
435 renderWithStyle :: DynFlags -> SDoc -> PprStyle -> String
436 renderWithStyle dflags sdoc sty
437 = Pretty.showDoc PageMode (pprCols dflags) $
438 runSDoc sdoc (initSDocContext dflags sty)
439
440 -- This shows an SDoc, but on one line only. It's cheaper than a full
441 -- showSDoc, designed for when we're getting results like "Foo.bar"
442 -- and "foo{uniq strictness}" so we don't want fancy layout anyway.
443 showSDocOneLine :: DynFlags -> SDoc -> String
444 showSDocOneLine dflags d
445 = Pretty.showDoc OneLineMode (pprCols dflags) $
446 runSDoc d (initSDocContext dflags defaultUserStyle)
447
448 showSDocDumpOneLine :: DynFlags -> SDoc -> String
449 showSDocDumpOneLine dflags d
450 = Pretty.showDoc OneLineMode irrelevantNCols $
451 runSDoc d (initSDocContext dflags defaultDumpStyle)
452
453 irrelevantNCols :: Int
454 -- Used for OneLineMode and LeftMode when number of cols isn't used
455 irrelevantNCols = 1
456
457 docToSDoc :: Doc -> SDoc
458 docToSDoc d = SDoc (\_ -> d)
459
460 empty :: SDoc
461 char :: Char -> SDoc
462 text :: String -> SDoc
463 ftext :: FastString -> SDoc
464 ptext :: LitString -> SDoc
465 ztext :: FastZString -> SDoc
466 int :: Int -> SDoc
467 integer :: Integer -> SDoc
468 float :: Float -> SDoc
469 double :: Double -> SDoc
470 rational :: Rational -> SDoc
471
472 empty = docToSDoc $ Pretty.empty
473 char c = docToSDoc $ Pretty.char c
474
475 text s = docToSDoc $ Pretty.text s
476 {-# INLINE text #-} -- Inline so that the RULE Pretty.text will fire
477
478 ftext s = docToSDoc $ Pretty.ftext s
479 ptext s = docToSDoc $ Pretty.ptext s
480 ztext s = docToSDoc $ Pretty.ztext s
481 int n = docToSDoc $ Pretty.int n
482 integer n = docToSDoc $ Pretty.integer n
483 float n = docToSDoc $ Pretty.float n
484 double n = docToSDoc $ Pretty.double n
485 rational n = docToSDoc $ Pretty.rational n
486
487 parens, braces, brackets, quotes, quote,
488 paBrackets, doubleQuotes, angleBrackets :: SDoc -> SDoc
489
490 parens d = SDoc $ Pretty.parens . runSDoc d
491 braces d = SDoc $ Pretty.braces . runSDoc d
492 brackets d = SDoc $ Pretty.brackets . runSDoc d
493 quote d = SDoc $ Pretty.quote . runSDoc d
494 doubleQuotes d = SDoc $ Pretty.doubleQuotes . runSDoc d
495 angleBrackets d = char '<' <> d <> char '>'
496 paBrackets d = ptext (sLit "[:") <> d <> ptext (sLit ":]")
497
498 cparen :: Bool -> SDoc -> SDoc
499
500 cparen b d = SDoc $ Pretty.cparen b . runSDoc d
501
502 -- 'quotes' encloses something in single quotes...
503 -- but it omits them if the thing begins or ends in a single quote
504 -- so that we don't get `foo''. Instead we just have foo'.
505 quotes d =
506 sdocWithDynFlags $ \dflags ->
507 if useUnicode dflags
508 then char '' <> d <> char ''
509 else SDoc $ \sty ->
510 let pp_d = runSDoc d sty
511 str = show pp_d
512 in case (str, snocView str) of
513 (_, Just (_, '\'')) -> pp_d
514 ('\'' : _, _) -> pp_d
515 _other -> Pretty.quotes pp_d
516
517 semi, comma, colon, equals, space, dcolon, underscore, dot :: SDoc
518 arrow, larrow, darrow, arrowt, larrowt, arrowtt, larrowtt :: SDoc
519 lparen, rparen, lbrack, rbrack, lbrace, rbrace, blankLine :: SDoc
520
521 blankLine = docToSDoc $ Pretty.ptext (sLit "")
522 dcolon = unicodeSyntax (char '') (docToSDoc $ Pretty.ptext (sLit "::"))
523 arrow = unicodeSyntax (char '') (docToSDoc $ Pretty.ptext (sLit "->"))
524 larrow = unicodeSyntax (char '') (docToSDoc $ Pretty.ptext (sLit "<-"))
525 darrow = unicodeSyntax (char '') (docToSDoc $ Pretty.ptext (sLit "=>"))
526 arrowt = unicodeSyntax (char '') (docToSDoc $ Pretty.ptext (sLit ">-"))
527 larrowt = unicodeSyntax (char '') (docToSDoc $ Pretty.ptext (sLit "-<"))
528 arrowtt = unicodeSyntax (char '') (docToSDoc $ Pretty.ptext (sLit ">>-"))
529 larrowtt = unicodeSyntax (char '') (docToSDoc $ Pretty.ptext (sLit "-<<"))
530 semi = docToSDoc $ Pretty.semi
531 comma = docToSDoc $ Pretty.comma
532 colon = docToSDoc $ Pretty.colon
533 equals = docToSDoc $ Pretty.equals
534 space = docToSDoc $ Pretty.space
535 underscore = char '_'
536 dot = char '.'
537 lparen = docToSDoc $ Pretty.lparen
538 rparen = docToSDoc $ Pretty.rparen
539 lbrack = docToSDoc $ Pretty.lbrack
540 rbrack = docToSDoc $ Pretty.rbrack
541 lbrace = docToSDoc $ Pretty.lbrace
542 rbrace = docToSDoc $ Pretty.rbrace
543
544 forAllLit :: SDoc
545 forAllLit = unicodeSyntax (char '') (ptext (sLit "forall"))
546
547 unicodeSyntax :: SDoc -> SDoc -> SDoc
548 unicodeSyntax unicode plain = sdocWithDynFlags $ \dflags ->
549 if useUnicode dflags && useUnicodeSyntax dflags
550 then unicode
551 else plain
552
553 nest :: Int -> SDoc -> SDoc
554 -- ^ Indent 'SDoc' some specified amount
555 (<>) :: SDoc -> SDoc -> SDoc
556 -- ^ Join two 'SDoc' together horizontally without a gap
557 (<+>) :: SDoc -> SDoc -> SDoc
558 -- ^ Join two 'SDoc' together horizontally with a gap between them
559 ($$) :: SDoc -> SDoc -> SDoc
560 -- ^ Join two 'SDoc' together vertically; if there is
561 -- no vertical overlap it "dovetails" the two onto one line
562 ($+$) :: SDoc -> SDoc -> SDoc
563 -- ^ Join two 'SDoc' together vertically
564
565 nest n d = SDoc $ Pretty.nest n . runSDoc d
566 (<>) d1 d2 = SDoc $ \sty -> (Pretty.<>) (runSDoc d1 sty) (runSDoc d2 sty)
567 (<+>) d1 d2 = SDoc $ \sty -> (Pretty.<+>) (runSDoc d1 sty) (runSDoc d2 sty)
568 ($$) d1 d2 = SDoc $ \sty -> (Pretty.$$) (runSDoc d1 sty) (runSDoc d2 sty)
569 ($+$) d1 d2 = SDoc $ \sty -> (Pretty.$+$) (runSDoc d1 sty) (runSDoc d2 sty)
570
571 hcat :: [SDoc] -> SDoc
572 -- ^ Concatenate 'SDoc' horizontally
573 hsep :: [SDoc] -> SDoc
574 -- ^ Concatenate 'SDoc' horizontally with a space between each one
575 vcat :: [SDoc] -> SDoc
576 -- ^ Concatenate 'SDoc' vertically with dovetailing
577 sep :: [SDoc] -> SDoc
578 -- ^ Separate: is either like 'hsep' or like 'vcat', depending on what fits
579 cat :: [SDoc] -> SDoc
580 -- ^ Catenate: is either like 'hcat' or like 'vcat', depending on what fits
581 fsep :: [SDoc] -> SDoc
582 -- ^ A paragraph-fill combinator. It's much like sep, only it
583 -- keeps fitting things on one line until it can't fit any more.
584 fcat :: [SDoc] -> SDoc
585 -- ^ This behaves like 'fsep', but it uses '<>' for horizontal conposition rather than '<+>'
586
587
588 hcat ds = SDoc $ \sty -> Pretty.hcat [runSDoc d sty | d <- ds]
589 hsep ds = SDoc $ \sty -> Pretty.hsep [runSDoc d sty | d <- ds]
590 vcat ds = SDoc $ \sty -> Pretty.vcat [runSDoc d sty | d <- ds]
591 sep ds = SDoc $ \sty -> Pretty.sep [runSDoc d sty | d <- ds]
592 cat ds = SDoc $ \sty -> Pretty.cat [runSDoc d sty | d <- ds]
593 fsep ds = SDoc $ \sty -> Pretty.fsep [runSDoc d sty | d <- ds]
594 fcat ds = SDoc $ \sty -> Pretty.fcat [runSDoc d sty | d <- ds]
595
596 hang :: SDoc -- ^ The header
597 -> Int -- ^ Amount to indent the hung body
598 -> SDoc -- ^ The hung body, indented and placed below the header
599 -> SDoc
600 hang d1 n d2 = SDoc $ \sty -> Pretty.hang (runSDoc d1 sty) n (runSDoc d2 sty)
601
602 punctuate :: SDoc -- ^ The punctuation
603 -> [SDoc] -- ^ The list that will have punctuation added between every adjacent pair of elements
604 -> [SDoc] -- ^ Punctuated list
605 punctuate _ [] = []
606 punctuate p (d:ds) = go d ds
607 where
608 go d [] = [d]
609 go d (e:es) = (d <> p) : go e es
610
611 ppWhen, ppUnless :: Bool -> SDoc -> SDoc
612 ppWhen True doc = doc
613 ppWhen False _ = empty
614
615 ppUnless True _ = empty
616 ppUnless False doc = doc
617
618 -- | A colour\/style for use with 'coloured'.
619 newtype PprColour = PprColour String
620
621 -- Colours
622
623 colType :: PprColour
624 colType = PprColour "\27[34m"
625
626 colBold :: PprColour
627 colBold = PprColour "\27[;1m"
628
629 colCoerc :: PprColour
630 colCoerc = PprColour "\27[34m"
631
632 colDataCon :: PprColour
633 colDataCon = PprColour "\27[31m"
634
635 colBinder :: PprColour
636 colBinder = PprColour "\27[32m"
637
638 colReset :: PprColour
639 colReset = PprColour "\27[0m"
640
641 -- | Apply the given colour\/style for the argument.
642 --
643 -- Only takes effect if colours are enabled.
644 coloured :: PprColour -> SDoc -> SDoc
645 -- TODO: coloured _ sdoc ctxt | coloursDisabled = sdoc ctxt
646 coloured col@(PprColour c) sdoc =
647 SDoc $ \ctx@SDC{ sdocLastColour = PprColour lc } ->
648 let ctx' = ctx{ sdocLastColour = col } in
649 Pretty.zeroWidthText c Pretty.<> runSDoc sdoc ctx' Pretty.<> Pretty.zeroWidthText lc
650
651 bold :: SDoc -> SDoc
652 bold = coloured colBold
653
654 keyword :: SDoc -> SDoc
655 keyword = bold
656
657 {-
658 ************************************************************************
659 * *
660 \subsection[Outputable-class]{The @Outputable@ class}
661 * *
662 ************************************************************************
663 -}
664
665 -- | Class designating that some type has an 'SDoc' representation
666 class Outputable a where
667 ppr :: a -> SDoc
668 pprPrec :: Rational -> a -> SDoc
669 -- 0 binds least tightly
670 -- We use Rational because there is always a
671 -- Rational between any other two Rationals
672
673 ppr = pprPrec 0
674 pprPrec _ = ppr
675
676 instance Outputable Char where
677 ppr c = text [c]
678
679 instance Outputable Bool where
680 ppr True = ptext (sLit "True")
681 ppr False = ptext (sLit "False")
682
683 instance Outputable Int32 where
684 ppr n = integer $ fromIntegral n
685
686 instance Outputable Int64 where
687 ppr n = integer $ fromIntegral n
688
689 instance Outputable Int where
690 ppr n = int n
691
692 instance Outputable Word16 where
693 ppr n = integer $ fromIntegral n
694
695 instance Outputable Word32 where
696 ppr n = integer $ fromIntegral n
697
698 instance Outputable Word where
699 ppr n = integer $ fromIntegral n
700
701 instance Outputable () where
702 ppr _ = text "()"
703
704 instance (Outputable a) => Outputable [a] where
705 ppr xs = brackets (fsep (punctuate comma (map ppr xs)))
706
707 instance (Outputable a) => Outputable (Set a) where
708 ppr s = braces (fsep (punctuate comma (map ppr (Set.toList s))))
709
710 instance (Outputable a, Outputable b) => Outputable (a, b) where
711 ppr (x,y) = parens (sep [ppr x <> comma, ppr y])
712
713 instance Outputable a => Outputable (Maybe a) where
714 ppr Nothing = ptext (sLit "Nothing")
715 ppr (Just x) = ptext (sLit "Just") <+> ppr x
716
717 instance (Outputable a, Outputable b) => Outputable (Either a b) where
718 ppr (Left x) = ptext (sLit "Left") <+> ppr x
719 ppr (Right y) = ptext (sLit "Right") <+> ppr y
720
721 -- ToDo: may not be used
722 instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c) where
723 ppr (x,y,z) =
724 parens (sep [ppr x <> comma,
725 ppr y <> comma,
726 ppr z ])
727
728 instance (Outputable a, Outputable b, Outputable c, Outputable d) =>
729 Outputable (a, b, c, d) where
730 ppr (a,b,c,d) =
731 parens (sep [ppr a <> comma,
732 ppr b <> comma,
733 ppr c <> comma,
734 ppr d])
735
736 instance (Outputable a, Outputable b, Outputable c, Outputable d, Outputable e) =>
737 Outputable (a, b, c, d, e) where
738 ppr (a,b,c,d,e) =
739 parens (sep [ppr a <> comma,
740 ppr b <> comma,
741 ppr c <> comma,
742 ppr d <> comma,
743 ppr e])
744
745 instance (Outputable a, Outputable b, Outputable c, Outputable d, Outputable e, Outputable f) =>
746 Outputable (a, b, c, d, e, f) where
747 ppr (a,b,c,d,e,f) =
748 parens (sep [ppr a <> comma,
749 ppr b <> comma,
750 ppr c <> comma,
751 ppr d <> comma,
752 ppr e <> comma,
753 ppr f])
754
755 instance (Outputable a, Outputable b, Outputable c, Outputable d, Outputable e, Outputable f, Outputable g) =>
756 Outputable (a, b, c, d, e, f, g) where
757 ppr (a,b,c,d,e,f,g) =
758 parens (sep [ppr a <> comma,
759 ppr b <> comma,
760 ppr c <> comma,
761 ppr d <> comma,
762 ppr e <> comma,
763 ppr f <> comma,
764 ppr g])
765
766 instance Outputable FastString where
767 ppr fs = ftext fs -- Prints an unadorned string,
768 -- no double quotes or anything
769
770 instance (Outputable key, Outputable elt) => Outputable (M.Map key elt) where
771 ppr m = ppr (M.toList m)
772 instance (Outputable elt) => Outputable (IM.IntMap elt) where
773 ppr m = ppr (IM.toList m)
774
775 instance Outputable Fingerprint where
776 ppr (Fingerprint w1 w2) = text (printf "%016x%016x" w1 w2)
777
778 instance Outputable a => Outputable (SCC a) where
779 ppr (AcyclicSCC v) = text "NONREC" $$ (nest 3 (ppr v))
780 ppr (CyclicSCC vs) = text "REC" $$ (nest 3 (vcat (map ppr vs)))
781
782 {-
783 ************************************************************************
784 * *
785 \subsection{The @OutputableBndr@ class}
786 * *
787 ************************************************************************
788 -}
789
790 -- | 'BindingSite' is used to tell the thing that prints binder what
791 -- language construct is binding the identifier. This can be used
792 -- to decide how much info to print.
793 data BindingSite = LambdaBind | CaseBind | LetBind
794
795 -- | When we print a binder, we often want to print its type too.
796 -- The @OutputableBndr@ class encapsulates this idea.
797 class Outputable a => OutputableBndr a where
798 pprBndr :: BindingSite -> a -> SDoc
799 pprBndr _b x = ppr x
800
801 pprPrefixOcc, pprInfixOcc :: a -> SDoc
802 -- Print an occurrence of the name, suitable either in the
803 -- prefix position of an application, thus (f a b) or ((+) x)
804 -- or infix position, thus (a `f` b) or (x + y)
805
806 {-
807 ************************************************************************
808 * *
809 \subsection{Random printing helpers}
810 * *
811 ************************************************************************
812 -}
813
814 -- We have 31-bit Chars and will simply use Show instances of Char and String.
815
816 -- | Special combinator for showing character literals.
817 pprHsChar :: Char -> SDoc
818 pprHsChar c | c > '\x10ffff' = char '\\' <> text (show (fromIntegral (ord c) :: Word32))
819 | otherwise = text (show c)
820
821 -- | Special combinator for showing string literals.
822 pprHsString :: FastString -> SDoc
823 pprHsString fs = vcat (map text (showMultiLineString (unpackFS fs)))
824
825 -- | Special combinator for showing bytestring literals.
826 pprHsBytes :: ByteString -> SDoc
827 pprHsBytes bs = let escaped = concatMap escape $ BS.unpack bs
828 in vcat (map text (showMultiLineString escaped)) <> char '#'
829 where escape :: Word8 -> String
830 escape w = let c = chr (fromIntegral w)
831 in if isAscii c
832 then [c]
833 else '\\' : show w
834
835 -- Postfix modifiers for unboxed literals.
836 -- See Note [Printing of literals in Core] in `basicTypes/Literal.hs`.
837 primCharSuffix, primFloatSuffix, primIntSuffix :: SDoc
838 primDoubleSuffix, primWordSuffix, primInt64Suffix, primWord64Suffix :: SDoc
839 primCharSuffix = char '#'
840 primFloatSuffix = char '#'
841 primIntSuffix = char '#'
842 primDoubleSuffix = text "##"
843 primWordSuffix = text "##"
844 primInt64Suffix = text "L#"
845 primWord64Suffix = text "L##"
846
847 -- | Special combinator for showing unboxed literals.
848 pprPrimChar :: Char -> SDoc
849 pprPrimInt, pprPrimWord, pprPrimInt64, pprPrimWord64 :: Integer -> SDoc
850 pprPrimChar c = pprHsChar c <> primCharSuffix
851 pprPrimInt i = integer i <> primIntSuffix
852 pprPrimWord w = integer w <> primWordSuffix
853 pprPrimInt64 i = integer i <> primInt64Suffix
854 pprPrimWord64 w = integer w <> primWord64Suffix
855
856 ---------------------
857 -- Put a name in parens if it's an operator
858 pprPrefixVar :: Bool -> SDoc -> SDoc
859 pprPrefixVar is_operator pp_v
860 | is_operator = parens pp_v
861 | otherwise = pp_v
862
863 -- Put a name in backquotes if it's not an operator
864 pprInfixVar :: Bool -> SDoc -> SDoc
865 pprInfixVar is_operator pp_v
866 | is_operator = pp_v
867 | otherwise = char '`' <> pp_v <> char '`'
868
869 ---------------------
870 pprFastFilePath :: FastString -> SDoc
871 pprFastFilePath path = text $ normalise $ unpackFS path
872
873 {-
874 ************************************************************************
875 * *
876 \subsection{Other helper functions}
877 * *
878 ************************************************************************
879 -}
880
881 pprWithCommas :: (a -> SDoc) -- ^ The pretty printing function to use
882 -> [a] -- ^ The things to be pretty printed
883 -> SDoc -- ^ 'SDoc' where the things have been pretty printed,
884 -- comma-separated and finally packed into a paragraph.
885 pprWithCommas pp xs = fsep (punctuate comma (map pp xs))
886
887 -- | Returns the separated concatenation of the pretty printed things.
888 interppSP :: Outputable a => [a] -> SDoc
889 interppSP xs = sep (map ppr xs)
890
891 -- | Returns the comma-separated concatenation of the pretty printed things.
892 interpp'SP :: Outputable a => [a] -> SDoc
893 interpp'SP xs = sep (punctuate comma (map ppr xs))
894
895 -- | Returns the comma-separated concatenation of the quoted pretty printed things.
896 --
897 -- > [x,y,z] ==> `x', `y', `z'
898 pprQuotedList :: Outputable a => [a] -> SDoc
899 pprQuotedList = quotedList . map ppr
900
901 quotedList :: [SDoc] -> SDoc
902 quotedList xs = hsep (punctuate comma (map quotes xs))
903
904 quotedListWithOr :: [SDoc] -> SDoc
905 -- [x,y,z] ==> `x', `y' or `z'
906 quotedListWithOr xs@(_:_:_) = quotedList (init xs) <+> ptext (sLit "or") <+> quotes (last xs)
907 quotedListWithOr xs = quotedList xs
908
909 {-
910 ************************************************************************
911 * *
912 \subsection{Printing numbers verbally}
913 * *
914 ************************************************************************
915 -}
916
917 intWithCommas :: Integral a => a -> SDoc
918 -- Prints a big integer with commas, eg 345,821
919 intWithCommas n
920 | n < 0 = char '-' <> intWithCommas (-n)
921 | q == 0 = int (fromIntegral r)
922 | otherwise = intWithCommas q <> comma <> zeroes <> int (fromIntegral r)
923 where
924 (q,r) = n `quotRem` 1000
925 zeroes | r >= 100 = empty
926 | r >= 10 = char '0'
927 | otherwise = ptext (sLit "00")
928
929 -- | Converts an integer to a verbal index:
930 --
931 -- > speakNth 1 = text "first"
932 -- > speakNth 5 = text "fifth"
933 -- > speakNth 21 = text "21st"
934 speakNth :: Int -> SDoc
935 speakNth 1 = ptext (sLit "first")
936 speakNth 2 = ptext (sLit "second")
937 speakNth 3 = ptext (sLit "third")
938 speakNth 4 = ptext (sLit "fourth")
939 speakNth 5 = ptext (sLit "fifth")
940 speakNth 6 = ptext (sLit "sixth")
941 speakNth n = hcat [ int n, text suffix ]
942 where
943 suffix | n <= 20 = "th" -- 11,12,13 are non-std
944 | last_dig == 1 = "st"
945 | last_dig == 2 = "nd"
946 | last_dig == 3 = "rd"
947 | otherwise = "th"
948
949 last_dig = n `rem` 10
950
951 -- | Converts an integer to a verbal multiplicity:
952 --
953 -- > speakN 0 = text "none"
954 -- > speakN 5 = text "five"
955 -- > speakN 10 = text "10"
956 speakN :: Int -> SDoc
957 speakN 0 = ptext (sLit "none") -- E.g. "he has none"
958 speakN 1 = ptext (sLit "one") -- E.g. "he has one"
959 speakN 2 = ptext (sLit "two")
960 speakN 3 = ptext (sLit "three")
961 speakN 4 = ptext (sLit "four")
962 speakN 5 = ptext (sLit "five")
963 speakN 6 = ptext (sLit "six")
964 speakN n = int n
965
966 -- | Converts an integer and object description to a statement about the
967 -- multiplicity of those objects:
968 --
969 -- > speakNOf 0 (text "melon") = text "no melons"
970 -- > speakNOf 1 (text "melon") = text "one melon"
971 -- > speakNOf 3 (text "melon") = text "three melons"
972 speakNOf :: Int -> SDoc -> SDoc
973 speakNOf 0 d = ptext (sLit "no") <+> d <> char 's'
974 speakNOf 1 d = ptext (sLit "one") <+> d -- E.g. "one argument"
975 speakNOf n d = speakN n <+> d <> char 's' -- E.g. "three arguments"
976
977 -- | Converts a strictly positive integer into a number of times:
978 --
979 -- > speakNTimes 1 = text "once"
980 -- > speakNTimes 2 = text "twice"
981 -- > speakNTimes 4 = text "4 times"
982 speakNTimes :: Int {- >=1 -} -> SDoc
983 speakNTimes t | t == 1 = ptext (sLit "once")
984 | t == 2 = ptext (sLit "twice")
985 | otherwise = speakN t <+> ptext (sLit "times")
986
987 -- | Determines the pluralisation suffix appropriate for the length of a list:
988 --
989 -- > plural [] = char 's'
990 -- > plural ["Hello"] = empty
991 -- > plural ["Hello", "World"] = char 's'
992 plural :: [a] -> SDoc
993 plural [_] = empty -- a bit frightening, but there you are
994 plural _ = char 's'
995
996 -- | Determines the form of to be appropriate for the length of a list:
997 --
998 -- > isOrAre [] = ptext (sLit "are")
999 -- > isOrAre ["Hello"] = ptext (sLit "is")
1000 -- > isOrAre ["Hello", "World"] = ptext (sLit "are")
1001 isOrAre :: [a] -> SDoc
1002 isOrAre [_] = ptext (sLit "is")
1003 isOrAre _ = ptext (sLit "are")
1004
1005 {-
1006 ************************************************************************
1007 * *
1008 \subsection{Error handling}
1009 * *
1010 ************************************************************************
1011 -}
1012
1013 pprPanic :: String -> SDoc -> a
1014 -- ^ Throw an exception saying "bug in GHC"
1015 pprPanic = panicDoc
1016
1017 pprSorry :: String -> SDoc -> a
1018 -- ^ Throw an exception saying "this isn't finished yet"
1019 pprSorry = sorryDoc
1020
1021
1022 pprPgmError :: String -> SDoc -> a
1023 -- ^ Throw an exception saying "bug in pgm being compiled" (used for unusual program errors)
1024 pprPgmError = pgmErrorDoc
1025
1026
1027 pprTrace :: String -> SDoc -> a -> a
1028 -- ^ If debug output is on, show some 'SDoc' on the screen
1029 pprTrace str doc x
1030 | opt_NoDebugOutput = x
1031 | otherwise = pprDebugAndThen unsafeGlobalDynFlags trace (text str) doc x
1032
1033 pprPanicFastInt :: String -> SDoc -> FastInt
1034 -- ^ Specialization of pprPanic that can be safely used with 'FastInt'
1035 pprPanicFastInt heading pretty_msg = panicDocFastInt heading pretty_msg
1036
1037 warnPprTrace :: Bool -> String -> Int -> SDoc -> a -> a
1038 -- ^ Just warn about an assertion failure, recording the given file and line number.
1039 -- Should typically be accessed with the WARN macros
1040 warnPprTrace _ _ _ _ x | not debugIsOn = x
1041 warnPprTrace _ _file _line _msg x | opt_NoDebugOutput = x
1042 warnPprTrace False _file _line _msg x = x
1043 warnPprTrace True file line msg x
1044 = pprDebugAndThen unsafeGlobalDynFlags trace heading msg x
1045 where
1046 heading = hsep [text "WARNING: file", text file <> comma, text "line", int line]
1047
1048 assertPprPanic :: String -> Int -> SDoc -> a
1049 -- ^ Panic with an assertation failure, recording the given file and line number.
1050 -- Should typically be accessed with the ASSERT family of macros
1051 assertPprPanic file line msg
1052 = pprPanic "ASSERT failed!" doc
1053 where
1054 doc = sep [ hsep [ text "file", text file
1055 , text "line", int line ]
1056 , msg ]
1057
1058 pprDebugAndThen :: DynFlags -> (String -> a) -> SDoc -> SDoc -> a
1059 pprDebugAndThen dflags cont heading pretty_msg
1060 = cont (showSDocDump dflags doc)
1061 where
1062 doc = sep [heading, nest 2 pretty_msg]