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, ModuleName, moduleName )
55 import {-# SOURCE #-} OccName( OccName )
57 import StaticFlags ( opt_PprStyle_Debug, opt_PprUserLength )
61 import qualified Pretty
62 import Pretty ( Doc, Mode(..) )
65 import Data.Word ( Word32 )
66 import System.IO ( Handle, stderr, stdout, hFlush )
67 import Data.Char ( ord )
71 %************************************************************************
73 \subsection{The @PprStyle@ data type}
75 %************************************************************************
80 = PprUser PrintUnqualified Depth
81 -- Pretty-print in a way that will make sense to the
82 -- ordinary user; must be very close to Haskell
84 -- Assumes printing tidied code: non-system names are
85 -- printed without uniques.
88 -- Print code; either C or assembler
90 | PprDump -- For -ddump-foo; less verbose than PprDebug.
91 -- Does not assume tidied code: non-external names
92 -- are printed with uniques.
94 | PprDebug -- Full debugging output
96 data CodeStyle = CStyle -- The format of labels differs for C and assembler
99 data Depth = AllTheWay
100 | PartWay Int -- 0 => stop
103 -- -----------------------------------------------------------------------------
104 -- Printing original names
106 -- When printing code that contains original names, we need to map the
107 -- original names back to something the user understands. This is the
108 -- purpose of the pair of functions that gets passed around
109 -- when rendering 'SDoc'.
111 -- | given an /original/ name, this function tells you which module
112 -- name it should be qualified with when printing for the user, if
113 -- any. For example, given @Control.Exception.catch@, which is in scope
114 -- as @Exception.catch@, this fuction will return @Just "Exception"@.
115 -- Note that the return value is a ModuleName, not a Module, because
116 -- in source code, names are qualified by ModuleNames.
117 type QueryQualifyName = Module -> OccName -> QualifyName
119 data QualifyName -- given P:M.T
120 = NameUnqual -- refer to it as "T"
121 | NameQual ModuleName -- refer to it as "X.T" for the supplied X
123 -- it is not in scope at all, but M.T is not bound in the current
124 -- scope, so we can refer to it as "M.T"
126 -- it is not in scope at all, and M.T is already bound in the
127 -- current scope, so we must refer to it as "P:M.T"
130 -- | For a given module, we need to know whether to print it with
131 -- a package name to disambiguate it.
132 type QueryQualifyModule = Module -> Bool
134 type PrintUnqualified = (QueryQualifyName, QueryQualifyModule)
136 alwaysQualifyNames :: QueryQualifyName
137 alwaysQualifyNames m _ = NameQual (moduleName m)
139 neverQualifyNames :: QueryQualifyName
140 neverQualifyNames _ _ = NameUnqual
142 alwaysQualifyModules :: QueryQualifyModule
143 alwaysQualifyModules _ = True
145 neverQualifyModules :: QueryQualifyModule
146 neverQualifyModules _ = False
148 type QueryQualifies = (QueryQualifyName, QueryQualifyModule)
150 alwaysQualify, neverQualify :: QueryQualifies
151 alwaysQualify = (alwaysQualifyNames, alwaysQualifyModules)
152 neverQualify = (neverQualifyNames, neverQualifyModules)
154 defaultUserStyle, defaultDumpStyle :: PprStyle
156 defaultUserStyle = mkUserStyle alwaysQualify AllTheWay
158 defaultDumpStyle | opt_PprStyle_Debug = PprDebug
159 | otherwise = PprDump
161 -- | Style for printing error messages
162 mkErrStyle :: PrintUnqualified -> PprStyle
163 mkErrStyle qual = mkUserStyle qual (PartWay opt_PprUserLength)
165 defaultErrStyle :: PprStyle
166 -- Default style for error messages
167 -- It's a bit of a hack because it doesn't take into account what's in scope
168 -- Only used for desugarer warnings, and typechecker errors in interface sigs
170 | opt_PprStyle_Debug = mkUserStyle alwaysQualify AllTheWay
171 | otherwise = mkUserStyle alwaysQualify (PartWay opt_PprUserLength)
173 mkUserStyle :: QueryQualifies -> Depth -> PprStyle
174 mkUserStyle unqual depth
175 | opt_PprStyle_Debug = PprDebug
176 | otherwise = PprUser unqual depth
179 Orthogonal to the above printing styles are (possibly) some
180 command-line flags that affect printing (often carried with the
181 style). The most likely ones are variations on how much type info is
184 The following test decides whether or not we are actually generating
185 code (either C or assembly), or generating interface files.
187 %************************************************************************
189 \subsection{The @SDoc@ data type}
191 %************************************************************************
194 type SDoc = PprStyle -> Doc
196 withPprStyle :: PprStyle -> SDoc -> SDoc
197 withPprStyle sty d _sty' = d sty
199 withPprStyleDoc :: PprStyle -> SDoc -> Doc
200 withPprStyleDoc sty d = d sty
202 pprDeeper :: SDoc -> SDoc
203 pprDeeper _ (PprUser _ (PartWay 0)) = Pretty.text "..."
204 pprDeeper d (PprUser q (PartWay n)) = d (PprUser q (PartWay (n-1)))
205 pprDeeper d other_sty = d other_sty
207 pprDeeperList :: ([SDoc] -> SDoc) -> [SDoc] -> SDoc
208 -- Truncate a list that list that is longer than the current depth
209 pprDeeperList f ds (PprUser q (PartWay n))
210 | n==0 = Pretty.text "..."
211 | otherwise = f (go 0 ds) (PprUser q (PartWay (n-1)))
214 go i (d:ds) | i >= n = [text "...."]
215 | otherwise = d : go (i+1) ds
217 pprDeeperList f ds other_sty
220 pprSetDepth :: Int -> SDoc -> SDoc
221 pprSetDepth n d (PprUser q _) = d (PprUser q (PartWay n))
222 pprSetDepth _n d other_sty = d other_sty
224 getPprStyle :: (PprStyle -> SDoc) -> SDoc
225 getPprStyle df sty = df sty sty
229 qualName :: PprStyle -> QueryQualifyName
230 qualName (PprUser (qual_name,_) _) m n = qual_name m n
231 qualName _other m _n = NameQual (moduleName m)
233 qualModule :: PprStyle -> QueryQualifyModule
234 qualModule (PprUser (_,qual_mod) _) m = qual_mod m
235 qualModule _other _m = True
237 codeStyle :: PprStyle -> Bool
238 codeStyle (PprCode _) = True
241 asmStyle :: PprStyle -> Bool
242 asmStyle (PprCode AsmStyle) = True
243 asmStyle _other = False
245 dumpStyle :: PprStyle -> Bool
246 dumpStyle PprDump = True
247 dumpStyle _other = False
249 debugStyle :: PprStyle -> Bool
250 debugStyle PprDebug = True
251 debugStyle _other = False
253 userStyle :: PprStyle -> Bool
254 userStyle (PprUser _ _) = True
255 userStyle _other = False
257 ifPprDebug :: SDoc -> SDoc -- Empty for non-debug style
258 ifPprDebug d sty@PprDebug = d sty
259 ifPprDebug _ _ = Pretty.empty
264 printSDoc :: SDoc -> PprStyle -> IO ()
266 Pretty.printDoc PageMode stdout (d sty)
269 -- I'm not sure whether the direct-IO approach of Pretty.printDoc
270 -- above is better or worse than the put-big-string approach here
271 printErrs :: Doc -> IO ()
272 printErrs doc = do Pretty.printDoc PageMode stderr doc
275 printDump :: SDoc -> IO ()
276 printDump doc = hPrintDump stdout doc
278 hPrintDump :: Handle -> SDoc -> IO ()
279 hPrintDump h doc = do
280 Pretty.printDoc PageMode h (better_doc defaultDumpStyle)
283 better_doc = doc $$ text ""
285 printForUser :: Handle -> PrintUnqualified -> SDoc -> IO ()
286 printForUser handle unqual doc
287 = Pretty.printDoc PageMode handle (doc (mkUserStyle unqual AllTheWay))
289 -- printForC, printForAsm do what they sound like
290 printForC :: Handle -> SDoc -> IO ()
291 printForC handle doc = Pretty.printDoc LeftMode handle (doc (PprCode CStyle))
293 printForAsm :: Handle -> SDoc -> IO ()
294 printForAsm handle doc = Pretty.printDoc LeftMode handle (doc (PprCode AsmStyle))
296 pprCode :: CodeStyle -> SDoc -> SDoc
297 pprCode cs d = withPprStyle (PprCode cs) d
299 mkCodeStyle :: CodeStyle -> PprStyle
300 mkCodeStyle = PprCode
302 -- Can't make SDoc an instance of Show because SDoc is just a function type
303 -- However, Doc *is* an instance of Show
304 -- showSDoc just blasts it out as a string
305 showSDoc :: SDoc -> String
306 showSDoc d = show (d defaultUserStyle)
308 showSDocForUser :: PrintUnqualified -> SDoc -> String
309 showSDocForUser unqual doc = show (doc (mkUserStyle unqual AllTheWay))
311 showSDocUnqual :: SDoc -> String
312 -- Only used in the gruesome HsExpr.isOperator
313 showSDocUnqual d = show (d (mkUserStyle neverQualify AllTheWay))
315 showsPrecSDoc :: Int -> SDoc -> ShowS
316 showsPrecSDoc p d = showsPrec p (d defaultUserStyle)
318 showSDocDump :: SDoc -> String
319 showSDocDump d = show (d PprDump)
321 showSDocDebug :: SDoc -> String
322 showSDocDebug d = show (d PprDebug)
326 docToSDoc :: Doc -> SDoc
327 docToSDoc d = \_ -> d
330 text :: String -> SDoc
332 ftext :: FastString -> SDoc
333 ptext :: Ptr t -> SDoc
335 integer :: Integer -> SDoc
336 float :: Float -> SDoc
337 double :: Double -> SDoc
338 rational :: Rational -> SDoc
340 empty _sty = Pretty.empty
341 text s _sty = Pretty.text s
342 char c _sty = Pretty.char c
343 ftext s _sty = Pretty.ftext s
344 ptext s _sty = Pretty.ptext s
345 int n _sty = Pretty.int n
346 integer n _sty = Pretty.integer n
347 float n _sty = Pretty.float n
348 double n _sty = Pretty.double n
349 rational n _sty = Pretty.rational n
351 parens, braces, brackets, quotes, doubleQuotes, angleBrackets :: SDoc -> SDoc
353 parens d sty = Pretty.parens (d sty)
354 braces d sty = Pretty.braces (d sty)
355 brackets d sty = Pretty.brackets (d sty)
356 doubleQuotes d sty = Pretty.doubleQuotes (d sty)
357 angleBrackets d = char '<' <> d <> char '>'
359 cparen :: Bool -> SDoc -> SDoc
361 cparen b d sty = Pretty.cparen b (d sty)
363 -- quotes encloses something in single quotes...
364 -- but it omits them if the thing ends in a single quote
365 -- so that we don't get `foo''. Instead we just have foo'.
366 quotes d sty = case show pp_d of
368 _other -> Pretty.quotes pp_d
372 semi, comma, colon, equals, space, dcolon, arrow, underscore, dot :: SDoc
373 lparen, rparen, lbrack, rbrack, lbrace, rbrace :: SDoc
375 semi _sty = Pretty.semi
376 comma _sty = Pretty.comma
377 colon _sty = Pretty.colon
378 equals _sty = Pretty.equals
379 space _sty = Pretty.space
380 dcolon _sty = Pretty.ptext SLIT("::")
381 arrow _sty = Pretty.ptext SLIT("->")
382 underscore = char '_'
384 lparen _sty = Pretty.lparen
385 rparen _sty = Pretty.rparen
386 lbrack _sty = Pretty.lbrack
387 rbrack _sty = Pretty.rbrack
388 lbrace _sty = Pretty.lbrace
389 rbrace _sty = Pretty.rbrace
391 nest :: Int -> SDoc -> SDoc
392 (<>), (<+>), ($$), ($+$) :: SDoc -> SDoc -> SDoc
394 nest n d sty = Pretty.nest n (d sty)
395 (<>) d1 d2 sty = (Pretty.<>) (d1 sty) (d2 sty)
396 (<+>) d1 d2 sty = (Pretty.<+>) (d1 sty) (d2 sty)
397 ($$) d1 d2 sty = (Pretty.$$) (d1 sty) (d2 sty)
398 ($+$) d1 d2 sty = (Pretty.$+$) (d1 sty) (d2 sty)
400 hcat, hsep, vcat, sep, cat, fsep, fcat :: [SDoc] -> SDoc
403 hcat ds sty = Pretty.hcat [d sty | d <- ds]
404 hsep ds sty = Pretty.hsep [d sty | d <- ds]
405 vcat ds sty = Pretty.vcat [d sty | d <- ds]
406 sep ds sty = Pretty.sep [d sty | d <- ds]
407 cat ds sty = Pretty.cat [d sty | d <- ds]
408 fsep ds sty = Pretty.fsep [d sty | d <- ds]
409 fcat ds sty = Pretty.fcat [d sty | d <- ds]
411 hang :: SDoc -> Int -> SDoc -> SDoc
413 hang d1 n d2 sty = Pretty.hang (d1 sty) n (d2 sty)
415 punctuate :: SDoc -> [SDoc] -> [SDoc]
417 punctuate p (d:ds) = go d ds
420 go d (e:es) = (d <> p) : go e es
424 %************************************************************************
426 \subsection[Outputable-class]{The @Outputable@ class}
428 %************************************************************************
431 class Outputable a where
436 instance Outputable Bool where
437 ppr True = ptext SLIT("True")
438 ppr False = ptext SLIT("False")
440 instance Outputable Int where
443 instance Outputable () where
446 instance (Outputable a) => Outputable [a] where
447 ppr xs = brackets (fsep (punctuate comma (map ppr xs)))
449 instance (Outputable a, Outputable b) => Outputable (a, b) where
450 ppr (x,y) = parens (sep [ppr x <> comma, ppr y])
452 instance Outputable a => Outputable (Maybe a) where
453 ppr Nothing = ptext SLIT("Nothing")
454 ppr (Just x) = ptext SLIT("Just") <+> ppr x
456 instance (Outputable a, Outputable b) => Outputable (Either a b) where
457 ppr (Left x) = ptext SLIT("Left") <+> ppr x
458 ppr (Right y) = ptext SLIT("Right") <+> ppr y
460 -- ToDo: may not be used
461 instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c) where
463 parens (sep [ppr x <> comma,
467 instance (Outputable a, Outputable b, Outputable c, Outputable d) =>
468 Outputable (a, b, c, d) where
470 parens (sep [ppr x <> comma,
475 instance Outputable FastString where
476 ppr fs = ftext fs -- Prints an unadorned string,
477 -- no double quotes or anything
481 %************************************************************************
483 \subsection{The @OutputableBndr@ class}
485 %************************************************************************
487 When we print a binder, we often want to print its type too.
488 The @OutputableBndr@ class encapsulates this idea.
490 @BindingSite@ is used to tell the thing that prints binder what
491 language construct is binding the identifier. This can be used
492 to decide how much info to print.
495 data BindingSite = LambdaBind | CaseBind | LetBind
497 class Outputable a => OutputableBndr a where
498 pprBndr :: BindingSite -> a -> SDoc
504 %************************************************************************
506 \subsection{Random printing helpers}
508 %************************************************************************
511 -- We have 31-bit Chars and will simply use Show instances
512 -- of Char and String.
514 pprHsChar :: Char -> SDoc
515 pprHsChar c | c > '\x10ffff' = char '\\' <> text (show (fromIntegral (ord c) :: Word32))
516 | otherwise = text (show c)
518 pprHsString :: FastString -> SDoc
519 pprHsString fs = text (show (unpackFS fs))
523 %************************************************************************
525 \subsection{Other helper functions}
527 %************************************************************************
530 pprWithCommas :: (a -> SDoc) -> [a] -> SDoc
531 pprWithCommas pp xs = fsep (punctuate comma (map pp xs))
533 interppSP :: Outputable a => [a] -> SDoc
534 interppSP xs = sep (map ppr xs)
536 interpp'SP :: Outputable a => [a] -> SDoc
537 interpp'SP xs = sep (punctuate comma (map ppr xs))
539 pprQuotedList :: Outputable a => [a] -> SDoc
540 -- [x,y,z] ==> `x', `y', `z'
541 pprQuotedList xs = hsep (punctuate comma (map (quotes . ppr) xs))
545 %************************************************************************
547 \subsection{Printing numbers verbally}
549 %************************************************************************
551 @speakNth@ converts an integer to a verbal index; eg 1 maps to
555 speakNth :: Int -> SDoc
556 speakNth 1 = ptext SLIT("first")
557 speakNth 2 = ptext SLIT("second")
558 speakNth 3 = ptext SLIT("third")
559 speakNth 4 = ptext SLIT("fourth")
560 speakNth 5 = ptext SLIT("fifth")
561 speakNth 6 = ptext SLIT("sixth")
562 speakNth n = hcat [ int n, text suffix ]
564 suffix | n <= 20 = "th" -- 11,12,13 are non-std
565 | last_dig == 1 = "st"
566 | last_dig == 2 = "nd"
567 | last_dig == 3 = "rd"
570 last_dig = n `rem` 10
572 speakN :: Int -> SDoc
573 speakN 0 = ptext SLIT("none") -- E.g. "he has none"
574 speakN 1 = ptext SLIT("one") -- E.g. "he has one"
575 speakN 2 = ptext SLIT("two")
576 speakN 3 = ptext SLIT("three")
577 speakN 4 = ptext SLIT("four")
578 speakN 5 = ptext SLIT("five")
579 speakN 6 = ptext SLIT("six")
582 speakNOf :: Int -> SDoc -> SDoc
583 speakNOf 0 d = ptext SLIT("no") <+> d <> char 's' -- E.g. "no arguments"
584 speakNOf 1 d = ptext SLIT("one") <+> d -- E.g. "one argument"
585 speakNOf n d = speakN n <+> d <> char 's' -- E.g. "three arguments"
587 speakNTimes :: Int {- >=1 -} -> SDoc
588 speakNTimes t | t == 1 = ptext SLIT("once")
589 | t == 2 = ptext SLIT("twice")
590 | otherwise = speakN t <+> ptext SLIT("times")
592 plural :: [a] -> SDoc
593 plural [_] = empty -- a bit frightening, but there you are
598 %************************************************************************
600 \subsection{Error handling}
602 %************************************************************************
605 pprPanic, pprPgmError :: String -> SDoc -> a
606 pprTrace :: String -> SDoc -> a -> a
607 pprPanic = pprAndThen panic -- Throw an exn saying "bug in GHC"
609 pprPgmError = pprAndThen pgmError -- Throw an exn saying "bug in pgm being compiled"
610 -- (used for unusual pgm errors)
611 pprTrace = pprAndThen trace
613 pprPanic# :: String -> SDoc -> FastInt
614 pprPanic# heading pretty_msg = panic# (show (doc PprDebug))
616 doc = text heading <+> pretty_msg
618 pprAndThen :: (String -> a) -> String -> SDoc -> a
619 pprAndThen cont heading pretty_msg = cont (show (doc PprDebug))
621 doc = sep [text heading, nest 4 pretty_msg]
623 assertPprPanic :: String -> Int -> SDoc -> a
624 assertPprPanic file line msg
625 = panic (show (doc PprDebug))
627 doc = sep [hsep[text "ASSERT failed! file",
629 text "line", int line],
632 warnPprTrace :: Bool -> String -> Int -> SDoc -> a -> a
633 warnPprTrace False _file _line _msg x = x
634 warnPprTrace True file line msg x
635 = trace (show (doc PprDebug)) x
637 doc = sep [hsep [text "WARNING: file", text file, text "line", int line],