Pretty: mimic pretty API more closely (#10735)
[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 function 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 = let s = Pretty.style{ Pretty.mode = PageMode,
438 Pretty.lineLength = pprCols dflags }
439 in Pretty.renderStyle s $ runSDoc sdoc (initSDocContext dflags sty)
440
441 -- This shows an SDoc, but on one line only. It's cheaper than a full
442 -- showSDoc, designed for when we're getting results like "Foo.bar"
443 -- and "foo{uniq strictness}" so we don't want fancy layout anyway.
444 showSDocOneLine :: DynFlags -> SDoc -> String
445 showSDocOneLine dflags d
446 = let s = Pretty.style{ Pretty.mode = OneLineMode,
447 Pretty.lineLength = pprCols dflags } in
448 Pretty.renderStyle s $ runSDoc d (initSDocContext dflags defaultUserStyle)
449
450 showSDocDumpOneLine :: DynFlags -> SDoc -> String
451 showSDocDumpOneLine dflags d
452 = let s = Pretty.style{ Pretty.mode = OneLineMode,
453 Pretty.lineLength = irrelevantNCols } in
454 Pretty.renderStyle s $ runSDoc d (initSDocContext dflags defaultDumpStyle)
455
456 irrelevantNCols :: Int
457 -- Used for OneLineMode and LeftMode when number of cols isn't used
458 irrelevantNCols = 1
459
460 docToSDoc :: Doc -> SDoc
461 docToSDoc d = SDoc (\_ -> d)
462
463 empty :: SDoc
464 char :: Char -> SDoc
465 text :: String -> SDoc
466 ftext :: FastString -> SDoc
467 ptext :: LitString -> SDoc
468 ztext :: FastZString -> SDoc
469 int :: Int -> SDoc
470 integer :: Integer -> SDoc
471 float :: Float -> SDoc
472 double :: Double -> SDoc
473 rational :: Rational -> SDoc
474
475 empty = docToSDoc $ Pretty.empty
476 char c = docToSDoc $ Pretty.char c
477
478 text s = docToSDoc $ Pretty.text s
479 {-# INLINE text #-} -- Inline so that the RULE Pretty.text will fire
480
481 ftext s = docToSDoc $ Pretty.ftext s
482 ptext s = docToSDoc $ Pretty.ptext s
483 ztext s = docToSDoc $ Pretty.ztext s
484 int n = docToSDoc $ Pretty.int n
485 integer n = docToSDoc $ Pretty.integer n
486 float n = docToSDoc $ Pretty.float n
487 double n = docToSDoc $ Pretty.double n
488 rational n = docToSDoc $ Pretty.rational n
489
490 parens, braces, brackets, quotes, quote,
491 paBrackets, doubleQuotes, angleBrackets :: SDoc -> SDoc
492
493 parens d = SDoc $ Pretty.parens . runSDoc d
494 braces d = SDoc $ Pretty.braces . runSDoc d
495 brackets d = SDoc $ Pretty.brackets . runSDoc d
496 quote d = SDoc $ Pretty.quote . runSDoc d
497 doubleQuotes d = SDoc $ Pretty.doubleQuotes . runSDoc d
498 angleBrackets d = char '<' <> d <> char '>'
499 paBrackets d = ptext (sLit "[:") <> d <> ptext (sLit ":]")
500
501 cparen :: Bool -> SDoc -> SDoc
502 cparen b d = SDoc $ Pretty.maybeParens b . runSDoc d
503
504 -- 'quotes' encloses something in single quotes...
505 -- but it omits them if the thing begins or ends in a single quote
506 -- so that we don't get `foo''. Instead we just have foo'.
507 quotes d =
508 sdocWithDynFlags $ \dflags ->
509 if useUnicode dflags
510 then char '' <> d <> char ''
511 else SDoc $ \sty ->
512 let pp_d = runSDoc d sty
513 str = show pp_d
514 in case (str, snocView str) of
515 (_, Just (_, '\'')) -> pp_d
516 ('\'' : _, _) -> pp_d
517 _other -> Pretty.quotes pp_d
518
519 semi, comma, colon, equals, space, dcolon, underscore, dot :: SDoc
520 arrow, larrow, darrow, arrowt, larrowt, arrowtt, larrowtt :: SDoc
521 lparen, rparen, lbrack, rbrack, lbrace, rbrace, blankLine :: SDoc
522
523 blankLine = docToSDoc $ Pretty.ptext (sLit "")
524 dcolon = unicodeSyntax (char '') (docToSDoc $ Pretty.ptext (sLit "::"))
525 arrow = unicodeSyntax (char '') (docToSDoc $ Pretty.ptext (sLit "->"))
526 larrow = unicodeSyntax (char '') (docToSDoc $ Pretty.ptext (sLit "<-"))
527 darrow = unicodeSyntax (char '') (docToSDoc $ Pretty.ptext (sLit "=>"))
528 arrowt = unicodeSyntax (char '') (docToSDoc $ Pretty.ptext (sLit ">-"))
529 larrowt = unicodeSyntax (char '') (docToSDoc $ Pretty.ptext (sLit "-<"))
530 arrowtt = unicodeSyntax (char '') (docToSDoc $ Pretty.ptext (sLit ">>-"))
531 larrowtt = unicodeSyntax (char '') (docToSDoc $ Pretty.ptext (sLit "-<<"))
532 semi = docToSDoc $ Pretty.semi
533 comma = docToSDoc $ Pretty.comma
534 colon = docToSDoc $ Pretty.colon
535 equals = docToSDoc $ Pretty.equals
536 space = docToSDoc $ Pretty.space
537 underscore = char '_'
538 dot = char '.'
539 lparen = docToSDoc $ Pretty.lparen
540 rparen = docToSDoc $ Pretty.rparen
541 lbrack = docToSDoc $ Pretty.lbrack
542 rbrack = docToSDoc $ Pretty.rbrack
543 lbrace = docToSDoc $ Pretty.lbrace
544 rbrace = docToSDoc $ Pretty.rbrace
545
546 forAllLit :: SDoc
547 forAllLit = unicodeSyntax (char '') (ptext (sLit "forall"))
548
549 unicodeSyntax :: SDoc -> SDoc -> SDoc
550 unicodeSyntax unicode plain = sdocWithDynFlags $ \dflags ->
551 if useUnicode dflags && useUnicodeSyntax dflags
552 then unicode
553 else plain
554
555 nest :: Int -> SDoc -> SDoc
556 -- ^ Indent 'SDoc' some specified amount
557 (<>) :: SDoc -> SDoc -> SDoc
558 -- ^ Join two 'SDoc' together horizontally without a gap
559 (<+>) :: SDoc -> SDoc -> SDoc
560 -- ^ Join two 'SDoc' together horizontally with a gap between them
561 ($$) :: SDoc -> SDoc -> SDoc
562 -- ^ Join two 'SDoc' together vertically; if there is
563 -- no vertical overlap it "dovetails" the two onto one line
564 ($+$) :: SDoc -> SDoc -> SDoc
565 -- ^ Join two 'SDoc' together vertically
566
567 nest n d = SDoc $ Pretty.nest n . runSDoc d
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 ($$) d1 d2 = SDoc $ \sty -> (Pretty.$$) (runSDoc d1 sty) (runSDoc d2 sty)
571 ($+$) d1 d2 = SDoc $ \sty -> (Pretty.$+$) (runSDoc d1 sty) (runSDoc d2 sty)
572
573 hcat :: [SDoc] -> SDoc
574 -- ^ Concatenate 'SDoc' horizontally
575 hsep :: [SDoc] -> SDoc
576 -- ^ Concatenate 'SDoc' horizontally with a space between each one
577 vcat :: [SDoc] -> SDoc
578 -- ^ Concatenate 'SDoc' vertically with dovetailing
579 sep :: [SDoc] -> SDoc
580 -- ^ Separate: is either like 'hsep' or like 'vcat', depending on what fits
581 cat :: [SDoc] -> SDoc
582 -- ^ Catenate: is either like 'hcat' or like 'vcat', depending on what fits
583 fsep :: [SDoc] -> SDoc
584 -- ^ A paragraph-fill combinator. It's much like sep, only it
585 -- keeps fitting things on one line until it can't fit any more.
586 fcat :: [SDoc] -> SDoc
587 -- ^ This behaves like 'fsep', but it uses '<>' for horizontal conposition rather than '<+>'
588
589
590 hcat ds = SDoc $ \sty -> Pretty.hcat [runSDoc d sty | d <- ds]
591 hsep ds = SDoc $ \sty -> Pretty.hsep [runSDoc d sty | d <- ds]
592 vcat ds = SDoc $ \sty -> Pretty.vcat [runSDoc d sty | d <- ds]
593 sep ds = SDoc $ \sty -> Pretty.sep [runSDoc d sty | d <- ds]
594 cat ds = SDoc $ \sty -> Pretty.cat [runSDoc d sty | d <- ds]
595 fsep ds = SDoc $ \sty -> Pretty.fsep [runSDoc d sty | d <- ds]
596 fcat ds = SDoc $ \sty -> Pretty.fcat [runSDoc d sty | d <- ds]
597
598 hang :: SDoc -- ^ The header
599 -> Int -- ^ Amount to indent the hung body
600 -> SDoc -- ^ The hung body, indented and placed below the header
601 -> SDoc
602 hang d1 n d2 = SDoc $ \sty -> Pretty.hang (runSDoc d1 sty) n (runSDoc d2 sty)
603
604 punctuate :: SDoc -- ^ The punctuation
605 -> [SDoc] -- ^ The list that will have punctuation added between every adjacent pair of elements
606 -> [SDoc] -- ^ Punctuated list
607 punctuate _ [] = []
608 punctuate p (d:ds) = go d ds
609 where
610 go d [] = [d]
611 go d (e:es) = (d <> p) : go e es
612
613 ppWhen, ppUnless :: Bool -> SDoc -> SDoc
614 ppWhen True doc = doc
615 ppWhen False _ = empty
616
617 ppUnless True _ = empty
618 ppUnless False doc = doc
619
620 -- | A colour\/style for use with 'coloured'.
621 newtype PprColour = PprColour String
622
623 -- Colours
624
625 colType :: PprColour
626 colType = PprColour "\27[34m"
627
628 colBold :: PprColour
629 colBold = PprColour "\27[;1m"
630
631 colCoerc :: PprColour
632 colCoerc = PprColour "\27[34m"
633
634 colDataCon :: PprColour
635 colDataCon = PprColour "\27[31m"
636
637 colBinder :: PprColour
638 colBinder = PprColour "\27[32m"
639
640 colReset :: PprColour
641 colReset = PprColour "\27[0m"
642
643 -- | Apply the given colour\/style for the argument.
644 --
645 -- Only takes effect if colours are enabled.
646 coloured :: PprColour -> SDoc -> SDoc
647 -- TODO: coloured _ sdoc ctxt | coloursDisabled = sdoc ctxt
648 coloured col@(PprColour c) sdoc =
649 SDoc $ \ctx@SDC{ sdocLastColour = PprColour lc } ->
650 let ctx' = ctx{ sdocLastColour = col } in
651 Pretty.zeroWidthText c Pretty.<> runSDoc sdoc ctx' Pretty.<> Pretty.zeroWidthText lc
652
653 bold :: SDoc -> SDoc
654 bold = coloured colBold
655
656 keyword :: SDoc -> SDoc
657 keyword = bold
658
659 {-
660 ************************************************************************
661 * *
662 \subsection[Outputable-class]{The @Outputable@ class}
663 * *
664 ************************************************************************
665 -}
666
667 -- | Class designating that some type has an 'SDoc' representation
668 class Outputable a where
669 ppr :: a -> SDoc
670 pprPrec :: Rational -> a -> SDoc
671 -- 0 binds least tightly
672 -- We use Rational because there is always a
673 -- Rational between any other two Rationals
674
675 ppr = pprPrec 0
676 pprPrec _ = ppr
677
678 instance Outputable Char where
679 ppr c = text [c]
680
681 instance Outputable Bool where
682 ppr True = ptext (sLit "True")
683 ppr False = ptext (sLit "False")
684
685 instance Outputable Int32 where
686 ppr n = integer $ fromIntegral n
687
688 instance Outputable Int64 where
689 ppr n = integer $ fromIntegral n
690
691 instance Outputable Int where
692 ppr n = int n
693
694 instance Outputable Word16 where
695 ppr n = integer $ fromIntegral n
696
697 instance Outputable Word32 where
698 ppr n = integer $ fromIntegral n
699
700 instance Outputable Word where
701 ppr n = integer $ fromIntegral n
702
703 instance Outputable () where
704 ppr _ = text "()"
705
706 instance (Outputable a) => Outputable [a] where
707 ppr xs = brackets (fsep (punctuate comma (map ppr xs)))
708
709 instance (Outputable a) => Outputable (Set a) where
710 ppr s = braces (fsep (punctuate comma (map ppr (Set.toList s))))
711
712 instance (Outputable a, Outputable b) => Outputable (a, b) where
713 ppr (x,y) = parens (sep [ppr x <> comma, ppr y])
714
715 instance Outputable a => Outputable (Maybe a) where
716 ppr Nothing = ptext (sLit "Nothing")
717 ppr (Just x) = ptext (sLit "Just") <+> ppr x
718
719 instance (Outputable a, Outputable b) => Outputable (Either a b) where
720 ppr (Left x) = ptext (sLit "Left") <+> ppr x
721 ppr (Right y) = ptext (sLit "Right") <+> ppr y
722
723 -- ToDo: may not be used
724 instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c) where
725 ppr (x,y,z) =
726 parens (sep [ppr x <> comma,
727 ppr y <> comma,
728 ppr z ])
729
730 instance (Outputable a, Outputable b, Outputable c, Outputable d) =>
731 Outputable (a, b, c, d) where
732 ppr (a,b,c,d) =
733 parens (sep [ppr a <> comma,
734 ppr b <> comma,
735 ppr c <> comma,
736 ppr d])
737
738 instance (Outputable a, Outputable b, Outputable c, Outputable d, Outputable e) =>
739 Outputable (a, b, c, d, e) where
740 ppr (a,b,c,d,e) =
741 parens (sep [ppr a <> comma,
742 ppr b <> comma,
743 ppr c <> comma,
744 ppr d <> comma,
745 ppr e])
746
747 instance (Outputable a, Outputable b, Outputable c, Outputable d, Outputable e, Outputable f) =>
748 Outputable (a, b, c, d, e, f) where
749 ppr (a,b,c,d,e,f) =
750 parens (sep [ppr a <> comma,
751 ppr b <> comma,
752 ppr c <> comma,
753 ppr d <> comma,
754 ppr e <> comma,
755 ppr f])
756
757 instance (Outputable a, Outputable b, Outputable c, Outputable d, Outputable e, Outputable f, Outputable g) =>
758 Outputable (a, b, c, d, e, f, g) where
759 ppr (a,b,c,d,e,f,g) =
760 parens (sep [ppr a <> comma,
761 ppr b <> comma,
762 ppr c <> comma,
763 ppr d <> comma,
764 ppr e <> comma,
765 ppr f <> comma,
766 ppr g])
767
768 instance Outputable FastString where
769 ppr fs = ftext fs -- Prints an unadorned string,
770 -- no double quotes or anything
771
772 instance (Outputable key, Outputable elt) => Outputable (M.Map key elt) where
773 ppr m = ppr (M.toList m)
774 instance (Outputable elt) => Outputable (IM.IntMap elt) where
775 ppr m = ppr (IM.toList m)
776
777 instance Outputable Fingerprint where
778 ppr (Fingerprint w1 w2) = text (printf "%016x%016x" w1 w2)
779
780 instance Outputable a => Outputable (SCC a) where
781 ppr (AcyclicSCC v) = text "NONREC" $$ (nest 3 (ppr v))
782 ppr (CyclicSCC vs) = text "REC" $$ (nest 3 (vcat (map ppr vs)))
783
784 {-
785 ************************************************************************
786 * *
787 \subsection{The @OutputableBndr@ class}
788 * *
789 ************************************************************************
790 -}
791
792 -- | 'BindingSite' is used to tell the thing that prints binder what
793 -- language construct is binding the identifier. This can be used
794 -- to decide how much info to print.
795 data BindingSite = LambdaBind | CaseBind | LetBind
796
797 -- | When we print a binder, we often want to print its type too.
798 -- The @OutputableBndr@ class encapsulates this idea.
799 class Outputable a => OutputableBndr a where
800 pprBndr :: BindingSite -> a -> SDoc
801 pprBndr _b x = ppr x
802
803 pprPrefixOcc, pprInfixOcc :: a -> SDoc
804 -- Print an occurrence of the name, suitable either in the
805 -- prefix position of an application, thus (f a b) or ((+) x)
806 -- or infix position, thus (a `f` b) or (x + y)
807
808 {-
809 ************************************************************************
810 * *
811 \subsection{Random printing helpers}
812 * *
813 ************************************************************************
814 -}
815
816 -- We have 31-bit Chars and will simply use Show instances of Char and String.
817
818 -- | Special combinator for showing character literals.
819 pprHsChar :: Char -> SDoc
820 pprHsChar c | c > '\x10ffff' = char '\\' <> text (show (fromIntegral (ord c) :: Word32))
821 | otherwise = text (show c)
822
823 -- | Special combinator for showing string literals.
824 pprHsString :: FastString -> SDoc
825 pprHsString fs = vcat (map text (showMultiLineString (unpackFS fs)))
826
827 -- | Special combinator for showing bytestring literals.
828 pprHsBytes :: ByteString -> SDoc
829 pprHsBytes bs = let escaped = concatMap escape $ BS.unpack bs
830 in vcat (map text (showMultiLineString escaped)) <> char '#'
831 where escape :: Word8 -> String
832 escape w = let c = chr (fromIntegral w)
833 in if isAscii c
834 then [c]
835 else '\\' : show w
836
837 -- Postfix modifiers for unboxed literals.
838 -- See Note [Printing of literals in Core] in `basicTypes/Literal.hs`.
839 primCharSuffix, primFloatSuffix, primIntSuffix :: SDoc
840 primDoubleSuffix, primWordSuffix, primInt64Suffix, primWord64Suffix :: SDoc
841 primCharSuffix = char '#'
842 primFloatSuffix = char '#'
843 primIntSuffix = char '#'
844 primDoubleSuffix = text "##"
845 primWordSuffix = text "##"
846 primInt64Suffix = text "L#"
847 primWord64Suffix = text "L##"
848
849 -- | Special combinator for showing unboxed literals.
850 pprPrimChar :: Char -> SDoc
851 pprPrimInt, pprPrimWord, pprPrimInt64, pprPrimWord64 :: Integer -> SDoc
852 pprPrimChar c = pprHsChar c <> primCharSuffix
853 pprPrimInt i = integer i <> primIntSuffix
854 pprPrimWord w = integer w <> primWordSuffix
855 pprPrimInt64 i = integer i <> primInt64Suffix
856 pprPrimWord64 w = integer w <> primWord64Suffix
857
858 ---------------------
859 -- Put a name in parens if it's an operator
860 pprPrefixVar :: Bool -> SDoc -> SDoc
861 pprPrefixVar is_operator pp_v
862 | is_operator = parens pp_v
863 | otherwise = pp_v
864
865 -- Put a name in backquotes if it's not an operator
866 pprInfixVar :: Bool -> SDoc -> SDoc
867 pprInfixVar is_operator pp_v
868 | is_operator = pp_v
869 | otherwise = char '`' <> pp_v <> char '`'
870
871 ---------------------
872 pprFastFilePath :: FastString -> SDoc
873 pprFastFilePath path = text $ normalise $ unpackFS path
874
875 {-
876 ************************************************************************
877 * *
878 \subsection{Other helper functions}
879 * *
880 ************************************************************************
881 -}
882
883 pprWithCommas :: (a -> SDoc) -- ^ The pretty printing function to use
884 -> [a] -- ^ The things to be pretty printed
885 -> SDoc -- ^ 'SDoc' where the things have been pretty printed,
886 -- comma-separated and finally packed into a paragraph.
887 pprWithCommas pp xs = fsep (punctuate comma (map pp xs))
888
889 -- | Returns the separated concatenation of the pretty printed things.
890 interppSP :: Outputable a => [a] -> SDoc
891 interppSP xs = sep (map ppr xs)
892
893 -- | Returns the comma-separated concatenation of the pretty printed things.
894 interpp'SP :: Outputable a => [a] -> SDoc
895 interpp'SP xs = sep (punctuate comma (map ppr xs))
896
897 -- | Returns the comma-separated concatenation of the quoted pretty printed things.
898 --
899 -- > [x,y,z] ==> `x', `y', `z'
900 pprQuotedList :: Outputable a => [a] -> SDoc
901 pprQuotedList = quotedList . map ppr
902
903 quotedList :: [SDoc] -> SDoc
904 quotedList xs = hsep (punctuate comma (map quotes xs))
905
906 quotedListWithOr :: [SDoc] -> SDoc
907 -- [x,y,z] ==> `x', `y' or `z'
908 quotedListWithOr xs@(_:_:_) = quotedList (init xs) <+> ptext (sLit "or") <+> quotes (last xs)
909 quotedListWithOr xs = quotedList xs
910
911 {-
912 ************************************************************************
913 * *
914 \subsection{Printing numbers verbally}
915 * *
916 ************************************************************************
917 -}
918
919 intWithCommas :: Integral a => a -> SDoc
920 -- Prints a big integer with commas, eg 345,821
921 intWithCommas n
922 | n < 0 = char '-' <> intWithCommas (-n)
923 | q == 0 = int (fromIntegral r)
924 | otherwise = intWithCommas q <> comma <> zeroes <> int (fromIntegral r)
925 where
926 (q,r) = n `quotRem` 1000
927 zeroes | r >= 100 = empty
928 | r >= 10 = char '0'
929 | otherwise = ptext (sLit "00")
930
931 -- | Converts an integer to a verbal index:
932 --
933 -- > speakNth 1 = text "first"
934 -- > speakNth 5 = text "fifth"
935 -- > speakNth 21 = text "21st"
936 speakNth :: Int -> SDoc
937 speakNth 1 = ptext (sLit "first")
938 speakNth 2 = ptext (sLit "second")
939 speakNth 3 = ptext (sLit "third")
940 speakNth 4 = ptext (sLit "fourth")
941 speakNth 5 = ptext (sLit "fifth")
942 speakNth 6 = ptext (sLit "sixth")
943 speakNth n = hcat [ int n, text suffix ]
944 where
945 suffix | n <= 20 = "th" -- 11,12,13 are non-std
946 | last_dig == 1 = "st"
947 | last_dig == 2 = "nd"
948 | last_dig == 3 = "rd"
949 | otherwise = "th"
950
951 last_dig = n `rem` 10
952
953 -- | Converts an integer to a verbal multiplicity:
954 --
955 -- > speakN 0 = text "none"
956 -- > speakN 5 = text "five"
957 -- > speakN 10 = text "10"
958 speakN :: Int -> SDoc
959 speakN 0 = ptext (sLit "none") -- E.g. "he has none"
960 speakN 1 = ptext (sLit "one") -- E.g. "he has one"
961 speakN 2 = ptext (sLit "two")
962 speakN 3 = ptext (sLit "three")
963 speakN 4 = ptext (sLit "four")
964 speakN 5 = ptext (sLit "five")
965 speakN 6 = ptext (sLit "six")
966 speakN n = int n
967
968 -- | Converts an integer and object description to a statement about the
969 -- multiplicity of those objects:
970 --
971 -- > speakNOf 0 (text "melon") = text "no melons"
972 -- > speakNOf 1 (text "melon") = text "one melon"
973 -- > speakNOf 3 (text "melon") = text "three melons"
974 speakNOf :: Int -> SDoc -> SDoc
975 speakNOf 0 d = ptext (sLit "no") <+> d <> char 's'
976 speakNOf 1 d = ptext (sLit "one") <+> d -- E.g. "one argument"
977 speakNOf n d = speakN n <+> d <> char 's' -- E.g. "three arguments"
978
979 -- | Converts a strictly positive integer into a number of times:
980 --
981 -- > speakNTimes 1 = text "once"
982 -- > speakNTimes 2 = text "twice"
983 -- > speakNTimes 4 = text "4 times"
984 speakNTimes :: Int {- >=1 -} -> SDoc
985 speakNTimes t | t == 1 = ptext (sLit "once")
986 | t == 2 = ptext (sLit "twice")
987 | otherwise = speakN t <+> ptext (sLit "times")
988
989 -- | Determines the pluralisation suffix appropriate for the length of a list:
990 --
991 -- > plural [] = char 's'
992 -- > plural ["Hello"] = empty
993 -- > plural ["Hello", "World"] = char 's'
994 plural :: [a] -> SDoc
995 plural [_] = empty -- a bit frightening, but there you are
996 plural _ = char 's'
997
998 -- | Determines the form of to be appropriate for the length of a list:
999 --
1000 -- > isOrAre [] = ptext (sLit "are")
1001 -- > isOrAre ["Hello"] = ptext (sLit "is")
1002 -- > isOrAre ["Hello", "World"] = ptext (sLit "are")
1003 isOrAre :: [a] -> SDoc
1004 isOrAre [_] = ptext (sLit "is")
1005 isOrAre _ = ptext (sLit "are")
1006
1007 {-
1008 ************************************************************************
1009 * *
1010 \subsection{Error handling}
1011 * *
1012 ************************************************************************
1013 -}
1014
1015 pprPanic :: String -> SDoc -> a
1016 -- ^ Throw an exception saying "bug in GHC"
1017 pprPanic = panicDoc
1018
1019 pprSorry :: String -> SDoc -> a
1020 -- ^ Throw an exception saying "this isn't finished yet"
1021 pprSorry = sorryDoc
1022
1023
1024 pprPgmError :: String -> SDoc -> a
1025 -- ^ Throw an exception saying "bug in pgm being compiled" (used for unusual program errors)
1026 pprPgmError = pgmErrorDoc
1027
1028
1029 pprTrace :: String -> SDoc -> a -> a
1030 -- ^ If debug output is on, show some 'SDoc' on the screen
1031 pprTrace str doc x
1032 | opt_NoDebugOutput = x
1033 | otherwise = pprDebugAndThen unsafeGlobalDynFlags trace (text str) doc x
1034
1035 pprPanicFastInt :: String -> SDoc -> FastInt
1036 -- ^ Specialization of pprPanic that can be safely used with 'FastInt'
1037 pprPanicFastInt heading pretty_msg = panicDocFastInt heading pretty_msg
1038
1039 warnPprTrace :: Bool -> String -> Int -> SDoc -> a -> a
1040 -- ^ Just warn about an assertion failure, recording the given file and line number.
1041 -- Should typically be accessed with the WARN macros
1042 warnPprTrace _ _ _ _ x | not debugIsOn = x
1043 warnPprTrace _ _file _line _msg x | opt_NoDebugOutput = x
1044 warnPprTrace False _file _line _msg x = x
1045 warnPprTrace True file line msg x
1046 = pprDebugAndThen unsafeGlobalDynFlags trace heading msg x
1047 where
1048 heading = hsep [text "WARNING: file", text file <> comma, text "line", int line]
1049
1050 assertPprPanic :: String -> Int -> SDoc -> a
1051 -- ^ Panic with an assertation failure, recording the given file and line number.
1052 -- Should typically be accessed with the ASSERT family of macros
1053 assertPprPanic file line msg
1054 = pprPanic "ASSERT failed!" doc
1055 where
1056 doc = sep [ hsep [ text "file", text file
1057 , text "line", int line ]
1058 , msg ]
1059
1060 pprDebugAndThen :: DynFlags -> (String -> a) -> SDoc -> SDoc -> a
1061 pprDebugAndThen dflags cont heading pretty_msg
1062 = cont (showSDocDump dflags doc)
1063 where
1064 doc = sep [heading, nest 2 pretty_msg]