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