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(..), PrintUnqualified, alwaysQualify,
18 getPprStyle, withPprStyle, pprDeeper,
19 codeStyle, ifaceStyle, userStyle, debugStyle, asmStyle,
20 ifPprDebug, unqualStyle,
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, showSDocUnqual, showsPrecSDoc,
41 pprHsChar, pprHsString,
45 pprPanic, pprPanic#, pprError, pprTrace, assertPprPanic, warnPprTrace,
46 trace, panic, panic#, assertPanic
49 #include "HsVersions.h"
52 import {-# SOURCE #-} Name( Name )
54 import IO ( Handle, hPutChar, hPutStr, stderr, stdout )
55 import CmdLineOpts ( opt_PprStyle_Debug, opt_PprUserLength )
57 import qualified Pretty
58 import Pretty ( Doc, Mode(..), TextDetails(..), fullRender )
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 showSDocUnqual :: SDoc -> String
210 -- Only used in the gruesome HsExpr.isOperator
211 showSDocUnqual d = show (d (mkUserStyle neverQualify AllTheWay))
213 showsPrecSDoc :: Int -> SDoc -> ShowS
214 showsPrecSDoc p d = showsPrec p (d defaultUserStyle)
216 showSDocIface :: SDoc -> String
217 showSDocIface doc = showDocWith OneLineMode (doc (PprInterface alwaysQualify))
219 showSDocDebug :: SDoc -> String
220 showSDocDebug d = show (d PprDebug)
224 empty sty = Pretty.empty
225 text s sty = Pretty.text s
226 char c sty = Pretty.char c
227 ptext s sty = Pretty.ptext s
228 int n sty = Pretty.int n
229 integer n sty = Pretty.integer n
230 float n sty = Pretty.float n
231 double n sty = Pretty.double n
232 rational n sty = Pretty.rational n
234 parens d sty = Pretty.parens (d sty)
235 braces d sty = Pretty.braces (d sty)
236 brackets d sty = Pretty.brackets (d sty)
237 doubleQuotes d sty = Pretty.doubleQuotes (d sty)
238 angleBrackets d = char '<' <> d <> char '>'
240 -- quotes encloses something in single quotes...
241 -- but it omits them if the thing ends in a single quote
242 -- so that we don't get `foo''. Instead we just have foo'.
243 quotes d sty = case show pp_d of
245 other -> Pretty.quotes pp_d
249 semi sty = Pretty.semi
250 comma sty = Pretty.comma
251 colon sty = Pretty.colon
252 equals sty = Pretty.equals
253 space sty = Pretty.space
254 lparen sty = Pretty.lparen
255 rparen sty = Pretty.rparen
256 lbrack sty = Pretty.lbrack
257 rbrack sty = Pretty.rbrack
258 lbrace sty = Pretty.lbrace
259 rbrace sty = Pretty.rbrace
260 dcolon sty = Pretty.ptext SLIT("::")
261 underscore = char '_'
264 nest n d sty = Pretty.nest n (d sty)
265 (<>) d1 d2 sty = (Pretty.<>) (d1 sty) (d2 sty)
266 (<+>) d1 d2 sty = (Pretty.<+>) (d1 sty) (d2 sty)
267 ($$) d1 d2 sty = (Pretty.$$) (d1 sty) (d2 sty)
268 ($+$) d1 d2 sty = (Pretty.$+$) (d1 sty) (d2 sty)
270 hcat ds sty = Pretty.hcat [d sty | d <- ds]
271 hsep ds sty = Pretty.hsep [d sty | d <- ds]
272 vcat ds sty = Pretty.vcat [d sty | d <- ds]
273 sep ds sty = Pretty.sep [d sty | d <- ds]
274 cat ds sty = Pretty.cat [d sty | d <- ds]
275 fsep ds sty = Pretty.fsep [d sty | d <- ds]
276 fcat ds sty = Pretty.fcat [d sty | d <- ds]
278 hang d1 n d2 sty = Pretty.hang (d1 sty) n (d2 sty)
280 punctuate :: SDoc -> [SDoc] -> [SDoc]
282 punctuate p (d:ds) = go d ds
285 go d (e:es) = (d <> p) : go e es
289 %************************************************************************
291 \subsection[Outputable-class]{The @Outputable@ class}
293 %************************************************************************
296 class Outputable a where
301 instance Outputable Bool where
302 ppr True = ptext SLIT("True")
303 ppr False = ptext SLIT("False")
305 instance Outputable Int where
308 instance Outputable () where
311 instance (Outputable a) => Outputable [a] where
312 ppr xs = brackets (fsep (punctuate comma (map ppr xs)))
314 instance (Outputable a, Outputable b) => Outputable (a, b) where
315 ppr (x,y) = parens (sep [ppr x <> comma, ppr y])
317 instance Outputable a => Outputable (Maybe a) where
318 ppr Nothing = ptext SLIT("Nothing")
319 ppr (Just x) = ptext SLIT("Just") <+> ppr x
321 -- ToDo: may not be used
322 instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c) where
324 parens (sep [ppr x <> comma,
328 instance (Outputable a, Outputable b, Outputable c, Outputable d) =>
329 Outputable (a, b, c, d) where
331 parens (sep [ppr x <> comma,
336 instance Outputable FastString where
337 ppr fs = text (unpackFS fs) -- Prints an unadorned string,
338 -- no double quotes or anything
340 #if __GLASGOW_HASKELL__ < 410
341 -- Assume we have only 8-bit Chars.
343 pprHsChar :: Int -> SDoc
344 pprHsChar c = char '\'' <> text (showCharLit c "") <> char '\''
346 pprHsString :: FAST_STRING -> SDoc
347 pprHsString fs = doubleQuotes (text (foldr showCharLit "" (_UNPK_INT_ fs)))
349 showCharLit :: Int -> String -> String
351 | c == ord '\"' = "\\\"" ++ rest
352 | c == ord '\'' = "\\\'" ++ rest
353 | c == ord '\\' = "\\\\" ++ rest
354 | c >= 0x20 && c <= 0x7E = chr c : rest
355 | c == ord '\a' = "\\a" ++ rest
356 | c == ord '\b' = "\\b" ++ rest
357 | c == ord '\f' = "\\f" ++ rest
358 | c == ord '\n' = "\\n" ++ rest
359 | c == ord '\r' = "\\r" ++ rest
360 | c == ord '\t' = "\\t" ++ rest
361 | c == ord '\v' = "\\v" ++ rest
362 | otherwise = ('\\':) $ shows c $ case rest of
363 d:_ | isDigit d -> "\\&" ++ rest
367 -- We have 31-bit Chars and will simply use Show instances
368 -- of Char and String.
370 pprHsChar :: Int -> SDoc
371 pprHsChar c = text (show (chr c))
373 pprHsString :: FastString -> SDoc
374 pprHsString fs = text (show (unpackFS fs))
378 instance Show FastString where
379 showsPrec p fs = showsPrecSDoc p (ppr fs)
383 %************************************************************************
385 \subsection{Other helper functions}
387 %************************************************************************
390 pprCols = (100 :: Int) -- could make configurable
392 printDoc :: Mode -> Handle -> Doc -> IO ()
393 printDoc mode hdl doc
394 = fullRender mode pprCols 1.5 put done doc
396 put (Chr c) next = hPutChar hdl c >> next
397 put (Str s) next = hPutStr hdl s >> next
398 put (PStr s) next = hPutFS hdl s >> next
400 done = hPutChar hdl '\n'
402 showDocWith :: Mode -> Doc -> String
404 = fullRender mode 100 1.5 put "" doc
407 put (Str s1) s2 = s1 ++ s2
408 put (PStr s1) s2 = _UNPK_ s1 ++ s2
413 pprWithCommas :: (a -> SDoc) -> [a] -> SDoc
414 pprWithCommas pp xs = hsep (punctuate comma (map pp xs))
416 interppSP :: Outputable a => [a] -> SDoc
417 interppSP xs = hsep (map ppr xs)
419 interpp'SP :: Outputable a => [a] -> SDoc
420 interpp'SP xs = hsep (punctuate comma (map ppr xs))
422 pprQuotedList :: Outputable a => [a] -> SDoc
423 -- [x,y,z] ==> `x', `y', `z'
424 pprQuotedList xs = hsep (punctuate comma (map (quotes . ppr) xs))
428 %************************************************************************
430 \subsection{Printing numbers verbally}
432 %************************************************************************
434 @speakNth@ converts an integer to a verbal index; eg 1 maps to
438 speakNth :: Int -> SDoc
440 speakNth 1 = ptext SLIT("first")
441 speakNth 2 = ptext SLIT("second")
442 speakNth 3 = ptext SLIT("third")
443 speakNth 4 = ptext SLIT("fourth")
444 speakNth 5 = ptext SLIT("fifth")
445 speakNth 6 = ptext SLIT("sixth")
446 speakNth n = hcat [ int n, text st_nd_rd_th ]
448 st_nd_rd_th | n_rem_10 == 1 = "st"
449 | n_rem_10 == 2 = "nd"
450 | n_rem_10 == 3 = "rd"
453 n_rem_10 = n `rem` 10
457 speakNTimes :: Int {- >=1 -} -> SDoc
458 speakNTimes t | t == 1 = ptext SLIT("once")
459 | t == 2 = ptext SLIT("twice")
460 | otherwise = int t <+> ptext SLIT("times")
464 %************************************************************************
466 \subsection{Error handling}
468 %************************************************************************
471 pprPanic :: String -> SDoc -> a
472 pprError :: String -> SDoc -> a
473 pprTrace :: String -> SDoc -> a -> a
474 pprPanic = pprAndThen panic
475 pprError = pprAndThen error
476 pprTrace = pprAndThen trace
478 pprPanic# heading pretty_msg = panic# (show (doc PprDebug))
480 doc = text heading <+> pretty_msg
482 pprAndThen :: (String -> a) -> String -> SDoc -> a
483 pprAndThen cont heading pretty_msg = cont (show (doc PprDebug))
485 doc = sep [text heading, nest 4 pretty_msg]
487 assertPprPanic :: String -> Int -> SDoc -> a
488 assertPprPanic file line msg
489 = panic (show (doc PprDebug))
491 doc = sep [hsep[text "ASSERT failed! file",
493 text "line", int line],
496 warnPprTrace :: Bool -> String -> Int -> SDoc -> a -> a
497 warnPprTrace False file line msg x = x
498 warnPprTrace True file line msg x
499 = trace (show (doc PprDebug)) x
501 doc = sep [hsep [text "WARNING: file", text file, text "line", int line],