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, pprSetDepth,
18 codeStyle, userStyle, debugStyle, dumpStyle, asmStyle,
19 ifPprDebug, qualName, qualModule,
20 mkErrStyle, defaultErrStyle, defaultDumpStyle, defaultUserStyle,
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, speakN, speakNOf, plural,
38 printSDoc, printErrs, printDump,
39 printForC, printForAsm, printForUser,
41 showSDoc, showSDocForUser, showSDocDebug, showSDocDump,
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, modulePackageId,
55 ModuleName, moduleName )
56 import {-# SOURCE #-} OccName( OccName )
58 import StaticFlags ( opt_PprStyle_Debug, opt_PprUserLength )
59 import PackageConfig ( PackageId, packageIdString )
61 import qualified Pretty
62 import Pretty ( Doc, Mode(..) )
65 import DATA_WORD ( Word32 )
67 import IO ( Handle, stderr, stdout, hFlush )
72 %************************************************************************
74 \subsection{The @PprStyle@ data type}
76 %************************************************************************
81 = PprUser PrintUnqualified Depth
82 -- Pretty-print in a way that will make sense to the
83 -- ordinary user; must be very close to Haskell
85 -- Assumes printing tidied code: non-system names are
86 -- printed without uniques.
89 -- Print code; either C or assembler
91 | PprDump -- For -ddump-foo; less verbose than PprDebug.
92 -- Does not assume tidied code: non-external names
93 -- are printed with uniques.
95 | PprDebug -- Full debugging output
97 data CodeStyle = CStyle -- The format of labels differs for C and assembler
100 data Depth = AllTheWay
101 | PartWay Int -- 0 => stop
104 -- -----------------------------------------------------------------------------
105 -- Printing original names
107 -- When printing code that contains original names, we need to map the
108 -- original names back to something the user understands. This is the
109 -- purpose of the pair of functions that gets passed around
110 -- when rendering 'SDoc'.
112 -- | given an /original/ name, this function tells you which module
113 -- name it should be qualified with when printing for the user, if
114 -- any. For example, given @Control.Exception.catch@, which is in scope
115 -- as @Exception.catch@, this fuction will return @Just "Exception"@.
116 -- Note that the return value is a ModuleName, not a Module, because
117 -- in source code, names are qualified by ModuleNames.
118 type QualifyName = Module -> OccName -> Maybe ModuleName
120 -- | For a given module, we need to know whether to print it with
121 -- a package name to disambiguate it, and if so which package name should
123 type QualifyModule = Module -> Maybe PackageId
125 type PrintUnqualified = (QualifyName, QualifyModule)
127 alwaysQualifyNames :: QualifyName
128 alwaysQualifyNames m n = Just (moduleName m)
130 neverQualifyNames :: QualifyName
131 neverQualifyNames m n = Nothing
133 alwaysQualifyModules :: QualifyModule
134 alwaysQualifyModules m = Just (modulePackageId m)
136 neverQualifyModules :: QualifyModule
137 neverQualifyModules m = Nothing
139 alwaysQualify = (alwaysQualifyNames, alwaysQualifyModules)
140 neverQualify = (neverQualifyNames, neverQualifyModules)
142 defaultUserStyle = mkUserStyle alwaysQualify AllTheWay
144 defaultDumpStyle | opt_PprStyle_Debug = PprDebug
145 | otherwise = PprDump
147 -- | Style for printing error messages
148 mkErrStyle :: PrintUnqualified -> PprStyle
149 mkErrStyle qual = mkUserStyle qual (PartWay opt_PprUserLength)
151 defaultErrStyle :: PprStyle
152 -- Default style for error messages
153 -- It's a bit of a hack because it doesn't take into account what's in scope
154 -- Only used for desugarer warnings, and typechecker errors in interface sigs
156 | opt_PprStyle_Debug = mkUserStyle alwaysQualify AllTheWay
157 | otherwise = mkUserStyle alwaysQualify (PartWay opt_PprUserLength)
159 mkUserStyle unqual depth
160 | opt_PprStyle_Debug = PprDebug
161 | otherwise = PprUser unqual depth
164 Orthogonal to the above printing styles are (possibly) some
165 command-line flags that affect printing (often carried with the
166 style). The most likely ones are variations on how much type info is
169 The following test decides whether or not we are actually generating
170 code (either C or assembly), or generating interface files.
172 %************************************************************************
174 \subsection{The @SDoc@ data type}
176 %************************************************************************
179 type SDoc = PprStyle -> Doc
181 withPprStyle :: PprStyle -> SDoc -> SDoc
182 withPprStyle sty d sty' = d sty
184 withPprStyleDoc :: PprStyle -> SDoc -> Doc
185 withPprStyleDoc sty d = d sty
187 pprDeeper :: SDoc -> SDoc
188 pprDeeper d (PprUser q (PartWay 0)) = Pretty.text "..."
189 pprDeeper d (PprUser q (PartWay n)) = d (PprUser q (PartWay (n-1)))
190 pprDeeper d other_sty = d other_sty
192 pprSetDepth :: Int -> SDoc -> SDoc
193 pprSetDepth n d (PprUser q _) = d (PprUser q (PartWay n))
194 pprSetDepth n d other_sty = d other_sty
196 getPprStyle :: (PprStyle -> SDoc) -> SDoc
197 getPprStyle df sty = df sty sty
201 qualName :: PprStyle -> QualifyName
202 qualName (PprUser (qual_name,_) _) m n = qual_name m n
203 qualName other m n = Just (moduleName m)
205 qualModule :: PprStyle -> QualifyModule
206 qualModule (PprUser (_,qual_mod) _) m = qual_mod m
207 qualModule other m = Just (modulePackageId m)
209 codeStyle :: PprStyle -> Bool
210 codeStyle (PprCode _) = True
213 asmStyle :: PprStyle -> Bool
214 asmStyle (PprCode AsmStyle) = True
215 asmStyle other = False
217 dumpStyle :: PprStyle -> Bool
218 dumpStyle PprDump = True
219 dumpStyle other = False
221 debugStyle :: PprStyle -> Bool
222 debugStyle PprDebug = True
223 debugStyle other = False
225 userStyle :: PprStyle -> Bool
226 userStyle (PprUser _ _) = True
227 userStyle other = False
229 ifPprDebug :: SDoc -> SDoc -- Empty for non-debug style
230 ifPprDebug d sty@PprDebug = d sty
231 ifPprDebug d sty = Pretty.empty
236 printSDoc :: SDoc -> PprStyle -> IO ()
238 Pretty.printDoc PageMode stdout (d sty)
241 -- I'm not sure whether the direct-IO approach of Pretty.printDoc
242 -- above is better or worse than the put-big-string approach here
243 printErrs :: Doc -> IO ()
244 printErrs doc = do Pretty.printDoc PageMode stderr doc
247 printDump :: SDoc -> IO ()
249 Pretty.printDoc PageMode stdout (better_doc defaultDumpStyle)
252 better_doc = doc $$ text ""
254 printForUser :: Handle -> PrintUnqualified -> SDoc -> IO ()
255 printForUser handle unqual doc
256 = Pretty.printDoc PageMode handle (doc (mkUserStyle unqual AllTheWay))
258 -- printForC, printForAsm do what they sound like
259 printForC :: Handle -> SDoc -> IO ()
260 printForC handle doc = Pretty.printDoc LeftMode handle (doc (PprCode CStyle))
262 printForAsm :: Handle -> SDoc -> IO ()
263 printForAsm handle doc = Pretty.printDoc LeftMode handle (doc (PprCode AsmStyle))
265 pprCode :: CodeStyle -> SDoc -> SDoc
266 pprCode cs d = withPprStyle (PprCode cs) d
268 mkCodeStyle :: CodeStyle -> PprStyle
269 mkCodeStyle = PprCode
271 -- Can't make SDoc an instance of Show because SDoc is just a function type
272 -- However, Doc *is* an instance of Show
273 -- showSDoc just blasts it out as a string
274 showSDoc :: SDoc -> String
275 showSDoc d = show (d defaultUserStyle)
277 showSDocForUser :: PrintUnqualified -> SDoc -> String
278 showSDocForUser unqual doc = show (doc (mkUserStyle unqual AllTheWay))
280 showSDocUnqual :: SDoc -> String
281 -- Only used in the gruesome HsExpr.isOperator
282 showSDocUnqual d = show (d (mkUserStyle neverQualify AllTheWay))
284 showsPrecSDoc :: Int -> SDoc -> ShowS
285 showsPrecSDoc p d = showsPrec p (d defaultUserStyle)
287 showSDocDump :: SDoc -> String
288 showSDocDump d = show (d PprDump)
290 showSDocDebug :: SDoc -> String
291 showSDocDebug d = show (d PprDebug)
295 docToSDoc :: Doc -> SDoc
296 docToSDoc d = \_ -> d
298 empty sty = Pretty.empty
299 text s sty = Pretty.text s
300 char c sty = Pretty.char c
301 ftext s sty = Pretty.ftext s
302 ptext s sty = Pretty.ptext s
303 int n sty = Pretty.int n
304 integer n sty = Pretty.integer n
305 float n sty = Pretty.float n
306 double n sty = Pretty.double n
307 rational n sty = Pretty.rational n
309 parens d sty = Pretty.parens (d sty)
310 braces d sty = Pretty.braces (d sty)
311 brackets d sty = Pretty.brackets (d sty)
312 doubleQuotes d sty = Pretty.doubleQuotes (d sty)
313 angleBrackets d = char '<' <> d <> char '>'
315 -- quotes encloses something in single quotes...
316 -- but it omits them if the thing ends in a single quote
317 -- so that we don't get `foo''. Instead we just have foo'.
318 quotes d sty = case show pp_d of
320 other -> Pretty.quotes pp_d
324 semi sty = Pretty.semi
325 comma sty = Pretty.comma
326 colon sty = Pretty.colon
327 equals sty = Pretty.equals
328 space sty = Pretty.space
329 lparen sty = Pretty.lparen
330 rparen sty = Pretty.rparen
331 lbrack sty = Pretty.lbrack
332 rbrack sty = Pretty.rbrack
333 lbrace sty = Pretty.lbrace
334 rbrace sty = Pretty.rbrace
335 dcolon sty = Pretty.ptext SLIT("::")
336 arrow sty = Pretty.ptext SLIT("->")
337 underscore = char '_'
340 nest n d sty = Pretty.nest n (d sty)
341 (<>) d1 d2 sty = (Pretty.<>) (d1 sty) (d2 sty)
342 (<+>) d1 d2 sty = (Pretty.<+>) (d1 sty) (d2 sty)
343 ($$) d1 d2 sty = (Pretty.$$) (d1 sty) (d2 sty)
344 ($+$) d1 d2 sty = (Pretty.$+$) (d1 sty) (d2 sty)
346 hcat ds sty = Pretty.hcat [d sty | d <- ds]
347 hsep ds sty = Pretty.hsep [d sty | d <- ds]
348 vcat ds sty = Pretty.vcat [d sty | d <- ds]
349 sep ds sty = Pretty.sep [d sty | d <- ds]
350 cat ds sty = Pretty.cat [d sty | d <- ds]
351 fsep ds sty = Pretty.fsep [d sty | d <- ds]
352 fcat ds sty = Pretty.fcat [d sty | d <- ds]
354 hang d1 n d2 sty = Pretty.hang (d1 sty) n (d2 sty)
356 punctuate :: SDoc -> [SDoc] -> [SDoc]
358 punctuate p (d:ds) = go d ds
361 go d (e:es) = (d <> p) : go e es
365 %************************************************************************
367 \subsection[Outputable-class]{The @Outputable@ class}
369 %************************************************************************
372 class Outputable a where
377 instance Outputable Bool where
378 ppr True = ptext SLIT("True")
379 ppr False = ptext SLIT("False")
381 instance Outputable Int where
384 instance Outputable () where
387 instance (Outputable a) => Outputable [a] where
388 ppr xs = brackets (fsep (punctuate comma (map ppr xs)))
390 instance (Outputable a, Outputable b) => Outputable (a, b) where
391 ppr (x,y) = parens (sep [ppr x <> comma, ppr y])
393 instance Outputable a => Outputable (Maybe a) where
394 ppr Nothing = ptext SLIT("Nothing")
395 ppr (Just x) = ptext SLIT("Just") <+> ppr x
397 -- ToDo: may not be used
398 instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c) where
400 parens (sep [ppr x <> comma,
404 instance (Outputable a, Outputable b, Outputable c, Outputable d) =>
405 Outputable (a, b, c, d) where
407 parens (sep [ppr x <> comma,
412 instance Outputable FastString where
413 ppr fs = ftext fs -- Prints an unadorned string,
414 -- no double quotes or anything
416 instance Outputable PackageId where
417 ppr pid = text (packageIdString pid)
421 %************************************************************************
423 \subsection{The @OutputableBndr@ class}
425 %************************************************************************
427 When we print a binder, we often want to print its type too.
428 The @OutputableBndr@ class encapsulates this idea.
430 @BindingSite@ is used to tell the thing that prints binder what
431 language construct is binding the identifier. This can be used
432 to decide how much info to print.
435 data BindingSite = LambdaBind | CaseBind | LetBind
437 class Outputable a => OutputableBndr a where
438 pprBndr :: BindingSite -> a -> SDoc
444 %************************************************************************
446 \subsection{Random printing helpers}
448 %************************************************************************
451 -- We have 31-bit Chars and will simply use Show instances
452 -- of Char and String.
454 pprHsChar :: Char -> SDoc
455 pprHsChar c | c > '\x10ffff' = char '\\' <> text (show (fromIntegral (ord c) :: Word32))
456 | otherwise = text (show c)
458 pprHsString :: FastString -> SDoc
459 pprHsString fs = text (show (unpackFS fs))
463 %************************************************************************
465 \subsection{Other helper functions}
467 %************************************************************************
470 pprWithCommas :: (a -> SDoc) -> [a] -> SDoc
471 pprWithCommas pp xs = fsep (punctuate comma (map pp xs))
473 interppSP :: Outputable a => [a] -> SDoc
474 interppSP xs = sep (map ppr xs)
476 interpp'SP :: Outputable a => [a] -> SDoc
477 interpp'SP xs = sep (punctuate comma (map ppr xs))
479 pprQuotedList :: Outputable a => [a] -> SDoc
480 -- [x,y,z] ==> `x', `y', `z'
481 pprQuotedList xs = hsep (punctuate comma (map (quotes . ppr) xs))
485 %************************************************************************
487 \subsection{Printing numbers verbally}
489 %************************************************************************
491 @speakNth@ converts an integer to a verbal index; eg 1 maps to
495 speakNth :: Int -> SDoc
496 speakNth 1 = ptext SLIT("first")
497 speakNth 2 = ptext SLIT("second")
498 speakNth 3 = ptext SLIT("third")
499 speakNth 4 = ptext SLIT("fourth")
500 speakNth 5 = ptext SLIT("fifth")
501 speakNth 6 = ptext SLIT("sixth")
502 speakNth n = hcat [ int n, text suffix ]
504 suffix | n <= 20 = "th" -- 11,12,13 are non-std
505 | last_dig == 1 = "st"
506 | last_dig == 2 = "nd"
507 | last_dig == 3 = "rd"
510 last_dig = n `rem` 10
512 speakN :: Int -> SDoc
513 speakN 0 = ptext SLIT("none") -- E.g. "he has none"
514 speakN 1 = ptext SLIT("one") -- E.g. "he has one"
515 speakN 2 = ptext SLIT("two")
516 speakN 3 = ptext SLIT("three")
517 speakN 4 = ptext SLIT("four")
518 speakN 5 = ptext SLIT("five")
519 speakN 6 = ptext SLIT("six")
522 speakNOf :: Int -> SDoc -> SDoc
523 speakNOf 0 d = ptext SLIT("no") <+> d <> char 's' -- E.g. "no arguments"
524 speakNOf 1 d = ptext SLIT("one") <+> d -- E.g. "one argument"
525 speakNOf n d = speakN n <+> d <> char 's' -- E.g. "three arguments"
527 speakNTimes :: Int {- >=1 -} -> SDoc
528 speakNTimes t | t == 1 = ptext SLIT("once")
529 | t == 2 = ptext SLIT("twice")
530 | otherwise = speakN t <+> ptext SLIT("times")
537 %************************************************************************
539 \subsection{Error handling}
541 %************************************************************************
544 pprPanic, pprPgmError :: String -> SDoc -> a
545 pprTrace :: String -> SDoc -> a -> a
546 pprPanic = pprAndThen panic -- Throw an exn saying "bug in GHC"
548 pprPgmError = pprAndThen pgmError -- Throw an exn saying "bug in pgm being compiled"
549 -- (used for unusual pgm errors)
550 pprTrace = pprAndThen trace
552 pprPanic# heading pretty_msg = panic# (show (doc PprDebug))
554 doc = text heading <+> pretty_msg
556 pprAndThen :: (String -> a) -> String -> SDoc -> a
557 pprAndThen cont heading pretty_msg = cont (show (doc PprDebug))
559 doc = sep [text heading, nest 4 pretty_msg]
561 assertPprPanic :: String -> Int -> SDoc -> a
562 assertPprPanic file line msg
563 = panic (show (doc PprDebug))
565 doc = sep [hsep[text "ASSERT failed! file",
567 text "line", int line],
570 warnPprTrace :: Bool -> String -> Int -> SDoc -> a -> a
571 warnPprTrace False file line msg x = x
572 warnPprTrace True file line msg x
573 = trace (show (doc PprDebug)) x
575 doc = sep [hsep [text "WARNING: file", text file, text "line", int line],