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