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