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