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, pprDeeper,
16 codeStyle, ifaceStyle, userStyle, debugStyle, asmStyle,
17 ifPprDebug, unqualStyle,
20 interppSP, interpp'SP, pprQuotedList, pprWithCommas,
23 int, integer, float, double, rational,
24 parens, brackets, braces, quotes, doubleQuotes, angleBrackets,
25 semi, comma, colon, dcolon, space, equals, dot,
26 lparen, rparen, lbrack, rbrack, lbrace, rbrace, underscore,
27 (<>), (<+>), hcat, hsep,
32 speakNth, speakNTimes,
34 printSDoc, printErrs, printDump,
35 printForC, printForAsm, printForIface, printForUser,
37 showSDoc, showSDocForUser, showSDocDebug, showSDocIface,
38 showSDocUnqual, showsPrecSDoc,
39 pprHsChar, pprHsString,
43 pprPanic, pprPanic#, pprError, pprTrace, assertPprPanic, warnPprTrace,
44 trace, panic, panic#, assertPanic
47 #include "HsVersions.h"
50 import {-# SOURCE #-} Name( Name )
52 import CmdLineOpts ( opt_PprStyle_Debug, opt_PprUserLength )
54 import qualified Pretty
55 import Pretty ( Doc, Mode(..), TextDetails(..), fullRender )
58 import Word ( Word32 )
59 import IO ( Handle, hPutChar, hPutStr, stderr, stdout )
60 import Char ( chr, ord, isDigit )
64 %************************************************************************
66 \subsection{The @PprStyle@ data type}
68 %************************************************************************
72 = PprUser PrintUnqualified Depth -- Pretty-print in a way that will
73 -- make sense to the ordinary user;
74 -- must be very close to Haskell
77 | PprInterface PrintUnqualified -- Interface generation
79 | PprCode CodeStyle -- Print code; either C or assembler
81 | PprDebug -- Standard debugging output
83 data CodeStyle = CStyle -- The format of labels differs for C and assembler
86 data Depth = AllTheWay
87 | PartWay Int -- 0 => stop
90 type PrintUnqualified = Name -> Bool
91 -- This function tells when it's ok to print
92 -- a (Global) name unqualified
94 alwaysQualify,neverQualify :: PrintUnqualified
95 alwaysQualify n = False
98 defaultUserStyle = mkUserStyle alwaysQualify AllTheWay
100 mkUserStyle unqual depth | opt_PprStyle_Debug = PprDebug
101 | otherwise = PprUser unqual depth
104 Orthogonal to the above printing styles are (possibly) some
105 command-line flags that affect printing (often carried with the
106 style). The most likely ones are variations on how much type info is
109 The following test decides whether or not we are actually generating
110 code (either C or assembly), or generating interface files.
112 %************************************************************************
114 \subsection{The @SDoc@ data type}
116 %************************************************************************
119 type SDoc = PprStyle -> Doc
121 withPprStyle :: PprStyle -> SDoc -> SDoc
122 withPprStyle sty d sty' = d sty
124 pprDeeper :: SDoc -> SDoc
125 pprDeeper d (PprUser unqual (PartWay 0)) = Pretty.text "..."
126 pprDeeper d (PprUser unqual (PartWay n)) = d (PprUser unqual (PartWay (n-1)))
127 pprDeeper d other_sty = d other_sty
129 getPprStyle :: (PprStyle -> SDoc) -> SDoc
130 getPprStyle df sty = df sty sty
134 unqualStyle :: PprStyle -> Name -> Bool
135 unqualStyle (PprUser unqual _) n = unqual n
136 unqualStyle (PprInterface unqual) n = unqual n
137 unqualStyle other n = False
139 codeStyle :: PprStyle -> Bool
140 codeStyle (PprCode _) = True
143 asmStyle :: PprStyle -> Bool
144 asmStyle (PprCode AsmStyle) = True
145 asmStyle other = False
147 ifaceStyle :: PprStyle -> Bool
148 ifaceStyle (PprInterface _) = True
149 ifaceStyle other = False
151 debugStyle :: PprStyle -> Bool
152 debugStyle PprDebug = True
153 debugStyle other = False
155 userStyle :: PprStyle -> Bool
156 userStyle (PprUser _ _) = True
157 userStyle other = False
159 ifPprDebug :: SDoc -> SDoc -- Empty for non-debug style
160 ifPprDebug d sty@PprDebug = d sty
161 ifPprDebug d sty = Pretty.empty
165 printSDoc :: SDoc -> PprStyle -> IO ()
166 printSDoc d sty = printDoc PageMode stdout (d sty)
168 -- I'm not sure whether the direct-IO approach of printDoc
169 -- above is better or worse than the put-big-string approach here
170 printErrs :: PrintUnqualified -> SDoc -> IO ()
171 printErrs unqual doc = printDoc PageMode stderr (doc style)
173 style = mkUserStyle unqual (PartWay opt_PprUserLength)
175 printDump :: SDoc -> IO ()
176 printDump doc = printDoc PageMode stdout (better_doc defaultUserStyle)
178 better_doc = doc $$ text ""
179 -- We used to always print in debug style, but I want
180 -- to try the effect of a more user-ish style (unless you
183 printForUser :: Handle -> PrintUnqualified -> SDoc -> IO ()
184 printForUser handle unqual doc
185 = printDoc PageMode handle (doc (mkUserStyle unqual AllTheWay))
187 -- printForIface prints all on one line for interface files.
188 -- It's called repeatedly for successive lines
189 printForIface :: Handle -> PrintUnqualified -> SDoc -> IO ()
190 printForIface handle unqual doc
191 = printDoc LeftMode handle (doc (PprInterface unqual))
193 -- printForC, printForAsm do what they sound like
194 printForC :: Handle -> SDoc -> IO ()
195 printForC handle doc = printDoc LeftMode handle (doc (PprCode CStyle))
197 printForAsm :: Handle -> SDoc -> IO ()
198 printForAsm handle doc = printDoc LeftMode handle (doc (PprCode AsmStyle))
200 pprCode :: CodeStyle -> SDoc -> SDoc
201 pprCode cs d = withPprStyle (PprCode cs) d
203 -- Can't make SDoc an instance of Show because SDoc is just a function type
204 -- However, Doc *is* an instance of Show
205 -- showSDoc just blasts it out as a string
206 showSDoc :: SDoc -> String
207 showSDoc d = show (d defaultUserStyle)
209 showSDocForUser :: PrintUnqualified -> SDoc -> String
210 showSDocForUser unqual doc = show (doc (mkUserStyle unqual AllTheWay))
212 showSDocUnqual :: SDoc -> String
213 -- Only used in the gruesome HsExpr.isOperator
214 showSDocUnqual d = show (d (mkUserStyle neverQualify AllTheWay))
216 showsPrecSDoc :: Int -> SDoc -> ShowS
217 showsPrecSDoc p d = showsPrec p (d defaultUserStyle)
219 showSDocIface :: SDoc -> String
220 showSDocIface doc = showDocWith OneLineMode (doc (PprInterface alwaysQualify))
222 showSDocDebug :: SDoc -> String
223 showSDocDebug d = show (d PprDebug)
227 empty sty = Pretty.empty
228 text s sty = Pretty.text s
229 char c sty = Pretty.char c
230 ptext s sty = Pretty.ptext s
231 int n sty = Pretty.int n
232 integer n sty = Pretty.integer n
233 float n sty = Pretty.float n
234 double n sty = Pretty.double n
235 rational n sty = Pretty.rational n
237 parens d sty = Pretty.parens (d sty)
238 braces d sty = Pretty.braces (d sty)
239 brackets d sty = Pretty.brackets (d sty)
240 doubleQuotes d sty = Pretty.doubleQuotes (d sty)
241 angleBrackets d = char '<' <> d <> char '>'
243 -- quotes encloses something in single quotes...
244 -- but it omits them if the thing ends in a single quote
245 -- so that we don't get `foo''. Instead we just have foo'.
246 quotes d sty = case show pp_d of
248 other -> Pretty.quotes pp_d
252 semi sty = Pretty.semi
253 comma sty = Pretty.comma
254 colon sty = Pretty.colon
255 equals sty = Pretty.equals
256 space sty = Pretty.space
257 lparen sty = Pretty.lparen
258 rparen sty = Pretty.rparen
259 lbrack sty = Pretty.lbrack
260 rbrack sty = Pretty.rbrack
261 lbrace sty = Pretty.lbrace
262 rbrace sty = Pretty.rbrace
263 dcolon sty = Pretty.ptext SLIT("::")
264 underscore = char '_'
267 nest n d sty = Pretty.nest n (d sty)
268 (<>) d1 d2 sty = (Pretty.<>) (d1 sty) (d2 sty)
269 (<+>) d1 d2 sty = (Pretty.<+>) (d1 sty) (d2 sty)
270 ($$) d1 d2 sty = (Pretty.$$) (d1 sty) (d2 sty)
271 ($+$) d1 d2 sty = (Pretty.$+$) (d1 sty) (d2 sty)
273 hcat ds sty = Pretty.hcat [d sty | d <- ds]
274 hsep ds sty = Pretty.hsep [d sty | d <- ds]
275 vcat ds sty = Pretty.vcat [d sty | d <- ds]
276 sep ds sty = Pretty.sep [d sty | d <- ds]
277 cat ds sty = Pretty.cat [d sty | d <- ds]
278 fsep ds sty = Pretty.fsep [d sty | d <- ds]
279 fcat ds sty = Pretty.fcat [d sty | d <- ds]
281 hang d1 n d2 sty = Pretty.hang (d1 sty) n (d2 sty)
283 punctuate :: SDoc -> [SDoc] -> [SDoc]
285 punctuate p (d:ds) = go d ds
288 go d (e:es) = (d <> p) : go e es
292 %************************************************************************
294 \subsection[Outputable-class]{The @Outputable@ class}
296 %************************************************************************
299 class Outputable a where
304 instance Outputable Bool where
305 ppr True = ptext SLIT("True")
306 ppr False = ptext SLIT("False")
308 instance Outputable Int where
311 instance Outputable () where
314 instance (Outputable a) => Outputable [a] where
315 ppr xs = brackets (fsep (punctuate comma (map ppr xs)))
317 instance (Outputable a, Outputable b) => Outputable (a, b) where
318 ppr (x,y) = parens (sep [ppr x <> comma, ppr y])
320 instance Outputable a => Outputable (Maybe a) where
321 ppr Nothing = ptext SLIT("Nothing")
322 ppr (Just x) = ptext SLIT("Just") <+> ppr x
324 -- ToDo: may not be used
325 instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c) where
327 parens (sep [ppr x <> comma,
331 instance (Outputable a, Outputable b, Outputable c, Outputable d) =>
332 Outputable (a, b, c, d) where
334 parens (sep [ppr x <> comma,
339 instance Outputable FastString where
340 ppr fs = text (unpackFS fs) -- Prints an unadorned string,
341 -- no double quotes or anything
343 #if __GLASGOW_HASKELL__ < 410
344 -- Assume we have only 8-bit Chars.
346 pprHsChar :: Int -> SDoc
347 pprHsChar c = char '\'' <> text (showCharLit c "") <> char '\''
349 pprHsString :: FAST_STRING -> SDoc
350 pprHsString fs = doubleQuotes (text (foldr showCharLit "" (_UNPK_INT_ fs)))
352 showCharLit :: Int -> String -> String
354 | c == ord '\"' = "\\\"" ++ rest
355 | c == ord '\'' = "\\\'" ++ rest
356 | c == ord '\\' = "\\\\" ++ rest
357 | c >= 0x20 && c <= 0x7E = chr c : rest
358 | c == ord '\a' = "\\a" ++ rest
359 | c == ord '\b' = "\\b" ++ rest
360 | c == ord '\f' = "\\f" ++ rest
361 | c == ord '\n' = "\\n" ++ rest
362 | c == ord '\r' = "\\r" ++ rest
363 | c == ord '\t' = "\\t" ++ rest
364 | c == ord '\v' = "\\v" ++ rest
365 | otherwise = ('\\':) $ shows (fromIntegral c :: Word32) $ case rest of
366 d:_ | isDigit d -> "\\&" ++ rest
370 -- We have 31-bit Chars and will simply use Show instances
371 -- of Char and String.
373 pprHsChar :: Int -> SDoc
374 pprHsChar c | c > 0x10ffff = char '\\' <> text (show (fromIntegral c :: Word32))
375 | otherwise = text (show (chr c))
377 pprHsString :: FastString -> SDoc
378 pprHsString fs = text (show (unpackFS fs))
382 instance Show FastString where
383 showsPrec p fs = showsPrecSDoc p (ppr fs)
387 %************************************************************************
389 \subsection{Other helper functions}
391 %************************************************************************
394 pprCols = (100 :: Int) -- could make configurable
396 printDoc :: Mode -> Handle -> Doc -> IO ()
397 printDoc mode hdl doc
398 = fullRender mode pprCols 1.5 put done doc
400 put (Chr c) next = hPutChar hdl c >> next
401 put (Str s) next = hPutStr hdl s >> next
402 put (PStr s) next = hPutFS hdl s >> next
404 done = hPutChar hdl '\n'
406 showDocWith :: Mode -> Doc -> String
408 = fullRender mode 100 1.5 put "" doc
411 put (Str s1) s2 = s1 ++ s2
412 put (PStr s1) s2 = _UNPK_ s1 ++ s2
417 pprWithCommas :: (a -> SDoc) -> [a] -> SDoc
418 pprWithCommas pp xs = hsep (punctuate comma (map pp xs))
420 interppSP :: Outputable a => [a] -> SDoc
421 interppSP xs = hsep (map ppr xs)
423 interpp'SP :: Outputable a => [a] -> SDoc
424 interpp'SP xs = hsep (punctuate comma (map ppr xs))
426 pprQuotedList :: Outputable a => [a] -> SDoc
427 -- [x,y,z] ==> `x', `y', `z'
428 pprQuotedList xs = hsep (punctuate comma (map (quotes . ppr) xs))
432 %************************************************************************
434 \subsection{Printing numbers verbally}
436 %************************************************************************
438 @speakNth@ converts an integer to a verbal index; eg 1 maps to
442 speakNth :: Int -> SDoc
444 speakNth 1 = ptext SLIT("first")
445 speakNth 2 = ptext SLIT("second")
446 speakNth 3 = ptext SLIT("third")
447 speakNth 4 = ptext SLIT("fourth")
448 speakNth 5 = ptext SLIT("fifth")
449 speakNth 6 = ptext SLIT("sixth")
450 speakNth n = hcat [ int n, text st_nd_rd_th ]
452 st_nd_rd_th | n_rem_10 == 1 = "st"
453 | n_rem_10 == 2 = "nd"
454 | n_rem_10 == 3 = "rd"
457 n_rem_10 = n `rem` 10
461 speakNTimes :: Int {- >=1 -} -> SDoc
462 speakNTimes t | t == 1 = ptext SLIT("once")
463 | t == 2 = ptext SLIT("twice")
464 | otherwise = int t <+> ptext SLIT("times")
468 %************************************************************************
470 \subsection{Error handling}
472 %************************************************************************
475 pprPanic :: String -> SDoc -> a
476 pprError :: String -> SDoc -> a
477 pprTrace :: String -> SDoc -> a -> a
478 pprPanic = pprAndThen panic
479 pprError = pprAndThen error
480 pprTrace = pprAndThen trace
482 pprPanic# heading pretty_msg = panic# (show (doc PprDebug))
484 doc = text heading <+> pretty_msg
486 pprAndThen :: (String -> a) -> String -> SDoc -> a
487 pprAndThen cont heading pretty_msg = cont (show (doc PprDebug))
489 doc = sep [text heading, nest 4 pretty_msg]
491 assertPprPanic :: String -> Int -> SDoc -> a
492 assertPprPanic file line msg
493 = panic (show (doc PprDebug))
495 doc = sep [hsep[text "ASSERT failed! file",
497 text "line", int line],
500 warnPprTrace :: Bool -> String -> Int -> SDoc -> a -> a
501 warnPprTrace False file line msg x = x
502 warnPprTrace True file line msg x
503 = trace (show (doc PprDebug)) x
505 doc = sep [hsep [text "WARNING: file", text file, text "line", int line],