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, withPprStyleDoc, pprDeeper,
16 codeStyle, userStyle, debugStyle, asmStyle,
17 ifPprDebug, unqualStyle,
21 interppSP, interpp'SP, pprQuotedList, pprWithCommas,
24 int, integer, float, double, rational,
25 parens, brackets, braces, quotes, doubleQuotes, angleBrackets,
26 semi, comma, colon, dcolon, space, equals, dot,
27 lparen, rparen, lbrack, rbrack, lbrace, rbrace, underscore,
28 (<>), (<+>), hcat, hsep,
33 speakNth, speakNTimes,
35 printSDoc, printErrs, printDump,
36 printForC, printForAsm, printForUser,
38 showSDoc, showSDocForUser, showSDocDebug,
39 showSDocUnqual, showsPrecSDoc,
40 pprHsChar, pprHsString,
44 pprPanic, pprPanic#, pprError, pprTrace, assertPprPanic, warnPprTrace,
45 trace, panic, panic#, assertPanic
48 #include "HsVersions.h"
51 import {-# SOURCE #-} Name( Name )
53 import CmdLineOpts ( opt_PprStyle_Debug, opt_PprUserLength )
55 import qualified Pretty
56 import Pretty ( Doc, Mode(..), TextDetails(..), fullRender )
59 import Word ( Word32 )
60 import IO ( Handle, stderr, stdout )
62 #if __GLASGOW_HASKELL__ < 410
63 import Char ( ord, isDigit )
68 %************************************************************************
70 \subsection{The @PprStyle@ data type}
72 %************************************************************************
76 = PprUser PrintUnqualified Depth -- Pretty-print in a way that will
77 -- make sense to the ordinary user;
78 -- must be very close to Haskell
81 | PprInterface PrintUnqualified -- Interface generation
83 | PprCode CodeStyle -- Print code; either C or assembler
85 | PprDebug -- Standard debugging output
87 data CodeStyle = CStyle -- The format of labels differs for C and assembler
90 data Depth = AllTheWay
91 | PartWay Int -- 0 => stop
94 type PrintUnqualified = Name -> Bool
95 -- This function tells when it's ok to print
96 -- a (Global) name unqualified
98 alwaysQualify,neverQualify :: PrintUnqualified
99 alwaysQualify n = False
100 neverQualify n = True
102 defaultUserStyle = mkUserStyle alwaysQualify AllTheWay
104 mkUserStyle unqual depth | opt_PprStyle_Debug = PprDebug
105 | otherwise = PprUser unqual depth
108 Orthogonal to the above printing styles are (possibly) some
109 command-line flags that affect printing (often carried with the
110 style). The most likely ones are variations on how much type info is
113 The following test decides whether or not we are actually generating
114 code (either C or assembly), or generating interface files.
116 %************************************************************************
118 \subsection{The @SDoc@ data type}
120 %************************************************************************
123 type SDoc = PprStyle -> Doc
125 withPprStyle :: PprStyle -> SDoc -> SDoc
126 withPprStyle sty d sty' = d sty
128 withPprStyleDoc :: PprStyle -> SDoc -> Doc
129 withPprStyleDoc sty d = d sty
131 pprDeeper :: SDoc -> SDoc
132 pprDeeper d (PprUser unqual (PartWay 0)) = Pretty.text "..."
133 pprDeeper d (PprUser unqual (PartWay n)) = d (PprUser unqual (PartWay (n-1)))
134 pprDeeper d other_sty = d other_sty
136 getPprStyle :: (PprStyle -> SDoc) -> SDoc
137 getPprStyle df sty = df sty sty
141 unqualStyle :: PprStyle -> Name -> Bool
142 unqualStyle (PprUser unqual _) n = unqual n
143 unqualStyle (PprInterface unqual) n = unqual n
144 unqualStyle other n = False
146 codeStyle :: PprStyle -> Bool
147 codeStyle (PprCode _) = True
150 asmStyle :: PprStyle -> Bool
151 asmStyle (PprCode AsmStyle) = True
152 asmStyle other = False
154 debugStyle :: PprStyle -> Bool
155 debugStyle PprDebug = True
156 debugStyle other = False
158 userStyle :: PprStyle -> Bool
159 userStyle (PprUser _ _) = True
160 userStyle other = False
162 ifPprDebug :: SDoc -> SDoc -- Empty for non-debug style
163 ifPprDebug d sty@PprDebug = d sty
164 ifPprDebug d sty = Pretty.empty
168 printSDoc :: SDoc -> PprStyle -> IO ()
169 printSDoc d sty = Pretty.printDoc PageMode stdout (d sty)
171 -- I'm not sure whether the direct-IO approach of Pretty.printDoc
172 -- above is better or worse than the put-big-string approach here
173 printErrs :: PrintUnqualified -> SDoc -> IO ()
174 printErrs unqual doc = Pretty.printDoc PageMode stderr (doc style)
176 style = mkUserStyle unqual (PartWay opt_PprUserLength)
178 printDump :: SDoc -> IO ()
179 printDump doc = Pretty.printDoc PageMode stdout (better_doc defaultUserStyle)
181 better_doc = doc $$ text ""
182 -- We used to always print in debug style, but I want
183 -- to try the effect of a more user-ish style (unless you
186 printForUser :: Handle -> PrintUnqualified -> SDoc -> IO ()
187 printForUser handle unqual doc
188 = Pretty.printDoc PageMode handle (doc (mkUserStyle unqual AllTheWay))
190 -- printForC, printForAsm do what they sound like
191 printForC :: Handle -> SDoc -> IO ()
192 printForC handle doc = Pretty.printDoc LeftMode handle (doc (PprCode CStyle))
194 printForAsm :: Handle -> SDoc -> IO ()
195 printForAsm handle doc = Pretty.printDoc LeftMode handle (doc (PprCode AsmStyle))
197 pprCode :: CodeStyle -> SDoc -> SDoc
198 pprCode cs d = withPprStyle (PprCode cs) d
200 mkCodeStyle :: CodeStyle -> PprStyle
201 mkCodeStyle = PprCode
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 showSDocDebug :: SDoc -> String
220 showSDocDebug d = show (d PprDebug)
224 docToSDoc :: Doc -> SDoc
225 docToSDoc d = \_ -> d
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 showDocWith :: Mode -> Doc -> String
396 = fullRender mode 100 1.5 put "" doc
399 put (Str s1) s2 = s1 ++ s2
400 put (PStr s1) s2 = _UNPK_ s1 ++ s2
405 pprWithCommas :: (a -> SDoc) -> [a] -> SDoc
406 pprWithCommas pp xs = hsep (punctuate comma (map pp xs))
408 interppSP :: Outputable a => [a] -> SDoc
409 interppSP xs = hsep (map ppr xs)
411 interpp'SP :: Outputable a => [a] -> SDoc
412 interpp'SP xs = hsep (punctuate comma (map ppr xs))
414 pprQuotedList :: Outputable a => [a] -> SDoc
415 -- [x,y,z] ==> `x', `y', `z'
416 pprQuotedList xs = hsep (punctuate comma (map (quotes . ppr) xs))
420 %************************************************************************
422 \subsection{Printing numbers verbally}
424 %************************************************************************
426 @speakNth@ converts an integer to a verbal index; eg 1 maps to
430 speakNth :: Int -> SDoc
432 speakNth 1 = ptext SLIT("first")
433 speakNth 2 = ptext SLIT("second")
434 speakNth 3 = ptext SLIT("third")
435 speakNth 4 = ptext SLIT("fourth")
436 speakNth 5 = ptext SLIT("fifth")
437 speakNth 6 = ptext SLIT("sixth")
438 speakNth n = hcat [ int n, text st_nd_rd_th ]
440 st_nd_rd_th | n_rem_10 == 1 = "st"
441 | n_rem_10 == 2 = "nd"
442 | n_rem_10 == 3 = "rd"
445 n_rem_10 = n `rem` 10
449 speakNTimes :: Int {- >=1 -} -> SDoc
450 speakNTimes t | t == 1 = ptext SLIT("once")
451 | t == 2 = ptext SLIT("twice")
452 | otherwise = int t <+> ptext SLIT("times")
456 %************************************************************************
458 \subsection{Error handling}
460 %************************************************************************
463 pprPanic :: String -> SDoc -> a
464 pprError :: String -> SDoc -> a
465 pprTrace :: String -> SDoc -> a -> a
466 pprPanic = pprAndThen panic
467 pprError = pprAndThen error
468 pprTrace = pprAndThen trace
470 pprPanic# heading pretty_msg = panic# (show (doc PprDebug))
472 doc = text heading <+> pretty_msg
474 pprAndThen :: (String -> a) -> String -> SDoc -> a
475 pprAndThen cont heading pretty_msg = cont (show (doc PprDebug))
477 doc = sep [text heading, nest 4 pretty_msg]
479 assertPprPanic :: String -> Int -> SDoc -> a
480 assertPprPanic file line msg
481 = panic (show (doc PprDebug))
483 doc = sep [hsep[text "ASSERT failed! file",
485 text "line", int line],
488 warnPprTrace :: Bool -> String -> Int -> SDoc -> a -> a
489 warnPprTrace False file line msg x = x
490 warnPprTrace True file line msg x
491 = trace (show (doc PprDebug)) x
493 doc = sep [hsep [text "WARNING: file", text file, text "line", int line],