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
12 Outputable(..), OutputableBndr(..), -- Class
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,
25 interppSP, interpp'SP, pprQuotedList, pprWithCommas,
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,
37 speakNth, speakNTimes, speakN, speakNOf, plural,
39 printSDoc, printErrs, hPrintDump, printDump,
40 printForC, printForAsm, printForUser,
42 showSDoc, showSDocForUser, showSDocDebug, showSDocDump,
43 showSDocUnqual, showsPrecSDoc,
44 pprHsChar, pprHsString,
47 pprPanic, assertPprPanic, pprPanic#, pprPgmError,
48 pprTrace, warnPprTrace,
49 trace, pgmError, panic, panic#, assertPanic
52 #include "HsVersions.h"
55 import {-# SOURCE #-} Module( Module, modulePackageId,
56 ModuleName, moduleName )
57 import {-# SOURCE #-} OccName( OccName )
59 import StaticFlags ( opt_PprStyle_Debug, opt_PprUserLength )
60 import PackageConfig ( PackageId, packageIdString )
62 import qualified Pretty
63 import Pretty ( Doc, Mode(..) )
66 import Data.Word ( Word32 )
67 import System.IO ( Handle, stderr, stdout, hFlush )
68 import Data.Char ( ord )
72 %************************************************************************
74 \subsection{The @PprStyle@ data type}
76 %************************************************************************
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
85 -- Assumes printing tidied code: non-system names are
86 -- printed without uniques.
89 -- Print code; either C or assembler
91 | PprDump -- For -ddump-foo; less verbose than PprDebug.
92 -- Does not assume tidied code: non-external names
93 -- are printed with uniques.
95 | PprDebug -- Full debugging output
97 data CodeStyle = CStyle -- The format of labels differs for C and assembler
100 data Depth = AllTheWay
101 | PartWay Int -- 0 => stop
104 -- -----------------------------------------------------------------------------
105 -- Printing original names
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'.
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
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
123 type QualifyModule = Module -> Maybe PackageId
125 type PrintUnqualified = (QualifyName, QualifyModule)
127 alwaysQualifyNames :: QualifyName
128 alwaysQualifyNames m n = Just (moduleName m)
130 neverQualifyNames :: QualifyName
131 neverQualifyNames m n = Nothing
133 alwaysQualifyModules :: QualifyModule
134 alwaysQualifyModules m = Just (modulePackageId m)
136 neverQualifyModules :: QualifyModule
137 neverQualifyModules m = Nothing
139 alwaysQualify = (alwaysQualifyNames, alwaysQualifyModules)
140 neverQualify = (neverQualifyNames, neverQualifyModules)
142 defaultUserStyle = mkUserStyle alwaysQualify AllTheWay
144 defaultDumpStyle | opt_PprStyle_Debug = PprDebug
145 | otherwise = PprDump
147 -- | Style for printing error messages
148 mkErrStyle :: PrintUnqualified -> PprStyle
149 mkErrStyle qual = mkUserStyle qual (PartWay opt_PprUserLength)
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
156 | opt_PprStyle_Debug = mkUserStyle alwaysQualify AllTheWay
157 | otherwise = mkUserStyle alwaysQualify (PartWay opt_PprUserLength)
159 mkUserStyle unqual depth
160 | opt_PprStyle_Debug = PprDebug
161 | otherwise = PprUser unqual depth
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
169 The following test decides whether or not we are actually generating
170 code (either C or assembly), or generating interface files.
172 %************************************************************************
174 \subsection{The @SDoc@ data type}
176 %************************************************************************
179 type SDoc = PprStyle -> Doc
181 withPprStyle :: PprStyle -> SDoc -> SDoc
182 withPprStyle sty d sty' = d sty
184 withPprStyleDoc :: PprStyle -> SDoc -> Doc
185 withPprStyleDoc sty d = d sty
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
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)))
199 go i (d:ds) | i >= n = [text "...."]
200 | otherwise = d : go (i+1) ds
202 pprDeeperList f ds other_sty
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
209 getPprStyle :: (PprStyle -> SDoc) -> SDoc
210 getPprStyle df sty = df sty sty
214 qualName :: PprStyle -> QualifyName
215 qualName (PprUser (qual_name,_) _) m n = qual_name m n
216 qualName other m n = Just (moduleName m)
218 qualModule :: PprStyle -> QualifyModule
219 qualModule (PprUser (_,qual_mod) _) m = qual_mod m
220 qualModule other m = Just (modulePackageId m)
222 codeStyle :: PprStyle -> Bool
223 codeStyle (PprCode _) = True
226 asmStyle :: PprStyle -> Bool
227 asmStyle (PprCode AsmStyle) = True
228 asmStyle other = False
230 dumpStyle :: PprStyle -> Bool
231 dumpStyle PprDump = True
232 dumpStyle other = False
234 debugStyle :: PprStyle -> Bool
235 debugStyle PprDebug = True
236 debugStyle other = False
238 userStyle :: PprStyle -> Bool
239 userStyle (PprUser _ _) = True
240 userStyle other = False
242 ifPprDebug :: SDoc -> SDoc -- Empty for non-debug style
243 ifPprDebug d sty@PprDebug = d sty
244 ifPprDebug d sty = Pretty.empty
249 printSDoc :: SDoc -> PprStyle -> IO ()
251 Pretty.printDoc PageMode stdout (d sty)
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
260 printDump :: SDoc -> IO ()
261 printDump doc = hPrintDump stdout doc
263 hPrintDump :: Handle -> SDoc -> IO ()
264 hPrintDump h doc = do
265 Pretty.printDoc PageMode h (better_doc defaultDumpStyle)
268 better_doc = doc $$ text ""
270 printForUser :: Handle -> PrintUnqualified -> SDoc -> IO ()
271 printForUser handle unqual doc
272 = Pretty.printDoc PageMode handle (doc (mkUserStyle unqual AllTheWay))
274 -- printForC, printForAsm do what they sound like
275 printForC :: Handle -> SDoc -> IO ()
276 printForC handle doc = Pretty.printDoc LeftMode handle (doc (PprCode CStyle))
278 printForAsm :: Handle -> SDoc -> IO ()
279 printForAsm handle doc = Pretty.printDoc LeftMode handle (doc (PprCode AsmStyle))
281 pprCode :: CodeStyle -> SDoc -> SDoc
282 pprCode cs d = withPprStyle (PprCode cs) d
284 mkCodeStyle :: CodeStyle -> PprStyle
285 mkCodeStyle = PprCode
287 -- Can't make SDoc an instance of Show because SDoc is just a function type
288 -- However, Doc *is* an instance of Show
289 -- showSDoc just blasts it out as a string
290 showSDoc :: SDoc -> String
291 showSDoc d = show (d defaultUserStyle)
293 showSDocForUser :: PrintUnqualified -> SDoc -> String
294 showSDocForUser unqual doc = show (doc (mkUserStyle unqual AllTheWay))
296 showSDocUnqual :: SDoc -> String
297 -- Only used in the gruesome HsExpr.isOperator
298 showSDocUnqual d = show (d (mkUserStyle neverQualify AllTheWay))
300 showsPrecSDoc :: Int -> SDoc -> ShowS
301 showsPrecSDoc p d = showsPrec p (d defaultUserStyle)
303 showSDocDump :: SDoc -> String
304 showSDocDump d = show (d PprDump)
306 showSDocDebug :: SDoc -> String
307 showSDocDebug d = show (d PprDebug)
311 docToSDoc :: Doc -> SDoc
312 docToSDoc d = \_ -> d
314 empty sty = Pretty.empty
315 text s sty = Pretty.text s
316 char c sty = Pretty.char c
317 ftext s sty = Pretty.ftext s
318 ptext s sty = Pretty.ptext s
319 int n sty = Pretty.int n
320 integer n sty = Pretty.integer n
321 float n sty = Pretty.float n
322 double n sty = Pretty.double n
323 rational n sty = Pretty.rational n
325 parens d sty = Pretty.parens (d sty)
326 braces d sty = Pretty.braces (d sty)
327 brackets d sty = Pretty.brackets (d sty)
328 doubleQuotes d sty = Pretty.doubleQuotes (d sty)
329 angleBrackets d = char '<' <> d <> char '>'
331 cparen b d sty = Pretty.cparen b (d sty)
333 -- quotes encloses something in single quotes...
334 -- but it omits them if the thing ends in a single quote
335 -- so that we don't get `foo''. Instead we just have foo'.
336 quotes d sty = case show pp_d of
338 other -> Pretty.quotes pp_d
342 semi sty = Pretty.semi
343 comma sty = Pretty.comma
344 colon sty = Pretty.colon
345 equals sty = Pretty.equals
346 space sty = Pretty.space
347 lparen sty = Pretty.lparen
348 rparen sty = Pretty.rparen
349 lbrack sty = Pretty.lbrack
350 rbrack sty = Pretty.rbrack
351 lbrace sty = Pretty.lbrace
352 rbrace sty = Pretty.rbrace
353 dcolon sty = Pretty.ptext SLIT("::")
354 arrow sty = Pretty.ptext SLIT("->")
355 underscore = char '_'
358 nest n d sty = Pretty.nest n (d sty)
359 (<>) d1 d2 sty = (Pretty.<>) (d1 sty) (d2 sty)
360 (<+>) d1 d2 sty = (Pretty.<+>) (d1 sty) (d2 sty)
361 ($$) d1 d2 sty = (Pretty.$$) (d1 sty) (d2 sty)
362 ($+$) d1 d2 sty = (Pretty.$+$) (d1 sty) (d2 sty)
364 hcat ds sty = Pretty.hcat [d sty | d <- ds]
365 hsep ds sty = Pretty.hsep [d sty | d <- ds]
366 vcat ds sty = Pretty.vcat [d sty | d <- ds]
367 sep ds sty = Pretty.sep [d sty | d <- ds]
368 cat ds sty = Pretty.cat [d sty | d <- ds]
369 fsep ds sty = Pretty.fsep [d sty | d <- ds]
370 fcat ds sty = Pretty.fcat [d sty | d <- ds]
372 hang d1 n d2 sty = Pretty.hang (d1 sty) n (d2 sty)
374 punctuate :: SDoc -> [SDoc] -> [SDoc]
376 punctuate p (d:ds) = go d ds
379 go d (e:es) = (d <> p) : go e es
383 %************************************************************************
385 \subsection[Outputable-class]{The @Outputable@ class}
387 %************************************************************************
390 class Outputable a where
395 instance Outputable Bool where
396 ppr True = ptext SLIT("True")
397 ppr False = ptext SLIT("False")
399 instance Outputable Int where
402 instance Outputable () where
405 instance (Outputable a) => Outputable [a] where
406 ppr xs = brackets (fsep (punctuate comma (map ppr xs)))
408 instance (Outputable a, Outputable b) => Outputable (a, b) where
409 ppr (x,y) = parens (sep [ppr x <> comma, ppr y])
411 instance Outputable a => Outputable (Maybe a) where
412 ppr Nothing = ptext SLIT("Nothing")
413 ppr (Just x) = ptext SLIT("Just") <+> ppr x
415 instance (Outputable a, Outputable b) => Outputable (Either a b) where
416 ppr (Left x) = ptext SLIT("Left") <+> ppr x
417 ppr (Right y) = ptext SLIT("Right") <+> ppr y
419 -- ToDo: may not be used
420 instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c) where
422 parens (sep [ppr x <> comma,
426 instance (Outputable a, Outputable b, Outputable c, Outputable d) =>
427 Outputable (a, b, c, d) where
429 parens (sep [ppr x <> comma,
434 instance Outputable FastString where
435 ppr fs = ftext fs -- Prints an unadorned string,
436 -- no double quotes or anything
438 instance Outputable PackageId where
439 ppr pid = text (packageIdString pid)
443 %************************************************************************
445 \subsection{The @OutputableBndr@ class}
447 %************************************************************************
449 When we print a binder, we often want to print its type too.
450 The @OutputableBndr@ class encapsulates this idea.
452 @BindingSite@ is used to tell the thing that prints binder what
453 language construct is binding the identifier. This can be used
454 to decide how much info to print.
457 data BindingSite = LambdaBind | CaseBind | LetBind
459 class Outputable a => OutputableBndr a where
460 pprBndr :: BindingSite -> a -> SDoc
466 %************************************************************************
468 \subsection{Random printing helpers}
470 %************************************************************************
473 -- We have 31-bit Chars and will simply use Show instances
474 -- of Char and String.
476 pprHsChar :: Char -> SDoc
477 pprHsChar c | c > '\x10ffff' = char '\\' <> text (show (fromIntegral (ord c) :: Word32))
478 | otherwise = text (show c)
480 pprHsString :: FastString -> SDoc
481 pprHsString fs = text (show (unpackFS fs))
485 %************************************************************************
487 \subsection{Other helper functions}
489 %************************************************************************
492 pprWithCommas :: (a -> SDoc) -> [a] -> SDoc
493 pprWithCommas pp xs = fsep (punctuate comma (map pp xs))
495 interppSP :: Outputable a => [a] -> SDoc
496 interppSP xs = sep (map ppr xs)
498 interpp'SP :: Outputable a => [a] -> SDoc
499 interpp'SP xs = sep (punctuate comma (map ppr xs))
501 pprQuotedList :: Outputable a => [a] -> SDoc
502 -- [x,y,z] ==> `x', `y', `z'
503 pprQuotedList xs = hsep (punctuate comma (map (quotes . ppr) xs))
507 %************************************************************************
509 \subsection{Printing numbers verbally}
511 %************************************************************************
513 @speakNth@ converts an integer to a verbal index; eg 1 maps to
517 speakNth :: Int -> SDoc
518 speakNth 1 = ptext SLIT("first")
519 speakNth 2 = ptext SLIT("second")
520 speakNth 3 = ptext SLIT("third")
521 speakNth 4 = ptext SLIT("fourth")
522 speakNth 5 = ptext SLIT("fifth")
523 speakNth 6 = ptext SLIT("sixth")
524 speakNth n = hcat [ int n, text suffix ]
526 suffix | n <= 20 = "th" -- 11,12,13 are non-std
527 | last_dig == 1 = "st"
528 | last_dig == 2 = "nd"
529 | last_dig == 3 = "rd"
532 last_dig = n `rem` 10
534 speakN :: Int -> SDoc
535 speakN 0 = ptext SLIT("none") -- E.g. "he has none"
536 speakN 1 = ptext SLIT("one") -- E.g. "he has one"
537 speakN 2 = ptext SLIT("two")
538 speakN 3 = ptext SLIT("three")
539 speakN 4 = ptext SLIT("four")
540 speakN 5 = ptext SLIT("five")
541 speakN 6 = ptext SLIT("six")
544 speakNOf :: Int -> SDoc -> SDoc
545 speakNOf 0 d = ptext SLIT("no") <+> d <> char 's' -- E.g. "no arguments"
546 speakNOf 1 d = ptext SLIT("one") <+> d -- E.g. "one argument"
547 speakNOf n d = speakN n <+> d <> char 's' -- E.g. "three arguments"
549 speakNTimes :: Int {- >=1 -} -> SDoc
550 speakNTimes t | t == 1 = ptext SLIT("once")
551 | t == 2 = ptext SLIT("twice")
552 | otherwise = speakN t <+> ptext SLIT("times")
559 %************************************************************************
561 \subsection{Error handling}
563 %************************************************************************
566 pprPanic, pprPgmError :: String -> SDoc -> a
567 pprTrace :: String -> SDoc -> a -> a
568 pprPanic = pprAndThen panic -- Throw an exn saying "bug in GHC"
570 pprPgmError = pprAndThen pgmError -- Throw an exn saying "bug in pgm being compiled"
571 -- (used for unusual pgm errors)
572 pprTrace = pprAndThen trace
574 pprPanic# heading pretty_msg = panic# (show (doc PprDebug))
576 doc = text heading <+> pretty_msg
578 pprAndThen :: (String -> a) -> String -> SDoc -> a
579 pprAndThen cont heading pretty_msg = cont (show (doc PprDebug))
581 doc = sep [text heading, nest 4 pretty_msg]
583 assertPprPanic :: String -> Int -> SDoc -> a
584 assertPprPanic file line msg
585 = panic (show (doc PprDebug))
587 doc = sep [hsep[text "ASSERT failed! file",
589 text "line", int line],
592 warnPprTrace :: Bool -> String -> Int -> SDoc -> a -> a
593 warnPprTrace False file line msg x = x
594 warnPprTrace True file line msg x
595 = trace (show (doc PprDebug)) x
597 doc = sep [hsep [text "WARNING: file", text file, text "line", int line],