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, showSDocDebug, showSDocIface, showSDocUnqual, showsPrecSDoc,
38 pprHsChar, pprHsString,
42 pprPanic, pprPanic#, pprError, pprTrace, assertPprPanic, warnPprTrace,
43 trace, panic, panic#, assertPanic
46 #include "HsVersions.h"
49 import {-# SOURCE #-} Name( Name )
51 import IO ( Handle, hPutChar, hPutStr, stderr, stdout )
52 import CmdLineOpts ( opt_PprStyle_Debug, opt_PprUserLength )
54 import qualified Pretty
55 import Pretty ( Doc, Mode(..), TextDetails(..), fullRender )
57 import Char ( chr, ord, isDigit )
61 %************************************************************************
63 \subsection{The @PprStyle@ data type}
65 %************************************************************************
69 = PprUser PrintUnqualified Depth -- Pretty-print in a way that will
70 -- make sense to the ordinary user;
71 -- must be very close to Haskell
74 | PprInterface PrintUnqualified -- Interface generation
76 | PprCode CodeStyle -- Print code; either C or assembler
78 | PprDebug -- Standard debugging output
80 data CodeStyle = CStyle -- The format of labels differs for C and assembler
83 data Depth = AllTheWay
84 | PartWay Int -- 0 => stop
87 type PrintUnqualified = Name -> Bool
88 -- This function tells when it's ok to print
89 -- a (Global) name unqualified
91 alwaysQualify,neverQualify :: PrintUnqualified
92 alwaysQualify n = False
95 defaultUserStyle = mkUserStyle alwaysQualify AllTheWay
97 mkUserStyle unqual depth | opt_PprStyle_Debug = PprDebug
98 | otherwise = PprUser unqual depth
101 Orthogonal to the above printing styles are (possibly) some
102 command-line flags that affect printing (often carried with the
103 style). The most likely ones are variations on how much type info is
106 The following test decides whether or not we are actually generating
107 code (either C or assembly), or generating interface files.
109 %************************************************************************
111 \subsection{The @SDoc@ data type}
113 %************************************************************************
116 type SDoc = PprStyle -> Doc
118 withPprStyle :: PprStyle -> SDoc -> SDoc
119 withPprStyle sty d sty' = d sty
121 pprDeeper :: SDoc -> SDoc
122 pprDeeper d (PprUser unqual (PartWay 0)) = Pretty.text "..."
123 pprDeeper d (PprUser unqual (PartWay n)) = d (PprUser unqual (PartWay (n-1)))
124 pprDeeper d other_sty = d other_sty
126 getPprStyle :: (PprStyle -> SDoc) -> SDoc
127 getPprStyle df sty = df sty sty
131 unqualStyle :: PprStyle -> Name -> Bool
132 unqualStyle (PprUser unqual _) n = unqual n
133 unqualStyle (PprInterface unqual) n = unqual n
134 unqualStyle other n = False
136 codeStyle :: PprStyle -> Bool
137 codeStyle (PprCode _) = True
140 asmStyle :: PprStyle -> Bool
141 asmStyle (PprCode AsmStyle) = True
142 asmStyle other = False
144 ifaceStyle :: PprStyle -> Bool
145 ifaceStyle (PprInterface _) = True
146 ifaceStyle other = False
148 debugStyle :: PprStyle -> Bool
149 debugStyle PprDebug = True
150 debugStyle other = False
152 userStyle :: PprStyle -> Bool
153 userStyle (PprUser _ _) = True
154 userStyle other = False
156 ifPprDebug :: SDoc -> SDoc -- Empty for non-debug style
157 ifPprDebug d sty@PprDebug = d sty
158 ifPprDebug d sty = Pretty.empty
162 printSDoc :: SDoc -> PprStyle -> IO ()
163 printSDoc d sty = printDoc PageMode stdout (d sty)
165 -- I'm not sure whether the direct-IO approach of printDoc
166 -- above is better or worse than the put-big-string approach here
167 printErrs :: PrintUnqualified -> SDoc -> IO ()
168 printErrs unqual doc = printDoc PageMode stderr (doc style)
170 style = mkUserStyle unqual (PartWay opt_PprUserLength)
172 printDump :: SDoc -> IO ()
173 printDump doc = printDoc PageMode stdout (better_doc defaultUserStyle)
175 better_doc = doc $$ text ""
176 -- We used to always print in debug style, but I want
177 -- to try the effect of a more user-ish style (unless you
180 printForUser :: Handle -> PrintUnqualified -> SDoc -> IO ()
181 printForUser handle unqual doc
182 = printDoc PageMode handle (doc (mkUserStyle unqual AllTheWay))
184 -- printForIface prints all on one line for interface files.
185 -- It's called repeatedly for successive lines
186 printForIface :: Handle -> PrintUnqualified -> SDoc -> IO ()
187 printForIface handle unqual doc
188 = printDoc LeftMode handle (doc (PprInterface unqual))
190 -- printForC, printForAsm do what they sound like
191 printForC :: Handle -> SDoc -> IO ()
192 printForC handle doc = printDoc LeftMode handle (doc (PprCode CStyle))
194 printForAsm :: Handle -> SDoc -> IO ()
195 printForAsm handle doc = printDoc LeftMode handle (doc (PprCode AsmStyle))
197 pprCode :: CodeStyle -> SDoc -> SDoc
198 pprCode cs d = withPprStyle (PprCode cs) d
200 -- Can't make SDoc an instance of Show because SDoc is just a function type
201 -- However, Doc *is* an instance of Show
202 -- showSDoc just blasts it out as a string
203 showSDoc :: SDoc -> String
204 showSDoc d = show (d defaultUserStyle)
206 showSDocUnqual :: SDoc -> String
207 -- Only used in the gruesome HsExpr.isOperator
208 showSDocUnqual d = show (d (mkUserStyle neverQualify AllTheWay))
210 showsPrecSDoc :: Int -> SDoc -> ShowS
211 showsPrecSDoc p d = showsPrec p (d defaultUserStyle)
213 showSDocIface :: SDoc -> String
214 showSDocIface doc = showDocWith OneLineMode (doc (PprInterface alwaysQualify))
216 showSDocDebug :: SDoc -> String
217 showSDocDebug d = show (d PprDebug)
221 empty sty = Pretty.empty
222 text s sty = Pretty.text s
223 char c sty = Pretty.char c
224 ptext s sty = Pretty.ptext s
225 int n sty = Pretty.int n
226 integer n sty = Pretty.integer n
227 float n sty = Pretty.float n
228 double n sty = Pretty.double n
229 rational n sty = Pretty.rational n
231 parens d sty = Pretty.parens (d sty)
232 braces d sty = Pretty.braces (d sty)
233 brackets d sty = Pretty.brackets (d sty)
234 doubleQuotes d sty = Pretty.doubleQuotes (d sty)
235 angleBrackets d = char '<' <> d <> char '>'
237 -- quotes encloses something in single quotes...
238 -- but it omits them if the thing ends in a single quote
239 -- so that we don't get `foo''. Instead we just have foo'.
240 quotes d sty = case show pp_d of
242 other -> Pretty.quotes pp_d
246 semi sty = Pretty.semi
247 comma sty = Pretty.comma
248 colon sty = Pretty.colon
249 equals sty = Pretty.equals
250 space sty = Pretty.space
251 lparen sty = Pretty.lparen
252 rparen sty = Pretty.rparen
253 lbrack sty = Pretty.lbrack
254 rbrack sty = Pretty.rbrack
255 lbrace sty = Pretty.lbrace
256 rbrace sty = Pretty.rbrace
257 dcolon sty = Pretty.ptext SLIT("::")
258 underscore = char '_'
261 nest n d sty = Pretty.nest n (d sty)
262 (<>) d1 d2 sty = (Pretty.<>) (d1 sty) (d2 sty)
263 (<+>) d1 d2 sty = (Pretty.<+>) (d1 sty) (d2 sty)
264 ($$) d1 d2 sty = (Pretty.$$) (d1 sty) (d2 sty)
265 ($+$) d1 d2 sty = (Pretty.$+$) (d1 sty) (d2 sty)
267 hcat ds sty = Pretty.hcat [d sty | d <- ds]
268 hsep ds sty = Pretty.hsep [d sty | d <- ds]
269 vcat ds sty = Pretty.vcat [d sty | d <- ds]
270 sep ds sty = Pretty.sep [d sty | d <- ds]
271 cat ds sty = Pretty.cat [d sty | d <- ds]
272 fsep ds sty = Pretty.fsep [d sty | d <- ds]
273 fcat ds sty = Pretty.fcat [d sty | d <- ds]
275 hang d1 n d2 sty = Pretty.hang (d1 sty) n (d2 sty)
277 punctuate :: SDoc -> [SDoc] -> [SDoc]
279 punctuate p (d:ds) = go d ds
282 go d (e:es) = (d <> p) : go e es
286 %************************************************************************
288 \subsection[Outputable-class]{The @Outputable@ class}
290 %************************************************************************
293 class Outputable a where
298 instance Outputable Bool where
299 ppr True = ptext SLIT("True")
300 ppr False = ptext SLIT("False")
302 instance Outputable Int where
305 instance Outputable () where
308 instance (Outputable a) => Outputable [a] where
309 ppr xs = brackets (fsep (punctuate comma (map ppr xs)))
311 instance (Outputable a, Outputable b) => Outputable (a, b) where
312 ppr (x,y) = parens (sep [ppr x <> comma, ppr y])
314 instance Outputable a => Outputable (Maybe a) where
315 ppr Nothing = ptext SLIT("Nothing")
316 ppr (Just x) = ptext SLIT("Just") <+> ppr x
318 -- ToDo: may not be used
319 instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c) where
321 parens (sep [ppr x <> comma,
325 instance (Outputable a, Outputable b, Outputable c, Outputable d) =>
326 Outputable (a, b, c, d) where
328 parens (sep [ppr x <> comma,
333 instance Outputable FastString where
334 ppr fs = text (unpackFS fs) -- Prints an unadorned string,
335 -- no double quotes or anything
337 #if __GLASGOW_HASKELL__ < 410
338 -- Assume we have only 8-bit Chars.
340 pprHsChar :: Int -> SDoc
341 pprHsChar c = char '\'' <> text (showCharLit c "") <> char '\''
343 pprHsString :: FAST_STRING -> SDoc
344 pprHsString fs = doubleQuotes (text (foldr showCharLit "" (_UNPK_INT_ fs)))
346 showCharLit :: Int -> String -> String
348 | c == ord '\"' = "\\\"" ++ rest
349 | c == ord '\'' = "\\\'" ++ rest
350 | c == ord '\\' = "\\\\" ++ rest
351 | c >= 0x20 && c <= 0x7E = chr c : rest
352 | c == ord '\a' = "\\a" ++ rest
353 | c == ord '\b' = "\\b" ++ rest
354 | c == ord '\f' = "\\f" ++ rest
355 | c == ord '\n' = "\\n" ++ rest
356 | c == ord '\r' = "\\r" ++ rest
357 | c == ord '\t' = "\\t" ++ rest
358 | c == ord '\v' = "\\v" ++ rest
359 | otherwise = ('\\':) $ shows c $ case rest of
360 d:_ | isDigit d -> "\\&" ++ rest
364 -- We have 31-bit Chars and will simply use Show instances
365 -- of Char and String.
367 pprHsChar :: Int -> SDoc
368 pprHsChar c = text (show (chr c))
370 pprHsString :: FastString -> SDoc
371 pprHsString fs = text (show (unpackFS fs))
375 instance Show FastString where
376 showsPrec p fs = showsPrecSDoc p (ppr fs)
380 %************************************************************************
382 \subsection{Other helper functions}
384 %************************************************************************
387 pprCols = (100 :: Int) -- could make configurable
389 printDoc :: Mode -> Handle -> Doc -> IO ()
390 printDoc mode hdl doc
391 = fullRender mode pprCols 1.5 put done doc
393 put (Chr c) next = hPutChar hdl c >> next
394 put (Str s) next = hPutStr hdl s >> next
395 put (PStr s) next = hPutFS hdl s >> next
397 done = hPutChar hdl '\n'
399 showDocWith :: Mode -> Doc -> String
401 = fullRender mode 100 1.5 put "" doc
404 put (Str s1) s2 = s1 ++ s2
405 put (PStr s1) s2 = _UNPK_ s1 ++ s2
410 pprWithCommas :: (a -> SDoc) -> [a] -> SDoc
411 pprWithCommas pp xs = hsep (punctuate comma (map pp xs))
413 interppSP :: Outputable a => [a] -> SDoc
414 interppSP xs = hsep (map ppr xs)
416 interpp'SP :: Outputable a => [a] -> SDoc
417 interpp'SP xs = hsep (punctuate comma (map ppr xs))
419 pprQuotedList :: Outputable a => [a] -> SDoc
420 -- [x,y,z] ==> `x', `y', `z'
421 pprQuotedList xs = hsep (punctuate comma (map (quotes . ppr) xs))
425 %************************************************************************
427 \subsection{Printing numbers verbally}
429 %************************************************************************
431 @speakNth@ converts an integer to a verbal index; eg 1 maps to
435 speakNth :: Int -> SDoc
437 speakNth 1 = ptext SLIT("first")
438 speakNth 2 = ptext SLIT("second")
439 speakNth 3 = ptext SLIT("third")
440 speakNth 4 = ptext SLIT("fourth")
441 speakNth 5 = ptext SLIT("fifth")
442 speakNth 6 = ptext SLIT("sixth")
443 speakNth n = hcat [ int n, text st_nd_rd_th ]
445 st_nd_rd_th | n_rem_10 == 1 = "st"
446 | n_rem_10 == 2 = "nd"
447 | n_rem_10 == 3 = "rd"
450 n_rem_10 = n `rem` 10
454 speakNTimes :: Int {- >=1 -} -> SDoc
455 speakNTimes t | t == 1 = ptext SLIT("once")
456 | t == 2 = ptext SLIT("twice")
457 | otherwise = int t <+> ptext SLIT("times")
461 %************************************************************************
463 \subsection{Error handling}
465 %************************************************************************
468 pprPanic :: String -> SDoc -> a
469 pprError :: String -> SDoc -> a
470 pprTrace :: String -> SDoc -> a -> a
471 pprPanic = pprAndThen panic
472 pprError = pprAndThen error
473 pprTrace = pprAndThen trace
475 pprPanic# heading pretty_msg = panic# (show (doc PprDebug))
477 doc = text heading <+> pretty_msg
479 pprAndThen :: (String -> a) -> String -> SDoc -> a
480 pprAndThen cont heading pretty_msg = cont (show (doc PprDebug))
482 doc = sep [text heading, nest 4 pretty_msg]
484 assertPprPanic :: String -> Int -> SDoc -> a
485 assertPprPanic file line msg
486 = panic (show (doc PprDebug))
488 doc = sep [hsep[text "ASSERT failed! file",
490 text "line", int line],
493 warnPprTrace :: Bool -> String -> Int -> SDoc -> a -> a
494 warnPprTrace False file line msg x = x
495 warnPprTrace True file line msg x
496 = trace (show (doc PprDebug)) x
498 doc = sep [hsep [text "WARNING: file", text file, text "line", int line],