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 )
69 %************************************************************************
71 \subsection{The @PprStyle@ data type}
73 %************************************************************************
77 = PprUser PrintUnqualified Depth -- Pretty-print in a way that will
78 -- make sense to the ordinary user;
79 -- must be very close to Haskell
82 | PprCode CodeStyle -- Print code; either C or assembler
84 | PprDebug -- Standard debugging output
86 data CodeStyle = CStyle -- The format of labels differs for C and assembler
89 data Depth = AllTheWay
90 | PartWay Int -- 0 => stop
93 type PrintUnqualified = Name -> Bool
94 -- This function tells when it's ok to print
95 -- a (Global) name unqualified
97 alwaysQualify,neverQualify :: PrintUnqualified
98 alwaysQualify n = False
101 defaultUserStyle = mkUserStyle alwaysQualify AllTheWay
103 mkErrStyle :: PrintUnqualified -> PprStyle
104 -- Style for printing error messages
105 mkErrStyle print_unqual = mkUserStyle print_unqual (PartWay opt_PprUserLength)
107 defaultErrStyle :: PprStyle
108 -- Default style for error messages
109 -- It's a bit of a hack because it doesn't take into account what's in scope
110 -- Only used for desugarer warnings, and typechecker errors in interface sigs
112 | opt_PprStyle_Debug = mkUserStyle alwaysQualify AllTheWay
113 | otherwise = mkUserStyle alwaysQualify (PartWay opt_PprUserLength)
115 mkUserStyle unqual depth | opt_PprStyle_Debug = PprDebug
116 | otherwise = PprUser unqual depth
119 Orthogonal to the above printing styles are (possibly) some
120 command-line flags that affect printing (often carried with the
121 style). The most likely ones are variations on how much type info is
124 The following test decides whether or not we are actually generating
125 code (either C or assembly), or generating interface files.
127 %************************************************************************
129 \subsection{The @SDoc@ data type}
131 %************************************************************************
134 type SDoc = PprStyle -> Doc
136 withPprStyle :: PprStyle -> SDoc -> SDoc
137 withPprStyle sty d sty' = d sty
139 withPprStyleDoc :: PprStyle -> SDoc -> Doc
140 withPprStyleDoc sty d = d sty
142 pprDeeper :: SDoc -> SDoc
143 pprDeeper d (PprUser unqual (PartWay 0)) = Pretty.text "..."
144 pprDeeper d (PprUser unqual (PartWay n)) = d (PprUser unqual (PartWay (n-1)))
145 pprDeeper d other_sty = d other_sty
147 getPprStyle :: (PprStyle -> SDoc) -> SDoc
148 getPprStyle df sty = df sty sty
152 unqualStyle :: PprStyle -> Name -> Bool
153 unqualStyle (PprUser unqual _) n = unqual n
154 unqualStyle other n = False
156 codeStyle :: PprStyle -> Bool
157 codeStyle (PprCode _) = True
160 asmStyle :: PprStyle -> Bool
161 asmStyle (PprCode AsmStyle) = True
162 asmStyle other = False
164 debugStyle :: PprStyle -> Bool
165 debugStyle PprDebug = True
166 debugStyle other = False
168 userStyle :: PprStyle -> Bool
169 userStyle (PprUser _ _) = True
170 userStyle other = False
172 ifPprDebug :: SDoc -> SDoc -- Empty for non-debug style
173 ifPprDebug d sty@PprDebug = d sty
174 ifPprDebug d sty = Pretty.empty
179 printSDoc :: SDoc -> PprStyle -> IO ()
181 Pretty.printDoc PageMode stdout (d sty)
184 -- I'm not sure whether the direct-IO approach of Pretty.printDoc
185 -- above is better or worse than the put-big-string approach here
186 printErrs :: Doc -> IO ()
187 printErrs doc = do Pretty.printDoc PageMode stderr doc
190 printDump :: SDoc -> IO ()
192 Pretty.printDoc PageMode stdout (better_doc defaultUserStyle)
195 better_doc = doc $$ text ""
196 -- We used to always print in debug style, but I want
197 -- to try the effect of a more user-ish style (unless you
200 printForUser :: Handle -> PrintUnqualified -> SDoc -> IO ()
201 printForUser handle unqual doc
202 = Pretty.printDoc PageMode handle (doc (mkUserStyle unqual AllTheWay))
204 -- printForC, printForAsm do what they sound like
205 printForC :: Handle -> SDoc -> IO ()
206 printForC handle doc = Pretty.printDoc LeftMode handle (doc (PprCode CStyle))
208 printForAsm :: Handle -> SDoc -> IO ()
209 printForAsm handle doc = Pretty.printDoc LeftMode handle (doc (PprCode AsmStyle))
211 pprCode :: CodeStyle -> SDoc -> SDoc
212 pprCode cs d = withPprStyle (PprCode cs) d
214 mkCodeStyle :: CodeStyle -> PprStyle
215 mkCodeStyle = PprCode
217 -- Can't make SDoc an instance of Show because SDoc is just a function type
218 -- However, Doc *is* an instance of Show
219 -- showSDoc just blasts it out as a string
220 showSDoc :: SDoc -> String
221 showSDoc d = show (d defaultUserStyle)
223 showSDocForUser :: PrintUnqualified -> SDoc -> String
224 showSDocForUser unqual doc = show (doc (mkUserStyle unqual AllTheWay))
226 showSDocUnqual :: SDoc -> String
227 -- Only used in the gruesome HsExpr.isOperator
228 showSDocUnqual d = show (d (mkUserStyle neverQualify AllTheWay))
230 showsPrecSDoc :: Int -> SDoc -> ShowS
231 showsPrecSDoc p d = showsPrec p (d defaultUserStyle)
233 showSDocDebug :: SDoc -> String
234 showSDocDebug d = show (d PprDebug)
238 docToSDoc :: Doc -> SDoc
239 docToSDoc d = \_ -> d
241 empty sty = Pretty.empty
242 text s sty = Pretty.text s
243 char c sty = Pretty.char c
244 ftext s sty = Pretty.ftext s
245 ptext s sty = Pretty.ptext s
246 int n sty = Pretty.int n
247 integer n sty = Pretty.integer n
248 float n sty = Pretty.float n
249 double n sty = Pretty.double n
250 rational n sty = Pretty.rational n
252 parens d sty = Pretty.parens (d sty)
253 braces d sty = Pretty.braces (d sty)
254 brackets d sty = Pretty.brackets (d sty)
255 doubleQuotes d sty = Pretty.doubleQuotes (d sty)
256 angleBrackets d = char '<' <> d <> char '>'
258 -- quotes encloses something in single quotes...
259 -- but it omits them if the thing ends in a single quote
260 -- so that we don't get `foo''. Instead we just have foo'.
261 quotes d sty = case show pp_d of
263 other -> Pretty.quotes pp_d
267 semi sty = Pretty.semi
268 comma sty = Pretty.comma
269 colon sty = Pretty.colon
270 equals sty = Pretty.equals
271 space sty = Pretty.space
272 lparen sty = Pretty.lparen
273 rparen sty = Pretty.rparen
274 lbrack sty = Pretty.lbrack
275 rbrack sty = Pretty.rbrack
276 lbrace sty = Pretty.lbrace
277 rbrace sty = Pretty.rbrace
278 dcolon sty = Pretty.ptext SLIT("::")
279 arrow sty = Pretty.ptext SLIT("->")
280 underscore = char '_'
283 nest n d sty = Pretty.nest n (d sty)
284 (<>) d1 d2 sty = (Pretty.<>) (d1 sty) (d2 sty)
285 (<+>) d1 d2 sty = (Pretty.<+>) (d1 sty) (d2 sty)
286 ($$) d1 d2 sty = (Pretty.$$) (d1 sty) (d2 sty)
287 ($+$) d1 d2 sty = (Pretty.$+$) (d1 sty) (d2 sty)
289 hcat ds sty = Pretty.hcat [d sty | d <- ds]
290 hsep ds sty = Pretty.hsep [d sty | d <- ds]
291 vcat ds sty = Pretty.vcat [d sty | d <- ds]
292 sep ds sty = Pretty.sep [d sty | d <- ds]
293 cat ds sty = Pretty.cat [d sty | d <- ds]
294 fsep ds sty = Pretty.fsep [d sty | d <- ds]
295 fcat ds sty = Pretty.fcat [d sty | d <- ds]
297 hang d1 n d2 sty = Pretty.hang (d1 sty) n (d2 sty)
299 punctuate :: SDoc -> [SDoc] -> [SDoc]
301 punctuate p (d:ds) = go d ds
304 go d (e:es) = (d <> p) : go e es
308 %************************************************************************
310 \subsection[Outputable-class]{The @Outputable@ class}
312 %************************************************************************
315 class Outputable a where
320 instance Outputable Bool where
321 ppr True = ptext SLIT("True")
322 ppr False = ptext SLIT("False")
324 instance Outputable Int where
327 instance Outputable () where
330 instance (Outputable a) => Outputable [a] where
331 ppr xs = brackets (fsep (punctuate comma (map ppr xs)))
333 instance (Outputable a, Outputable b) => Outputable (a, b) where
334 ppr (x,y) = parens (sep [ppr x <> comma, ppr y])
336 instance Outputable a => Outputable (Maybe a) where
337 ppr Nothing = ptext SLIT("Nothing")
338 ppr (Just x) = ptext SLIT("Just") <+> ppr x
340 -- ToDo: may not be used
341 instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c) where
343 parens (sep [ppr x <> comma,
347 instance (Outputable a, Outputable b, Outputable c, Outputable d) =>
348 Outputable (a, b, c, d) where
350 parens (sep [ppr x <> comma,
355 instance Outputable FastString where
356 ppr fs = text (unpackFS fs) -- Prints an unadorned string,
357 -- no double quotes or anything
361 %************************************************************************
363 \subsection{The @OutputableBndr@ class}
365 %************************************************************************
367 When we print a binder, we often want to print its type too.
368 The @OutputableBndr@ class encapsulates this idea.
370 @BindingSite@ is used to tell the thing that prints binder what
371 language construct is binding the identifier. This can be used
372 to decide how much info to print.
375 data BindingSite = LambdaBind | CaseBind | LetBind
377 class Outputable a => OutputableBndr a where
378 pprBndr :: BindingSite -> a -> SDoc
384 %************************************************************************
386 \subsection{Random printing helpers}
388 %************************************************************************
391 -- We have 31-bit Chars and will simply use Show instances
392 -- of Char and String.
394 pprHsChar :: Char -> SDoc
395 pprHsChar c | c > '\x10ffff' = char '\\' <> text (show (fromIntegral (ord c) :: Word32))
396 | otherwise = text (show c)
398 pprHsString :: FastString -> SDoc
399 pprHsString fs = text (show (unpackFS fs))
401 instance Show FastString where
402 showsPrec p fs = showsPrecSDoc p (ppr fs)
406 %************************************************************************
408 \subsection{Other helper functions}
410 %************************************************************************
413 pprWithCommas :: (a -> SDoc) -> [a] -> SDoc
414 pprWithCommas pp xs = fsep (punctuate comma (map pp xs))
416 interppSP :: Outputable a => [a] -> SDoc
417 interppSP xs = sep (map ppr xs)
419 interpp'SP :: Outputable a => [a] -> SDoc
420 interpp'SP xs = sep (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 suffix ]
448 suffix | n <= 20 = "th" -- 11,12,13 are non-std
449 | last_dig == 1 = "st"
450 | last_dig == 2 = "nd"
451 | last_dig == 3 = "rd"
454 last_dig = n `rem` 10
458 speakNTimes :: Int {- >=1 -} -> SDoc
459 speakNTimes t | t == 1 = ptext SLIT("once")
460 | t == 2 = ptext SLIT("twice")
461 | otherwise = int t <+> ptext SLIT("times")
465 %************************************************************************
467 \subsection{Error handling}
469 %************************************************************************
472 pprPanic :: String -> SDoc -> a
473 pprError :: String -> SDoc -> a
474 pprTrace :: String -> SDoc -> a -> a
475 pprPanic = pprAndThen panic
476 pprError = pprAndThen error
477 pprTrace = pprAndThen trace
479 pprPanic# heading pretty_msg = panic# (show (doc PprDebug))
481 doc = text heading <+> pretty_msg
483 pprAndThen :: (String -> a) -> String -> SDoc -> a
484 pprAndThen cont heading pretty_msg = cont (show (doc PprDebug))
486 doc = sep [text heading, nest 4 pretty_msg]
488 assertPprPanic :: String -> Int -> SDoc -> a
489 assertPprPanic file line msg
490 = panic (show (doc PprDebug))
492 doc = sep [hsep[text "ASSERT failed! file",
494 text "line", int line],
497 warnPprTrace :: Bool -> String -> Int -> SDoc -> a -> a
498 warnPprTrace False file line msg x = x
499 warnPprTrace True file line msg x
500 = trace (show (doc PprDebug)) x
502 doc = sep [hsep [text "WARNING: file", text file, text "line", int line],