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, 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,
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( ModuleName )
55 import {-# SOURCE #-} OccName( OccName )
57 import CmdLineOpts ( opt_PprStyle_Debug, opt_PprUserLength )
59 import qualified Pretty
60 import Pretty ( Doc, Mode(..) )
63 import DATA_WORD ( Word32 )
65 import IO ( Handle, stderr, stdout, hFlush )
70 %************************************************************************
72 \subsection{The @PprStyle@ data type}
74 %************************************************************************
78 = PprUser PrintUnqualified Depth -- Pretty-print in a way that will
79 -- make sense to the ordinary user;
80 -- must be very close to Haskell
83 | PprCode CodeStyle -- Print code; either C or assembler
85 | PprDebug -- Standard debugging output
87 data CodeStyle = CStyle -- The format of labels differs for C and assembler
90 data Depth = AllTheWay
91 | PartWay Int -- 0 => stop
94 type PrintUnqualified = ModuleName -> OccName -> Bool
95 -- This function tells when it's ok to print
96 -- a (Global) name unqualified
98 alwaysQualify,neverQualify :: PrintUnqualified
99 alwaysQualify m n = False
100 neverQualify m n = True
102 defaultUserStyle = mkUserStyle alwaysQualify AllTheWay
104 mkErrStyle :: PrintUnqualified -> PprStyle
105 -- Style for printing error messages
106 mkErrStyle print_unqual = mkUserStyle print_unqual (PartWay opt_PprUserLength)
108 defaultErrStyle :: PprStyle
109 -- Default style for error messages
110 -- It's a bit of a hack because it doesn't take into account what's in scope
111 -- Only used for desugarer warnings, and typechecker errors in interface sigs
113 | opt_PprStyle_Debug = mkUserStyle alwaysQualify AllTheWay
114 | otherwise = mkUserStyle alwaysQualify (PartWay opt_PprUserLength)
116 mkUserStyle unqual depth | opt_PprStyle_Debug = PprDebug
117 | otherwise = PprUser unqual depth
120 Orthogonal to the above printing styles are (possibly) some
121 command-line flags that affect printing (often carried with the
122 style). The most likely ones are variations on how much type info is
125 The following test decides whether or not we are actually generating
126 code (either C or assembly), or generating interface files.
128 %************************************************************************
130 \subsection{The @SDoc@ data type}
132 %************************************************************************
135 type SDoc = PprStyle -> Doc
137 withPprStyle :: PprStyle -> SDoc -> SDoc
138 withPprStyle sty d sty' = d sty
140 withPprStyleDoc :: PprStyle -> SDoc -> Doc
141 withPprStyleDoc sty d = d sty
143 pprDeeper :: SDoc -> SDoc
144 pprDeeper d (PprUser unqual (PartWay 0)) = Pretty.text "..."
145 pprDeeper d (PprUser unqual (PartWay n)) = d (PprUser unqual (PartWay (n-1)))
146 pprDeeper d other_sty = d other_sty
148 getPprStyle :: (PprStyle -> SDoc) -> SDoc
149 getPprStyle df sty = df sty sty
153 unqualStyle :: PprStyle -> PrintUnqualified
154 unqualStyle (PprUser unqual _) m n = unqual m n
155 unqualStyle other m n = False
157 codeStyle :: PprStyle -> Bool
158 codeStyle (PprCode _) = True
161 asmStyle :: PprStyle -> Bool
162 asmStyle (PprCode AsmStyle) = True
163 asmStyle other = False
165 debugStyle :: PprStyle -> Bool
166 debugStyle PprDebug = True
167 debugStyle other = False
169 userStyle :: PprStyle -> Bool
170 userStyle (PprUser _ _) = True
171 userStyle other = False
173 ifPprDebug :: SDoc -> SDoc -- Empty for non-debug style
174 ifPprDebug d sty@PprDebug = d sty
175 ifPprDebug d sty = Pretty.empty
180 printSDoc :: SDoc -> PprStyle -> IO ()
182 Pretty.printDoc PageMode stdout (d sty)
185 -- I'm not sure whether the direct-IO approach of Pretty.printDoc
186 -- above is better or worse than the put-big-string approach here
187 printErrs :: Doc -> IO ()
188 printErrs doc = do Pretty.printDoc PageMode stderr doc
191 printDump :: SDoc -> IO ()
193 Pretty.printDoc PageMode stdout (better_doc defaultUserStyle)
196 better_doc = doc $$ text ""
197 -- We used to always print in debug style, but I want
198 -- to try the effect of a more user-ish style (unless you
201 printForUser :: Handle -> PrintUnqualified -> SDoc -> IO ()
202 printForUser handle unqual doc
203 = Pretty.printDoc PageMode handle (doc (mkUserStyle unqual AllTheWay))
205 -- printForC, printForAsm do what they sound like
206 printForC :: Handle -> SDoc -> IO ()
207 printForC handle doc = Pretty.printDoc LeftMode handle (doc (PprCode CStyle))
209 printForAsm :: Handle -> SDoc -> IO ()
210 printForAsm handle doc = Pretty.printDoc LeftMode handle (doc (PprCode AsmStyle))
212 pprCode :: CodeStyle -> SDoc -> SDoc
213 pprCode cs d = withPprStyle (PprCode cs) d
215 mkCodeStyle :: CodeStyle -> PprStyle
216 mkCodeStyle = PprCode
218 -- Can't make SDoc an instance of Show because SDoc is just a function type
219 -- However, Doc *is* an instance of Show
220 -- showSDoc just blasts it out as a string
221 showSDoc :: SDoc -> String
222 showSDoc d = show (d defaultUserStyle)
224 showSDocForUser :: PrintUnqualified -> SDoc -> String
225 showSDocForUser unqual doc = show (doc (mkUserStyle unqual AllTheWay))
227 showSDocUnqual :: SDoc -> String
228 -- Only used in the gruesome HsExpr.isOperator
229 showSDocUnqual d = show (d (mkUserStyle neverQualify AllTheWay))
231 showsPrecSDoc :: Int -> SDoc -> ShowS
232 showsPrecSDoc p d = showsPrec p (d defaultUserStyle)
234 showSDocDebug :: SDoc -> String
235 showSDocDebug d = show (d PprDebug)
239 docToSDoc :: Doc -> SDoc
240 docToSDoc d = \_ -> d
242 empty sty = Pretty.empty
243 text s sty = Pretty.text s
244 char c sty = Pretty.char c
245 ftext s sty = Pretty.ftext s
246 ptext s sty = Pretty.ptext s
247 int n sty = Pretty.int n
248 integer n sty = Pretty.integer n
249 float n sty = Pretty.float n
250 double n sty = Pretty.double n
251 rational n sty = Pretty.rational n
253 parens d sty = Pretty.parens (d sty)
254 braces d sty = Pretty.braces (d sty)
255 brackets d sty = Pretty.brackets (d sty)
256 doubleQuotes d sty = Pretty.doubleQuotes (d sty)
257 angleBrackets d = char '<' <> d <> char '>'
259 -- quotes encloses something in single quotes...
260 -- but it omits them if the thing ends in a single quote
261 -- so that we don't get `foo''. Instead we just have foo'.
262 quotes d sty = case show pp_d of
264 other -> Pretty.quotes pp_d
268 semi sty = Pretty.semi
269 comma sty = Pretty.comma
270 colon sty = Pretty.colon
271 equals sty = Pretty.equals
272 space sty = Pretty.space
273 lparen sty = Pretty.lparen
274 rparen sty = Pretty.rparen
275 lbrack sty = Pretty.lbrack
276 rbrack sty = Pretty.rbrack
277 lbrace sty = Pretty.lbrace
278 rbrace sty = Pretty.rbrace
279 dcolon sty = Pretty.ptext SLIT("::")
280 arrow sty = Pretty.ptext SLIT("->")
281 underscore = char '_'
284 nest n d sty = Pretty.nest n (d sty)
285 (<>) d1 d2 sty = (Pretty.<>) (d1 sty) (d2 sty)
286 (<+>) d1 d2 sty = (Pretty.<+>) (d1 sty) (d2 sty)
287 ($$) d1 d2 sty = (Pretty.$$) (d1 sty) (d2 sty)
288 ($+$) d1 d2 sty = (Pretty.$+$) (d1 sty) (d2 sty)
290 hcat ds sty = Pretty.hcat [d sty | d <- ds]
291 hsep ds sty = Pretty.hsep [d sty | d <- ds]
292 vcat ds sty = Pretty.vcat [d sty | d <- ds]
293 sep ds sty = Pretty.sep [d sty | d <- ds]
294 cat ds sty = Pretty.cat [d sty | d <- ds]
295 fsep ds sty = Pretty.fsep [d sty | d <- ds]
296 fcat ds sty = Pretty.fcat [d sty | d <- ds]
298 hang d1 n d2 sty = Pretty.hang (d1 sty) n (d2 sty)
300 punctuate :: SDoc -> [SDoc] -> [SDoc]
302 punctuate p (d:ds) = go d ds
305 go d (e:es) = (d <> p) : go e es
309 %************************************************************************
311 \subsection[Outputable-class]{The @Outputable@ class}
313 %************************************************************************
316 class Outputable a where
321 instance Outputable Bool where
322 ppr True = ptext SLIT("True")
323 ppr False = ptext SLIT("False")
325 instance Outputable Int where
328 instance Outputable () where
331 instance (Outputable a) => Outputable [a] where
332 ppr xs = brackets (fsep (punctuate comma (map ppr xs)))
334 instance (Outputable a, Outputable b) => Outputable (a, b) where
335 ppr (x,y) = parens (sep [ppr x <> comma, ppr y])
337 instance Outputable a => Outputable (Maybe a) where
338 ppr Nothing = ptext SLIT("Nothing")
339 ppr (Just x) = ptext SLIT("Just") <+> ppr x
341 -- ToDo: may not be used
342 instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c) where
344 parens (sep [ppr x <> comma,
348 instance (Outputable a, Outputable b, Outputable c, Outputable d) =>
349 Outputable (a, b, c, d) where
351 parens (sep [ppr x <> comma,
356 instance Outputable FastString where
357 ppr fs = text (unpackFS fs) -- Prints an unadorned string,
358 -- no double quotes or anything
362 %************************************************************************
364 \subsection{The @OutputableBndr@ class}
366 %************************************************************************
368 When we print a binder, we often want to print its type too.
369 The @OutputableBndr@ class encapsulates this idea.
371 @BindingSite@ is used to tell the thing that prints binder what
372 language construct is binding the identifier. This can be used
373 to decide how much info to print.
376 data BindingSite = LambdaBind | CaseBind | LetBind
378 class Outputable a => OutputableBndr a where
379 pprBndr :: BindingSite -> a -> SDoc
385 %************************************************************************
387 \subsection{Random printing helpers}
389 %************************************************************************
392 -- We have 31-bit Chars and will simply use Show instances
393 -- of Char and String.
395 pprHsChar :: Char -> SDoc
396 pprHsChar c | c > '\x10ffff' = char '\\' <> text (show (fromIntegral (ord c) :: Word32))
397 | otherwise = text (show c)
399 pprHsString :: FastString -> SDoc
400 pprHsString fs = text (show (unpackFS fs))
402 instance Show FastString where
403 showsPrec p fs = showsPrecSDoc p (ppr fs)
407 %************************************************************************
409 \subsection{Other helper functions}
411 %************************************************************************
414 pprWithCommas :: (a -> SDoc) -> [a] -> SDoc
415 pprWithCommas pp xs = fsep (punctuate comma (map pp xs))
417 interppSP :: Outputable a => [a] -> SDoc
418 interppSP xs = sep (map ppr xs)
420 interpp'SP :: Outputable a => [a] -> SDoc
421 interpp'SP xs = sep (punctuate comma (map ppr xs))
423 pprQuotedList :: Outputable a => [a] -> SDoc
424 -- [x,y,z] ==> `x', `y', `z'
425 pprQuotedList xs = hsep (punctuate comma (map (quotes . ppr) xs))
429 %************************************************************************
431 \subsection{Printing numbers verbally}
433 %************************************************************************
435 @speakNth@ converts an integer to a verbal index; eg 1 maps to
439 speakNth :: Int -> SDoc
441 speakNth 1 = ptext SLIT("first")
442 speakNth 2 = ptext SLIT("second")
443 speakNth 3 = ptext SLIT("third")
444 speakNth 4 = ptext SLIT("fourth")
445 speakNth 5 = ptext SLIT("fifth")
446 speakNth 6 = ptext SLIT("sixth")
447 speakNth n = hcat [ int n, text suffix ]
449 suffix | n <= 20 = "th" -- 11,12,13 are non-std
450 | last_dig == 1 = "st"
451 | last_dig == 2 = "nd"
452 | last_dig == 3 = "rd"
455 last_dig = n `rem` 10
459 speakNTimes :: Int {- >=1 -} -> SDoc
460 speakNTimes t | t == 1 = ptext SLIT("once")
461 | t == 2 = ptext SLIT("twice")
462 | otherwise = int t <+> ptext SLIT("times")
466 %************************************************************************
468 \subsection{Error handling}
470 %************************************************************************
473 pprPanic, pprPgmError :: String -> SDoc -> a
474 pprTrace :: String -> SDoc -> a -> a
475 pprPanic = pprAndThen panic -- Throw an exn saying "bug in GHC"
477 pprPgmError = pprAndThen pgmError -- Throw an exn saying "bug in pgm being compiled"
478 -- (used for unusual pgm errors)
479 pprTrace = pprAndThen trace
481 pprPanic# heading pretty_msg = panic# (show (doc PprDebug))
483 doc = text heading <+> pretty_msg
485 pprAndThen :: (String -> a) -> String -> SDoc -> a
486 pprAndThen cont heading pretty_msg = cont (show (doc PprDebug))
488 doc = sep [text heading, nest 4 pretty_msg]
490 assertPprPanic :: String -> Int -> SDoc -> a
491 assertPprPanic file line msg
492 = panic (show (doc PprDebug))
494 doc = sep [hsep[text "ASSERT failed! file",
496 text "line", int line],
499 warnPprTrace :: Bool -> String -> Int -> SDoc -> a -> a
500 warnPprTrace False file line msg x = x
501 warnPprTrace True file line msg x
502 = trace (show (doc PprDebug)) x
504 doc = sep [hsep [text "WARNING: file", text file, text "line", int line],