2 % (c) The GRASP Project, Glasgow University, 1992-1998
4 \section[Outputable]{Classes for pretty-printing}
6 Defines classes for pretty-printing and forcing, both forms of
12 Outputable(..), OutputableBndr(..), -- Class
16 PprStyle, CodeStyle(..), PrintUnqualified, alwaysQualify,
17 getPprStyle, withPprStyle, withPprStyleDoc, pprDeeper, pprSetDepth,
18 codeStyle, userStyle, debugStyle, dumpStyle, asmStyle,
19 ifPprDebug, unqualStyle,
20 mkErrStyle, defaultErrStyle, defaultDumpStyle, defaultUserStyle,
24 interppSP, interpp'SP, pprQuotedList, pprWithCommas,
26 text, char, ftext, ptext,
27 int, integer, float, double, rational,
28 parens, brackets, braces, quotes, doubleQuotes, angleBrackets,
29 semi, comma, colon, dcolon, space, equals, dot, arrow,
30 lparen, rparen, lbrack, rbrack, lbrace, rbrace, underscore,
31 (<>), (<+>), hcat, hsep,
36 speakNth, speakNTimes, speakN, speakNOf, plural,
38 printSDoc, printErrs, printDump,
39 printForC, printForAsm, printForUser,
41 showSDoc, showSDocForUser, showSDocDebug, showSDocDump,
42 showSDocUnqual, showsPrecSDoc,
43 pprHsChar, pprHsString,
46 pprPanic, assertPprPanic, pprPanic#, pprPgmError,
47 pprTrace, warnPprTrace,
48 trace, pgmError, panic, panic#, assertPanic
51 #include "HsVersions.h"
54 import {-# SOURCE #-} Module( Module )
55 import {-# SOURCE #-} OccName( OccName )
57 import StaticFlags ( opt_PprStyle_Debug, opt_PprUserLength )
58 import PackageConfig ( PackageId, packageIdString )
60 import qualified Pretty
61 import Pretty ( Doc, Mode(..) )
64 import DATA_WORD ( Word32 )
66 import IO ( Handle, stderr, stdout, hFlush )
71 %************************************************************************
73 \subsection{The @PprStyle@ data type}
75 %************************************************************************
79 = PprUser PrintUnqualified Depth
80 -- Pretty-print in a way that will make sense to the
81 -- ordinary user; must be very close to Haskell
83 -- Assumes printing tidied code: non-system names are
84 -- printed without uniques.
87 -- Print code; either C or assembler
89 | PprDump -- For -ddump-foo; less verbose than PprDebug.
90 -- Does not assume tidied code: non-external names
91 -- are printed with uniques.
93 | PprDebug -- Full debugging output
95 data CodeStyle = CStyle -- The format of labels differs for C and assembler
98 data Depth = AllTheWay
99 | PartWay Int -- 0 => stop
102 type PrintUnqualified = Module -> OccName -> Bool
103 -- This function tells when it's ok to print
104 -- a (Global) name unqualified
106 alwaysQualify,neverQualify :: PrintUnqualified
107 alwaysQualify m n = False
108 neverQualify m n = True
110 defaultUserStyle = mkUserStyle alwaysQualify AllTheWay
112 defaultDumpStyle | opt_PprStyle_Debug = PprDebug
113 | otherwise = PprDump
115 mkErrStyle :: PrintUnqualified -> PprStyle
116 -- Style for printing error messages
117 mkErrStyle print_unqual = mkUserStyle print_unqual (PartWay opt_PprUserLength)
119 defaultErrStyle :: PprStyle
120 -- Default style for error messages
121 -- It's a bit of a hack because it doesn't take into account what's in scope
122 -- Only used for desugarer warnings, and typechecker errors in interface sigs
124 | opt_PprStyle_Debug = mkUserStyle alwaysQualify AllTheWay
125 | otherwise = mkUserStyle alwaysQualify (PartWay opt_PprUserLength)
127 mkUserStyle unqual depth | opt_PprStyle_Debug = PprDebug
128 | otherwise = PprUser unqual depth
131 Orthogonal to the above printing styles are (possibly) some
132 command-line flags that affect printing (often carried with the
133 style). The most likely ones are variations on how much type info is
136 The following test decides whether or not we are actually generating
137 code (either C or assembly), or generating interface files.
139 %************************************************************************
141 \subsection{The @SDoc@ data type}
143 %************************************************************************
146 type SDoc = PprStyle -> Doc
148 withPprStyle :: PprStyle -> SDoc -> SDoc
149 withPprStyle sty d sty' = d sty
151 withPprStyleDoc :: PprStyle -> SDoc -> Doc
152 withPprStyleDoc sty d = d sty
154 pprDeeper :: SDoc -> SDoc
155 pprDeeper d (PprUser unqual (PartWay 0)) = Pretty.text "..."
156 pprDeeper d (PprUser unqual (PartWay n)) = d (PprUser unqual (PartWay (n-1)))
157 pprDeeper d other_sty = d other_sty
159 pprSetDepth :: Int -> SDoc -> SDoc
160 pprSetDepth n d (PprUser unqual _) = d (PprUser unqual (PartWay n))
161 pprSetDepth n d other_sty = d other_sty
163 getPprStyle :: (PprStyle -> SDoc) -> SDoc
164 getPprStyle df sty = df sty sty
168 unqualStyle :: PprStyle -> PrintUnqualified
169 unqualStyle (PprUser unqual _) m n = unqual m n
170 unqualStyle other m n = False
172 codeStyle :: PprStyle -> Bool
173 codeStyle (PprCode _) = True
176 asmStyle :: PprStyle -> Bool
177 asmStyle (PprCode AsmStyle) = True
178 asmStyle other = False
180 dumpStyle :: PprStyle -> Bool
181 dumpStyle PprDump = True
182 dumpStyle other = False
184 debugStyle :: PprStyle -> Bool
185 debugStyle PprDebug = True
186 debugStyle other = False
188 userStyle :: PprStyle -> Bool
189 userStyle (PprUser _ _) = True
190 userStyle other = False
192 ifPprDebug :: SDoc -> SDoc -- Empty for non-debug style
193 ifPprDebug d sty@PprDebug = d sty
194 ifPprDebug d sty = Pretty.empty
199 printSDoc :: SDoc -> PprStyle -> IO ()
201 Pretty.printDoc PageMode stdout (d sty)
204 -- I'm not sure whether the direct-IO approach of Pretty.printDoc
205 -- above is better or worse than the put-big-string approach here
206 printErrs :: Doc -> IO ()
207 printErrs doc = do Pretty.printDoc PageMode stderr doc
210 printDump :: SDoc -> IO ()
212 Pretty.printDoc PageMode stdout (better_doc defaultDumpStyle)
215 better_doc = doc $$ text ""
217 printForUser :: Handle -> PrintUnqualified -> SDoc -> IO ()
218 printForUser handle unqual doc
219 = Pretty.printDoc PageMode handle (doc (mkUserStyle unqual AllTheWay))
221 -- printForC, printForAsm do what they sound like
222 printForC :: Handle -> SDoc -> IO ()
223 printForC handle doc = Pretty.printDoc LeftMode handle (doc (PprCode CStyle))
225 printForAsm :: Handle -> SDoc -> IO ()
226 printForAsm handle doc = Pretty.printDoc LeftMode handle (doc (PprCode AsmStyle))
228 pprCode :: CodeStyle -> SDoc -> SDoc
229 pprCode cs d = withPprStyle (PprCode cs) d
231 mkCodeStyle :: CodeStyle -> PprStyle
232 mkCodeStyle = PprCode
234 -- Can't make SDoc an instance of Show because SDoc is just a function type
235 -- However, Doc *is* an instance of Show
236 -- showSDoc just blasts it out as a string
237 showSDoc :: SDoc -> String
238 showSDoc d = show (d defaultUserStyle)
240 showSDocForUser :: PrintUnqualified -> SDoc -> String
241 showSDocForUser unqual doc = show (doc (mkUserStyle unqual AllTheWay))
243 showSDocUnqual :: SDoc -> String
244 -- Only used in the gruesome HsExpr.isOperator
245 showSDocUnqual d = show (d (mkUserStyle neverQualify AllTheWay))
247 showsPrecSDoc :: Int -> SDoc -> ShowS
248 showsPrecSDoc p d = showsPrec p (d defaultUserStyle)
250 showSDocDump :: SDoc -> String
251 showSDocDump d = show (d PprDump)
253 showSDocDebug :: SDoc -> String
254 showSDocDebug d = show (d PprDebug)
258 docToSDoc :: Doc -> SDoc
259 docToSDoc d = \_ -> d
261 empty sty = Pretty.empty
262 text s sty = Pretty.text s
263 char c sty = Pretty.char c
264 ftext s sty = Pretty.ftext s
265 ptext s sty = Pretty.ptext s
266 int n sty = Pretty.int n
267 integer n sty = Pretty.integer n
268 float n sty = Pretty.float n
269 double n sty = Pretty.double n
270 rational n sty = Pretty.rational n
272 parens d sty = Pretty.parens (d sty)
273 braces d sty = Pretty.braces (d sty)
274 brackets d sty = Pretty.brackets (d sty)
275 doubleQuotes d sty = Pretty.doubleQuotes (d sty)
276 angleBrackets d = char '<' <> d <> char '>'
278 -- quotes encloses something in single quotes...
279 -- but it omits them if the thing ends in a single quote
280 -- so that we don't get `foo''. Instead we just have foo'.
281 quotes d sty = case show pp_d of
283 other -> Pretty.quotes pp_d
287 semi sty = Pretty.semi
288 comma sty = Pretty.comma
289 colon sty = Pretty.colon
290 equals sty = Pretty.equals
291 space sty = Pretty.space
292 lparen sty = Pretty.lparen
293 rparen sty = Pretty.rparen
294 lbrack sty = Pretty.lbrack
295 rbrack sty = Pretty.rbrack
296 lbrace sty = Pretty.lbrace
297 rbrace sty = Pretty.rbrace
298 dcolon sty = Pretty.ptext SLIT("::")
299 arrow sty = Pretty.ptext SLIT("->")
300 underscore = char '_'
303 nest n d sty = Pretty.nest n (d sty)
304 (<>) d1 d2 sty = (Pretty.<>) (d1 sty) (d2 sty)
305 (<+>) d1 d2 sty = (Pretty.<+>) (d1 sty) (d2 sty)
306 ($$) d1 d2 sty = (Pretty.$$) (d1 sty) (d2 sty)
307 ($+$) d1 d2 sty = (Pretty.$+$) (d1 sty) (d2 sty)
309 hcat ds sty = Pretty.hcat [d sty | d <- ds]
310 hsep ds sty = Pretty.hsep [d sty | d <- ds]
311 vcat ds sty = Pretty.vcat [d sty | d <- ds]
312 sep ds sty = Pretty.sep [d sty | d <- ds]
313 cat ds sty = Pretty.cat [d sty | d <- ds]
314 fsep ds sty = Pretty.fsep [d sty | d <- ds]
315 fcat ds sty = Pretty.fcat [d sty | d <- ds]
317 hang d1 n d2 sty = Pretty.hang (d1 sty) n (d2 sty)
319 punctuate :: SDoc -> [SDoc] -> [SDoc]
321 punctuate p (d:ds) = go d ds
324 go d (e:es) = (d <> p) : go e es
328 %************************************************************************
330 \subsection[Outputable-class]{The @Outputable@ class}
332 %************************************************************************
335 class Outputable a where
340 instance Outputable Bool where
341 ppr True = ptext SLIT("True")
342 ppr False = ptext SLIT("False")
344 instance Outputable Int where
347 instance Outputable () where
350 instance (Outputable a) => Outputable [a] where
351 ppr xs = brackets (fsep (punctuate comma (map ppr xs)))
353 instance (Outputable a, Outputable b) => Outputable (a, b) where
354 ppr (x,y) = parens (sep [ppr x <> comma, ppr y])
356 instance Outputable a => Outputable (Maybe a) where
357 ppr Nothing = ptext SLIT("Nothing")
358 ppr (Just x) = ptext SLIT("Just") <+> ppr x
360 -- ToDo: may not be used
361 instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c) where
363 parens (sep [ppr x <> comma,
367 instance (Outputable a, Outputable b, Outputable c, Outputable d) =>
368 Outputable (a, b, c, d) where
370 parens (sep [ppr x <> comma,
375 instance Outputable FastString where
376 ppr fs = ftext fs -- Prints an unadorned string,
377 -- no double quotes or anything
379 instance Outputable PackageId where
380 ppr pid = text (packageIdString pid)
384 %************************************************************************
386 \subsection{The @OutputableBndr@ class}
388 %************************************************************************
390 When we print a binder, we often want to print its type too.
391 The @OutputableBndr@ class encapsulates this idea.
393 @BindingSite@ is used to tell the thing that prints binder what
394 language construct is binding the identifier. This can be used
395 to decide how much info to print.
398 data BindingSite = LambdaBind | CaseBind | LetBind
400 class Outputable a => OutputableBndr a where
401 pprBndr :: BindingSite -> a -> SDoc
407 %************************************************************************
409 \subsection{Random printing helpers}
411 %************************************************************************
414 -- We have 31-bit Chars and will simply use Show instances
415 -- of Char and String.
417 pprHsChar :: Char -> SDoc
418 pprHsChar c | c > '\x10ffff' = char '\\' <> text (show (fromIntegral (ord c) :: Word32))
419 | otherwise = text (show c)
421 pprHsString :: FastString -> SDoc
422 pprHsString fs = text (show (unpackFS fs))
426 %************************************************************************
428 \subsection{Other helper functions}
430 %************************************************************************
433 pprWithCommas :: (a -> SDoc) -> [a] -> SDoc
434 pprWithCommas pp xs = fsep (punctuate comma (map pp xs))
436 interppSP :: Outputable a => [a] -> SDoc
437 interppSP xs = sep (map ppr xs)
439 interpp'SP :: Outputable a => [a] -> SDoc
440 interpp'SP xs = sep (punctuate comma (map ppr xs))
442 pprQuotedList :: Outputable a => [a] -> SDoc
443 -- [x,y,z] ==> `x', `y', `z'
444 pprQuotedList xs = hsep (punctuate comma (map (quotes . ppr) xs))
448 %************************************************************************
450 \subsection{Printing numbers verbally}
452 %************************************************************************
454 @speakNth@ converts an integer to a verbal index; eg 1 maps to
458 speakNth :: Int -> SDoc
459 speakNth 1 = ptext SLIT("first")
460 speakNth 2 = ptext SLIT("second")
461 speakNth 3 = ptext SLIT("third")
462 speakNth 4 = ptext SLIT("fourth")
463 speakNth 5 = ptext SLIT("fifth")
464 speakNth 6 = ptext SLIT("sixth")
465 speakNth n = hcat [ int n, text suffix ]
467 suffix | n <= 20 = "th" -- 11,12,13 are non-std
468 | last_dig == 1 = "st"
469 | last_dig == 2 = "nd"
470 | last_dig == 3 = "rd"
473 last_dig = n `rem` 10
475 speakN :: Int -> SDoc
476 speakN 0 = ptext SLIT("none") -- E.g. "he has none"
477 speakN 1 = ptext SLIT("one") -- E.g. "he has one"
478 speakN 2 = ptext SLIT("two")
479 speakN 3 = ptext SLIT("three")
480 speakN 4 = ptext SLIT("four")
481 speakN 5 = ptext SLIT("five")
482 speakN 6 = ptext SLIT("six")
485 speakNOf :: Int -> SDoc -> SDoc
486 speakNOf 0 d = ptext SLIT("no") <+> d <> char 's' -- E.g. "no arguments"
487 speakNOf 1 d = ptext SLIT("one") <+> d -- E.g. "one argument"
488 speakNOf n d = speakN n <+> d <> char 's' -- E.g. "three arguments"
490 speakNTimes :: Int {- >=1 -} -> SDoc
491 speakNTimes t | t == 1 = ptext SLIT("once")
492 | t == 2 = ptext SLIT("twice")
493 | otherwise = speakN t <+> ptext SLIT("times")
500 %************************************************************************
502 \subsection{Error handling}
504 %************************************************************************
507 pprPanic, pprPgmError :: String -> SDoc -> a
508 pprTrace :: String -> SDoc -> a -> a
509 pprPanic = pprAndThen panic -- Throw an exn saying "bug in GHC"
511 pprPgmError = pprAndThen pgmError -- Throw an exn saying "bug in pgm being compiled"
512 -- (used for unusual pgm errors)
513 pprTrace = pprAndThen trace
515 pprPanic# heading pretty_msg = panic# (show (doc PprDebug))
517 doc = text heading <+> pretty_msg
519 pprAndThen :: (String -> a) -> String -> SDoc -> a
520 pprAndThen cont heading pretty_msg = cont (show (doc PprDebug))
522 doc = sep [text heading, nest 4 pretty_msg]
524 assertPprPanic :: String -> Int -> SDoc -> a
525 assertPprPanic file line msg
526 = panic (show (doc PprDebug))
528 doc = sep [hsep[text "ASSERT failed! file",
530 text "line", int line],
533 warnPprTrace :: Bool -> String -> Int -> SDoc -> a -> a
534 warnPprTrace False file line msg x = x
535 warnPprTrace True file line msg x
536 = trace (show (doc PprDebug)) x
538 doc = sep [hsep [text "WARNING: file", text file, text "line", int line],