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