2 % (c) The University of Glasgow 2006
3 % (c) The GRASP Project, Glasgow University, 1992-1998
6 Outputable: defines classes for pretty-printing and forcing, both
11 Outputable(..), OutputableBndr(..), -- Class
15 PprStyle, CodeStyle(..), PrintUnqualified, alwaysQualify, QualifyName(..),
16 getPprStyle, withPprStyle, withPprStyleDoc,
17 pprDeeper, pprDeeperList, 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, cparen, 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, hPrintDump, 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,
55 ModuleName, moduleName )
56 import {-# SOURCE #-} OccName( OccName )
58 import StaticFlags ( opt_PprStyle_Debug, opt_PprUserLength )
59 import PackageConfig ( PackageId, packageIdString )
63 import qualified Pretty
64 import Pretty ( Doc, Mode(..) )
67 import Data.Word ( Word32 )
68 import System.IO ( Handle, stderr, stdout, hFlush )
69 import Data.Char ( ord )
73 %************************************************************************
75 \subsection{The @PprStyle@ data type}
77 %************************************************************************
82 = PprUser PrintUnqualified Depth
83 -- Pretty-print in a way that will make sense to the
84 -- ordinary user; must be very close to Haskell
86 -- Assumes printing tidied code: non-system names are
87 -- printed without uniques.
90 -- Print code; either C or assembler
92 | PprDump -- For -ddump-foo; less verbose than PprDebug.
93 -- Does not assume tidied code: non-external names
94 -- are printed with uniques.
96 | PprDebug -- Full debugging output
98 data CodeStyle = CStyle -- The format of labels differs for C and assembler
101 data Depth = AllTheWay
102 | PartWay Int -- 0 => stop
105 -- -----------------------------------------------------------------------------
106 -- Printing original names
108 -- When printing code that contains original names, we need to map the
109 -- original names back to something the user understands. This is the
110 -- purpose of the pair of functions that gets passed around
111 -- when rendering 'SDoc'.
113 -- | given an /original/ name, this function tells you which module
114 -- name it should be qualified with when printing for the user, if
115 -- any. For example, given @Control.Exception.catch@, which is in scope
116 -- as @Exception.catch@, this fuction will return @Just "Exception"@.
117 -- Note that the return value is a ModuleName, not a Module, because
118 -- in source code, names are qualified by ModuleNames.
119 type QueryQualifyName = Module -> OccName -> QualifyName
121 data QualifyName -- given P:M.T
122 = NameUnqual -- refer to it as "T"
123 | NameQual ModuleName -- refer to it as "X.T" for the supplied X
125 -- it is not in scope at all, but M.T is not bound in the current
126 -- scope, so we can refer to it as "M.T"
128 -- it is not in scope at all, and M.T is already bound in the
129 -- current scope, so we must refer to it as "P:M.T"
132 -- | For a given module, we need to know whether to print it with
133 -- a package name to disambiguate it.
134 type QueryQualifyModule = Module -> Bool
136 type PrintUnqualified = (QueryQualifyName, QueryQualifyModule)
138 alwaysQualifyNames :: QueryQualifyName
139 alwaysQualifyNames m _ = NameQual (moduleName m)
141 neverQualifyNames :: QueryQualifyName
142 neverQualifyNames _ _ = NameUnqual
144 alwaysQualifyModules :: QueryQualifyModule
145 alwaysQualifyModules _ = True
147 neverQualifyModules :: QueryQualifyModule
148 neverQualifyModules _ = False
150 type QueryQualifies = (QueryQualifyName, QueryQualifyModule)
152 alwaysQualify, neverQualify :: QueryQualifies
153 alwaysQualify = (alwaysQualifyNames, alwaysQualifyModules)
154 neverQualify = (neverQualifyNames, neverQualifyModules)
156 defaultUserStyle, defaultDumpStyle :: PprStyle
158 defaultUserStyle = mkUserStyle alwaysQualify AllTheWay
160 defaultDumpStyle | opt_PprStyle_Debug = PprDebug
161 | otherwise = PprDump
163 -- | Style for printing error messages
164 mkErrStyle :: PrintUnqualified -> PprStyle
165 mkErrStyle qual = mkUserStyle qual (PartWay opt_PprUserLength)
167 defaultErrStyle :: PprStyle
168 -- Default style for error messages
169 -- It's a bit of a hack because it doesn't take into account what's in scope
170 -- Only used for desugarer warnings, and typechecker errors in interface sigs
172 | opt_PprStyle_Debug = mkUserStyle alwaysQualify AllTheWay
173 | otherwise = mkUserStyle alwaysQualify (PartWay opt_PprUserLength)
175 mkUserStyle :: QueryQualifies -> Depth -> PprStyle
176 mkUserStyle unqual depth
177 | opt_PprStyle_Debug = PprDebug
178 | otherwise = PprUser unqual depth
181 Orthogonal to the above printing styles are (possibly) some
182 command-line flags that affect printing (often carried with the
183 style). The most likely ones are variations on how much type info is
186 The following test decides whether or not we are actually generating
187 code (either C or assembly), or generating interface files.
189 %************************************************************************
191 \subsection{The @SDoc@ data type}
193 %************************************************************************
196 type SDoc = PprStyle -> Doc
198 withPprStyle :: PprStyle -> SDoc -> SDoc
199 withPprStyle sty d _sty' = d sty
201 withPprStyleDoc :: PprStyle -> SDoc -> Doc
202 withPprStyleDoc sty d = d sty
204 pprDeeper :: SDoc -> SDoc
205 pprDeeper _ (PprUser _ (PartWay 0)) = Pretty.text "..."
206 pprDeeper d (PprUser q (PartWay n)) = d (PprUser q (PartWay (n-1)))
207 pprDeeper d other_sty = d other_sty
209 pprDeeperList :: ([SDoc] -> SDoc) -> [SDoc] -> SDoc
210 -- Truncate a list that list that is longer than the current depth
211 pprDeeperList f ds (PprUser q (PartWay n))
212 | n==0 = Pretty.text "..."
213 | otherwise = f (go 0 ds) (PprUser q (PartWay (n-1)))
216 go i (d:ds) | i >= n = [text "...."]
217 | otherwise = d : go (i+1) ds
219 pprDeeperList f ds other_sty
222 pprSetDepth :: Int -> SDoc -> SDoc
223 pprSetDepth n d (PprUser q _) = d (PprUser q (PartWay n))
224 pprSetDepth _n d other_sty = d other_sty
226 getPprStyle :: (PprStyle -> SDoc) -> SDoc
227 getPprStyle df sty = df sty sty
231 qualName :: PprStyle -> QueryQualifyName
232 qualName (PprUser (qual_name,_) _) m n = qual_name m n
233 qualName _other m _n = NameQual (moduleName m)
235 qualModule :: PprStyle -> QueryQualifyModule
236 qualModule (PprUser (_,qual_mod) _) m = qual_mod m
237 qualModule _other _m = True
239 codeStyle :: PprStyle -> Bool
240 codeStyle (PprCode _) = True
243 asmStyle :: PprStyle -> Bool
244 asmStyle (PprCode AsmStyle) = True
245 asmStyle _other = False
247 dumpStyle :: PprStyle -> Bool
248 dumpStyle PprDump = True
249 dumpStyle _other = False
251 debugStyle :: PprStyle -> Bool
252 debugStyle PprDebug = True
253 debugStyle _other = False
255 userStyle :: PprStyle -> Bool
256 userStyle (PprUser _ _) = True
257 userStyle _other = False
259 ifPprDebug :: SDoc -> SDoc -- Empty for non-debug style
260 ifPprDebug d sty@PprDebug = d sty
261 ifPprDebug _ _ = Pretty.empty
266 printSDoc :: SDoc -> PprStyle -> IO ()
268 Pretty.printDoc PageMode stdout (d sty)
271 -- I'm not sure whether the direct-IO approach of Pretty.printDoc
272 -- above is better or worse than the put-big-string approach here
273 printErrs :: Doc -> IO ()
274 printErrs doc = do Pretty.printDoc PageMode stderr doc
277 printDump :: SDoc -> IO ()
278 printDump doc = hPrintDump stdout doc
280 hPrintDump :: Handle -> SDoc -> IO ()
281 hPrintDump h doc = do
282 Pretty.printDoc PageMode h (better_doc defaultDumpStyle)
285 better_doc = doc $$ text ""
287 printForUser :: Handle -> PrintUnqualified -> SDoc -> IO ()
288 printForUser handle unqual doc
289 = Pretty.printDoc PageMode handle (doc (mkUserStyle unqual AllTheWay))
291 -- printForC, printForAsm do what they sound like
292 printForC :: Handle -> SDoc -> IO ()
293 printForC handle doc = Pretty.printDoc LeftMode handle (doc (PprCode CStyle))
295 printForAsm :: Handle -> SDoc -> IO ()
296 printForAsm handle doc = Pretty.printDoc LeftMode handle (doc (PprCode AsmStyle))
298 pprCode :: CodeStyle -> SDoc -> SDoc
299 pprCode cs d = withPprStyle (PprCode cs) d
301 mkCodeStyle :: CodeStyle -> PprStyle
302 mkCodeStyle = PprCode
304 -- Can't make SDoc an instance of Show because SDoc is just a function type
305 -- However, Doc *is* an instance of Show
306 -- showSDoc just blasts it out as a string
307 showSDoc :: SDoc -> String
308 showSDoc d = show (d defaultUserStyle)
310 showSDocForUser :: PrintUnqualified -> SDoc -> String
311 showSDocForUser unqual doc = show (doc (mkUserStyle unqual AllTheWay))
313 showSDocUnqual :: SDoc -> String
314 -- Only used in the gruesome HsExpr.isOperator
315 showSDocUnqual d = show (d (mkUserStyle neverQualify AllTheWay))
317 showsPrecSDoc :: Int -> SDoc -> ShowS
318 showsPrecSDoc p d = showsPrec p (d defaultUserStyle)
320 showSDocDump :: SDoc -> String
321 showSDocDump d = show (d PprDump)
323 showSDocDebug :: SDoc -> String
324 showSDocDebug d = show (d PprDebug)
328 docToSDoc :: Doc -> SDoc
329 docToSDoc d = \_ -> d
332 text :: String -> SDoc
334 ftext :: FastString -> SDoc
335 ptext :: Ptr t -> SDoc
337 integer :: Integer -> SDoc
338 float :: Float -> SDoc
339 double :: Double -> SDoc
340 rational :: Rational -> SDoc
342 empty _sty = Pretty.empty
343 text s _sty = Pretty.text s
344 char c _sty = Pretty.char c
345 ftext s _sty = Pretty.ftext s
346 ptext s _sty = Pretty.ptext s
347 int n _sty = Pretty.int n
348 integer n _sty = Pretty.integer n
349 float n _sty = Pretty.float n
350 double n _sty = Pretty.double n
351 rational n _sty = Pretty.rational n
353 parens, braces, brackets, quotes, doubleQuotes, angleBrackets :: SDoc -> SDoc
355 parens d sty = Pretty.parens (d sty)
356 braces d sty = Pretty.braces (d sty)
357 brackets d sty = Pretty.brackets (d sty)
358 doubleQuotes d sty = Pretty.doubleQuotes (d sty)
359 angleBrackets d = char '<' <> d <> char '>'
361 cparen :: Bool -> SDoc -> SDoc
363 cparen b d sty = Pretty.cparen b (d sty)
365 -- quotes encloses something in single quotes...
366 -- but it omits them if the thing ends in a single quote
367 -- so that we don't get `foo''. Instead we just have foo'.
368 quotes d sty = case show pp_d of
370 _other -> Pretty.quotes pp_d
374 semi, comma, colon, equals, space, dcolon, arrow, underscore, dot :: SDoc
375 lparen, rparen, lbrack, rbrack, lbrace, rbrace :: SDoc
377 semi _sty = Pretty.semi
378 comma _sty = Pretty.comma
379 colon _sty = Pretty.colon
380 equals _sty = Pretty.equals
381 space _sty = Pretty.space
382 dcolon _sty = Pretty.ptext SLIT("::")
383 arrow _sty = Pretty.ptext SLIT("->")
384 underscore = char '_'
386 lparen _sty = Pretty.lparen
387 rparen _sty = Pretty.rparen
388 lbrack _sty = Pretty.lbrack
389 rbrack _sty = Pretty.rbrack
390 lbrace _sty = Pretty.lbrace
391 rbrace _sty = Pretty.rbrace
393 nest :: Int -> SDoc -> SDoc
394 (<>), (<+>), ($$), ($+$) :: SDoc -> SDoc -> SDoc
396 nest n d sty = Pretty.nest n (d sty)
397 (<>) d1 d2 sty = (Pretty.<>) (d1 sty) (d2 sty)
398 (<+>) d1 d2 sty = (Pretty.<+>) (d1 sty) (d2 sty)
399 ($$) d1 d2 sty = (Pretty.$$) (d1 sty) (d2 sty)
400 ($+$) d1 d2 sty = (Pretty.$+$) (d1 sty) (d2 sty)
402 hcat, hsep, vcat, sep, cat, fsep, fcat :: [SDoc] -> SDoc
405 hcat ds sty = Pretty.hcat [d sty | d <- ds]
406 hsep ds sty = Pretty.hsep [d sty | d <- ds]
407 vcat ds sty = Pretty.vcat [d sty | d <- ds]
408 sep ds sty = Pretty.sep [d sty | d <- ds]
409 cat ds sty = Pretty.cat [d sty | d <- ds]
410 fsep ds sty = Pretty.fsep [d sty | d <- ds]
411 fcat ds sty = Pretty.fcat [d sty | d <- ds]
413 hang :: SDoc -> Int -> SDoc -> SDoc
415 hang d1 n d2 sty = Pretty.hang (d1 sty) n (d2 sty)
417 punctuate :: SDoc -> [SDoc] -> [SDoc]
419 punctuate p (d:ds) = go d ds
422 go d (e:es) = (d <> p) : go e es
426 %************************************************************************
428 \subsection[Outputable-class]{The @Outputable@ class}
430 %************************************************************************
433 class Outputable a where
438 instance Outputable Bool where
439 ppr True = ptext SLIT("True")
440 ppr False = ptext SLIT("False")
442 instance Outputable Int where
445 instance Outputable () where
448 instance (Outputable a) => Outputable [a] where
449 ppr xs = brackets (fsep (punctuate comma (map ppr xs)))
451 instance (Outputable a, Outputable b) => Outputable (a, b) where
452 ppr (x,y) = parens (sep [ppr x <> comma, ppr y])
454 instance Outputable a => Outputable (Maybe a) where
455 ppr Nothing = ptext SLIT("Nothing")
456 ppr (Just x) = ptext SLIT("Just") <+> ppr x
458 instance (Outputable a, Outputable b) => Outputable (Either a b) where
459 ppr (Left x) = ptext SLIT("Left") <+> ppr x
460 ppr (Right y) = ptext SLIT("Right") <+> ppr y
462 -- ToDo: may not be used
463 instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c) where
465 parens (sep [ppr x <> comma,
469 instance (Outputable a, Outputable b, Outputable c, Outputable d) =>
470 Outputable (a, b, c, d) where
472 parens (sep [ppr x <> comma,
477 instance Outputable FastString where
478 ppr fs = ftext fs -- Prints an unadorned string,
479 -- no double quotes or anything
481 instance Outputable PackageId where
482 ppr pid = text (packageIdString pid)
486 %************************************************************************
488 \subsection{The @OutputableBndr@ class}
490 %************************************************************************
492 When we print a binder, we often want to print its type too.
493 The @OutputableBndr@ class encapsulates this idea.
495 @BindingSite@ is used to tell the thing that prints binder what
496 language construct is binding the identifier. This can be used
497 to decide how much info to print.
500 data BindingSite = LambdaBind | CaseBind | LetBind
502 class Outputable a => OutputableBndr a where
503 pprBndr :: BindingSite -> a -> SDoc
509 %************************************************************************
511 \subsection{Random printing helpers}
513 %************************************************************************
516 -- We have 31-bit Chars and will simply use Show instances
517 -- of Char and String.
519 pprHsChar :: Char -> SDoc
520 pprHsChar c | c > '\x10ffff' = char '\\' <> text (show (fromIntegral (ord c) :: Word32))
521 | otherwise = text (show c)
523 pprHsString :: FastString -> SDoc
524 pprHsString fs = text (show (unpackFS fs))
528 %************************************************************************
530 \subsection{Other helper functions}
532 %************************************************************************
535 pprWithCommas :: (a -> SDoc) -> [a] -> SDoc
536 pprWithCommas pp xs = fsep (punctuate comma (map pp xs))
538 interppSP :: Outputable a => [a] -> SDoc
539 interppSP xs = sep (map ppr xs)
541 interpp'SP :: Outputable a => [a] -> SDoc
542 interpp'SP xs = sep (punctuate comma (map ppr xs))
544 pprQuotedList :: Outputable a => [a] -> SDoc
545 -- [x,y,z] ==> `x', `y', `z'
546 pprQuotedList xs = hsep (punctuate comma (map (quotes . ppr) xs))
550 %************************************************************************
552 \subsection{Printing numbers verbally}
554 %************************************************************************
556 @speakNth@ converts an integer to a verbal index; eg 1 maps to
560 speakNth :: Int -> SDoc
561 speakNth 1 = ptext SLIT("first")
562 speakNth 2 = ptext SLIT("second")
563 speakNth 3 = ptext SLIT("third")
564 speakNth 4 = ptext SLIT("fourth")
565 speakNth 5 = ptext SLIT("fifth")
566 speakNth 6 = ptext SLIT("sixth")
567 speakNth n = hcat [ int n, text suffix ]
569 suffix | n <= 20 = "th" -- 11,12,13 are non-std
570 | last_dig == 1 = "st"
571 | last_dig == 2 = "nd"
572 | last_dig == 3 = "rd"
575 last_dig = n `rem` 10
577 speakN :: Int -> SDoc
578 speakN 0 = ptext SLIT("none") -- E.g. "he has none"
579 speakN 1 = ptext SLIT("one") -- E.g. "he has one"
580 speakN 2 = ptext SLIT("two")
581 speakN 3 = ptext SLIT("three")
582 speakN 4 = ptext SLIT("four")
583 speakN 5 = ptext SLIT("five")
584 speakN 6 = ptext SLIT("six")
587 speakNOf :: Int -> SDoc -> SDoc
588 speakNOf 0 d = ptext SLIT("no") <+> d <> char 's' -- E.g. "no arguments"
589 speakNOf 1 d = ptext SLIT("one") <+> d -- E.g. "one argument"
590 speakNOf n d = speakN n <+> d <> char 's' -- E.g. "three arguments"
592 speakNTimes :: Int {- >=1 -} -> SDoc
593 speakNTimes t | t == 1 = ptext SLIT("once")
594 | t == 2 = ptext SLIT("twice")
595 | otherwise = speakN t <+> ptext SLIT("times")
597 plural :: [a] -> SDoc
598 plural [_] = empty -- a bit frightening, but there you are
603 %************************************************************************
605 \subsection{Error handling}
607 %************************************************************************
610 pprPanic, pprPgmError :: String -> SDoc -> a
611 pprTrace :: String -> SDoc -> a -> a
612 pprPanic = pprAndThen panic -- Throw an exn saying "bug in GHC"
614 pprPgmError = pprAndThen pgmError -- Throw an exn saying "bug in pgm being compiled"
615 -- (used for unusual pgm errors)
616 pprTrace = pprAndThen trace
618 pprPanic# :: String -> SDoc -> FastInt
619 pprPanic# heading pretty_msg = panic# (show (doc PprDebug))
621 doc = text heading <+> pretty_msg
623 pprAndThen :: (String -> a) -> String -> SDoc -> a
624 pprAndThen cont heading pretty_msg = cont (show (doc PprDebug))
626 doc = sep [text heading, nest 4 pretty_msg]
628 assertPprPanic :: String -> Int -> SDoc -> a
629 assertPprPanic file line msg
630 = panic (show (doc PprDebug))
632 doc = sep [hsep[text "ASSERT failed! file",
634 text "line", int line],
637 warnPprTrace :: Bool -> String -> Int -> SDoc -> a -> a
638 warnPprTrace False _file _line _msg x = x
639 warnPprTrace True file line msg x
640 = trace (show (doc PprDebug)) x
642 doc = sep [hsep [text "WARNING: file", text file, text "line", int line],