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
10 {-# OPTIONS -fno-prune-tydecls #-}
11 -- Hopefully temporary; 3.02 complained about not being able
12 -- to see the consructors for ForeignObj
15 Outputable(..), -- Class
17 PprStyle, CodeStyle(..),
18 getPprStyle, withPprStyle, pprDeeper,
19 codeStyle, ifaceStyle, userStyle, debugStyle, asmStyle,
20 ifPprDebug, ifNotPprForUser,
23 interppSP, interpp'SP, pprQuotedList, pprWithCommas,
26 int, integer, float, double, rational,
27 parens, brackets, braces, quotes, doubleQuotes, angleBrackets,
28 semi, comma, colon, dcolon, space, equals, dot,
29 lparen, rparen, lbrack, rbrack, lbrace, rbrace, underscore,
30 (<>), (<+>), hcat, hsep,
35 speakNth, speakNTimes,
37 printSDoc, printErrs, printDump,
38 printForC, printForAsm, printForIface, printForUser,
40 showSDoc, showSDocDebug, showSDocIface, showsPrecSDoc,
41 pprHsChar, pprHsString,
45 pprPanic, pprPanic#, pprError, pprTrace, assertPprPanic, warnPprTrace,
46 trace, panic, panic#, assertPanic
49 #include "HsVersions.h"
52 import IO ( Handle, hPutChar, hPutStr, stderr, stdout )
53 import CmdLineOpts ( opt_PprStyle_Debug, opt_PprUserLength )
55 import qualified Pretty
56 import Pretty ( Doc, Mode(..), TextDetails(..), fullRender )
60 import Char ( chr, ord, isDigit )
64 %************************************************************************
66 \subsection{The @PprStyle@ data type}
68 %************************************************************************
72 = PprUser Depth -- Pretty-print in a way that will
73 -- make sense to the ordinary user;
74 -- must be very close to Haskell
77 | PprDebug -- Standard debugging output
79 | PprInterface -- Interface generation
81 | PprCode CodeStyle -- Print code; either C or assembler
84 data CodeStyle = CStyle -- The format of labels differs for C and assembler
87 data Depth = AllTheWay
88 | PartWay Int -- 0 => stop
91 Orthogonal to the above printing styles are (possibly) some
92 command-line flags that affect printing (often carried with the
93 style). The most likely ones are variations on how much type info is
96 The following test decides whether or not we are actually generating
97 code (either C or assembly), or generating interface files.
99 %************************************************************************
101 \subsection{The @SDoc@ data type}
103 %************************************************************************
106 type SDoc = PprStyle -> Doc
108 withPprStyle :: PprStyle -> SDoc -> SDoc
109 withPprStyle sty d sty' = d sty
111 pprDeeper :: SDoc -> SDoc
112 pprDeeper d (PprUser (PartWay 0)) = Pretty.text "..."
113 pprDeeper d (PprUser (PartWay n)) = d (PprUser (PartWay (n-1)))
114 pprDeeper d other_sty = d other_sty
116 getPprStyle :: (PprStyle -> SDoc) -> SDoc
117 getPprStyle df sty = df sty sty
121 codeStyle :: PprStyle -> Bool
122 codeStyle (PprCode _) = True
125 asmStyle :: PprStyle -> Bool
126 asmStyle (PprCode AsmStyle) = True
127 asmStyle other = False
129 ifaceStyle :: PprStyle -> Bool
130 ifaceStyle PprInterface = True
131 ifaceStyle other = False
133 debugStyle :: PprStyle -> Bool
134 debugStyle PprDebug = True
135 debugStyle other = False
137 userStyle :: PprStyle -> Bool
138 userStyle (PprUser _) = True
139 userStyle other = False
143 ifNotPprForUser :: SDoc -> SDoc -- Returns empty document for User style
144 ifNotPprForUser d sty@(PprUser _) = Pretty.empty
145 ifNotPprForUser d sty = d sty
147 ifPprDebug :: SDoc -> SDoc -- Empty for non-debug style
148 ifPprDebug d sty@PprDebug = d sty
149 ifPprDebug d sty = Pretty.empty
153 printSDoc :: SDoc -> PprStyle -> IO ()
154 printSDoc d sty = printDoc PageMode stdout (d sty)
156 -- I'm not sure whether the direct-IO approach of printDoc
157 -- above is better or worse than the put-big-string approach here
158 printErrs :: SDoc -> IO ()
159 printErrs doc = printDoc PageMode stderr (final_doc user_style)
161 final_doc = doc -- $$ text ""
162 user_style = mkUserStyle (PartWay opt_PprUserLength)
164 printDump :: SDoc -> IO ()
165 printDump doc = printForUser stdout (doc $$ text "")
166 -- We used to always print in debug style, but I want
167 -- to try the effect of a more user-ish style (unless you
170 printForUser :: Handle -> SDoc -> IO ()
171 printForUser handle doc = printDoc PageMode handle (doc (mkUserStyle AllTheWay))
173 -- printForC, printForAsm do what they sound like
174 printForC :: Handle -> SDoc -> IO ()
175 printForC handle doc = printDoc LeftMode handle (doc (PprCode CStyle))
177 printForAsm :: Handle -> SDoc -> IO ()
178 printForAsm handle doc = printDoc LeftMode handle (doc (PprCode AsmStyle))
180 -- printForIface prints all on one line for interface files.
181 -- It's called repeatedly for successive lines
182 printForIface :: Handle -> SDoc -> IO ()
183 printForIface handle doc = printDoc LeftMode handle (doc PprInterface)
185 pprCode :: CodeStyle -> SDoc -> SDoc
186 pprCode cs d = withPprStyle (PprCode cs) d
188 -- Can't make SDoc an instance of Show because SDoc is just a function type
189 -- However, Doc *is* an instance of Show
190 -- showSDoc just blasts it out as a string
191 showSDoc :: SDoc -> String
192 showSDoc d = show (d (mkUserStyle AllTheWay))
194 showSDocIface :: SDoc -> String
195 showSDocIface doc = showDocWith OneLineMode (doc PprInterface)
197 showSDocDebug :: SDoc -> String
198 showSDocDebug d = show (d PprDebug)
200 showsPrecSDoc :: Int -> SDoc -> ShowS
201 showsPrecSDoc p d = showsPrec p (d (mkUserStyle AllTheWay))
203 mkUserStyle depth | opt_PprStyle_Debug = PprDebug
204 | otherwise = PprUser depth
208 empty sty = Pretty.empty
209 text s sty = Pretty.text s
210 char c sty = Pretty.char c
211 ptext s sty = Pretty.ptext s
212 int n sty = Pretty.int n
213 integer n sty = Pretty.integer n
214 float n sty = Pretty.float n
215 double n sty = Pretty.double n
216 rational n sty = Pretty.rational n
218 parens d sty = Pretty.parens (d sty)
219 braces d sty = Pretty.braces (d sty)
220 brackets d sty = Pretty.brackets (d sty)
221 doubleQuotes d sty = Pretty.doubleQuotes (d sty)
222 angleBrackets d = char '<' <> d <> char '>'
224 -- quotes encloses something in single quotes...
225 -- but it omits them if the thing ends in a single quote
226 -- so that we don't get `foo''. Instead we just have foo'.
227 quotes d sty = case show pp_d of
229 other -> Pretty.quotes pp_d
233 semi sty = Pretty.semi
234 comma sty = Pretty.comma
235 colon sty = Pretty.colon
236 equals sty = Pretty.equals
237 space sty = Pretty.space
238 lparen sty = Pretty.lparen
239 rparen sty = Pretty.rparen
240 lbrack sty = Pretty.lbrack
241 rbrack sty = Pretty.rbrack
242 lbrace sty = Pretty.lbrace
243 rbrace sty = Pretty.rbrace
244 dcolon sty = Pretty.ptext SLIT("::")
245 underscore = char '_'
248 nest n d sty = Pretty.nest n (d sty)
249 (<>) d1 d2 sty = (Pretty.<>) (d1 sty) (d2 sty)
250 (<+>) d1 d2 sty = (Pretty.<+>) (d1 sty) (d2 sty)
251 ($$) d1 d2 sty = (Pretty.$$) (d1 sty) (d2 sty)
252 ($+$) d1 d2 sty = (Pretty.$+$) (d1 sty) (d2 sty)
254 hcat ds sty = Pretty.hcat [d sty | d <- ds]
255 hsep ds sty = Pretty.hsep [d sty | d <- ds]
256 vcat ds sty = Pretty.vcat [d sty | d <- ds]
257 sep ds sty = Pretty.sep [d sty | d <- ds]
258 cat ds sty = Pretty.cat [d sty | d <- ds]
259 fsep ds sty = Pretty.fsep [d sty | d <- ds]
260 fcat ds sty = Pretty.fcat [d sty | d <- ds]
262 hang d1 n d2 sty = Pretty.hang (d1 sty) n (d2 sty)
264 punctuate :: SDoc -> [SDoc] -> [SDoc]
266 punctuate p (d:ds) = go d ds
269 go d (e:es) = (d <> p) : go e es
273 %************************************************************************
275 \subsection[Outputable-class]{The @Outputable@ class}
277 %************************************************************************
280 class Outputable a where
285 instance Outputable Bool where
286 ppr True = ptext SLIT("True")
287 ppr False = ptext SLIT("False")
289 instance Outputable Int where
292 instance (Outputable a) => Outputable [a] where
293 ppr xs = brackets (fsep (punctuate comma (map ppr xs)))
295 instance (Outputable a, Outputable b) => Outputable (a, b) where
296 ppr (x,y) = parens (sep [ppr x <> comma, ppr y])
298 instance Outputable a => Outputable (Maybe a) where
299 ppr Nothing = text "Nothing"
300 ppr (Just x) = text "Just" <+> ppr x
302 -- ToDo: may not be used
303 instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c) where
305 parens (sep [ppr x <> comma,
309 instance (Outputable a, Outputable b, Outputable c, Outputable d) =>
310 Outputable (a, b, c, d) where
312 parens (sep [ppr x <> comma,
317 instance Outputable FastString where
318 ppr fs = text (unpackFS fs) -- Prints an unadorned string,
319 -- no double quotes or anything
321 #if __GLASGOW_HASKELL__ < 410
322 -- Assume we have only 8-bit Chars.
324 pprHsChar :: Int -> SDoc
325 pprHsChar c = char '\'' <> text (showCharLit c "") <> char '\''
327 pprHsString :: FAST_STRING -> SDoc
328 pprHsString fs = doubleQuotes (text (foldr showCharLit "" (_UNPK_INT_ fs)))
330 showCharLit :: Int -> String -> String
332 | c == ord '\"' = "\\\"" ++ rest
333 | c == ord '\'' = "\\\'" ++ rest
334 | c == ord '\\' = "\\\\" ++ rest
335 | c >= 0x20 && c <= 0x7E = chr c : rest
336 | c == ord '\a' = "\\a" ++ rest
337 | c == ord '\b' = "\\b" ++ rest
338 | c == ord '\f' = "\\f" ++ rest
339 | c == ord '\n' = "\\n" ++ rest
340 | c == ord '\r' = "\\r" ++ rest
341 | c == ord '\t' = "\\t" ++ rest
342 | c == ord '\v' = "\\v" ++ rest
343 | otherwise = ('\\':) $ shows c $ case rest of
344 d:_ | isDigit d -> "\\&" ++ rest
348 -- We have 31-bit Chars and will simply use Show instances
349 -- of Char and String.
351 pprHsChar :: Int -> SDoc
352 pprHsChar c = text (show (chr c))
354 pprHsString :: FastString -> SDoc
355 pprHsString fs = text (show (unpackFS fs))
359 instance Show FastString where
360 showsPrec p fs = showsPrecSDoc p (ppr fs)
364 %************************************************************************
366 \subsection{Other helper functions}
368 %************************************************************************
371 pprCols = (100 :: Int) -- could make configurable
373 printDoc :: Mode -> Handle -> Doc -> IO ()
374 printDoc mode hdl doc
375 = fullRender mode pprCols 1.5 put done doc
377 put (Chr c) next = hPutChar hdl c >> next
378 put (Str s) next = hPutStr hdl s >> next
379 put (PStr s) next = hPutFS hdl s >> next
381 done = hPutChar hdl '\n'
383 showDocWith :: Mode -> Doc -> String
385 = fullRender mode 100 1.5 put "" doc
388 put (Str s1) s2 = s1 ++ s2
389 put (PStr s1) s2 = _UNPK_ s1 ++ s2
394 pprWithCommas :: (a -> SDoc) -> [a] -> SDoc
395 pprWithCommas pp xs = hsep (punctuate comma (map pp xs))
397 interppSP :: Outputable a => [a] -> SDoc
398 interppSP xs = hsep (map ppr xs)
400 interpp'SP :: Outputable a => [a] -> SDoc
401 interpp'SP xs = hsep (punctuate comma (map ppr xs))
403 pprQuotedList :: Outputable a => [a] -> SDoc
404 -- [x,y,z] ==> `x', `y', `z'
405 pprQuotedList xs = hsep (punctuate comma (map (quotes . ppr) xs))
409 %************************************************************************
411 \subsection{Printing numbers verbally}
413 %************************************************************************
415 @speakNth@ converts an integer to a verbal index; eg 1 maps to
419 speakNth :: Int -> SDoc
421 speakNth 1 = ptext SLIT("first")
422 speakNth 2 = ptext SLIT("second")
423 speakNth 3 = ptext SLIT("third")
424 speakNth 4 = ptext SLIT("fourth")
425 speakNth 5 = ptext SLIT("fifth")
426 speakNth 6 = ptext SLIT("sixth")
427 speakNth n = hcat [ int n, text st_nd_rd_th ]
429 st_nd_rd_th | n_rem_10 == 1 = "st"
430 | n_rem_10 == 2 = "nd"
431 | n_rem_10 == 3 = "rd"
434 n_rem_10 = n `rem` 10
438 speakNTimes :: Int {- >=1 -} -> SDoc
439 speakNTimes t | t == 1 = ptext SLIT("once")
440 | t == 2 = ptext SLIT("twice")
441 | otherwise = int t <+> ptext SLIT("times")
445 %************************************************************************
447 \subsection{Error handling}
449 %************************************************************************
452 pprPanic :: String -> SDoc -> a
453 pprError :: String -> SDoc -> a
454 pprTrace :: String -> SDoc -> a -> a
455 pprPanic = pprAndThen panic
456 pprError = pprAndThen error
457 pprTrace = pprAndThen trace
459 pprPanic# heading pretty_msg = panic# (show (doc PprDebug))
461 doc = text heading <+> pretty_msg
463 pprAndThen :: (String -> a) -> String -> SDoc -> a
464 pprAndThen cont heading pretty_msg = cont (show (doc PprDebug))
466 doc = sep [text heading, nest 4 pretty_msg]
468 assertPprPanic :: String -> Int -> SDoc -> a
469 assertPprPanic file line msg
470 = panic (show (doc PprDebug))
472 doc = sep [hsep[text "ASSERT failed! file",
474 text "line", int line],
477 warnPprTrace :: Bool -> String -> Int -> SDoc -> a -> a
478 warnPprTrace False file line msg x = x
479 warnPprTrace True file line msg x
480 = trace (show (doc PprDebug)) x
482 doc = sep [hsep [text "WARNING: file", text file, text "line", int line],