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