FIX BUILD with GHC 6.2.x: VectInfo -> HscTypes.VectInfo
[ghc-hetmet.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 Outputable: defines classes for pretty-printing and forcing, both
7 forms of ``output.''
8
9 \begin{code}
10
11 module Outputable (
12         Outputable(..), OutputableBndr(..),     -- Class
13
14         BindingSite(..),
15
16         PprStyle, CodeStyle(..), PrintUnqualified, alwaysQualify,
17         getPprStyle, withPprStyle, withPprStyleDoc, 
18         pprDeeper, pprDeeperList, pprSetDepth,
19         codeStyle, userStyle, debugStyle, dumpStyle, asmStyle,
20         ifPprDebug, qualName, qualModule,
21         mkErrStyle, defaultErrStyle, defaultDumpStyle, defaultUserStyle,
22
23         SDoc,           -- Abstract
24         docToSDoc,
25         interppSP, interpp'SP, pprQuotedList, pprWithCommas,
26         empty, nest,
27         text, char, ftext, ptext,
28         int, integer, float, double, rational,
29         parens, cparen, brackets, braces, quotes, doubleQuotes, angleBrackets,
30         semi, comma, colon, dcolon, space, equals, dot, arrow,
31         lparen, rparen, lbrack, rbrack, lbrace, rbrace, underscore,
32         (<>), (<+>), hcat, hsep, 
33         ($$), ($+$), vcat, 
34         sep, cat, 
35         fsep, fcat, 
36         hang, punctuate,
37         speakNth, speakNTimes, speakN, speakNOf, plural,
38
39         printSDoc, printErrs, printDump,
40         printForC, printForAsm, printForUser,
41         pprCode, mkCodeStyle,
42         showSDoc, showSDocForUser, showSDocDebug, showSDocDump,
43         showSDocUnqual, showsPrecSDoc,
44         pprHsChar, pprHsString,
45
46         -- error handling
47         pprPanic, assertPprPanic, pprPanic#, pprPgmError, 
48         pprTrace, warnPprTrace,
49         trace, pgmError, panic, panic#, assertPanic
50     ) where
51
52 #include "HsVersions.h"
53
54
55 import {-# SOURCE #-}   Module( Module, modulePackageId, 
56                                 ModuleName, moduleName )
57 import {-# SOURCE #-}   OccName( OccName )
58
59 import StaticFlags      ( opt_PprStyle_Debug, opt_PprUserLength )
60 import PackageConfig    ( PackageId, packageIdString )
61 import FastString
62 import qualified Pretty
63 import Pretty           ( Doc, Mode(..) )
64 import Panic
65
66 import Data.Word        ( Word32 )
67 import System.IO        ( Handle, stderr, stdout, hFlush )
68 import Data.Char        ( ord )
69 \end{code}
70
71
72 %************************************************************************
73 %*                                                                      *
74 \subsection{The @PprStyle@ data type}
75 %*                                                                      *
76 %************************************************************************
77
78 \begin{code}
79
80 data PprStyle
81   = PprUser PrintUnqualified Depth
82                 -- Pretty-print in a way that will make sense to the
83                 -- ordinary user; must be very close to Haskell
84                 -- syntax, etc.
85                 -- Assumes printing tidied code: non-system names are
86                 -- printed without uniques.
87
88   | PprCode CodeStyle
89                 -- Print code; either C or assembler
90
91   | PprDump     -- For -ddump-foo; less verbose than PprDebug.
92                 -- Does not assume tidied code: non-external names
93                 -- are printed with uniques.
94
95   | PprDebug    -- Full debugging output
96
97 data CodeStyle = CStyle         -- The format of labels differs for C and assembler
98                | AsmStyle
99
100 data Depth = AllTheWay
101            | PartWay Int        -- 0 => stop
102
103
104 -- -----------------------------------------------------------------------------
105 -- Printing original names
106
107 -- When printing code that contains original names, we need to map the
108 -- original names back to something the user understands.  This is the
109 -- purpose of the pair of functions that gets passed around
110 -- when rendering 'SDoc'.
111
112 -- | given an /original/ name, this function tells you which module
113 -- name it should be qualified with when printing for the user, if
114 -- any.  For example, given @Control.Exception.catch@, which is in scope
115 -- as @Exception.catch@, this fuction will return @Just "Exception"@.
116 -- Note that the return value is a ModuleName, not a Module, because
117 -- in source code, names are qualified by ModuleNames.
118 type QualifyName = Module -> OccName -> Maybe ModuleName
119
120 -- | For a given module, we need to know whether to print it with
121 -- a package name to disambiguate it, and if so which package name should
122 -- we use.
123 type QualifyModule = Module -> Maybe PackageId
124
125 type PrintUnqualified = (QualifyName, QualifyModule)
126
127 alwaysQualifyNames :: QualifyName
128 alwaysQualifyNames m n = Just (moduleName m)
129
130 neverQualifyNames :: QualifyName
131 neverQualifyNames m n = Nothing
132
133 alwaysQualifyModules :: QualifyModule
134 alwaysQualifyModules m = Just (modulePackageId m)
135
136 neverQualifyModules :: QualifyModule
137 neverQualifyModules m = Nothing
138
139 alwaysQualify = (alwaysQualifyNames, alwaysQualifyModules)
140 neverQualify  = (neverQualifyNames,  neverQualifyModules)
141
142 defaultUserStyle = mkUserStyle alwaysQualify AllTheWay
143
144 defaultDumpStyle |  opt_PprStyle_Debug = PprDebug
145                  |  otherwise          = PprDump
146
147 -- | Style for printing error messages
148 mkErrStyle :: PrintUnqualified -> PprStyle
149 mkErrStyle qual = mkUserStyle qual (PartWay opt_PprUserLength)
150
151 defaultErrStyle :: PprStyle
152 -- Default style for error messages
153 -- It's a bit of a hack because it doesn't take into account what's in scope
154 -- Only used for desugarer warnings, and typechecker errors in interface sigs
155 defaultErrStyle 
156   | opt_PprStyle_Debug   = mkUserStyle alwaysQualify AllTheWay
157   | otherwise            = mkUserStyle alwaysQualify (PartWay opt_PprUserLength)
158
159 mkUserStyle unqual depth
160    | opt_PprStyle_Debug = PprDebug
161    | otherwise          = PprUser unqual depth
162 \end{code}
163
164 Orthogonal to the above printing styles are (possibly) some
165 command-line flags that affect printing (often carried with the
166 style).  The most likely ones are variations on how much type info is
167 shown.
168
169 The following test decides whether or not we are actually generating
170 code (either C or assembly), or generating interface files.
171
172 %************************************************************************
173 %*                                                                      *
174 \subsection{The @SDoc@ data type}
175 %*                                                                      *
176 %************************************************************************
177
178 \begin{code}
179 type SDoc = PprStyle -> Doc
180
181 withPprStyle :: PprStyle -> SDoc -> SDoc
182 withPprStyle sty d sty' = d sty
183
184 withPprStyleDoc :: PprStyle -> SDoc -> Doc
185 withPprStyleDoc sty d = d sty
186
187 pprDeeper :: SDoc -> SDoc
188 pprDeeper d (PprUser q (PartWay 0)) = Pretty.text "..."
189 pprDeeper d (PprUser q (PartWay n)) = d (PprUser q (PartWay (n-1)))
190 pprDeeper d other_sty               = d other_sty
191
192 pprDeeperList :: ([SDoc] -> SDoc) -> [SDoc] -> SDoc
193 -- Truncate a list that list that is longer than the current depth
194 pprDeeperList f ds (PprUser q (PartWay n))
195   | n==0      = Pretty.text "..."
196   | otherwise = f (go 0 ds) (PprUser q (PartWay (n-1)))
197   where
198     go i [] = []
199     go i (d:ds) | i >= n    = [text "...."]
200                 | otherwise = d : go (i+1) ds
201
202 pprDeeperList f ds other_sty
203   = f ds other_sty
204
205 pprSetDepth :: Int -> SDoc -> SDoc
206 pprSetDepth n d (PprUser q _) = d (PprUser q (PartWay n))
207 pprSetDepth n d other_sty     = d other_sty
208
209 getPprStyle :: (PprStyle -> SDoc) -> SDoc
210 getPprStyle df sty = df sty sty
211 \end{code}
212
213 \begin{code}
214 qualName :: PprStyle -> QualifyName
215 qualName (PprUser (qual_name,_) _) m n = qual_name m n
216 qualName other                     m n = Just (moduleName m)
217
218 qualModule :: PprStyle -> QualifyModule
219 qualModule (PprUser (_,qual_mod) _) m = qual_mod m
220 qualModule other                    m = Just (modulePackageId m)
221
222 codeStyle :: PprStyle -> Bool
223 codeStyle (PprCode _)     = True
224 codeStyle _               = False
225
226 asmStyle :: PprStyle -> Bool
227 asmStyle (PprCode AsmStyle)  = True
228 asmStyle other               = False
229
230 dumpStyle :: PprStyle -> Bool
231 dumpStyle PprDump = True
232 dumpStyle other   = False
233
234 debugStyle :: PprStyle -> Bool
235 debugStyle PprDebug       = True
236 debugStyle other          = False
237
238 userStyle ::  PprStyle -> Bool
239 userStyle (PprUser _ _) = True
240 userStyle other         = False
241
242 ifPprDebug :: SDoc -> SDoc        -- Empty for non-debug style
243 ifPprDebug d sty@PprDebug = d sty
244 ifPprDebug d sty          = Pretty.empty
245 \end{code}
246
247 \begin{code}
248 -- Unused [7/02 sof]
249 printSDoc :: SDoc -> PprStyle -> IO ()
250 printSDoc d sty = do
251   Pretty.printDoc PageMode stdout (d sty)
252   hFlush stdout
253
254 -- I'm not sure whether the direct-IO approach of Pretty.printDoc
255 -- above is better or worse than the put-big-string approach here
256 printErrs :: Doc -> IO ()
257 printErrs doc = do Pretty.printDoc PageMode stderr doc
258                    hFlush stderr
259
260 printDump :: SDoc -> IO ()
261 printDump doc = do
262    Pretty.printDoc PageMode stdout (better_doc defaultDumpStyle)
263    hFlush stdout
264  where
265    better_doc = doc $$ text ""
266
267 printForUser :: Handle -> PrintUnqualified -> SDoc -> IO ()
268 printForUser handle unqual doc 
269   = Pretty.printDoc PageMode handle (doc (mkUserStyle unqual AllTheWay))
270
271 -- printForC, printForAsm do what they sound like
272 printForC :: Handle -> SDoc -> IO ()
273 printForC handle doc = Pretty.printDoc LeftMode handle (doc (PprCode CStyle))
274
275 printForAsm :: Handle -> SDoc -> IO ()
276 printForAsm handle doc = Pretty.printDoc LeftMode handle (doc (PprCode AsmStyle))
277
278 pprCode :: CodeStyle -> SDoc -> SDoc
279 pprCode cs d = withPprStyle (PprCode cs) d
280
281 mkCodeStyle :: CodeStyle -> PprStyle
282 mkCodeStyle = PprCode
283
284 -- Can't make SDoc an instance of Show because SDoc is just a function type
285 -- However, Doc *is* an instance of Show
286 -- showSDoc just blasts it out as a string
287 showSDoc :: SDoc -> String
288 showSDoc d = show (d defaultUserStyle)
289
290 showSDocForUser :: PrintUnqualified -> SDoc -> String
291 showSDocForUser unqual doc = show (doc (mkUserStyle unqual AllTheWay))
292
293 showSDocUnqual :: SDoc -> String
294 -- Only used in the gruesome HsExpr.isOperator
295 showSDocUnqual d = show (d (mkUserStyle neverQualify AllTheWay))
296
297 showsPrecSDoc :: Int -> SDoc -> ShowS
298 showsPrecSDoc p d = showsPrec p (d defaultUserStyle)
299
300 showSDocDump :: SDoc -> String
301 showSDocDump d = show (d PprDump)
302
303 showSDocDebug :: SDoc -> String
304 showSDocDebug d = show (d PprDebug)
305 \end{code}
306
307 \begin{code}
308 docToSDoc :: Doc -> SDoc
309 docToSDoc d = \_ -> d
310
311 empty sty      = Pretty.empty
312 text s sty     = Pretty.text s
313 char c sty     = Pretty.char c
314 ftext s sty    = Pretty.ftext s
315 ptext s sty    = Pretty.ptext s
316 int n sty      = Pretty.int n
317 integer n sty  = Pretty.integer n
318 float n sty    = Pretty.float n
319 double n sty   = Pretty.double n
320 rational n sty = Pretty.rational n
321
322 parens d sty       = Pretty.parens (d sty)
323 braces d sty       = Pretty.braces (d sty)
324 brackets d sty     = Pretty.brackets (d sty)
325 doubleQuotes d sty = Pretty.doubleQuotes (d sty)
326 angleBrackets d    = char '<' <> d <> char '>'
327
328 cparen b d sty       = Pretty.cparen b (d sty)
329
330 -- quotes encloses something in single quotes...
331 -- but it omits them if the thing ends in a single quote
332 -- so that we don't get `foo''.  Instead we just have foo'.
333 quotes d sty = case show pp_d of
334                  ('\'' : _) -> pp_d
335                  other      -> Pretty.quotes pp_d
336              where
337                pp_d = d sty
338
339 semi sty   = Pretty.semi
340 comma sty  = Pretty.comma
341 colon sty  = Pretty.colon
342 equals sty = Pretty.equals
343 space sty  = Pretty.space
344 lparen sty = Pretty.lparen
345 rparen sty = Pretty.rparen
346 lbrack sty = Pretty.lbrack
347 rbrack sty = Pretty.rbrack
348 lbrace sty = Pretty.lbrace
349 rbrace sty = Pretty.rbrace
350 dcolon sty = Pretty.ptext SLIT("::")
351 arrow  sty = Pretty.ptext SLIT("->")
352 underscore = char '_'
353 dot        = char '.'
354
355 nest n d sty    = Pretty.nest n (d sty)
356 (<>) d1 d2 sty  = (Pretty.<>)  (d1 sty) (d2 sty)
357 (<+>) d1 d2 sty = (Pretty.<+>) (d1 sty) (d2 sty)
358 ($$) d1 d2 sty  = (Pretty.$$)  (d1 sty) (d2 sty)
359 ($+$) d1 d2 sty = (Pretty.$+$) (d1 sty) (d2 sty)
360
361 hcat ds sty = Pretty.hcat [d sty | d <- ds]
362 hsep ds sty = Pretty.hsep [d sty | d <- ds]
363 vcat ds sty = Pretty.vcat [d sty | d <- ds]
364 sep ds sty  = Pretty.sep  [d sty | d <- ds]
365 cat ds sty  = Pretty.cat  [d sty | d <- ds]
366 fsep ds sty = Pretty.fsep [d sty | d <- ds]
367 fcat ds sty = Pretty.fcat [d sty | d <- ds]
368
369 hang d1 n d2 sty   = Pretty.hang (d1 sty) n (d2 sty)
370
371 punctuate :: SDoc -> [SDoc] -> [SDoc]
372 punctuate p []     = []
373 punctuate p (d:ds) = go d ds
374                    where
375                      go d [] = [d]
376                      go d (e:es) = (d <> p) : go e es
377 \end{code}
378
379
380 %************************************************************************
381 %*                                                                      *
382 \subsection[Outputable-class]{The @Outputable@ class}
383 %*                                                                      *
384 %************************************************************************
385
386 \begin{code}
387 class Outputable a where
388         ppr :: a -> SDoc
389 \end{code}
390
391 \begin{code}
392 instance Outputable Bool where
393     ppr True  = ptext SLIT("True")
394     ppr False = ptext SLIT("False")
395
396 instance Outputable Int where
397    ppr n = int n
398
399 instance Outputable () where
400    ppr _ = text "()"
401
402 instance (Outputable a) => Outputable [a] where
403     ppr xs = brackets (fsep (punctuate comma (map ppr xs)))
404
405 instance (Outputable a, Outputable b) => Outputable (a, b) where
406     ppr (x,y) = parens (sep [ppr x <> comma, ppr y])
407
408 instance Outputable a => Outputable (Maybe a) where
409   ppr Nothing = ptext SLIT("Nothing")
410   ppr (Just x) = ptext SLIT("Just") <+> ppr x
411
412 instance (Outputable a, Outputable b) => Outputable (Either a b) where
413   ppr (Left x)  = ptext SLIT("Left")  <+> ppr x
414   ppr (Right y) = ptext SLIT("Right") <+> ppr y
415
416 -- ToDo: may not be used
417 instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c) where
418     ppr (x,y,z) =
419       parens (sep [ppr x <> comma,
420                    ppr y <> comma,
421                    ppr z ])
422
423 instance (Outputable a, Outputable b, Outputable c, Outputable d) =>
424          Outputable (a, b, c, d) where
425     ppr (x,y,z,w) =
426       parens (sep [ppr x <> comma,
427                    ppr y <> comma,
428                    ppr z <> comma,
429                    ppr w])
430
431 instance Outputable FastString where
432     ppr fs = ftext fs           -- Prints an unadorned string,
433                                 -- no double quotes or anything
434
435 instance Outputable PackageId where
436    ppr pid = text (packageIdString pid)
437 \end{code}
438
439
440 %************************************************************************
441 %*                                                                      *
442 \subsection{The @OutputableBndr@ class}
443 %*                                                                      *
444 %************************************************************************
445
446 When we print a binder, we often want to print its type too.
447 The @OutputableBndr@ class encapsulates this idea.
448
449 @BindingSite@ is used to tell the thing that prints binder what
450 language construct is binding the identifier.  This can be used
451 to decide how much info to print.
452
453 \begin{code}
454 data BindingSite = LambdaBind | CaseBind | LetBind
455
456 class Outputable a => OutputableBndr a where
457    pprBndr :: BindingSite -> a -> SDoc
458    pprBndr b x = ppr x
459 \end{code}
460
461
462
463 %************************************************************************
464 %*                                                                      *
465 \subsection{Random printing helpers}
466 %*                                                                      *
467 %************************************************************************
468
469 \begin{code}
470 -- We have 31-bit Chars and will simply use Show instances
471 -- of Char and String.
472
473 pprHsChar :: Char -> SDoc
474 pprHsChar c | c > '\x10ffff' = char '\\' <> text (show (fromIntegral (ord c) :: Word32))
475             | otherwise      = text (show c)
476
477 pprHsString :: FastString -> SDoc
478 pprHsString fs = text (show (unpackFS fs))
479 \end{code}
480
481
482 %************************************************************************
483 %*                                                                      *
484 \subsection{Other helper functions}
485 %*                                                                      *
486 %************************************************************************
487
488 \begin{code}
489 pprWithCommas :: (a -> SDoc) -> [a] -> SDoc
490 pprWithCommas pp xs = fsep (punctuate comma (map pp xs))
491
492 interppSP  :: Outputable a => [a] -> SDoc
493 interppSP  xs = sep (map ppr xs)
494
495 interpp'SP :: Outputable a => [a] -> SDoc
496 interpp'SP xs = sep (punctuate comma (map ppr xs))
497
498 pprQuotedList :: Outputable a => [a] -> SDoc
499 -- [x,y,z]  ==>  `x', `y', `z'
500 pprQuotedList xs = hsep (punctuate comma (map (quotes . ppr) xs))
501 \end{code}
502
503
504 %************************************************************************
505 %*                                                                      *
506 \subsection{Printing numbers verbally}
507 %*                                                                      *
508 %************************************************************************
509
510 @speakNth@ converts an integer to a verbal index; eg 1 maps to
511 ``first'' etc.
512
513 \begin{code}
514 speakNth :: Int -> SDoc
515 speakNth 1 = ptext SLIT("first")
516 speakNth 2 = ptext SLIT("second")
517 speakNth 3 = ptext SLIT("third")
518 speakNth 4 = ptext SLIT("fourth")
519 speakNth 5 = ptext SLIT("fifth")
520 speakNth 6 = ptext SLIT("sixth")
521 speakNth n = hcat [ int n, text suffix ]
522   where
523     suffix | n <= 20       = "th"       -- 11,12,13 are non-std
524            | last_dig == 1 = "st"
525            | last_dig == 2 = "nd"
526            | last_dig == 3 = "rd"
527            | otherwise     = "th"
528
529     last_dig = n `rem` 10
530
531 speakN :: Int -> SDoc
532 speakN 0 = ptext SLIT("none")   -- E.g.  "he has none"
533 speakN 1 = ptext SLIT("one")    -- E.g.  "he has one"
534 speakN 2 = ptext SLIT("two")
535 speakN 3 = ptext SLIT("three")
536 speakN 4 = ptext SLIT("four")
537 speakN 5 = ptext SLIT("five")
538 speakN 6 = ptext SLIT("six")
539 speakN n = int n
540
541 speakNOf :: Int -> SDoc -> SDoc
542 speakNOf 0 d = ptext SLIT("no") <+> d <> char 's'       -- E.g. "no arguments"
543 speakNOf 1 d = ptext SLIT("one") <+> d                  -- E.g. "one argument"
544 speakNOf n d = speakN n <+> d <> char 's'               -- E.g. "three arguments"
545
546 speakNTimes :: Int {- >=1 -} -> SDoc
547 speakNTimes t | t == 1     = ptext SLIT("once")
548               | t == 2     = ptext SLIT("twice")
549               | otherwise  = speakN t <+> ptext SLIT("times")
550
551 plural [x] = empty
552 plural xs  = char 's'
553 \end{code}
554
555
556 %************************************************************************
557 %*                                                                      *
558 \subsection{Error handling}
559 %*                                                                      *
560 %************************************************************************
561
562 \begin{code}
563 pprPanic, pprPgmError :: String -> SDoc -> a
564 pprTrace :: String -> SDoc -> a -> a
565 pprPanic    = pprAndThen panic          -- Throw an exn saying "bug in GHC"
566
567 pprPgmError = pprAndThen pgmError       -- Throw an exn saying "bug in pgm being compiled"
568                                         --      (used for unusual pgm errors)
569 pprTrace    = pprAndThen trace
570
571 pprPanic# heading pretty_msg = panic# (show (doc PprDebug))
572                              where
573                                doc = text heading <+> pretty_msg
574
575 pprAndThen :: (String -> a) -> String -> SDoc -> a
576 pprAndThen cont heading pretty_msg = cont (show (doc PprDebug))
577     where
578      doc = sep [text heading, nest 4 pretty_msg]
579
580 assertPprPanic :: String -> Int -> SDoc -> a
581 assertPprPanic file line msg
582   = panic (show (doc PprDebug))
583   where
584     doc = sep [hsep[text "ASSERT failed! file", 
585                            text file, 
586                            text "line", int line], 
587                     msg]
588
589 warnPprTrace :: Bool -> String -> Int -> SDoc -> a -> a
590 warnPprTrace False file line msg x = x
591 warnPprTrace True  file line msg x
592   = trace (show (doc PprDebug)) x
593   where
594     doc = sep [hsep [text "WARNING: file", text file, text "line", int line],
595                msg]
596 \end{code}