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
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/Commentary/CodingStyle#Warnings
18 Outputable(..), OutputableBndr(..), -- Class
22 PprStyle, CodeStyle(..), PrintUnqualified, alwaysQualify, QualifyName(..),
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 QueryQualifyName = Module -> OccName -> QualifyName
126 data QualifyName -- given P:M.T
127 = NameUnqual -- refer to it as "T"
128 | NameQual ModuleName -- refer to it as "X.T" for the supplied X
130 -- it is not in scope at all, but M.T is not bound in the current
131 -- scope, so we can refer to it as "M.T"
133 -- it is not in scope at all, and M.T is already bound in the
134 -- current scope, so we must refer to it as "P:M.T"
137 -- | For a given module, we need to know whether to print it with
138 -- a package name to disambiguate it.
139 type QueryQualifyModule = Module -> Bool
141 type PrintUnqualified = (QueryQualifyName, QueryQualifyModule)
143 alwaysQualifyNames :: QueryQualifyName
144 alwaysQualifyNames m n = NameQual (moduleName m)
146 neverQualifyNames :: QueryQualifyName
147 neverQualifyNames m n = NameUnqual
149 alwaysQualifyModules :: QueryQualifyModule
150 alwaysQualifyModules m = True
152 neverQualifyModules :: QueryQualifyModule
153 neverQualifyModules m = False
155 alwaysQualify = (alwaysQualifyNames, alwaysQualifyModules)
156 neverQualify = (neverQualifyNames, neverQualifyModules)
158 defaultUserStyle = mkUserStyle alwaysQualify AllTheWay
160 defaultDumpStyle | opt_PprStyle_Debug = PprDebug
161 | otherwise = PprDump
163 -- | Style for printing error messages
164 mkErrStyle :: PrintUnqualified -> PprStyle
165 mkErrStyle qual = mkUserStyle qual (PartWay opt_PprUserLength)
167 defaultErrStyle :: PprStyle
168 -- Default style for error messages
169 -- It's a bit of a hack because it doesn't take into account what's in scope
170 -- Only used for desugarer warnings, and typechecker errors in interface sigs
172 | opt_PprStyle_Debug = mkUserStyle alwaysQualify AllTheWay
173 | otherwise = mkUserStyle alwaysQualify (PartWay opt_PprUserLength)
175 mkUserStyle unqual depth
176 | opt_PprStyle_Debug = PprDebug
177 | otherwise = PprUser unqual depth
180 Orthogonal to the above printing styles are (possibly) some
181 command-line flags that affect printing (often carried with the
182 style). The most likely ones are variations on how much type info is
185 The following test decides whether or not we are actually generating
186 code (either C or assembly), or generating interface files.
188 %************************************************************************
190 \subsection{The @SDoc@ data type}
192 %************************************************************************
195 type SDoc = PprStyle -> Doc
197 withPprStyle :: PprStyle -> SDoc -> SDoc
198 withPprStyle sty d sty' = d sty
200 withPprStyleDoc :: PprStyle -> SDoc -> Doc
201 withPprStyleDoc sty d = d sty
203 pprDeeper :: SDoc -> SDoc
204 pprDeeper d (PprUser q (PartWay 0)) = Pretty.text "..."
205 pprDeeper d (PprUser q (PartWay n)) = d (PprUser q (PartWay (n-1)))
206 pprDeeper d other_sty = d other_sty
208 pprDeeperList :: ([SDoc] -> SDoc) -> [SDoc] -> SDoc
209 -- Truncate a list that list that is longer than the current depth
210 pprDeeperList f ds (PprUser q (PartWay n))
211 | n==0 = Pretty.text "..."
212 | otherwise = f (go 0 ds) (PprUser q (PartWay (n-1)))
215 go i (d:ds) | i >= n = [text "...."]
216 | otherwise = d : go (i+1) ds
218 pprDeeperList f ds other_sty
221 pprSetDepth :: Int -> SDoc -> SDoc
222 pprSetDepth n d (PprUser q _) = d (PprUser q (PartWay n))
223 pprSetDepth n d other_sty = d other_sty
225 getPprStyle :: (PprStyle -> SDoc) -> SDoc
226 getPprStyle df sty = df sty sty
230 qualName :: PprStyle -> QueryQualifyName
231 qualName (PprUser (qual_name,_) _) m n = qual_name m n
232 qualName other m n = NameQual (moduleName m)
234 qualModule :: PprStyle -> QueryQualifyModule
235 qualModule (PprUser (_,qual_mod) _) m = qual_mod m
236 qualModule other m = True
238 codeStyle :: PprStyle -> Bool
239 codeStyle (PprCode _) = True
242 asmStyle :: PprStyle -> Bool
243 asmStyle (PprCode AsmStyle) = True
244 asmStyle other = False
246 dumpStyle :: PprStyle -> Bool
247 dumpStyle PprDump = True
248 dumpStyle other = False
250 debugStyle :: PprStyle -> Bool
251 debugStyle PprDebug = True
252 debugStyle other = False
254 userStyle :: PprStyle -> Bool
255 userStyle (PprUser _ _) = True
256 userStyle other = False
258 ifPprDebug :: SDoc -> SDoc -- Empty for non-debug style
259 ifPprDebug d sty@PprDebug = d sty
260 ifPprDebug d sty = Pretty.empty
265 printSDoc :: SDoc -> PprStyle -> IO ()
267 Pretty.printDoc PageMode stdout (d sty)
270 -- I'm not sure whether the direct-IO approach of Pretty.printDoc
271 -- above is better or worse than the put-big-string approach here
272 printErrs :: Doc -> IO ()
273 printErrs doc = do Pretty.printDoc PageMode stderr doc
276 printDump :: SDoc -> IO ()
277 printDump doc = hPrintDump stdout doc
279 hPrintDump :: Handle -> SDoc -> IO ()
280 hPrintDump h doc = do
281 Pretty.printDoc PageMode h (better_doc defaultDumpStyle)
284 better_doc = doc $$ text ""
286 printForUser :: Handle -> PrintUnqualified -> SDoc -> IO ()
287 printForUser handle unqual doc
288 = Pretty.printDoc PageMode handle (doc (mkUserStyle unqual AllTheWay))
290 -- printForC, printForAsm do what they sound like
291 printForC :: Handle -> SDoc -> IO ()
292 printForC handle doc = Pretty.printDoc LeftMode handle (doc (PprCode CStyle))
294 printForAsm :: Handle -> SDoc -> IO ()
295 printForAsm handle doc = Pretty.printDoc LeftMode handle (doc (PprCode AsmStyle))
297 pprCode :: CodeStyle -> SDoc -> SDoc
298 pprCode cs d = withPprStyle (PprCode cs) d
300 mkCodeStyle :: CodeStyle -> PprStyle
301 mkCodeStyle = PprCode
303 -- Can't make SDoc an instance of Show because SDoc is just a function type
304 -- However, Doc *is* an instance of Show
305 -- showSDoc just blasts it out as a string
306 showSDoc :: SDoc -> String
307 showSDoc d = show (d defaultUserStyle)
309 showSDocForUser :: PrintUnqualified -> SDoc -> String
310 showSDocForUser unqual doc = show (doc (mkUserStyle unqual AllTheWay))
312 showSDocUnqual :: SDoc -> String
313 -- Only used in the gruesome HsExpr.isOperator
314 showSDocUnqual d = show (d (mkUserStyle neverQualify AllTheWay))
316 showsPrecSDoc :: Int -> SDoc -> ShowS
317 showsPrecSDoc p d = showsPrec p (d defaultUserStyle)
319 showSDocDump :: SDoc -> String
320 showSDocDump d = show (d PprDump)
322 showSDocDebug :: SDoc -> String
323 showSDocDebug d = show (d PprDebug)
327 docToSDoc :: Doc -> SDoc
328 docToSDoc d = \_ -> d
330 empty sty = Pretty.empty
331 text s sty = Pretty.text s
332 char c sty = Pretty.char c
333 ftext s sty = Pretty.ftext s
334 ptext s sty = Pretty.ptext s
335 int n sty = Pretty.int n
336 integer n sty = Pretty.integer n
337 float n sty = Pretty.float n
338 double n sty = Pretty.double n
339 rational n sty = Pretty.rational n
341 parens d sty = Pretty.parens (d sty)
342 braces d sty = Pretty.braces (d sty)
343 brackets d sty = Pretty.brackets (d sty)
344 doubleQuotes d sty = Pretty.doubleQuotes (d sty)
345 angleBrackets d = char '<' <> d <> char '>'
347 cparen b d sty = Pretty.cparen b (d sty)
349 -- quotes encloses something in single quotes...
350 -- but it omits them if the thing ends in a single quote
351 -- so that we don't get `foo''. Instead we just have foo'.
352 quotes d sty = case show pp_d of
354 other -> Pretty.quotes pp_d
358 semi sty = Pretty.semi
359 comma sty = Pretty.comma
360 colon sty = Pretty.colon
361 equals sty = Pretty.equals
362 space sty = Pretty.space
363 lparen sty = Pretty.lparen
364 rparen sty = Pretty.rparen
365 lbrack sty = Pretty.lbrack
366 rbrack sty = Pretty.rbrack
367 lbrace sty = Pretty.lbrace
368 rbrace sty = Pretty.rbrace
369 dcolon sty = Pretty.ptext SLIT("::")
370 arrow sty = Pretty.ptext SLIT("->")
371 underscore = char '_'
374 nest n d sty = Pretty.nest n (d sty)
375 (<>) d1 d2 sty = (Pretty.<>) (d1 sty) (d2 sty)
376 (<+>) d1 d2 sty = (Pretty.<+>) (d1 sty) (d2 sty)
377 ($$) d1 d2 sty = (Pretty.$$) (d1 sty) (d2 sty)
378 ($+$) d1 d2 sty = (Pretty.$+$) (d1 sty) (d2 sty)
380 hcat ds sty = Pretty.hcat [d sty | d <- ds]
381 hsep ds sty = Pretty.hsep [d sty | d <- ds]
382 vcat ds sty = Pretty.vcat [d sty | d <- ds]
383 sep ds sty = Pretty.sep [d sty | d <- ds]
384 cat ds sty = Pretty.cat [d sty | d <- ds]
385 fsep ds sty = Pretty.fsep [d sty | d <- ds]
386 fcat ds sty = Pretty.fcat [d sty | d <- ds]
388 hang d1 n d2 sty = Pretty.hang (d1 sty) n (d2 sty)
390 punctuate :: SDoc -> [SDoc] -> [SDoc]
392 punctuate p (d:ds) = go d ds
395 go d (e:es) = (d <> p) : go e es
399 %************************************************************************
401 \subsection[Outputable-class]{The @Outputable@ class}
403 %************************************************************************
406 class Outputable a where
411 instance Outputable Bool where
412 ppr True = ptext SLIT("True")
413 ppr False = ptext SLIT("False")
415 instance Outputable Int where
418 instance Outputable () where
421 instance (Outputable a) => Outputable [a] where
422 ppr xs = brackets (fsep (punctuate comma (map ppr xs)))
424 instance (Outputable a, Outputable b) => Outputable (a, b) where
425 ppr (x,y) = parens (sep [ppr x <> comma, ppr y])
427 instance Outputable a => Outputable (Maybe a) where
428 ppr Nothing = ptext SLIT("Nothing")
429 ppr (Just x) = ptext SLIT("Just") <+> ppr x
431 instance (Outputable a, Outputable b) => Outputable (Either a b) where
432 ppr (Left x) = ptext SLIT("Left") <+> ppr x
433 ppr (Right y) = ptext SLIT("Right") <+> ppr y
435 -- ToDo: may not be used
436 instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c) where
438 parens (sep [ppr x <> comma,
442 instance (Outputable a, Outputable b, Outputable c, Outputable d) =>
443 Outputable (a, b, c, d) where
445 parens (sep [ppr x <> comma,
450 instance Outputable FastString where
451 ppr fs = ftext fs -- Prints an unadorned string,
452 -- no double quotes or anything
454 instance Outputable PackageId where
455 ppr pid = text (packageIdString pid)
459 %************************************************************************
461 \subsection{The @OutputableBndr@ class}
463 %************************************************************************
465 When we print a binder, we often want to print its type too.
466 The @OutputableBndr@ class encapsulates this idea.
468 @BindingSite@ is used to tell the thing that prints binder what
469 language construct is binding the identifier. This can be used
470 to decide how much info to print.
473 data BindingSite = LambdaBind | CaseBind | LetBind
475 class Outputable a => OutputableBndr a where
476 pprBndr :: BindingSite -> a -> SDoc
482 %************************************************************************
484 \subsection{Random printing helpers}
486 %************************************************************************
489 -- We have 31-bit Chars and will simply use Show instances
490 -- of Char and String.
492 pprHsChar :: Char -> SDoc
493 pprHsChar c | c > '\x10ffff' = char '\\' <> text (show (fromIntegral (ord c) :: Word32))
494 | otherwise = text (show c)
496 pprHsString :: FastString -> SDoc
497 pprHsString fs = text (show (unpackFS fs))
501 %************************************************************************
503 \subsection{Other helper functions}
505 %************************************************************************
508 pprWithCommas :: (a -> SDoc) -> [a] -> SDoc
509 pprWithCommas pp xs = fsep (punctuate comma (map pp xs))
511 interppSP :: Outputable a => [a] -> SDoc
512 interppSP xs = sep (map ppr xs)
514 interpp'SP :: Outputable a => [a] -> SDoc
515 interpp'SP xs = sep (punctuate comma (map ppr xs))
517 pprQuotedList :: Outputable a => [a] -> SDoc
518 -- [x,y,z] ==> `x', `y', `z'
519 pprQuotedList xs = hsep (punctuate comma (map (quotes . ppr) xs))
523 %************************************************************************
525 \subsection{Printing numbers verbally}
527 %************************************************************************
529 @speakNth@ converts an integer to a verbal index; eg 1 maps to
533 speakNth :: Int -> SDoc
534 speakNth 1 = ptext SLIT("first")
535 speakNth 2 = ptext SLIT("second")
536 speakNth 3 = ptext SLIT("third")
537 speakNth 4 = ptext SLIT("fourth")
538 speakNth 5 = ptext SLIT("fifth")
539 speakNth 6 = ptext SLIT("sixth")
540 speakNth n = hcat [ int n, text suffix ]
542 suffix | n <= 20 = "th" -- 11,12,13 are non-std
543 | last_dig == 1 = "st"
544 | last_dig == 2 = "nd"
545 | last_dig == 3 = "rd"
548 last_dig = n `rem` 10
550 speakN :: Int -> SDoc
551 speakN 0 = ptext SLIT("none") -- E.g. "he has none"
552 speakN 1 = ptext SLIT("one") -- E.g. "he has one"
553 speakN 2 = ptext SLIT("two")
554 speakN 3 = ptext SLIT("three")
555 speakN 4 = ptext SLIT("four")
556 speakN 5 = ptext SLIT("five")
557 speakN 6 = ptext SLIT("six")
560 speakNOf :: Int -> SDoc -> SDoc
561 speakNOf 0 d = ptext SLIT("no") <+> d <> char 's' -- E.g. "no arguments"
562 speakNOf 1 d = ptext SLIT("one") <+> d -- E.g. "one argument"
563 speakNOf n d = speakN n <+> d <> char 's' -- E.g. "three arguments"
565 speakNTimes :: Int {- >=1 -} -> SDoc
566 speakNTimes t | t == 1 = ptext SLIT("once")
567 | t == 2 = ptext SLIT("twice")
568 | otherwise = speakN t <+> ptext SLIT("times")
575 %************************************************************************
577 \subsection{Error handling}
579 %************************************************************************
582 pprPanic, pprPgmError :: String -> SDoc -> a
583 pprTrace :: String -> SDoc -> a -> a
584 pprPanic = pprAndThen panic -- Throw an exn saying "bug in GHC"
586 pprPgmError = pprAndThen pgmError -- Throw an exn saying "bug in pgm being compiled"
587 -- (used for unusual pgm errors)
588 pprTrace = pprAndThen trace
590 pprPanic# heading pretty_msg = panic# (show (doc PprDebug))
592 doc = text heading <+> pretty_msg
594 pprAndThen :: (String -> a) -> String -> SDoc -> a
595 pprAndThen cont heading pretty_msg = cont (show (doc PprDebug))
597 doc = sep [text heading, nest 4 pretty_msg]
599 assertPprPanic :: String -> Int -> SDoc -> a
600 assertPprPanic file line msg
601 = panic (show (doc PprDebug))
603 doc = sep [hsep[text "ASSERT failed! file",
605 text "line", int line],
608 warnPprTrace :: Bool -> String -> Int -> SDoc -> a -> a
609 warnPprTrace False file line msg x = x
610 warnPprTrace True file line msg x
611 = trace (show (doc PprDebug)) x
613 doc = sep [hsep [text "WARNING: file", text file, text "line", int line],