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,
23 text, char, ftext, ptext,
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(..) )
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 ftext s sty = Pretty.ftext s
231 ptext s sty = Pretty.ptext s
232 int n sty = Pretty.int n
233 integer n sty = Pretty.integer n
234 float n sty = Pretty.float n
235 double n sty = Pretty.double n
236 rational n sty = Pretty.rational n
238 parens d sty = Pretty.parens (d sty)
239 braces d sty = Pretty.braces (d sty)
240 brackets d sty = Pretty.brackets (d sty)
241 doubleQuotes d sty = Pretty.doubleQuotes (d sty)
242 angleBrackets d = char '<' <> d <> char '>'
244 -- quotes encloses something in single quotes...
245 -- but it omits them if the thing ends in a single quote
246 -- so that we don't get `foo''. Instead we just have foo'.
247 quotes d sty = case show pp_d of
249 other -> Pretty.quotes pp_d
253 semi sty = Pretty.semi
254 comma sty = Pretty.comma
255 colon sty = Pretty.colon
256 equals sty = Pretty.equals
257 space sty = Pretty.space
258 lparen sty = Pretty.lparen
259 rparen sty = Pretty.rparen
260 lbrack sty = Pretty.lbrack
261 rbrack sty = Pretty.rbrack
262 lbrace sty = Pretty.lbrace
263 rbrace sty = Pretty.rbrace
264 dcolon sty = Pretty.ptext SLIT("::")
265 underscore = char '_'
268 nest n d sty = Pretty.nest n (d 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)
272 ($+$) d1 d2 sty = (Pretty.$+$) (d1 sty) (d2 sty)
274 hcat ds sty = Pretty.hcat [d sty | d <- ds]
275 hsep ds sty = Pretty.hsep [d sty | d <- ds]
276 vcat ds sty = Pretty.vcat [d sty | d <- ds]
277 sep ds sty = Pretty.sep [d sty | d <- ds]
278 cat ds sty = Pretty.cat [d sty | d <- ds]
279 fsep ds sty = Pretty.fsep [d sty | d <- ds]
280 fcat ds sty = Pretty.fcat [d sty | d <- ds]
282 hang d1 n d2 sty = Pretty.hang (d1 sty) n (d2 sty)
284 punctuate :: SDoc -> [SDoc] -> [SDoc]
286 punctuate p (d:ds) = go d ds
289 go d (e:es) = (d <> p) : go e es
293 %************************************************************************
295 \subsection[Outputable-class]{The @Outputable@ class}
297 %************************************************************************
300 class Outputable a where
305 instance Outputable Bool where
306 ppr True = ptext SLIT("True")
307 ppr False = ptext SLIT("False")
309 instance Outputable Int where
312 instance Outputable () where
315 instance (Outputable a) => Outputable [a] where
316 ppr xs = brackets (fsep (punctuate comma (map ppr xs)))
318 instance (Outputable a, Outputable b) => Outputable (a, b) where
319 ppr (x,y) = parens (sep [ppr x <> comma, ppr y])
321 instance Outputable a => Outputable (Maybe a) where
322 ppr Nothing = ptext SLIT("Nothing")
323 ppr (Just x) = ptext SLIT("Just") <+> ppr x
325 -- ToDo: may not be used
326 instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c) where
328 parens (sep [ppr x <> comma,
332 instance (Outputable a, Outputable b, Outputable c, Outputable d) =>
333 Outputable (a, b, c, d) where
335 parens (sep [ppr x <> comma,
340 instance Outputable FastString where
341 ppr fs = text (unpackFS fs) -- Prints an unadorned string,
342 -- no double quotes or anything
344 #if __GLASGOW_HASKELL__ < 410
345 -- Assume we have only 8-bit Chars.
347 pprHsChar :: Int -> SDoc
348 pprHsChar c = char '\'' <> text (showCharLit c "") <> char '\''
350 pprHsString :: FastString -> SDoc
351 pprHsString fs = doubleQuotes (text (foldr showCharLit "" (unpackIntFS fs)))
353 showCharLit :: Int -> String -> String
355 | c == ord '\"' = "\\\"" ++ rest
356 | c == ord '\'' = "\\\'" ++ rest
357 | c == ord '\\' = "\\\\" ++ rest
358 | c >= 0x20 && c <= 0x7E = chr c : rest
359 | c == ord '\a' = "\\a" ++ rest
360 | c == ord '\b' = "\\b" ++ rest
361 | c == ord '\f' = "\\f" ++ rest
362 | c == ord '\n' = "\\n" ++ rest
363 | c == ord '\r' = "\\r" ++ rest
364 | c == ord '\t' = "\\t" ++ rest
365 | c == ord '\v' = "\\v" ++ rest
366 | otherwise = ('\\':) $ shows (fromIntegral c :: Word32) $ case rest of
367 d:_ | isDigit d -> "\\&" ++ rest
371 -- We have 31-bit Chars and will simply use Show instances
372 -- of Char and String.
374 pprHsChar :: Int -> SDoc
375 pprHsChar c | c > 0x10ffff = char '\\' <> text (show (fromIntegral c :: Word32))
376 | otherwise = text (show (chr c))
378 pprHsString :: FastString -> SDoc
379 pprHsString fs = text (show (unpackFS fs))
383 instance Show FastString where
384 showsPrec p fs = showsPrecSDoc p (ppr fs)
388 %************************************************************************
390 \subsection{Other helper functions}
392 %************************************************************************
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 suffix ]
430 suffix | n <= 20 = "th" -- 11,12,13 are non-std
431 | last_dig == 1 = "st"
432 | last_dig == 2 = "nd"
433 | last_dig == 3 = "rd"
436 last_dig = n `rem` 10
440 speakNTimes :: Int {- >=1 -} -> SDoc
441 speakNTimes t | t == 1 = ptext SLIT("once")
442 | t == 2 = ptext SLIT("twice")
443 | otherwise = int t <+> ptext SLIT("times")
447 %************************************************************************
449 \subsection{Error handling}
451 %************************************************************************
454 pprPanic :: String -> SDoc -> a
455 pprError :: String -> SDoc -> a
456 pprTrace :: String -> SDoc -> a -> a
457 pprPanic = pprAndThen panic
458 pprError = pprAndThen error
459 pprTrace = pprAndThen trace
461 pprPanic# heading pretty_msg = panic# (show (doc PprDebug))
463 doc = text heading <+> pretty_msg
465 pprAndThen :: (String -> a) -> String -> SDoc -> a
466 pprAndThen cont heading pretty_msg = cont (show (doc PprDebug))
468 doc = sep [text heading, nest 4 pretty_msg]
470 assertPprPanic :: String -> Int -> SDoc -> a
471 assertPprPanic file line msg
472 = panic (show (doc PprDebug))
474 doc = sep [hsep[text "ASSERT failed! file",
476 text "line", int line],
479 warnPprTrace :: Bool -> String -> Int -> SDoc -> a -> a
480 warnPprTrace False file line msg x = x
481 warnPprTrace True file line msg x
482 = trace (show (doc PprDebug)) x
484 doc = sep [hsep [text "WARNING: file", text file, text "line", int line],