2 % (c) The University of Glasgow 2006
3 % (c) The GRASP Project, Glasgow University, 1992-1998
6 Outputable: defines classes for pretty-printing and forcing, both
10 {-# OPTIONS_GHC -w #-}
11 -- The above warning supression flag is a temporary kludge.
12 -- While working on this module you are encouraged to remove it and fix
13 -- any warnings in the module. See
14 -- http://hackage.haskell.org/trac/ghc/wiki/WorkingConventions#Warnings
18 Outputable(..), OutputableBndr(..), -- Class
22 PprStyle, CodeStyle(..), PrintUnqualified, alwaysQualify,
23 getPprStyle, withPprStyle, withPprStyleDoc,
24 pprDeeper, pprDeeperList, pprSetDepth,
25 codeStyle, userStyle, debugStyle, dumpStyle, asmStyle,
26 ifPprDebug, qualName, qualModule,
27 mkErrStyle, defaultErrStyle, defaultDumpStyle, defaultUserStyle,
31 interppSP, interpp'SP, pprQuotedList, pprWithCommas,
33 text, char, ftext, ptext,
34 int, integer, float, double, rational,
35 parens, cparen, brackets, braces, quotes, doubleQuotes, angleBrackets,
36 semi, comma, colon, dcolon, space, equals, dot, arrow,
37 lparen, rparen, lbrack, rbrack, lbrace, rbrace, underscore,
38 (<>), (<+>), hcat, hsep,
43 speakNth, speakNTimes, speakN, speakNOf, plural,
45 printSDoc, printErrs, hPrintDump, printDump,
46 printForC, printForAsm, printForUser,
48 showSDoc, showSDocForUser, showSDocDebug, showSDocDump,
49 showSDocUnqual, showsPrecSDoc,
50 pprHsChar, pprHsString,
53 pprPanic, assertPprPanic, pprPanic#, pprPgmError,
54 pprTrace, warnPprTrace,
55 trace, pgmError, panic, panic#, assertPanic
58 #include "HsVersions.h"
61 import {-# SOURCE #-} Module( Module, modulePackageId,
62 ModuleName, moduleName )
63 import {-# SOURCE #-} OccName( OccName )
65 import StaticFlags ( opt_PprStyle_Debug, opt_PprUserLength )
66 import PackageConfig ( PackageId, packageIdString )
68 import qualified Pretty
69 import Pretty ( Doc, Mode(..) )
72 import Data.Word ( Word32 )
73 import System.IO ( Handle, stderr, stdout, hFlush )
74 import Data.Char ( ord )
78 %************************************************************************
80 \subsection{The @PprStyle@ data type}
82 %************************************************************************
87 = PprUser PrintUnqualified Depth
88 -- Pretty-print in a way that will make sense to the
89 -- ordinary user; must be very close to Haskell
91 -- Assumes printing tidied code: non-system names are
92 -- printed without uniques.
95 -- Print code; either C or assembler
97 | PprDump -- For -ddump-foo; less verbose than PprDebug.
98 -- Does not assume tidied code: non-external names
99 -- are printed with uniques.
101 | PprDebug -- Full debugging output
103 data CodeStyle = CStyle -- The format of labels differs for C and assembler
106 data Depth = AllTheWay
107 | PartWay Int -- 0 => stop
110 -- -----------------------------------------------------------------------------
111 -- Printing original names
113 -- When printing code that contains original names, we need to map the
114 -- original names back to something the user understands. This is the
115 -- purpose of the pair of functions that gets passed around
116 -- when rendering 'SDoc'.
118 -- | given an /original/ name, this function tells you which module
119 -- name it should be qualified with when printing for the user, if
120 -- any. For example, given @Control.Exception.catch@, which is in scope
121 -- as @Exception.catch@, this fuction will return @Just "Exception"@.
122 -- Note that the return value is a ModuleName, not a Module, because
123 -- in source code, names are qualified by ModuleNames.
124 type QualifyName = Module -> OccName -> Maybe ModuleName
126 -- | For a given module, we need to know whether to print it with
127 -- a package name to disambiguate it, and if so which package name should
129 type QualifyModule = Module -> Maybe PackageId
131 type PrintUnqualified = (QualifyName, QualifyModule)
133 alwaysQualifyNames :: QualifyName
134 alwaysQualifyNames m n = Just (moduleName m)
136 neverQualifyNames :: QualifyName
137 neverQualifyNames m n = Nothing
139 alwaysQualifyModules :: QualifyModule
140 alwaysQualifyModules m = Just (modulePackageId m)
142 neverQualifyModules :: QualifyModule
143 neverQualifyModules m = Nothing
145 alwaysQualify = (alwaysQualifyNames, alwaysQualifyModules)
146 neverQualify = (neverQualifyNames, neverQualifyModules)
148 defaultUserStyle = mkUserStyle alwaysQualify AllTheWay
150 defaultDumpStyle | opt_PprStyle_Debug = PprDebug
151 | otherwise = PprDump
153 -- | Style for printing error messages
154 mkErrStyle :: PrintUnqualified -> PprStyle
155 mkErrStyle qual = mkUserStyle qual (PartWay opt_PprUserLength)
157 defaultErrStyle :: PprStyle
158 -- Default style for error messages
159 -- It's a bit of a hack because it doesn't take into account what's in scope
160 -- Only used for desugarer warnings, and typechecker errors in interface sigs
162 | opt_PprStyle_Debug = mkUserStyle alwaysQualify AllTheWay
163 | otherwise = mkUserStyle alwaysQualify (PartWay opt_PprUserLength)
165 mkUserStyle unqual depth
166 | opt_PprStyle_Debug = PprDebug
167 | otherwise = PprUser unqual depth
170 Orthogonal to the above printing styles are (possibly) some
171 command-line flags that affect printing (often carried with the
172 style). The most likely ones are variations on how much type info is
175 The following test decides whether or not we are actually generating
176 code (either C or assembly), or generating interface files.
178 %************************************************************************
180 \subsection{The @SDoc@ data type}
182 %************************************************************************
185 type SDoc = PprStyle -> Doc
187 withPprStyle :: PprStyle -> SDoc -> SDoc
188 withPprStyle sty d sty' = d sty
190 withPprStyleDoc :: PprStyle -> SDoc -> Doc
191 withPprStyleDoc sty d = d sty
193 pprDeeper :: SDoc -> SDoc
194 pprDeeper d (PprUser q (PartWay 0)) = Pretty.text "..."
195 pprDeeper d (PprUser q (PartWay n)) = d (PprUser q (PartWay (n-1)))
196 pprDeeper d other_sty = d other_sty
198 pprDeeperList :: ([SDoc] -> SDoc) -> [SDoc] -> SDoc
199 -- Truncate a list that list that is longer than the current depth
200 pprDeeperList f ds (PprUser q (PartWay n))
201 | n==0 = Pretty.text "..."
202 | otherwise = f (go 0 ds) (PprUser q (PartWay (n-1)))
205 go i (d:ds) | i >= n = [text "...."]
206 | otherwise = d : go (i+1) ds
208 pprDeeperList f ds other_sty
211 pprSetDepth :: Int -> SDoc -> SDoc
212 pprSetDepth n d (PprUser q _) = d (PprUser q (PartWay n))
213 pprSetDepth n d other_sty = d other_sty
215 getPprStyle :: (PprStyle -> SDoc) -> SDoc
216 getPprStyle df sty = df sty sty
220 qualName :: PprStyle -> QualifyName
221 qualName (PprUser (qual_name,_) _) m n = qual_name m n
222 qualName other m n = Just (moduleName m)
224 qualModule :: PprStyle -> QualifyModule
225 qualModule (PprUser (_,qual_mod) _) m = qual_mod m
226 qualModule other m = Just (modulePackageId m)
228 codeStyle :: PprStyle -> Bool
229 codeStyle (PprCode _) = True
232 asmStyle :: PprStyle -> Bool
233 asmStyle (PprCode AsmStyle) = True
234 asmStyle other = False
236 dumpStyle :: PprStyle -> Bool
237 dumpStyle PprDump = True
238 dumpStyle other = False
240 debugStyle :: PprStyle -> Bool
241 debugStyle PprDebug = True
242 debugStyle other = False
244 userStyle :: PprStyle -> Bool
245 userStyle (PprUser _ _) = True
246 userStyle other = False
248 ifPprDebug :: SDoc -> SDoc -- Empty for non-debug style
249 ifPprDebug d sty@PprDebug = d sty
250 ifPprDebug d sty = Pretty.empty
255 printSDoc :: SDoc -> PprStyle -> IO ()
257 Pretty.printDoc PageMode stdout (d sty)
260 -- I'm not sure whether the direct-IO approach of Pretty.printDoc
261 -- above is better or worse than the put-big-string approach here
262 printErrs :: Doc -> IO ()
263 printErrs doc = do Pretty.printDoc PageMode stderr doc
266 printDump :: SDoc -> IO ()
267 printDump doc = hPrintDump stdout doc
269 hPrintDump :: Handle -> SDoc -> IO ()
270 hPrintDump h doc = do
271 Pretty.printDoc PageMode h (better_doc defaultDumpStyle)
274 better_doc = doc $$ text ""
276 printForUser :: Handle -> PrintUnqualified -> SDoc -> IO ()
277 printForUser handle unqual doc
278 = Pretty.printDoc PageMode handle (doc (mkUserStyle unqual AllTheWay))
280 -- printForC, printForAsm do what they sound like
281 printForC :: Handle -> SDoc -> IO ()
282 printForC handle doc = Pretty.printDoc LeftMode handle (doc (PprCode CStyle))
284 printForAsm :: Handle -> SDoc -> IO ()
285 printForAsm handle doc = Pretty.printDoc LeftMode handle (doc (PprCode AsmStyle))
287 pprCode :: CodeStyle -> SDoc -> SDoc
288 pprCode cs d = withPprStyle (PprCode cs) d
290 mkCodeStyle :: CodeStyle -> PprStyle
291 mkCodeStyle = PprCode
293 -- Can't make SDoc an instance of Show because SDoc is just a function type
294 -- However, Doc *is* an instance of Show
295 -- showSDoc just blasts it out as a string
296 showSDoc :: SDoc -> String
297 showSDoc d = show (d defaultUserStyle)
299 showSDocForUser :: PrintUnqualified -> SDoc -> String
300 showSDocForUser unqual doc = show (doc (mkUserStyle unqual AllTheWay))
302 showSDocUnqual :: SDoc -> String
303 -- Only used in the gruesome HsExpr.isOperator
304 showSDocUnqual d = show (d (mkUserStyle neverQualify AllTheWay))
306 showsPrecSDoc :: Int -> SDoc -> ShowS
307 showsPrecSDoc p d = showsPrec p (d defaultUserStyle)
309 showSDocDump :: SDoc -> String
310 showSDocDump d = show (d PprDump)
312 showSDocDebug :: SDoc -> String
313 showSDocDebug d = show (d PprDebug)
317 docToSDoc :: Doc -> SDoc
318 docToSDoc d = \_ -> d
320 empty sty = Pretty.empty
321 text s sty = Pretty.text s
322 char c sty = Pretty.char c
323 ftext s sty = Pretty.ftext s
324 ptext s sty = Pretty.ptext s
325 int n sty = Pretty.int n
326 integer n sty = Pretty.integer n
327 float n sty = Pretty.float n
328 double n sty = Pretty.double n
329 rational n sty = Pretty.rational n
331 parens d sty = Pretty.parens (d sty)
332 braces d sty = Pretty.braces (d sty)
333 brackets d sty = Pretty.brackets (d sty)
334 doubleQuotes d sty = Pretty.doubleQuotes (d sty)
335 angleBrackets d = char '<' <> d <> char '>'
337 cparen b d sty = Pretty.cparen b (d sty)
339 -- quotes encloses something in single quotes...
340 -- but it omits them if the thing ends in a single quote
341 -- so that we don't get `foo''. Instead we just have foo'.
342 quotes d sty = case show pp_d of
344 other -> Pretty.quotes pp_d
348 semi sty = Pretty.semi
349 comma sty = Pretty.comma
350 colon sty = Pretty.colon
351 equals sty = Pretty.equals
352 space sty = Pretty.space
353 lparen sty = Pretty.lparen
354 rparen sty = Pretty.rparen
355 lbrack sty = Pretty.lbrack
356 rbrack sty = Pretty.rbrack
357 lbrace sty = Pretty.lbrace
358 rbrace sty = Pretty.rbrace
359 dcolon sty = Pretty.ptext SLIT("::")
360 arrow sty = Pretty.ptext SLIT("->")
361 underscore = char '_'
364 nest n d sty = Pretty.nest n (d sty)
365 (<>) d1 d2 sty = (Pretty.<>) (d1 sty) (d2 sty)
366 (<+>) d1 d2 sty = (Pretty.<+>) (d1 sty) (d2 sty)
367 ($$) d1 d2 sty = (Pretty.$$) (d1 sty) (d2 sty)
368 ($+$) d1 d2 sty = (Pretty.$+$) (d1 sty) (d2 sty)
370 hcat ds sty = Pretty.hcat [d sty | d <- ds]
371 hsep ds sty = Pretty.hsep [d sty | d <- ds]
372 vcat ds sty = Pretty.vcat [d sty | d <- ds]
373 sep ds sty = Pretty.sep [d sty | d <- ds]
374 cat ds sty = Pretty.cat [d sty | d <- ds]
375 fsep ds sty = Pretty.fsep [d sty | d <- ds]
376 fcat ds sty = Pretty.fcat [d sty | d <- ds]
378 hang d1 n d2 sty = Pretty.hang (d1 sty) n (d2 sty)
380 punctuate :: SDoc -> [SDoc] -> [SDoc]
382 punctuate p (d:ds) = go d ds
385 go d (e:es) = (d <> p) : go e es
389 %************************************************************************
391 \subsection[Outputable-class]{The @Outputable@ class}
393 %************************************************************************
396 class Outputable a where
401 instance Outputable Bool where
402 ppr True = ptext SLIT("True")
403 ppr False = ptext SLIT("False")
405 instance Outputable Int where
408 instance Outputable () where
411 instance (Outputable a) => Outputable [a] where
412 ppr xs = brackets (fsep (punctuate comma (map ppr xs)))
414 instance (Outputable a, Outputable b) => Outputable (a, b) where
415 ppr (x,y) = parens (sep [ppr x <> comma, ppr y])
417 instance Outputable a => Outputable (Maybe a) where
418 ppr Nothing = ptext SLIT("Nothing")
419 ppr (Just x) = ptext SLIT("Just") <+> ppr x
421 instance (Outputable a, Outputable b) => Outputable (Either a b) where
422 ppr (Left x) = ptext SLIT("Left") <+> ppr x
423 ppr (Right y) = ptext SLIT("Right") <+> ppr y
425 -- ToDo: may not be used
426 instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c) where
428 parens (sep [ppr x <> comma,
432 instance (Outputable a, Outputable b, Outputable c, Outputable d) =>
433 Outputable (a, b, c, d) where
435 parens (sep [ppr x <> comma,
440 instance Outputable FastString where
441 ppr fs = ftext fs -- Prints an unadorned string,
442 -- no double quotes or anything
444 instance Outputable PackageId where
445 ppr pid = text (packageIdString pid)
449 %************************************************************************
451 \subsection{The @OutputableBndr@ class}
453 %************************************************************************
455 When we print a binder, we often want to print its type too.
456 The @OutputableBndr@ class encapsulates this idea.
458 @BindingSite@ is used to tell the thing that prints binder what
459 language construct is binding the identifier. This can be used
460 to decide how much info to print.
463 data BindingSite = LambdaBind | CaseBind | LetBind
465 class Outputable a => OutputableBndr a where
466 pprBndr :: BindingSite -> a -> SDoc
472 %************************************************************************
474 \subsection{Random printing helpers}
476 %************************************************************************
479 -- We have 31-bit Chars and will simply use Show instances
480 -- of Char and String.
482 pprHsChar :: Char -> SDoc
483 pprHsChar c | c > '\x10ffff' = char '\\' <> text (show (fromIntegral (ord c) :: Word32))
484 | otherwise = text (show c)
486 pprHsString :: FastString -> SDoc
487 pprHsString fs = text (show (unpackFS fs))
491 %************************************************************************
493 \subsection{Other helper functions}
495 %************************************************************************
498 pprWithCommas :: (a -> SDoc) -> [a] -> SDoc
499 pprWithCommas pp xs = fsep (punctuate comma (map pp xs))
501 interppSP :: Outputable a => [a] -> SDoc
502 interppSP xs = sep (map ppr xs)
504 interpp'SP :: Outputable a => [a] -> SDoc
505 interpp'SP xs = sep (punctuate comma (map ppr xs))
507 pprQuotedList :: Outputable a => [a] -> SDoc
508 -- [x,y,z] ==> `x', `y', `z'
509 pprQuotedList xs = hsep (punctuate comma (map (quotes . ppr) xs))
513 %************************************************************************
515 \subsection{Printing numbers verbally}
517 %************************************************************************
519 @speakNth@ converts an integer to a verbal index; eg 1 maps to
523 speakNth :: Int -> SDoc
524 speakNth 1 = ptext SLIT("first")
525 speakNth 2 = ptext SLIT("second")
526 speakNth 3 = ptext SLIT("third")
527 speakNth 4 = ptext SLIT("fourth")
528 speakNth 5 = ptext SLIT("fifth")
529 speakNth 6 = ptext SLIT("sixth")
530 speakNth n = hcat [ int n, text suffix ]
532 suffix | n <= 20 = "th" -- 11,12,13 are non-std
533 | last_dig == 1 = "st"
534 | last_dig == 2 = "nd"
535 | last_dig == 3 = "rd"
538 last_dig = n `rem` 10
540 speakN :: Int -> SDoc
541 speakN 0 = ptext SLIT("none") -- E.g. "he has none"
542 speakN 1 = ptext SLIT("one") -- E.g. "he has one"
543 speakN 2 = ptext SLIT("two")
544 speakN 3 = ptext SLIT("three")
545 speakN 4 = ptext SLIT("four")
546 speakN 5 = ptext SLIT("five")
547 speakN 6 = ptext SLIT("six")
550 speakNOf :: Int -> SDoc -> SDoc
551 speakNOf 0 d = ptext SLIT("no") <+> d <> char 's' -- E.g. "no arguments"
552 speakNOf 1 d = ptext SLIT("one") <+> d -- E.g. "one argument"
553 speakNOf n d = speakN n <+> d <> char 's' -- E.g. "three arguments"
555 speakNTimes :: Int {- >=1 -} -> SDoc
556 speakNTimes t | t == 1 = ptext SLIT("once")
557 | t == 2 = ptext SLIT("twice")
558 | otherwise = speakN t <+> ptext SLIT("times")
565 %************************************************************************
567 \subsection{Error handling}
569 %************************************************************************
572 pprPanic, pprPgmError :: String -> SDoc -> a
573 pprTrace :: String -> SDoc -> a -> a
574 pprPanic = pprAndThen panic -- Throw an exn saying "bug in GHC"
576 pprPgmError = pprAndThen pgmError -- Throw an exn saying "bug in pgm being compiled"
577 -- (used for unusual pgm errors)
578 pprTrace = pprAndThen trace
580 pprPanic# heading pretty_msg = panic# (show (doc PprDebug))
582 doc = text heading <+> pretty_msg
584 pprAndThen :: (String -> a) -> String -> SDoc -> a
585 pprAndThen cont heading pretty_msg = cont (show (doc PprDebug))
587 doc = sep [text heading, nest 4 pretty_msg]
589 assertPprPanic :: String -> Int -> SDoc -> a
590 assertPprPanic file line msg
591 = panic (show (doc PprDebug))
593 doc = sep [hsep[text "ASSERT failed! file",
595 text "line", int line],
598 warnPprTrace :: Bool -> String -> Int -> SDoc -> a -> a
599 warnPprTrace False file line msg x = x
600 warnPprTrace True file line msg x
601 = trace (show (doc PprDebug)) x
603 doc = sep [hsep [text "WARNING: file", text file, text "line", int line],