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,
18 codeStyle, userStyle, debugStyle, dumpStyle, asmStyle,
19 ifPprDebug, unqualStyle,
20 mkErrStyle, defaultErrStyle,
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,
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 getPprStyle :: (PprStyle -> SDoc) -> SDoc
160 getPprStyle df sty = df sty sty
164 unqualStyle :: PprStyle -> PrintUnqualified
165 unqualStyle (PprUser unqual _) m n = unqual m n
166 unqualStyle other m n = False
168 codeStyle :: PprStyle -> Bool
169 codeStyle (PprCode _) = True
172 asmStyle :: PprStyle -> Bool
173 asmStyle (PprCode AsmStyle) = True
174 asmStyle other = False
176 dumpStyle :: PprStyle -> Bool
177 dumpStyle PprDump = True
178 dumpStyle other = False
180 debugStyle :: PprStyle -> Bool
181 debugStyle PprDebug = True
182 debugStyle other = False
184 userStyle :: PprStyle -> Bool
185 userStyle (PprUser _ _) = True
186 userStyle other = False
188 ifPprDebug :: SDoc -> SDoc -- Empty for non-debug style
189 ifPprDebug d sty@PprDebug = d sty
190 ifPprDebug d sty = Pretty.empty
195 printSDoc :: SDoc -> PprStyle -> IO ()
197 Pretty.printDoc PageMode stdout (d sty)
200 -- I'm not sure whether the direct-IO approach of Pretty.printDoc
201 -- above is better or worse than the put-big-string approach here
202 printErrs :: Doc -> IO ()
203 printErrs doc = do Pretty.printDoc PageMode stderr doc
206 printDump :: SDoc -> IO ()
208 Pretty.printDoc PageMode stdout (better_doc defaultDumpStyle)
211 better_doc = doc $$ text ""
213 printForUser :: Handle -> PrintUnqualified -> SDoc -> IO ()
214 printForUser handle unqual doc
215 = Pretty.printDoc PageMode handle (doc (mkUserStyle unqual AllTheWay))
217 -- printForC, printForAsm do what they sound like
218 printForC :: Handle -> SDoc -> IO ()
219 printForC handle doc = Pretty.printDoc LeftMode handle (doc (PprCode CStyle))
221 printForAsm :: Handle -> SDoc -> IO ()
222 printForAsm handle doc = Pretty.printDoc LeftMode handle (doc (PprCode AsmStyle))
224 pprCode :: CodeStyle -> SDoc -> SDoc
225 pprCode cs d = withPprStyle (PprCode cs) d
227 mkCodeStyle :: CodeStyle -> PprStyle
228 mkCodeStyle = PprCode
230 -- Can't make SDoc an instance of Show because SDoc is just a function type
231 -- However, Doc *is* an instance of Show
232 -- showSDoc just blasts it out as a string
233 showSDoc :: SDoc -> String
234 showSDoc d = show (d defaultUserStyle)
236 showSDocForUser :: PrintUnqualified -> SDoc -> String
237 showSDocForUser unqual doc = show (doc (mkUserStyle unqual AllTheWay))
239 showSDocUnqual :: SDoc -> String
240 -- Only used in the gruesome HsExpr.isOperator
241 showSDocUnqual d = show (d (mkUserStyle neverQualify AllTheWay))
243 showsPrecSDoc :: Int -> SDoc -> ShowS
244 showsPrecSDoc p d = showsPrec p (d defaultUserStyle)
246 showSDocDump :: SDoc -> String
247 showSDocDump d = show (d PprDump)
249 showSDocDebug :: SDoc -> String
250 showSDocDebug d = show (d PprDebug)
254 docToSDoc :: Doc -> SDoc
255 docToSDoc d = \_ -> d
257 empty sty = Pretty.empty
258 text s sty = Pretty.text s
259 char c sty = Pretty.char c
260 ftext s sty = Pretty.ftext s
261 ptext s sty = Pretty.ptext s
262 int n sty = Pretty.int n
263 integer n sty = Pretty.integer n
264 float n sty = Pretty.float n
265 double n sty = Pretty.double n
266 rational n sty = Pretty.rational n
268 parens d sty = Pretty.parens (d sty)
269 braces d sty = Pretty.braces (d sty)
270 brackets d sty = Pretty.brackets (d sty)
271 doubleQuotes d sty = Pretty.doubleQuotes (d sty)
272 angleBrackets d = char '<' <> d <> char '>'
274 -- quotes encloses something in single quotes...
275 -- but it omits them if the thing ends in a single quote
276 -- so that we don't get `foo''. Instead we just have foo'.
277 quotes d sty = case show pp_d of
279 other -> Pretty.quotes pp_d
283 semi sty = Pretty.semi
284 comma sty = Pretty.comma
285 colon sty = Pretty.colon
286 equals sty = Pretty.equals
287 space sty = Pretty.space
288 lparen sty = Pretty.lparen
289 rparen sty = Pretty.rparen
290 lbrack sty = Pretty.lbrack
291 rbrack sty = Pretty.rbrack
292 lbrace sty = Pretty.lbrace
293 rbrace sty = Pretty.rbrace
294 dcolon sty = Pretty.ptext SLIT("::")
295 arrow sty = Pretty.ptext SLIT("->")
296 underscore = char '_'
299 nest n d sty = Pretty.nest n (d sty)
300 (<>) d1 d2 sty = (Pretty.<>) (d1 sty) (d2 sty)
301 (<+>) d1 d2 sty = (Pretty.<+>) (d1 sty) (d2 sty)
302 ($$) d1 d2 sty = (Pretty.$$) (d1 sty) (d2 sty)
303 ($+$) d1 d2 sty = (Pretty.$+$) (d1 sty) (d2 sty)
305 hcat ds sty = Pretty.hcat [d sty | d <- ds]
306 hsep ds sty = Pretty.hsep [d sty | d <- ds]
307 vcat ds sty = Pretty.vcat [d sty | d <- ds]
308 sep ds sty = Pretty.sep [d sty | d <- ds]
309 cat ds sty = Pretty.cat [d sty | d <- ds]
310 fsep ds sty = Pretty.fsep [d sty | d <- ds]
311 fcat ds sty = Pretty.fcat [d sty | d <- ds]
313 hang d1 n d2 sty = Pretty.hang (d1 sty) n (d2 sty)
315 punctuate :: SDoc -> [SDoc] -> [SDoc]
317 punctuate p (d:ds) = go d ds
320 go d (e:es) = (d <> p) : go e es
324 %************************************************************************
326 \subsection[Outputable-class]{The @Outputable@ class}
328 %************************************************************************
331 class Outputable a where
336 instance Outputable Bool where
337 ppr True = ptext SLIT("True")
338 ppr False = ptext SLIT("False")
340 instance Outputable Int where
343 instance Outputable () where
346 instance (Outputable a) => Outputable [a] where
347 ppr xs = brackets (fsep (punctuate comma (map ppr xs)))
349 instance (Outputable a, Outputable b) => Outputable (a, b) where
350 ppr (x,y) = parens (sep [ppr x <> comma, ppr y])
352 instance Outputable a => Outputable (Maybe a) where
353 ppr Nothing = ptext SLIT("Nothing")
354 ppr (Just x) = ptext SLIT("Just") <+> ppr x
356 -- ToDo: may not be used
357 instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c) where
359 parens (sep [ppr x <> comma,
363 instance (Outputable a, Outputable b, Outputable c, Outputable d) =>
364 Outputable (a, b, c, d) where
366 parens (sep [ppr x <> comma,
371 instance Outputable FastString where
372 ppr fs = text (unpackFS fs) -- Prints an unadorned string,
373 -- no double quotes or anything
375 instance Outputable PackageId where
376 ppr pid = text (packageIdString pid)
380 %************************************************************************
382 \subsection{The @OutputableBndr@ class}
384 %************************************************************************
386 When we print a binder, we often want to print its type too.
387 The @OutputableBndr@ class encapsulates this idea.
389 @BindingSite@ is used to tell the thing that prints binder what
390 language construct is binding the identifier. This can be used
391 to decide how much info to print.
394 data BindingSite = LambdaBind | CaseBind | LetBind
396 class Outputable a => OutputableBndr a where
397 pprBndr :: BindingSite -> a -> SDoc
403 %************************************************************************
405 \subsection{Random printing helpers}
407 %************************************************************************
410 -- We have 31-bit Chars and will simply use Show instances
411 -- of Char and String.
413 pprHsChar :: Char -> SDoc
414 pprHsChar c | c > '\x10ffff' = char '\\' <> text (show (fromIntegral (ord c) :: Word32))
415 | otherwise = text (show c)
417 pprHsString :: FastString -> SDoc
418 pprHsString fs = text (show (unpackFS fs))
420 instance Show FastString where
421 showsPrec p fs = showsPrecSDoc p (ppr fs)
425 %************************************************************************
427 \subsection{Other helper functions}
429 %************************************************************************
432 pprWithCommas :: (a -> SDoc) -> [a] -> SDoc
433 pprWithCommas pp xs = fsep (punctuate comma (map pp xs))
435 interppSP :: Outputable a => [a] -> SDoc
436 interppSP xs = sep (map ppr xs)
438 interpp'SP :: Outputable a => [a] -> SDoc
439 interpp'SP xs = sep (punctuate comma (map ppr xs))
441 pprQuotedList :: Outputable a => [a] -> SDoc
442 -- [x,y,z] ==> `x', `y', `z'
443 pprQuotedList xs = hsep (punctuate comma (map (quotes . ppr) xs))
447 %************************************************************************
449 \subsection{Printing numbers verbally}
451 %************************************************************************
453 @speakNth@ converts an integer to a verbal index; eg 1 maps to
457 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
477 speakNTimes :: Int {- >=1 -} -> SDoc
478 speakNTimes t | t == 1 = ptext SLIT("once")
479 | t == 2 = ptext SLIT("twice")
480 | otherwise = int t <+> ptext SLIT("times")
484 %************************************************************************
486 \subsection{Error handling}
488 %************************************************************************
491 pprPanic, pprPgmError :: String -> SDoc -> a
492 pprTrace :: String -> SDoc -> a -> a
493 pprPanic = pprAndThen panic -- Throw an exn saying "bug in GHC"
495 pprPgmError = pprAndThen pgmError -- Throw an exn saying "bug in pgm being compiled"
496 -- (used for unusual pgm errors)
497 pprTrace = pprAndThen trace
499 pprPanic# heading pretty_msg = panic# (show (doc PprDebug))
501 doc = text heading <+> pretty_msg
503 pprAndThen :: (String -> a) -> String -> SDoc -> a
504 pprAndThen cont heading pretty_msg = cont (show (doc PprDebug))
506 doc = sep [text heading, nest 4 pretty_msg]
508 assertPprPanic :: String -> Int -> SDoc -> a
509 assertPprPanic file line msg
510 = panic (show (doc PprDebug))
512 doc = sep [hsep[text "ASSERT failed! file",
514 text "line", int line],
517 warnPprTrace :: Bool -> String -> Int -> SDoc -> a -> a
518 warnPprTrace False file line msg x = x
519 warnPprTrace True file line msg x
520 = trace (show (doc PprDebug)) x
522 doc = sep [hsep [text "WARNING: file", text file, text "line", int line],