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(..), -- Class
14 PprStyle, CodeStyle(..), PrintUnqualified, alwaysQualify,
15 getPprStyle, withPprStyle, withPprStyleDoc, pprDeeper,
16 codeStyle, ifaceStyle, userStyle, debugStyle, asmStyle,
17 ifPprDebug, unqualStyle,
21 interppSP, interpp'SP, pprQuotedList, pprWithCommas,
24 int, integer, float, double, rational,
25 parens, brackets, braces, quotes, doubleQuotes, angleBrackets,
26 semi, comma, colon, dcolon, space, equals, dot,
27 lparen, rparen, lbrack, rbrack, lbrace, rbrace, underscore,
28 (<>), (<+>), hcat, hsep,
33 speakNth, speakNTimes,
35 printSDoc, printErrs, printDump,
36 printForC, printForAsm, printForIface, printForUser,
38 showSDoc, showSDocForUser, showSDocDebug, showSDocIface,
39 showSDocUnqual, showsPrecSDoc,
40 pprHsChar, pprHsString,
44 pprPanic, pprPanic#, pprError, pprTrace, assertPprPanic, warnPprTrace,
45 trace, panic, panic#, assertPanic
48 #include "HsVersions.h"
51 import {-# SOURCE #-} Name( Name )
53 import CmdLineOpts ( opt_PprStyle_Debug, opt_PprUserLength )
55 import qualified Pretty
56 import Pretty ( Doc, Mode(..), TextDetails(..), fullRender )
59 import Word ( Word32 )
60 import IO ( Handle, stderr, stdout )
62 #if __GLASGOW_HASKELL__ < 410
63 import Char ( ord, isDigit )
68 %************************************************************************
70 \subsection{The @PprStyle@ data type}
72 %************************************************************************
76 = PprUser PrintUnqualified Depth -- Pretty-print in a way that will
77 -- make sense to the ordinary user;
78 -- must be very close to Haskell
81 | PprInterface PrintUnqualified -- Interface generation
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 = Name -> Bool
95 -- This function tells when it's ok to print
96 -- a (Global) name unqualified
98 alwaysQualify,neverQualify :: PrintUnqualified
99 alwaysQualify n = False
100 neverQualify n = True
102 defaultUserStyle = mkUserStyle alwaysQualify AllTheWay
104 mkUserStyle unqual depth | opt_PprStyle_Debug = PprDebug
105 | otherwise = PprUser unqual depth
108 Orthogonal to the above printing styles are (possibly) some
109 command-line flags that affect printing (often carried with the
110 style). The most likely ones are variations on how much type info is
113 The following test decides whether or not we are actually generating
114 code (either C or assembly), or generating interface files.
116 %************************************************************************
118 \subsection{The @SDoc@ data type}
120 %************************************************************************
123 type SDoc = PprStyle -> Doc
125 withPprStyle :: PprStyle -> SDoc -> SDoc
126 withPprStyle sty d sty' = d sty
128 withPprStyleDoc :: PprStyle -> SDoc -> Doc
129 withPprStyleDoc sty d = d sty
131 pprDeeper :: SDoc -> SDoc
132 pprDeeper d (PprUser unqual (PartWay 0)) = Pretty.text "..."
133 pprDeeper d (PprUser unqual (PartWay n)) = d (PprUser unqual (PartWay (n-1)))
134 pprDeeper d other_sty = d other_sty
136 getPprStyle :: (PprStyle -> SDoc) -> SDoc
137 getPprStyle df sty = df sty sty
141 unqualStyle :: PprStyle -> Name -> Bool
142 unqualStyle (PprUser unqual _) n = unqual n
143 unqualStyle (PprInterface unqual) n = unqual n
144 unqualStyle other n = False
146 codeStyle :: PprStyle -> Bool
147 codeStyle (PprCode _) = True
150 asmStyle :: PprStyle -> Bool
151 asmStyle (PprCode AsmStyle) = True
152 asmStyle other = False
154 ifaceStyle :: PprStyle -> Bool
155 ifaceStyle (PprInterface _) = True
156 ifaceStyle other = False
158 debugStyle :: PprStyle -> Bool
159 debugStyle PprDebug = True
160 debugStyle other = False
162 userStyle :: PprStyle -> Bool
163 userStyle (PprUser _ _) = True
164 userStyle other = False
166 ifPprDebug :: SDoc -> SDoc -- Empty for non-debug style
167 ifPprDebug d sty@PprDebug = d sty
168 ifPprDebug d sty = Pretty.empty
172 printSDoc :: SDoc -> PprStyle -> IO ()
173 printSDoc d sty = Pretty.printDoc PageMode stdout (d sty)
175 -- I'm not sure whether the direct-IO approach of Pretty.printDoc
176 -- above is better or worse than the put-big-string approach here
177 printErrs :: PrintUnqualified -> SDoc -> IO ()
178 printErrs unqual doc = Pretty.printDoc PageMode stderr (doc style)
180 style = mkUserStyle unqual (PartWay opt_PprUserLength)
182 printDump :: SDoc -> IO ()
183 printDump doc = Pretty.printDoc PageMode stdout (better_doc defaultUserStyle)
185 better_doc = doc $$ text ""
186 -- We used to always print in debug style, but I want
187 -- to try the effect of a more user-ish style (unless you
190 printForUser :: Handle -> PrintUnqualified -> SDoc -> IO ()
191 printForUser handle unqual doc
192 = Pretty.printDoc PageMode handle (doc (mkUserStyle unqual AllTheWay))
194 -- printForIface prints all on one line for interface files.
195 -- It's called repeatedly for successive lines
196 printForIface :: Handle -> PrintUnqualified -> SDoc -> IO ()
197 printForIface handle unqual doc
198 = Pretty.printDoc LeftMode handle (doc (PprInterface unqual))
200 -- printForC, printForAsm do what they sound like
201 printForC :: Handle -> SDoc -> IO ()
202 printForC handle doc = Pretty.printDoc LeftMode handle (doc (PprCode CStyle))
204 printForAsm :: Handle -> SDoc -> IO ()
205 printForAsm handle doc = Pretty.printDoc LeftMode handle (doc (PprCode AsmStyle))
207 pprCode :: CodeStyle -> SDoc -> SDoc
208 pprCode cs d = withPprStyle (PprCode cs) d
210 mkCodeStyle :: CodeStyle -> PprStyle
211 mkCodeStyle = PprCode
213 -- Can't make SDoc an instance of Show because SDoc is just a function type
214 -- However, Doc *is* an instance of Show
215 -- showSDoc just blasts it out as a string
216 showSDoc :: SDoc -> String
217 showSDoc d = show (d defaultUserStyle)
219 showSDocForUser :: PrintUnqualified -> SDoc -> String
220 showSDocForUser unqual doc = show (doc (mkUserStyle unqual AllTheWay))
222 showSDocUnqual :: SDoc -> String
223 -- Only used in the gruesome HsExpr.isOperator
224 showSDocUnqual d = show (d (mkUserStyle neverQualify AllTheWay))
226 showsPrecSDoc :: Int -> SDoc -> ShowS
227 showsPrecSDoc p d = showsPrec p (d defaultUserStyle)
229 showSDocIface :: SDoc -> String
230 showSDocIface doc = showDocWith OneLineMode (doc (PprInterface alwaysQualify))
232 showSDocDebug :: SDoc -> String
233 showSDocDebug d = show (d PprDebug)
237 docToSDoc :: Doc -> SDoc
238 docToSDoc d = \_ -> d
240 empty sty = Pretty.empty
241 text s sty = Pretty.text s
242 char c sty = Pretty.char c
243 ptext s sty = Pretty.ptext s
244 int n sty = Pretty.int n
245 integer n sty = Pretty.integer n
246 float n sty = Pretty.float n
247 double n sty = Pretty.double n
248 rational n sty = Pretty.rational n
250 parens d sty = Pretty.parens (d sty)
251 braces d sty = Pretty.braces (d sty)
252 brackets d sty = Pretty.brackets (d sty)
253 doubleQuotes d sty = Pretty.doubleQuotes (d sty)
254 angleBrackets d = char '<' <> d <> char '>'
256 -- quotes encloses something in single quotes...
257 -- but it omits them if the thing ends in a single quote
258 -- so that we don't get `foo''. Instead we just have foo'.
259 quotes d sty = case show pp_d of
261 other -> Pretty.quotes pp_d
265 semi sty = Pretty.semi
266 comma sty = Pretty.comma
267 colon sty = Pretty.colon
268 equals sty = Pretty.equals
269 space sty = Pretty.space
270 lparen sty = Pretty.lparen
271 rparen sty = Pretty.rparen
272 lbrack sty = Pretty.lbrack
273 rbrack sty = Pretty.rbrack
274 lbrace sty = Pretty.lbrace
275 rbrace sty = Pretty.rbrace
276 dcolon sty = Pretty.ptext SLIT("::")
277 underscore = char '_'
280 nest n d sty = Pretty.nest n (d sty)
281 (<>) d1 d2 sty = (Pretty.<>) (d1 sty) (d2 sty)
282 (<+>) d1 d2 sty = (Pretty.<+>) (d1 sty) (d2 sty)
283 ($$) d1 d2 sty = (Pretty.$$) (d1 sty) (d2 sty)
284 ($+$) d1 d2 sty = (Pretty.$+$) (d1 sty) (d2 sty)
286 hcat ds sty = Pretty.hcat [d sty | d <- ds]
287 hsep ds sty = Pretty.hsep [d sty | d <- ds]
288 vcat ds sty = Pretty.vcat [d sty | d <- ds]
289 sep ds sty = Pretty.sep [d sty | d <- ds]
290 cat ds sty = Pretty.cat [d sty | d <- ds]
291 fsep ds sty = Pretty.fsep [d sty | d <- ds]
292 fcat ds sty = Pretty.fcat [d sty | d <- ds]
294 hang d1 n d2 sty = Pretty.hang (d1 sty) n (d2 sty)
296 punctuate :: SDoc -> [SDoc] -> [SDoc]
298 punctuate p (d:ds) = go d ds
301 go d (e:es) = (d <> p) : go e es
305 %************************************************************************
307 \subsection[Outputable-class]{The @Outputable@ class}
309 %************************************************************************
312 class Outputable a where
317 instance Outputable Bool where
318 ppr True = ptext SLIT("True")
319 ppr False = ptext SLIT("False")
321 instance Outputable Int where
324 instance Outputable () where
327 instance (Outputable a) => Outputable [a] where
328 ppr xs = brackets (fsep (punctuate comma (map ppr xs)))
330 instance (Outputable a, Outputable b) => Outputable (a, b) where
331 ppr (x,y) = parens (sep [ppr x <> comma, ppr y])
333 instance Outputable a => Outputable (Maybe a) where
334 ppr Nothing = ptext SLIT("Nothing")
335 ppr (Just x) = ptext SLIT("Just") <+> ppr x
337 -- ToDo: may not be used
338 instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c) where
340 parens (sep [ppr x <> comma,
344 instance (Outputable a, Outputable b, Outputable c, Outputable d) =>
345 Outputable (a, b, c, d) where
347 parens (sep [ppr x <> comma,
352 instance Outputable FastString where
353 ppr fs = text (unpackFS fs) -- Prints an unadorned string,
354 -- no double quotes or anything
356 #if __GLASGOW_HASKELL__ < 410
357 -- Assume we have only 8-bit Chars.
359 pprHsChar :: Int -> SDoc
360 pprHsChar c = char '\'' <> text (showCharLit c "") <> char '\''
362 pprHsString :: FAST_STRING -> SDoc
363 pprHsString fs = doubleQuotes (text (foldr showCharLit "" (_UNPK_INT_ fs)))
365 showCharLit :: Int -> String -> String
367 | c == ord '\"' = "\\\"" ++ rest
368 | c == ord '\'' = "\\\'" ++ rest
369 | c == ord '\\' = "\\\\" ++ rest
370 | c >= 0x20 && c <= 0x7E = chr c : rest
371 | c == ord '\a' = "\\a" ++ rest
372 | c == ord '\b' = "\\b" ++ rest
373 | c == ord '\f' = "\\f" ++ rest
374 | c == ord '\n' = "\\n" ++ rest
375 | c == ord '\r' = "\\r" ++ rest
376 | c == ord '\t' = "\\t" ++ rest
377 | c == ord '\v' = "\\v" ++ rest
378 | otherwise = ('\\':) $ shows (fromIntegral c :: Word32) $ case rest of
379 d:_ | isDigit d -> "\\&" ++ rest
383 -- We have 31-bit Chars and will simply use Show instances
384 -- of Char and String.
386 pprHsChar :: Int -> SDoc
387 pprHsChar c | c > 0x10ffff = char '\\' <> text (show (fromIntegral c :: Word32))
388 | otherwise = text (show (chr c))
390 pprHsString :: FastString -> SDoc
391 pprHsString fs = text (show (unpackFS fs))
395 instance Show FastString where
396 showsPrec p fs = showsPrecSDoc p (ppr fs)
400 %************************************************************************
402 \subsection{Other helper functions}
404 %************************************************************************
407 showDocWith :: Mode -> Doc -> String
409 = fullRender mode 100 1.5 put "" doc
412 put (Str s1) s2 = s1 ++ s2
413 put (PStr s1) s2 = _UNPK_ s1 ++ s2
418 pprWithCommas :: (a -> SDoc) -> [a] -> SDoc
419 pprWithCommas pp xs = hsep (punctuate comma (map pp xs))
421 interppSP :: Outputable a => [a] -> SDoc
422 interppSP xs = hsep (map ppr xs)
424 interpp'SP :: Outputable a => [a] -> SDoc
425 interpp'SP xs = hsep (punctuate comma (map ppr xs))
427 pprQuotedList :: Outputable a => [a] -> SDoc
428 -- [x,y,z] ==> `x', `y', `z'
429 pprQuotedList xs = hsep (punctuate comma (map (quotes . ppr) xs))
433 %************************************************************************
435 \subsection{Printing numbers verbally}
437 %************************************************************************
439 @speakNth@ converts an integer to a verbal index; eg 1 maps to
443 speakNth :: Int -> SDoc
445 speakNth 1 = ptext SLIT("first")
446 speakNth 2 = ptext SLIT("second")
447 speakNth 3 = ptext SLIT("third")
448 speakNth 4 = ptext SLIT("fourth")
449 speakNth 5 = ptext SLIT("fifth")
450 speakNth 6 = ptext SLIT("sixth")
451 speakNth n = hcat [ int n, text st_nd_rd_th ]
453 st_nd_rd_th | n_rem_10 == 1 = "st"
454 | n_rem_10 == 2 = "nd"
455 | n_rem_10 == 3 = "rd"
458 n_rem_10 = n `rem` 10
462 speakNTimes :: Int {- >=1 -} -> SDoc
463 speakNTimes t | t == 1 = ptext SLIT("once")
464 | t == 2 = ptext SLIT("twice")
465 | otherwise = int t <+> ptext SLIT("times")
469 %************************************************************************
471 \subsection{Error handling}
473 %************************************************************************
476 pprPanic :: String -> SDoc -> a
477 pprError :: String -> SDoc -> a
478 pprTrace :: String -> SDoc -> a -> a
479 pprPanic = pprAndThen panic
480 pprError = pprAndThen error
481 pprTrace = pprAndThen trace
483 pprPanic# heading pretty_msg = panic# (show (doc PprDebug))
485 doc = text heading <+> pretty_msg
487 pprAndThen :: (String -> a) -> String -> SDoc -> a
488 pprAndThen cont heading pretty_msg = cont (show (doc PprDebug))
490 doc = sep [text heading, nest 4 pretty_msg]
492 assertPprPanic :: String -> Int -> SDoc -> a
493 assertPprPanic file line msg
494 = panic (show (doc PprDebug))
496 doc = sep [hsep[text "ASSERT failed! file",
498 text "line", int line],
501 warnPprTrace :: Bool -> String -> Int -> SDoc -> a -> a
502 warnPprTrace False file line msg x = x
503 warnPprTrace True file line msg x
504 = trace (show (doc PprDebug)) x
506 doc = sep [hsep [text "WARNING: file", text file, text "line", int line],