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