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 )
58 import Char ( chr, ord, isDigit )
62 %************************************************************************
64 \subsection{The @PprStyle@ data type}
66 %************************************************************************
70 = PprUser Depth -- Pretty-print in a way that will
71 -- make sense to the ordinary user;
72 -- must be very close to Haskell
75 | PprDebug -- Standard debugging output
77 | PprInterface -- Interface generation
79 | PprCode CodeStyle -- Print code; either C or assembler
82 data CodeStyle = CStyle -- The format of labels differs for C and assembler
85 data Depth = AllTheWay
86 | PartWay Int -- 0 => stop
89 Orthogonal to the above printing styles are (possibly) some
90 command-line flags that affect printing (often carried with the
91 style). The most likely ones are variations on how much type info is
94 The following test decides whether or not we are actually generating
95 code (either C or assembly), or generating interface files.
97 %************************************************************************
99 \subsection{The @SDoc@ data type}
101 %************************************************************************
104 type SDoc = PprStyle -> Doc
106 withPprStyle :: PprStyle -> SDoc -> SDoc
107 withPprStyle sty d sty' = d sty
109 pprDeeper :: SDoc -> SDoc
110 pprDeeper d (PprUser (PartWay 0)) = Pretty.text "..."
111 pprDeeper d (PprUser (PartWay n)) = d (PprUser (PartWay (n-1)))
112 pprDeeper d other_sty = d other_sty
114 getPprStyle :: (PprStyle -> SDoc) -> SDoc
115 getPprStyle df sty = df sty sty
119 codeStyle :: PprStyle -> Bool
120 codeStyle (PprCode _) = True
123 asmStyle :: PprStyle -> Bool
124 asmStyle (PprCode AsmStyle) = True
125 asmStyle other = False
127 ifaceStyle :: PprStyle -> Bool
128 ifaceStyle PprInterface = True
129 ifaceStyle other = False
131 debugStyle :: PprStyle -> Bool
132 debugStyle PprDebug = True
133 debugStyle other = False
135 userStyle :: PprStyle -> Bool
136 userStyle (PprUser _) = True
137 userStyle other = False
141 ifNotPprForUser :: SDoc -> SDoc -- Returns empty document for User style
142 ifNotPprForUser d sty@(PprUser _) = Pretty.empty
143 ifNotPprForUser d sty = d sty
145 ifPprDebug :: SDoc -> SDoc -- Empty for non-debug style
146 ifPprDebug d sty@PprDebug = d sty
147 ifPprDebug d sty = Pretty.empty
151 printSDoc :: SDoc -> PprStyle -> IO ()
152 printSDoc d sty = printDoc PageMode stdout (d sty)
154 -- I'm not sure whether the direct-IO approach of printDoc
155 -- above is better or worse than the put-big-string approach here
156 printErrs :: SDoc -> IO ()
157 printErrs doc = printDoc PageMode stderr (final_doc user_style)
159 final_doc = doc -- $$ text ""
160 user_style = mkUserStyle (PartWay opt_PprUserLength)
162 printDump :: SDoc -> IO ()
163 printDump doc = printForUser stdout (doc $$ text "")
164 -- We used to always print in debug style, but I want
165 -- to try the effect of a more user-ish style (unless you
168 printForUser :: Handle -> SDoc -> IO ()
169 printForUser handle doc = printDoc PageMode handle (doc (mkUserStyle AllTheWay))
171 -- printForC, printForAsm do what they sound like
172 printForC :: Handle -> SDoc -> IO ()
173 printForC handle doc = printDoc LeftMode handle (doc (PprCode CStyle))
175 printForAsm :: Handle -> SDoc -> IO ()
176 printForAsm handle doc = printDoc LeftMode handle (doc (PprCode AsmStyle))
178 -- printForIface prints all on one line for interface files.
179 -- It's called repeatedly for successive lines
180 printForIface :: Handle -> SDoc -> IO ()
181 printForIface handle doc = printDoc LeftMode handle (doc PprInterface)
183 pprCode :: CodeStyle -> SDoc -> SDoc
184 pprCode cs d = withPprStyle (PprCode cs) d
186 -- Can't make SDoc an instance of Show because SDoc is just a function type
187 -- However, Doc *is* an instance of Show
188 -- showSDoc just blasts it out as a string
189 showSDoc :: SDoc -> String
190 showSDoc d = show (d (mkUserStyle AllTheWay))
192 showSDocIface :: SDoc -> String
193 showSDocIface doc = showDocWith OneLineMode (doc PprInterface)
195 showSDocDebug :: SDoc -> String
196 showSDocDebug d = show (d PprDebug)
198 showsPrecSDoc :: Int -> SDoc -> ShowS
199 showsPrecSDoc p d = showsPrec p (d (mkUserStyle AllTheWay))
201 mkUserStyle depth | opt_PprStyle_Debug = PprDebug
202 | otherwise = PprUser depth
206 empty sty = Pretty.empty
207 text s sty = Pretty.text s
208 char c sty = Pretty.char c
209 ptext s sty = Pretty.ptext s
210 int n sty = Pretty.int n
211 integer n sty = Pretty.integer n
212 float n sty = Pretty.float n
213 double n sty = Pretty.double n
214 rational n sty = Pretty.rational n
216 parens d sty = Pretty.parens (d sty)
217 braces d sty = Pretty.braces (d sty)
218 brackets d sty = Pretty.brackets (d sty)
219 doubleQuotes d sty = Pretty.doubleQuotes (d sty)
220 angleBrackets d = char '<' <> d <> char '>'
222 -- quotes encloses something in single quotes...
223 -- but it omits them if the thing ends in a single quote
224 -- so that we don't get `foo''. Instead we just have foo'.
225 quotes d sty = case show pp_d of
227 other -> Pretty.quotes pp_d
231 semi sty = Pretty.semi
232 comma sty = Pretty.comma
233 colon sty = Pretty.colon
234 equals sty = Pretty.equals
235 space sty = Pretty.space
236 lparen sty = Pretty.lparen
237 rparen sty = Pretty.rparen
238 lbrack sty = Pretty.lbrack
239 rbrack sty = Pretty.rbrack
240 lbrace sty = Pretty.lbrace
241 rbrace sty = Pretty.rbrace
242 dcolon sty = Pretty.ptext SLIT("::")
243 underscore = char '_'
246 nest n d sty = Pretty.nest n (d sty)
247 (<>) d1 d2 sty = (Pretty.<>) (d1 sty) (d2 sty)
248 (<+>) d1 d2 sty = (Pretty.<+>) (d1 sty) (d2 sty)
249 ($$) d1 d2 sty = (Pretty.$$) (d1 sty) (d2 sty)
250 ($+$) d1 d2 sty = (Pretty.$+$) (d1 sty) (d2 sty)
252 hcat ds sty = Pretty.hcat [d sty | d <- ds]
253 hsep ds sty = Pretty.hsep [d sty | d <- ds]
254 vcat ds sty = Pretty.vcat [d sty | d <- ds]
255 sep ds sty = Pretty.sep [d sty | d <- ds]
256 cat ds sty = Pretty.cat [d sty | d <- ds]
257 fsep ds sty = Pretty.fsep [d sty | d <- ds]
258 fcat ds sty = Pretty.fcat [d sty | d <- ds]
260 hang d1 n d2 sty = Pretty.hang (d1 sty) n (d2 sty)
262 punctuate :: SDoc -> [SDoc] -> [SDoc]
264 punctuate p (d:ds) = go d ds
267 go d (e:es) = (d <> p) : go e es
271 %************************************************************************
273 \subsection[Outputable-class]{The @Outputable@ class}
275 %************************************************************************
278 class Outputable a where
283 instance Outputable Bool where
284 ppr True = ptext SLIT("True")
285 ppr False = ptext SLIT("False")
287 instance Outputable Int where
290 instance Outputable () where
293 instance (Outputable a) => Outputable [a] where
294 ppr xs = brackets (fsep (punctuate comma (map ppr xs)))
296 instance (Outputable a, Outputable b) => Outputable (a, b) where
297 ppr (x,y) = parens (sep [ppr x <> comma, ppr y])
299 instance Outputable a => Outputable (Maybe a) where
300 ppr Nothing = ptext SLIT("Nothing")
301 ppr (Just x) = ptext SLIT("Just") <+> ppr x
303 -- ToDo: may not be used
304 instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c) where
306 parens (sep [ppr x <> comma,
310 instance (Outputable a, Outputable b, Outputable c, Outputable d) =>
311 Outputable (a, b, c, d) where
313 parens (sep [ppr x <> comma,
318 instance Outputable FastString where
319 ppr fs = text (unpackFS fs) -- Prints an unadorned string,
320 -- no double quotes or anything
322 #if __GLASGOW_HASKELL__ < 410
323 -- Assume we have only 8-bit Chars.
325 pprHsChar :: Int -> SDoc
326 pprHsChar c = char '\'' <> text (showCharLit c "") <> char '\''
328 pprHsString :: FAST_STRING -> SDoc
329 pprHsString fs = doubleQuotes (text (foldr showCharLit "" (_UNPK_INT_ fs)))
331 showCharLit :: Int -> String -> String
333 | c == ord '\"' = "\\\"" ++ rest
334 | c == ord '\'' = "\\\'" ++ rest
335 | c == ord '\\' = "\\\\" ++ rest
336 | c >= 0x20 && c <= 0x7E = chr c : rest
337 | c == ord '\a' = "\\a" ++ rest
338 | c == ord '\b' = "\\b" ++ rest
339 | c == ord '\f' = "\\f" ++ rest
340 | c == ord '\n' = "\\n" ++ rest
341 | c == ord '\r' = "\\r" ++ rest
342 | c == ord '\t' = "\\t" ++ rest
343 | c == ord '\v' = "\\v" ++ rest
344 | otherwise = ('\\':) $ shows c $ case rest of
345 d:_ | isDigit d -> "\\&" ++ rest
349 -- We have 31-bit Chars and will simply use Show instances
350 -- of Char and String.
352 pprHsChar :: Int -> SDoc
353 pprHsChar c = text (show (chr c))
355 pprHsString :: FastString -> SDoc
356 pprHsString fs = text (show (unpackFS fs))
360 instance Show FastString where
361 showsPrec p fs = showsPrecSDoc p (ppr fs)
365 %************************************************************************
367 \subsection{Other helper functions}
369 %************************************************************************
372 pprCols = (100 :: Int) -- could make configurable
374 printDoc :: Mode -> Handle -> Doc -> IO ()
375 printDoc mode hdl doc
376 = fullRender mode pprCols 1.5 put done doc
378 put (Chr c) next = hPutChar hdl c >> next
379 put (Str s) next = hPutStr hdl s >> next
380 put (PStr s) next = hPutFS hdl s >> next
382 done = hPutChar hdl '\n'
384 showDocWith :: Mode -> Doc -> String
386 = fullRender mode 100 1.5 put "" doc
389 put (Str s1) s2 = s1 ++ s2
390 put (PStr s1) s2 = _UNPK_ s1 ++ s2
395 pprWithCommas :: (a -> SDoc) -> [a] -> SDoc
396 pprWithCommas pp xs = hsep (punctuate comma (map pp xs))
398 interppSP :: Outputable a => [a] -> SDoc
399 interppSP xs = hsep (map ppr xs)
401 interpp'SP :: Outputable a => [a] -> SDoc
402 interpp'SP xs = hsep (punctuate comma (map ppr xs))
404 pprQuotedList :: Outputable a => [a] -> SDoc
405 -- [x,y,z] ==> `x', `y', `z'
406 pprQuotedList xs = hsep (punctuate comma (map (quotes . ppr) xs))
410 %************************************************************************
412 \subsection{Printing numbers verbally}
414 %************************************************************************
416 @speakNth@ converts an integer to a verbal index; eg 1 maps to
420 speakNth :: Int -> SDoc
422 speakNth 1 = ptext SLIT("first")
423 speakNth 2 = ptext SLIT("second")
424 speakNth 3 = ptext SLIT("third")
425 speakNth 4 = ptext SLIT("fourth")
426 speakNth 5 = ptext SLIT("fifth")
427 speakNth 6 = ptext SLIT("sixth")
428 speakNth n = hcat [ int n, text st_nd_rd_th ]
430 st_nd_rd_th | n_rem_10 == 1 = "st"
431 | n_rem_10 == 2 = "nd"
432 | n_rem_10 == 3 = "rd"
435 n_rem_10 = n `rem` 10
439 speakNTimes :: Int {- >=1 -} -> SDoc
440 speakNTimes t | t == 1 = ptext SLIT("once")
441 | t == 2 = ptext SLIT("twice")
442 | otherwise = int t <+> ptext SLIT("times")
446 %************************************************************************
448 \subsection{Error handling}
450 %************************************************************************
453 pprPanic :: String -> SDoc -> a
454 pprError :: String -> SDoc -> a
455 pprTrace :: String -> SDoc -> a -> a
456 pprPanic = pprAndThen panic
457 pprError = pprAndThen error
458 pprTrace = pprAndThen trace
460 pprPanic# heading pretty_msg = panic# (show (doc PprDebug))
462 doc = text heading <+> pretty_msg
464 pprAndThen :: (String -> a) -> String -> SDoc -> a
465 pprAndThen cont heading pretty_msg = cont (show (doc PprDebug))
467 doc = sep [text heading, nest 4 pretty_msg]
469 assertPprPanic :: String -> Int -> SDoc -> a
470 assertPprPanic file line msg
471 = panic (show (doc PprDebug))
473 doc = sep [hsep[text "ASSERT failed! file",
475 text "line", int line],
478 warnPprTrace :: Bool -> String -> Int -> SDoc -> a -> a
479 warnPprTrace False file line msg x = x
480 warnPprTrace True file line msg x
481 = trace (show (doc PprDebug)) x
483 doc = sep [hsep [text "WARNING: file", text file, text "line", int line],