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,
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,
47 pprPanic, pprPanic#, pprError, pprTrace, assertPprPanic, warnPprTrace,
48 trace, panic, panic#, assertPanic
51 #include "HsVersions.h"
54 import {-# SOURCE #-} Name( Name )
56 import CmdLineOpts ( opt_PprStyle_Debug, opt_PprUserLength )
58 import qualified Pretty
59 import Pretty ( Doc, Mode(..) )
62 import DATA_WORD ( Word32 )
64 import IO ( Handle, stderr, stdout, hFlush )
66 #if __GLASGOW_HASKELL__ < 410
67 import Char ( ord, isDigit )
72 %************************************************************************
74 \subsection{The @PprStyle@ data type}
76 %************************************************************************
80 = PprUser PrintUnqualified Depth -- Pretty-print in a way that will
81 -- make sense to the ordinary user;
82 -- must be very close to Haskell
85 | PprInterface PrintUnqualified -- Interface generation
87 | PprCode CodeStyle -- Print code; either C or assembler
89 | PprDebug -- Standard debugging output
91 data CodeStyle = CStyle -- The format of labels differs for C and assembler
94 data Depth = AllTheWay
95 | PartWay Int -- 0 => stop
98 type PrintUnqualified = Name -> Bool
99 -- This function tells when it's ok to print
100 -- a (Global) name unqualified
102 alwaysQualify,neverQualify :: PrintUnqualified
103 alwaysQualify n = False
104 neverQualify n = True
106 defaultUserStyle = mkUserStyle alwaysQualify AllTheWay
108 mkErrStyle :: PrintUnqualified -> PprStyle
109 -- Style for printing error messages
110 mkErrStyle print_unqual = mkUserStyle print_unqual (PartWay opt_PprUserLength)
112 defaultErrStyle :: PprStyle
113 -- Default style for error messages
114 -- It's a bit of a hack because it doesn't take into account what's in scope
115 -- Only used for desugarer warnings, and typechecker errors in interface sigs
117 | opt_PprStyle_Debug = mkUserStyle alwaysQualify AllTheWay
118 | otherwise = mkUserStyle neverQualify (PartWay opt_PprUserLength)
120 mkUserStyle unqual depth | opt_PprStyle_Debug = PprDebug
121 | otherwise = PprUser unqual depth
124 Orthogonal to the above printing styles are (possibly) some
125 command-line flags that affect printing (often carried with the
126 style). The most likely ones are variations on how much type info is
129 The following test decides whether or not we are actually generating
130 code (either C or assembly), or generating interface files.
132 %************************************************************************
134 \subsection{The @SDoc@ data type}
136 %************************************************************************
139 type SDoc = PprStyle -> Doc
141 withPprStyle :: PprStyle -> SDoc -> SDoc
142 withPprStyle sty d sty' = d sty
144 withPprStyleDoc :: PprStyle -> SDoc -> Doc
145 withPprStyleDoc sty d = d sty
147 pprDeeper :: SDoc -> SDoc
148 pprDeeper d (PprUser unqual (PartWay 0)) = Pretty.text "..."
149 pprDeeper d (PprUser unqual (PartWay n)) = d (PprUser unqual (PartWay (n-1)))
150 pprDeeper d other_sty = d other_sty
152 getPprStyle :: (PprStyle -> SDoc) -> SDoc
153 getPprStyle df sty = df sty sty
157 unqualStyle :: PprStyle -> Name -> Bool
158 unqualStyle (PprUser unqual _) n = unqual n
159 unqualStyle (PprInterface unqual) n = unqual n
160 unqualStyle other n = False
162 codeStyle :: PprStyle -> Bool
163 codeStyle (PprCode _) = True
166 asmStyle :: PprStyle -> Bool
167 asmStyle (PprCode AsmStyle) = True
168 asmStyle other = False
170 debugStyle :: PprStyle -> Bool
171 debugStyle PprDebug = True
172 debugStyle other = False
174 userStyle :: PprStyle -> Bool
175 userStyle (PprUser _ _) = True
176 userStyle other = False
178 ifPprDebug :: SDoc -> SDoc -- Empty for non-debug style
179 ifPprDebug d sty@PprDebug = d sty
180 ifPprDebug d sty = Pretty.empty
185 printSDoc :: SDoc -> PprStyle -> IO ()
187 Pretty.printDoc PageMode stdout (d sty)
190 -- I'm not sure whether the direct-IO approach of Pretty.printDoc
191 -- above is better or worse than the put-big-string approach here
192 printErrs :: Doc -> IO ()
193 printErrs doc = do Pretty.printDoc PageMode stderr doc
196 printDump :: SDoc -> IO ()
198 Pretty.printDoc PageMode stdout (better_doc defaultUserStyle)
201 better_doc = doc $$ text ""
202 -- We used to always print in debug style, but I want
203 -- to try the effect of a more user-ish style (unless you
206 printForUser :: Handle -> PrintUnqualified -> SDoc -> IO ()
207 printForUser handle unqual doc
208 = Pretty.printDoc PageMode handle (doc (mkUserStyle unqual AllTheWay))
210 -- printForC, printForAsm do what they sound like
211 printForC :: Handle -> SDoc -> IO ()
212 printForC handle doc = Pretty.printDoc LeftMode handle (doc (PprCode CStyle))
214 printForAsm :: Handle -> SDoc -> IO ()
215 printForAsm handle doc = Pretty.printDoc LeftMode handle (doc (PprCode AsmStyle))
217 pprCode :: CodeStyle -> SDoc -> SDoc
218 pprCode cs d = withPprStyle (PprCode cs) d
220 mkCodeStyle :: CodeStyle -> PprStyle
221 mkCodeStyle = PprCode
223 -- Can't make SDoc an instance of Show because SDoc is just a function type
224 -- However, Doc *is* an instance of Show
225 -- showSDoc just blasts it out as a string
226 showSDoc :: SDoc -> String
227 showSDoc d = show (d defaultUserStyle)
229 showSDocForUser :: PrintUnqualified -> SDoc -> String
230 showSDocForUser unqual doc = show (doc (mkUserStyle unqual AllTheWay))
232 showSDocUnqual :: SDoc -> String
233 -- Only used in the gruesome HsExpr.isOperator
234 showSDocUnqual d = show (d (mkUserStyle neverQualify AllTheWay))
236 showsPrecSDoc :: Int -> SDoc -> ShowS
237 showsPrecSDoc p d = showsPrec p (d defaultUserStyle)
239 showSDocDebug :: SDoc -> String
240 showSDocDebug d = show (d PprDebug)
244 docToSDoc :: Doc -> SDoc
245 docToSDoc d = \_ -> d
247 empty sty = Pretty.empty
248 text s sty = Pretty.text s
249 char c sty = Pretty.char c
250 ftext s sty = Pretty.ftext s
251 ptext s sty = Pretty.ptext s
252 int n sty = Pretty.int n
253 integer n sty = Pretty.integer n
254 float n sty = Pretty.float n
255 double n sty = Pretty.double n
256 rational n sty = Pretty.rational n
258 parens d sty = Pretty.parens (d sty)
259 braces d sty = Pretty.braces (d sty)
260 brackets d sty = Pretty.brackets (d sty)
261 doubleQuotes d sty = Pretty.doubleQuotes (d sty)
262 angleBrackets d = char '<' <> d <> char '>'
264 -- quotes encloses something in single quotes...
265 -- but it omits them if the thing ends in a single quote
266 -- so that we don't get `foo''. Instead we just have foo'.
267 quotes d sty = case show pp_d of
269 other -> Pretty.quotes pp_d
273 semi sty = Pretty.semi
274 comma sty = Pretty.comma
275 colon sty = Pretty.colon
276 equals sty = Pretty.equals
277 space sty = Pretty.space
278 lparen sty = Pretty.lparen
279 rparen sty = Pretty.rparen
280 lbrack sty = Pretty.lbrack
281 rbrack sty = Pretty.rbrack
282 lbrace sty = Pretty.lbrace
283 rbrace sty = Pretty.rbrace
284 dcolon sty = Pretty.ptext SLIT("::")
285 underscore = char '_'
288 nest n d sty = Pretty.nest n (d sty)
289 (<>) d1 d2 sty = (Pretty.<>) (d1 sty) (d2 sty)
290 (<+>) d1 d2 sty = (Pretty.<+>) (d1 sty) (d2 sty)
291 ($$) d1 d2 sty = (Pretty.$$) (d1 sty) (d2 sty)
292 ($+$) d1 d2 sty = (Pretty.$+$) (d1 sty) (d2 sty)
294 hcat ds sty = Pretty.hcat [d sty | d <- ds]
295 hsep ds sty = Pretty.hsep [d sty | d <- ds]
296 vcat ds sty = Pretty.vcat [d sty | d <- ds]
297 sep ds sty = Pretty.sep [d sty | d <- ds]
298 cat ds sty = Pretty.cat [d sty | d <- ds]
299 fsep ds sty = Pretty.fsep [d sty | d <- ds]
300 fcat ds sty = Pretty.fcat [d sty | d <- ds]
302 hang d1 n d2 sty = Pretty.hang (d1 sty) n (d2 sty)
304 punctuate :: SDoc -> [SDoc] -> [SDoc]
306 punctuate p (d:ds) = go d ds
309 go d (e:es) = (d <> p) : go e es
313 %************************************************************************
315 \subsection[Outputable-class]{The @Outputable@ class}
317 %************************************************************************
320 class Outputable a where
325 instance Outputable Bool where
326 ppr True = ptext SLIT("True")
327 ppr False = ptext SLIT("False")
329 instance Outputable Int where
332 instance Outputable () where
335 instance (Outputable a) => Outputable [a] where
336 ppr xs = brackets (fsep (punctuate comma (map ppr xs)))
338 instance (Outputable a, Outputable b) => Outputable (a, b) where
339 ppr (x,y) = parens (sep [ppr x <> comma, ppr y])
341 instance Outputable a => Outputable (Maybe a) where
342 ppr Nothing = ptext SLIT("Nothing")
343 ppr (Just x) = ptext SLIT("Just") <+> ppr x
345 -- ToDo: may not be used
346 instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c) where
348 parens (sep [ppr x <> comma,
352 instance (Outputable a, Outputable b, Outputable c, Outputable d) =>
353 Outputable (a, b, c, d) where
355 parens (sep [ppr x <> comma,
360 instance Outputable FastString where
361 ppr fs = text (unpackFS fs) -- Prints an unadorned string,
362 -- no double quotes or anything
366 %************************************************************************
368 \subsection{The @OutputableBndr@ class}
370 %************************************************************************
372 When we print a binder, we often want to print its type too.
373 The @OutputableBndr@ class encapsulates this idea.
375 @BindingSite@ is used to tell the thing that prints binder what
376 language construct is binding the identifier. This can be used
377 to decide how much info to print.
380 data BindingSite = LambdaBind | CaseBind | LetBind
382 class Outputable a => OutputableBndr a where
383 pprBndr :: BindingSite -> a -> SDoc
389 %************************************************************************
391 \subsection{Random printing helpers}
393 %************************************************************************
396 #if __GLASGOW_HASKELL__ < 410
397 -- Assume we have only 8-bit Chars.
399 pprHsChar :: Int -> SDoc
400 pprHsChar c = char '\'' <> text (showCharLit c "") <> char '\''
402 pprHsString :: FastString -> SDoc
403 pprHsString fs = doubleQuotes (text (foldr showCharLit "" (unpackIntFS fs)))
405 showCharLit :: Int -> String -> String
407 | c == ord '\"' = "\\\"" ++ rest
408 | c == ord '\'' = "\\\'" ++ rest
409 | c == ord '\\' = "\\\\" ++ rest
410 | c >= 0x20 && c <= 0x7E = chr c : rest
411 | c == ord '\a' = "\\a" ++ rest
412 | c == ord '\b' = "\\b" ++ rest
413 | c == ord '\f' = "\\f" ++ rest
414 | c == ord '\n' = "\\n" ++ rest
415 | c == ord '\r' = "\\r" ++ rest
416 | c == ord '\t' = "\\t" ++ rest
417 | c == ord '\v' = "\\v" ++ rest
418 | otherwise = ('\\':) $ shows (fromIntegral c :: Word32) $ case rest of
419 d:_ | isDigit d -> "\\&" ++ rest
423 -- We have 31-bit Chars and will simply use Show instances
424 -- of Char and String.
426 pprHsChar :: Int -> SDoc
427 pprHsChar c | c > 0x10ffff = char '\\' <> text (show (fromIntegral c :: Word32))
428 | otherwise = text (show (chr c))
430 pprHsString :: FastString -> SDoc
431 pprHsString fs = text (show (unpackFS fs))
435 instance Show FastString where
436 showsPrec p fs = showsPrecSDoc p (ppr fs)
440 %************************************************************************
442 \subsection{Other helper functions}
444 %************************************************************************
447 pprWithCommas :: (a -> SDoc) -> [a] -> SDoc
448 pprWithCommas pp xs = fsep (punctuate comma (map pp xs))
450 interppSP :: Outputable a => [a] -> SDoc
451 interppSP xs = hsep (map ppr xs)
453 interpp'SP :: Outputable a => [a] -> SDoc
454 interpp'SP xs = hsep (punctuate comma (map ppr xs))
456 pprQuotedList :: Outputable a => [a] -> SDoc
457 -- [x,y,z] ==> `x', `y', `z'
458 pprQuotedList xs = hsep (punctuate comma (map (quotes . ppr) xs))
462 %************************************************************************
464 \subsection{Printing numbers verbally}
466 %************************************************************************
468 @speakNth@ converts an integer to a verbal index; eg 1 maps to
472 speakNth :: Int -> SDoc
474 speakNth 1 = ptext SLIT("first")
475 speakNth 2 = ptext SLIT("second")
476 speakNth 3 = ptext SLIT("third")
477 speakNth 4 = ptext SLIT("fourth")
478 speakNth 5 = ptext SLIT("fifth")
479 speakNth 6 = ptext SLIT("sixth")
480 speakNth n = hcat [ int n, text suffix ]
482 suffix | n <= 20 = "th" -- 11,12,13 are non-std
483 | last_dig == 1 = "st"
484 | last_dig == 2 = "nd"
485 | last_dig == 3 = "rd"
488 last_dig = n `rem` 10
492 speakNTimes :: Int {- >=1 -} -> SDoc
493 speakNTimes t | t == 1 = ptext SLIT("once")
494 | t == 2 = ptext SLIT("twice")
495 | otherwise = int t <+> ptext SLIT("times")
499 %************************************************************************
501 \subsection{Error handling}
503 %************************************************************************
506 pprPanic :: String -> SDoc -> a
507 pprError :: String -> SDoc -> a
508 pprTrace :: String -> SDoc -> a -> a
509 pprPanic = pprAndThen panic
510 pprError = pprAndThen error
511 pprTrace = pprAndThen trace
513 pprPanic# heading pretty_msg = panic# (show (doc PprDebug))
515 doc = text heading <+> pretty_msg
517 pprAndThen :: (String -> a) -> String -> SDoc -> a
518 pprAndThen cont heading pretty_msg = cont (show (doc PprDebug))
520 doc = sep [text heading, nest 4 pretty_msg]
522 assertPprPanic :: String -> Int -> SDoc -> a
523 assertPprPanic file line msg
524 = panic (show (doc PprDebug))
526 doc = sep [hsep[text "ASSERT failed! file",
528 text "line", int line],
531 warnPprTrace :: Bool -> String -> Int -> SDoc -> a -> a
532 warnPprTrace False file line msg x = x
533 warnPprTrace True file line msg x
534 = trace (show (doc PprDebug)) x
536 doc = sep [hsep [text "WARNING: file", text file, text "line", int line],