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