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(..), OutputableBndr(..), -- Class
16 PprStyle, CodeStyle(..), PrintUnqualified, alwaysQualify,
17 getPprStyle, withPprStyle, withPprStyleDoc, pprDeeper,
18 codeStyle, userStyle, debugStyle, asmStyle,
19 ifPprDebug, unqualStyle,
20 mkErrStyle, defaultErrStyle,
24 interppSP, interpp'SP, pprQuotedList, pprWithCommas,
26 text, char, ftext, ptext,
27 int, integer, float, double, rational,
28 parens, brackets, braces, quotes, doubleQuotes, angleBrackets,
29 semi, comma, colon, dcolon, space, equals, dot, arrow,
30 lparen, rparen, lbrack, rbrack, lbrace, rbrace, underscore,
31 (<>), (<+>), hcat, hsep,
36 speakNth, speakNTimes,
38 printSDoc, printErrs, printDump,
39 printForC, printForAsm, printForUser,
41 showSDoc, showSDocForUser, showSDocDebug,
42 showSDocUnqual, showsPrecSDoc,
43 pprHsChar, pprHsString,
47 pprPanic, pprPanic#, pprError, pprTrace, assertPprPanic, warnPprTrace,
48 trace, panic, panic#, assertPanic
51 #include "HsVersions.h"
54 import {-# SOURCE #-} Name( Name )
56 import CmdLineOpts ( opt_PprStyle_Debug, opt_PprUserLength )
58 import qualified Pretty
59 import Pretty ( Doc, Mode(..) )
62 import DATA_WORD ( Word32 )
64 import IO ( Handle, stderr, stdout, hFlush )
66 #if __GLASGOW_HASKELL__ < 410
67 import Char ( ord, isDigit )
72 %************************************************************************
74 \subsection{The @PprStyle@ data type}
76 %************************************************************************
80 = PprUser PrintUnqualified Depth -- Pretty-print in a way that will
81 -- make sense to the ordinary user;
82 -- must be very close to Haskell
85 | PprCode CodeStyle -- Print code; either C or assembler
87 | PprDebug -- Standard debugging output
89 data CodeStyle = CStyle -- The format of labels differs for C and assembler
92 data Depth = AllTheWay
93 | PartWay Int -- 0 => stop
96 type PrintUnqualified = Name -> Bool
97 -- This function tells when it's ok to print
98 -- a (Global) name unqualified
100 alwaysQualify,neverQualify :: PrintUnqualified
101 alwaysQualify n = False
102 neverQualify n = True
104 defaultUserStyle = mkUserStyle alwaysQualify AllTheWay
106 mkErrStyle :: PrintUnqualified -> PprStyle
107 -- Style for printing error messages
108 mkErrStyle print_unqual = mkUserStyle print_unqual (PartWay opt_PprUserLength)
110 defaultErrStyle :: PprStyle
111 -- Default style for error messages
112 -- It's a bit of a hack because it doesn't take into account what's in scope
113 -- Only used for desugarer warnings, and typechecker errors in interface sigs
115 | opt_PprStyle_Debug = mkUserStyle alwaysQualify AllTheWay
116 | otherwise = mkUserStyle neverQualify (PartWay opt_PprUserLength)
118 mkUserStyle unqual depth | opt_PprStyle_Debug = PprDebug
119 | otherwise = PprUser unqual depth
122 Orthogonal to the above printing styles are (possibly) some
123 command-line flags that affect printing (often carried with the
124 style). The most likely ones are variations on how much type info is
127 The following test decides whether or not we are actually generating
128 code (either C or assembly), or generating interface files.
130 %************************************************************************
132 \subsection{The @SDoc@ data type}
134 %************************************************************************
137 type SDoc = PprStyle -> Doc
139 withPprStyle :: PprStyle -> SDoc -> SDoc
140 withPprStyle sty d sty' = d sty
142 withPprStyleDoc :: PprStyle -> SDoc -> Doc
143 withPprStyleDoc sty d = d sty
145 pprDeeper :: SDoc -> SDoc
146 pprDeeper d (PprUser unqual (PartWay 0)) = Pretty.text "..."
147 pprDeeper d (PprUser unqual (PartWay n)) = d (PprUser unqual (PartWay (n-1)))
148 pprDeeper d other_sty = d other_sty
150 getPprStyle :: (PprStyle -> SDoc) -> SDoc
151 getPprStyle df sty = df sty sty
155 unqualStyle :: PprStyle -> Name -> Bool
156 unqualStyle (PprUser unqual _) n = unqual n
157 unqualStyle other n = False
159 codeStyle :: PprStyle -> Bool
160 codeStyle (PprCode _) = True
163 asmStyle :: PprStyle -> Bool
164 asmStyle (PprCode AsmStyle) = True
165 asmStyle other = False
167 debugStyle :: PprStyle -> Bool
168 debugStyle PprDebug = True
169 debugStyle other = False
171 userStyle :: PprStyle -> Bool
172 userStyle (PprUser _ _) = True
173 userStyle other = False
175 ifPprDebug :: SDoc -> SDoc -- Empty for non-debug style
176 ifPprDebug d sty@PprDebug = d sty
177 ifPprDebug d sty = Pretty.empty
182 printSDoc :: SDoc -> PprStyle -> IO ()
184 Pretty.printDoc PageMode stdout (d sty)
187 -- I'm not sure whether the direct-IO approach of Pretty.printDoc
188 -- above is better or worse than the put-big-string approach here
189 printErrs :: Doc -> IO ()
190 printErrs doc = do Pretty.printDoc PageMode stderr doc
193 printDump :: SDoc -> IO ()
195 Pretty.printDoc PageMode stdout (better_doc defaultUserStyle)
198 better_doc = doc $$ text ""
199 -- We used to always print in debug style, but I want
200 -- to try the effect of a more user-ish style (unless you
203 printForUser :: Handle -> PrintUnqualified -> SDoc -> IO ()
204 printForUser handle unqual doc
205 = Pretty.printDoc PageMode handle (doc (mkUserStyle unqual AllTheWay))
207 -- printForC, printForAsm do what they sound like
208 printForC :: Handle -> SDoc -> IO ()
209 printForC handle doc = Pretty.printDoc LeftMode handle (doc (PprCode CStyle))
211 printForAsm :: Handle -> SDoc -> IO ()
212 printForAsm handle doc = Pretty.printDoc LeftMode handle (doc (PprCode AsmStyle))
214 pprCode :: CodeStyle -> SDoc -> SDoc
215 pprCode cs d = withPprStyle (PprCode cs) d
217 mkCodeStyle :: CodeStyle -> PprStyle
218 mkCodeStyle = PprCode
220 -- Can't make SDoc an instance of Show because SDoc is just a function type
221 -- However, Doc *is* an instance of Show
222 -- showSDoc just blasts it out as a string
223 showSDoc :: SDoc -> String
224 showSDoc d = show (d defaultUserStyle)
226 showSDocForUser :: PrintUnqualified -> SDoc -> String
227 showSDocForUser unqual doc = show (doc (mkUserStyle unqual AllTheWay))
229 showSDocUnqual :: SDoc -> String
230 -- Only used in the gruesome HsExpr.isOperator
231 showSDocUnqual d = show (d (mkUserStyle neverQualify AllTheWay))
233 showsPrecSDoc :: Int -> SDoc -> ShowS
234 showsPrecSDoc p d = showsPrec p (d defaultUserStyle)
236 showSDocDebug :: SDoc -> String
237 showSDocDebug d = show (d PprDebug)
241 docToSDoc :: Doc -> SDoc
242 docToSDoc d = \_ -> d
244 empty sty = Pretty.empty
245 text s sty = Pretty.text s
246 char c sty = Pretty.char c
247 ftext s sty = Pretty.ftext s
248 ptext s sty = Pretty.ptext s
249 int n sty = Pretty.int n
250 integer n sty = Pretty.integer n
251 float n sty = Pretty.float n
252 double n sty = Pretty.double n
253 rational n sty = Pretty.rational n
255 parens d sty = Pretty.parens (d sty)
256 braces d sty = Pretty.braces (d sty)
257 brackets d sty = Pretty.brackets (d sty)
258 doubleQuotes d sty = Pretty.doubleQuotes (d sty)
259 angleBrackets d = char '<' <> d <> char '>'
261 -- quotes encloses something in single quotes...
262 -- but it omits them if the thing ends in a single quote
263 -- so that we don't get `foo''. Instead we just have foo'.
264 quotes d sty = case show pp_d of
266 other -> Pretty.quotes pp_d
270 semi sty = Pretty.semi
271 comma sty = Pretty.comma
272 colon sty = Pretty.colon
273 equals sty = Pretty.equals
274 space sty = Pretty.space
275 lparen sty = Pretty.lparen
276 rparen sty = Pretty.rparen
277 lbrack sty = Pretty.lbrack
278 rbrack sty = Pretty.rbrack
279 lbrace sty = Pretty.lbrace
280 rbrace sty = Pretty.rbrace
281 dcolon sty = Pretty.ptext SLIT("::")
282 arrow sty = Pretty.ptext SLIT("->")
283 underscore = char '_'
286 nest n d sty = Pretty.nest n (d sty)
287 (<>) d1 d2 sty = (Pretty.<>) (d1 sty) (d2 sty)
288 (<+>) d1 d2 sty = (Pretty.<+>) (d1 sty) (d2 sty)
289 ($$) d1 d2 sty = (Pretty.$$) (d1 sty) (d2 sty)
290 ($+$) d1 d2 sty = (Pretty.$+$) (d1 sty) (d2 sty)
292 hcat ds sty = Pretty.hcat [d sty | d <- ds]
293 hsep ds sty = Pretty.hsep [d sty | d <- ds]
294 vcat ds sty = Pretty.vcat [d sty | d <- ds]
295 sep ds sty = Pretty.sep [d sty | d <- ds]
296 cat ds sty = Pretty.cat [d sty | d <- ds]
297 fsep ds sty = Pretty.fsep [d sty | d <- ds]
298 fcat ds sty = Pretty.fcat [d sty | d <- ds]
300 hang d1 n d2 sty = Pretty.hang (d1 sty) n (d2 sty)
302 punctuate :: SDoc -> [SDoc] -> [SDoc]
304 punctuate p (d:ds) = go d ds
307 go d (e:es) = (d <> p) : go e es
311 %************************************************************************
313 \subsection[Outputable-class]{The @Outputable@ class}
315 %************************************************************************
318 class Outputable a where
323 instance Outputable Bool where
324 ppr True = ptext SLIT("True")
325 ppr False = ptext SLIT("False")
327 instance Outputable Int where
330 instance Outputable () where
333 instance (Outputable a) => Outputable [a] where
334 ppr xs = brackets (fsep (punctuate comma (map ppr xs)))
336 instance (Outputable a, Outputable b) => Outputable (a, b) where
337 ppr (x,y) = parens (sep [ppr x <> comma, ppr y])
339 instance Outputable a => Outputable (Maybe a) where
340 ppr Nothing = ptext SLIT("Nothing")
341 ppr (Just x) = ptext SLIT("Just") <+> ppr x
343 -- ToDo: may not be used
344 instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c) where
346 parens (sep [ppr x <> comma,
350 instance (Outputable a, Outputable b, Outputable c, Outputable d) =>
351 Outputable (a, b, c, d) where
353 parens (sep [ppr x <> comma,
358 instance Outputable FastString where
359 ppr fs = text (unpackFS fs) -- Prints an unadorned string,
360 -- no double quotes or anything
364 %************************************************************************
366 \subsection{The @OutputableBndr@ class}
368 %************************************************************************
370 When we print a binder, we often want to print its type too.
371 The @OutputableBndr@ class encapsulates this idea.
373 @BindingSite@ is used to tell the thing that prints binder what
374 language construct is binding the identifier. This can be used
375 to decide how much info to print.
378 data BindingSite = LambdaBind | CaseBind | LetBind
380 class Outputable a => OutputableBndr a where
381 pprBndr :: BindingSite -> a -> SDoc
387 %************************************************************************
389 \subsection{Random printing helpers}
391 %************************************************************************
394 #if __GLASGOW_HASKELL__ < 410
395 -- Assume we have only 8-bit Chars.
397 pprHsChar :: Int -> SDoc
398 pprHsChar c = char '\'' <> text (showCharLit c "") <> char '\''
400 pprHsString :: FastString -> SDoc
401 pprHsString fs = doubleQuotes (text (foldr showCharLit "" (unpackIntFS fs)))
403 showCharLit :: Int -> String -> String
405 | c == ord '\"' = "\\\"" ++ rest
406 | c == ord '\'' = "\\\'" ++ rest
407 | c == ord '\\' = "\\\\" ++ rest
408 | c >= 0x20 && c <= 0x7E = chr c : rest
409 | c == ord '\a' = "\\a" ++ rest
410 | c == ord '\b' = "\\b" ++ rest
411 | c == ord '\f' = "\\f" ++ rest
412 | c == ord '\n' = "\\n" ++ rest
413 | c == ord '\r' = "\\r" ++ rest
414 | c == ord '\t' = "\\t" ++ rest
415 | c == ord '\v' = "\\v" ++ rest
416 | otherwise = ('\\':) $ shows (fromIntegral c :: Word32) $ case rest of
417 d:_ | isDigit d -> "\\&" ++ rest
421 -- We have 31-bit Chars and will simply use Show instances
422 -- of Char and String.
424 pprHsChar :: Int -> SDoc
425 pprHsChar c | c > 0x10ffff = char '\\' <> text (show (fromIntegral c :: Word32))
426 | otherwise = text (show (chr c))
428 pprHsString :: FastString -> SDoc
429 pprHsString fs = text (show (unpackFS fs))
433 instance Show FastString where
434 showsPrec p fs = showsPrecSDoc p (ppr fs)
438 %************************************************************************
440 \subsection{Other helper functions}
442 %************************************************************************
445 pprWithCommas :: (a -> SDoc) -> [a] -> SDoc
446 pprWithCommas pp xs = fsep (punctuate comma (map pp xs))
448 interppSP :: Outputable a => [a] -> SDoc
449 interppSP xs = hsep (map ppr xs)
451 interpp'SP :: Outputable a => [a] -> SDoc
452 interpp'SP xs = hsep (punctuate comma (map ppr xs))
454 pprQuotedList :: Outputable a => [a] -> SDoc
455 -- [x,y,z] ==> `x', `y', `z'
456 pprQuotedList xs = hsep (punctuate comma (map (quotes . ppr) xs))
460 %************************************************************************
462 \subsection{Printing numbers verbally}
464 %************************************************************************
466 @speakNth@ converts an integer to a verbal index; eg 1 maps to
470 speakNth :: Int -> SDoc
472 speakNth 1 = ptext SLIT("first")
473 speakNth 2 = ptext SLIT("second")
474 speakNth 3 = ptext SLIT("third")
475 speakNth 4 = ptext SLIT("fourth")
476 speakNth 5 = ptext SLIT("fifth")
477 speakNth 6 = ptext SLIT("sixth")
478 speakNth n = hcat [ int n, text suffix ]
480 suffix | n <= 20 = "th" -- 11,12,13 are non-std
481 | last_dig == 1 = "st"
482 | last_dig == 2 = "nd"
483 | last_dig == 3 = "rd"
486 last_dig = n `rem` 10
490 speakNTimes :: Int {- >=1 -} -> SDoc
491 speakNTimes t | t == 1 = ptext SLIT("once")
492 | t == 2 = ptext SLIT("twice")
493 | otherwise = int t <+> ptext SLIT("times")
497 %************************************************************************
499 \subsection{Error handling}
501 %************************************************************************
504 pprPanic :: String -> SDoc -> a
505 pprError :: String -> SDoc -> a
506 pprTrace :: String -> SDoc -> a -> a
507 pprPanic = pprAndThen panic
508 pprError = pprAndThen error
509 pprTrace = pprAndThen trace
511 pprPanic# heading pretty_msg = panic# (show (doc PprDebug))
513 doc = text heading <+> pretty_msg
515 pprAndThen :: (String -> a) -> String -> SDoc -> a
516 pprAndThen cont heading pretty_msg = cont (show (doc PprDebug))
518 doc = sep [text heading, nest 4 pretty_msg]
520 assertPprPanic :: String -> Int -> SDoc -> a
521 assertPprPanic file line msg
522 = panic (show (doc PprDebug))
524 doc = sep [hsep[text "ASSERT failed! file",
526 text "line", int line],
529 warnPprTrace :: Bool -> String -> Int -> SDoc -> a -> a
530 warnPprTrace False file line msg x = x
531 warnPprTrace True file line msg x
532 = trace (show (doc PprDebug)) x
534 doc = sep [hsep [text "WARNING: file", text file, text "line", int line],