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