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,
46 pprPanic, assertPprPanic, pprPanic#, pprPgmError,
47 pprTrace, warnPprTrace,
48 trace, pgmError, panic, panic#, assertPanic
51 #include "HsVersions.h"
54 import {-# SOURCE #-} Module( Module )
55 import {-# SOURCE #-} OccName( OccName )
57 import CmdLineOpts ( opt_PprStyle_Debug, opt_PprUserLength )
58 import PackageConfig ( PackageId, packageIdString )
60 import qualified Pretty
61 import Pretty ( Doc, Mode(..) )
64 import DATA_WORD ( Word32 )
66 import IO ( Handle, stderr, stdout, hFlush )
71 %************************************************************************
73 \subsection{The @PprStyle@ data type}
75 %************************************************************************
79 = PprUser PrintUnqualified Depth -- Pretty-print in a way that will
80 -- make sense to the ordinary user;
81 -- must be very close to Haskell
84 | PprCode CodeStyle -- Print code; either C or assembler
86 | PprDebug -- Standard debugging output
88 data CodeStyle = CStyle -- The format of labels differs for C and assembler
91 data Depth = AllTheWay
92 | PartWay Int -- 0 => stop
95 type PrintUnqualified = Module -> OccName -> Bool
96 -- This function tells when it's ok to print
97 -- a (Global) name unqualified
99 alwaysQualify,neverQualify :: PrintUnqualified
100 alwaysQualify m n = False
101 neverQualify m n = True
103 defaultUserStyle = mkUserStyle alwaysQualify AllTheWay
105 mkErrStyle :: PrintUnqualified -> PprStyle
106 -- Style for printing error messages
107 mkErrStyle print_unqual = mkUserStyle print_unqual (PartWay opt_PprUserLength)
109 defaultErrStyle :: PprStyle
110 -- Default style for error messages
111 -- It's a bit of a hack because it doesn't take into account what's in scope
112 -- Only used for desugarer warnings, and typechecker errors in interface sigs
114 | opt_PprStyle_Debug = mkUserStyle alwaysQualify AllTheWay
115 | otherwise = mkUserStyle alwaysQualify (PartWay opt_PprUserLength)
117 mkUserStyle unqual depth | opt_PprStyle_Debug = PprDebug
118 | otherwise = PprUser unqual depth
121 Orthogonal to the above printing styles are (possibly) some
122 command-line flags that affect printing (often carried with the
123 style). The most likely ones are variations on how much type info is
126 The following test decides whether or not we are actually generating
127 code (either C or assembly), or generating interface files.
129 %************************************************************************
131 \subsection{The @SDoc@ data type}
133 %************************************************************************
136 type SDoc = PprStyle -> Doc
138 withPprStyle :: PprStyle -> SDoc -> SDoc
139 withPprStyle sty d sty' = d sty
141 withPprStyleDoc :: PprStyle -> SDoc -> Doc
142 withPprStyleDoc sty d = d sty
144 pprDeeper :: SDoc -> SDoc
145 pprDeeper d (PprUser unqual (PartWay 0)) = Pretty.text "..."
146 pprDeeper d (PprUser unqual (PartWay n)) = d (PprUser unqual (PartWay (n-1)))
147 pprDeeper d other_sty = d other_sty
149 getPprStyle :: (PprStyle -> SDoc) -> SDoc
150 getPprStyle df sty = df sty sty
154 unqualStyle :: PprStyle -> PrintUnqualified
155 unqualStyle (PprUser unqual _) m n = unqual m n
156 unqualStyle other m n = False
158 codeStyle :: PprStyle -> Bool
159 codeStyle (PprCode _) = True
162 asmStyle :: PprStyle -> Bool
163 asmStyle (PprCode AsmStyle) = True
164 asmStyle other = False
166 debugStyle :: PprStyle -> Bool
167 debugStyle PprDebug = True
168 debugStyle other = False
170 userStyle :: PprStyle -> Bool
171 userStyle (PprUser _ _) = True
172 userStyle other = False
174 ifPprDebug :: SDoc -> SDoc -- Empty for non-debug style
175 ifPprDebug d sty@PprDebug = d sty
176 ifPprDebug d sty = Pretty.empty
181 printSDoc :: SDoc -> PprStyle -> IO ()
183 Pretty.printDoc PageMode stdout (d sty)
186 -- I'm not sure whether the direct-IO approach of Pretty.printDoc
187 -- above is better or worse than the put-big-string approach here
188 printErrs :: Doc -> IO ()
189 printErrs doc = do Pretty.printDoc PageMode stderr doc
192 printDump :: SDoc -> IO ()
194 Pretty.printDoc PageMode stdout (better_doc defaultUserStyle)
197 better_doc = doc $$ text ""
198 -- We used to always print in debug style, but I want
199 -- to try the effect of a more user-ish style (unless you
202 printForUser :: Handle -> PrintUnqualified -> SDoc -> IO ()
203 printForUser handle unqual doc
204 = Pretty.printDoc PageMode handle (doc (mkUserStyle unqual AllTheWay))
206 -- printForC, printForAsm do what they sound like
207 printForC :: Handle -> SDoc -> IO ()
208 printForC handle doc = Pretty.printDoc LeftMode handle (doc (PprCode CStyle))
210 printForAsm :: Handle -> SDoc -> IO ()
211 printForAsm handle doc = Pretty.printDoc LeftMode handle (doc (PprCode AsmStyle))
213 pprCode :: CodeStyle -> SDoc -> SDoc
214 pprCode cs d = withPprStyle (PprCode cs) d
216 mkCodeStyle :: CodeStyle -> PprStyle
217 mkCodeStyle = PprCode
219 -- Can't make SDoc an instance of Show because SDoc is just a function type
220 -- However, Doc *is* an instance of Show
221 -- showSDoc just blasts it out as a string
222 showSDoc :: SDoc -> String
223 showSDoc d = show (d defaultUserStyle)
225 showSDocForUser :: PrintUnqualified -> SDoc -> String
226 showSDocForUser unqual doc = show (doc (mkUserStyle unqual AllTheWay))
228 showSDocUnqual :: SDoc -> String
229 -- Only used in the gruesome HsExpr.isOperator
230 showSDocUnqual d = show (d (mkUserStyle neverQualify AllTheWay))
232 showsPrecSDoc :: Int -> SDoc -> ShowS
233 showsPrecSDoc p d = showsPrec p (d defaultUserStyle)
235 showSDocDebug :: SDoc -> String
236 showSDocDebug d = show (d PprDebug)
240 docToSDoc :: Doc -> SDoc
241 docToSDoc d = \_ -> d
243 empty sty = Pretty.empty
244 text s sty = Pretty.text s
245 char c sty = Pretty.char c
246 ftext s sty = Pretty.ftext s
247 ptext s sty = Pretty.ptext s
248 int n sty = Pretty.int n
249 integer n sty = Pretty.integer n
250 float n sty = Pretty.float n
251 double n sty = Pretty.double n
252 rational n sty = Pretty.rational n
254 parens d sty = Pretty.parens (d sty)
255 braces d sty = Pretty.braces (d sty)
256 brackets d sty = Pretty.brackets (d sty)
257 doubleQuotes d sty = Pretty.doubleQuotes (d sty)
258 angleBrackets d = char '<' <> d <> char '>'
260 -- quotes encloses something in single quotes...
261 -- but it omits them if the thing ends in a single quote
262 -- so that we don't get `foo''. Instead we just have foo'.
263 quotes d sty = case show pp_d of
265 other -> Pretty.quotes pp_d
269 semi sty = Pretty.semi
270 comma sty = Pretty.comma
271 colon sty = Pretty.colon
272 equals sty = Pretty.equals
273 space sty = Pretty.space
274 lparen sty = Pretty.lparen
275 rparen sty = Pretty.rparen
276 lbrack sty = Pretty.lbrack
277 rbrack sty = Pretty.rbrack
278 lbrace sty = Pretty.lbrace
279 rbrace sty = Pretty.rbrace
280 dcolon sty = Pretty.ptext SLIT("::")
281 arrow sty = Pretty.ptext SLIT("->")
282 underscore = char '_'
285 nest n d sty = Pretty.nest n (d sty)
286 (<>) d1 d2 sty = (Pretty.<>) (d1 sty) (d2 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)
291 hcat ds sty = Pretty.hcat [d sty | d <- ds]
292 hsep ds sty = Pretty.hsep [d sty | d <- ds]
293 vcat ds sty = Pretty.vcat [d sty | d <- ds]
294 sep ds sty = Pretty.sep [d sty | d <- ds]
295 cat ds sty = Pretty.cat [d sty | d <- ds]
296 fsep ds sty = Pretty.fsep [d sty | d <- ds]
297 fcat ds sty = Pretty.fcat [d sty | d <- ds]
299 hang d1 n d2 sty = Pretty.hang (d1 sty) n (d2 sty)
301 punctuate :: SDoc -> [SDoc] -> [SDoc]
303 punctuate p (d:ds) = go d ds
306 go d (e:es) = (d <> p) : go e es
310 %************************************************************************
312 \subsection[Outputable-class]{The @Outputable@ class}
314 %************************************************************************
317 class Outputable a where
322 instance Outputable Bool where
323 ppr True = ptext SLIT("True")
324 ppr False = ptext SLIT("False")
326 instance Outputable Int where
329 instance Outputable () where
332 instance (Outputable a) => Outputable [a] where
333 ppr xs = brackets (fsep (punctuate comma (map ppr xs)))
335 instance (Outputable a, Outputable b) => Outputable (a, b) where
336 ppr (x,y) = parens (sep [ppr x <> comma, ppr y])
338 instance Outputable a => Outputable (Maybe a) where
339 ppr Nothing = ptext SLIT("Nothing")
340 ppr (Just x) = ptext SLIT("Just") <+> ppr x
342 -- ToDo: may not be used
343 instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c) where
345 parens (sep [ppr x <> comma,
349 instance (Outputable a, Outputable b, Outputable c, Outputable d) =>
350 Outputable (a, b, c, d) where
352 parens (sep [ppr x <> comma,
357 instance Outputable FastString where
358 ppr fs = text (unpackFS fs) -- Prints an unadorned string,
359 -- no double quotes or anything
361 instance Outputable PackageId where
362 ppr pid = text (packageIdString pid)
366 %************************************************************************
368 \subsection{The @OutputableBndr@ class}
370 %************************************************************************
372 When we print a binder, we often want to print its type too.
373 The @OutputableBndr@ class encapsulates this idea.
375 @BindingSite@ is used to tell the thing that prints binder what
376 language construct is binding the identifier. This can be used
377 to decide how much info to print.
380 data BindingSite = LambdaBind | CaseBind | LetBind
382 class Outputable a => OutputableBndr a where
383 pprBndr :: BindingSite -> a -> SDoc
389 %************************************************************************
391 \subsection{Random printing helpers}
393 %************************************************************************
396 -- We have 31-bit Chars and will simply use Show instances
397 -- of Char and String.
399 pprHsChar :: Char -> SDoc
400 pprHsChar c | c > '\x10ffff' = char '\\' <> text (show (fromIntegral (ord c) :: Word32))
401 | otherwise = text (show c)
403 pprHsString :: FastString -> SDoc
404 pprHsString fs = text (show (unpackFS fs))
406 instance Show FastString where
407 showsPrec p fs = showsPrecSDoc p (ppr fs)
411 %************************************************************************
413 \subsection{Other helper functions}
415 %************************************************************************
418 pprWithCommas :: (a -> SDoc) -> [a] -> SDoc
419 pprWithCommas pp xs = fsep (punctuate comma (map pp xs))
421 interppSP :: Outputable a => [a] -> SDoc
422 interppSP xs = sep (map ppr xs)
424 interpp'SP :: Outputable a => [a] -> SDoc
425 interpp'SP xs = sep (punctuate comma (map ppr xs))
427 pprQuotedList :: Outputable a => [a] -> SDoc
428 -- [x,y,z] ==> `x', `y', `z'
429 pprQuotedList xs = hsep (punctuate comma (map (quotes . ppr) xs))
433 %************************************************************************
435 \subsection{Printing numbers verbally}
437 %************************************************************************
439 @speakNth@ converts an integer to a verbal index; eg 1 maps to
443 speakNth :: Int -> SDoc
445 speakNth 1 = ptext SLIT("first")
446 speakNth 2 = ptext SLIT("second")
447 speakNth 3 = ptext SLIT("third")
448 speakNth 4 = ptext SLIT("fourth")
449 speakNth 5 = ptext SLIT("fifth")
450 speakNth 6 = ptext SLIT("sixth")
451 speakNth n = hcat [ int n, text suffix ]
453 suffix | n <= 20 = "th" -- 11,12,13 are non-std
454 | last_dig == 1 = "st"
455 | last_dig == 2 = "nd"
456 | last_dig == 3 = "rd"
459 last_dig = n `rem` 10
463 speakNTimes :: Int {- >=1 -} -> SDoc
464 speakNTimes t | t == 1 = ptext SLIT("once")
465 | t == 2 = ptext SLIT("twice")
466 | otherwise = int t <+> ptext SLIT("times")
470 %************************************************************************
472 \subsection{Error handling}
474 %************************************************************************
477 pprPanic, pprPgmError :: String -> SDoc -> a
478 pprTrace :: String -> SDoc -> a -> a
479 pprPanic = pprAndThen panic -- Throw an exn saying "bug in GHC"
481 pprPgmError = pprAndThen pgmError -- Throw an exn saying "bug in pgm being compiled"
482 -- (used for unusual pgm errors)
483 pprTrace = pprAndThen trace
485 pprPanic# heading pretty_msg = panic# (show (doc PprDebug))
487 doc = text heading <+> pretty_msg
489 pprAndThen :: (String -> a) -> String -> SDoc -> a
490 pprAndThen cont heading pretty_msg = cont (show (doc PprDebug))
492 doc = sep [text heading, nest 4 pretty_msg]
494 assertPprPanic :: String -> Int -> SDoc -> a
495 assertPprPanic file line msg
496 = panic (show (doc PprDebug))
498 doc = sep [hsep[text "ASSERT failed! file",
500 text "line", int line],
503 warnPprTrace :: Bool -> String -> Int -> SDoc -> a -> a
504 warnPprTrace False file line msg x = x
505 warnPprTrace True file line msg x
506 = trace (show (doc PprDebug)) x
508 doc = sep [hsep [text "WARNING: file", text file, text "line", int line],