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, neverQualify,
17 getPprStyle, withPprStyle, withPprStyleDoc,
18 pprDeeper, pprDeeperList, pprSetDepth,
19 codeStyle, userStyle, debugStyle, dumpStyle, asmStyle,
20 ifPprDebug, qualName, qualModule,
21 mkErrStyle, defaultErrStyle, defaultDumpStyle, defaultUserStyle,
26 interppSP, interpp'SP, pprQuotedList, pprWithCommas,
28 text, char, ftext, ptext,
29 int, integer, float, double, rational,
30 parens, cparen, brackets, braces, quotes, doubleQuotes, angleBrackets,
31 semi, comma, colon, dcolon, space, equals, dot, arrow,
32 lparen, rparen, lbrack, rbrack, lbrace, rbrace, underscore,
33 (<>), (<+>), hcat, hsep,
38 speakNth, speakNTimes, speakN, speakNOf, plural,
40 printSDoc, printErrs, hPrintDump, printDump,
41 printForC, printForAsm, printForUser, printForUserPartWay,
43 showSDoc, showSDocForUser, showSDocDebug, showSDocDump,
44 showSDocUnqual, showsPrecSDoc,
45 pprHsChar, pprHsString,
48 pprPanic, assertPprPanic, pprPanic#, pprPgmError,
49 pprTrace, warnPprTrace,
50 trace, pgmError, panic, panic#, assertPanic
53 #include "HsVersions.h"
56 import {-# SOURCE #-} Module( Module, ModuleName, moduleName )
57 import {-# SOURCE #-} OccName( OccName )
59 import StaticFlags ( opt_PprStyle_Debug, opt_PprUserLength )
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 printForUserPartWay :: Handle -> Int -> PrintUnqualified -> SDoc -> IO ()
292 printForUserPartWay handle d unqual doc
293 = Pretty.printDoc PageMode handle (doc (mkUserStyle unqual (PartWay d)))
295 -- printForC, printForAsm do what they sound like
296 printForC :: Handle -> SDoc -> IO ()
297 printForC handle doc = Pretty.printDoc LeftMode handle (doc (PprCode CStyle))
299 printForAsm :: Handle -> SDoc -> IO ()
300 printForAsm handle doc = Pretty.printDoc LeftMode handle (doc (PprCode AsmStyle))
302 pprCode :: CodeStyle -> SDoc -> SDoc
303 pprCode cs d = withPprStyle (PprCode cs) d
305 mkCodeStyle :: CodeStyle -> PprStyle
306 mkCodeStyle = PprCode
308 -- Can't make SDoc an instance of Show because SDoc is just a function type
309 -- However, Doc *is* an instance of Show
310 -- showSDoc just blasts it out as a string
311 showSDoc :: SDoc -> String
312 showSDoc d = show (d defaultUserStyle)
314 showSDocForUser :: PrintUnqualified -> SDoc -> String
315 showSDocForUser unqual doc = show (doc (mkUserStyle unqual AllTheWay))
317 showSDocUnqual :: SDoc -> String
318 -- Only used in the gruesome HsExpr.isOperator
319 showSDocUnqual d = show (d (mkUserStyle neverQualify AllTheWay))
321 showsPrecSDoc :: Int -> SDoc -> ShowS
322 showsPrecSDoc p d = showsPrec p (d defaultUserStyle)
324 showSDocDump :: SDoc -> String
325 showSDocDump d = show (d PprDump)
327 showSDocDebug :: SDoc -> String
328 showSDocDebug d = show (d PprDebug)
332 docToSDoc :: Doc -> SDoc
333 docToSDoc d = \_ -> d
336 text :: String -> SDoc
338 ftext :: FastString -> SDoc
339 ptext :: Ptr t -> SDoc
341 integer :: Integer -> SDoc
342 float :: Float -> SDoc
343 double :: Double -> SDoc
344 rational :: Rational -> SDoc
346 empty _sty = Pretty.empty
347 text s _sty = Pretty.text s
348 char c _sty = Pretty.char c
349 ftext s _sty = Pretty.ftext s
350 ptext s _sty = Pretty.ptext s
351 int n _sty = Pretty.int n
352 integer n _sty = Pretty.integer n
353 float n _sty = Pretty.float n
354 double n _sty = Pretty.double n
355 rational n _sty = Pretty.rational n
357 parens, braces, brackets, quotes, doubleQuotes, angleBrackets :: SDoc -> SDoc
359 parens d sty = Pretty.parens (d sty)
360 braces d sty = Pretty.braces (d sty)
361 brackets d sty = Pretty.brackets (d sty)
362 doubleQuotes d sty = Pretty.doubleQuotes (d sty)
363 angleBrackets d = char '<' <> d <> char '>'
365 cparen :: Bool -> SDoc -> SDoc
367 cparen b d sty = Pretty.cparen b (d sty)
369 -- quotes encloses something in single quotes...
370 -- but it omits them if the thing ends in a single quote
371 -- so that we don't get `foo''. Instead we just have foo'.
372 quotes d sty = case show pp_d of
374 _other -> Pretty.quotes pp_d
378 semi, comma, colon, equals, space, dcolon, arrow, underscore, dot :: SDoc
379 lparen, rparen, lbrack, rbrack, lbrace, rbrace :: SDoc
381 semi _sty = Pretty.semi
382 comma _sty = Pretty.comma
383 colon _sty = Pretty.colon
384 equals _sty = Pretty.equals
385 space _sty = Pretty.space
386 dcolon _sty = Pretty.ptext SLIT("::")
387 arrow _sty = Pretty.ptext SLIT("->")
388 underscore = char '_'
390 lparen _sty = Pretty.lparen
391 rparen _sty = Pretty.rparen
392 lbrack _sty = Pretty.lbrack
393 rbrack _sty = Pretty.rbrack
394 lbrace _sty = Pretty.lbrace
395 rbrace _sty = Pretty.rbrace
397 nest :: Int -> SDoc -> SDoc
398 (<>), (<+>), ($$), ($+$) :: SDoc -> SDoc -> SDoc
400 nest n d sty = Pretty.nest n (d sty)
401 (<>) d1 d2 sty = (Pretty.<>) (d1 sty) (d2 sty)
402 (<+>) d1 d2 sty = (Pretty.<+>) (d1 sty) (d2 sty)
403 ($$) d1 d2 sty = (Pretty.$$) (d1 sty) (d2 sty)
404 ($+$) d1 d2 sty = (Pretty.$+$) (d1 sty) (d2 sty)
406 hcat, hsep, vcat, sep, cat, fsep, fcat :: [SDoc] -> SDoc
409 hcat ds sty = Pretty.hcat [d sty | d <- ds]
410 hsep ds sty = Pretty.hsep [d sty | d <- ds]
411 vcat ds sty = Pretty.vcat [d sty | d <- ds]
412 sep ds sty = Pretty.sep [d sty | d <- ds]
413 cat ds sty = Pretty.cat [d sty | d <- ds]
414 fsep ds sty = Pretty.fsep [d sty | d <- ds]
415 fcat ds sty = Pretty.fcat [d sty | d <- ds]
417 hang :: SDoc -> Int -> SDoc -> SDoc
419 hang d1 n d2 sty = Pretty.hang (d1 sty) n (d2 sty)
421 punctuate :: SDoc -> [SDoc] -> [SDoc]
423 punctuate p (d:ds) = go d ds
426 go d (e:es) = (d <> p) : go e es
430 %************************************************************************
432 \subsection[Outputable-class]{The @Outputable@ class}
434 %************************************************************************
437 class Outputable a where
442 instance Outputable Bool where
443 ppr True = ptext SLIT("True")
444 ppr False = ptext SLIT("False")
446 instance Outputable Int where
449 instance Outputable () where
452 instance (Outputable a) => Outputable [a] where
453 ppr xs = brackets (fsep (punctuate comma (map ppr xs)))
455 instance (Outputable a, Outputable b) => Outputable (a, b) where
456 ppr (x,y) = parens (sep [ppr x <> comma, ppr y])
458 instance Outputable a => Outputable (Maybe a) where
459 ppr Nothing = ptext SLIT("Nothing")
460 ppr (Just x) = ptext SLIT("Just") <+> ppr x
462 instance (Outputable a, Outputable b) => Outputable (Either a b) where
463 ppr (Left x) = ptext SLIT("Left") <+> ppr x
464 ppr (Right y) = ptext SLIT("Right") <+> ppr y
466 -- ToDo: may not be used
467 instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c) where
469 parens (sep [ppr x <> comma,
473 instance (Outputable a, Outputable b, Outputable c, Outputable d) =>
474 Outputable (a, b, c, d) where
476 parens (sep [ppr x <> comma,
481 instance Outputable FastString where
482 ppr fs = ftext fs -- Prints an unadorned string,
483 -- no double quotes or anything
487 %************************************************************************
489 \subsection{The @OutputableBndr@ class}
491 %************************************************************************
493 When we print a binder, we often want to print its type too.
494 The @OutputableBndr@ class encapsulates this idea.
496 @BindingSite@ is used to tell the thing that prints binder what
497 language construct is binding the identifier. This can be used
498 to decide how much info to print.
501 data BindingSite = LambdaBind | CaseBind | LetBind
503 class Outputable a => OutputableBndr a where
504 pprBndr :: BindingSite -> a -> SDoc
510 %************************************************************************
512 \subsection{Random printing helpers}
514 %************************************************************************
517 -- We have 31-bit Chars and will simply use Show instances
518 -- of Char and String.
520 pprHsChar :: Char -> SDoc
521 pprHsChar c | c > '\x10ffff' = char '\\' <> text (show (fromIntegral (ord c) :: Word32))
522 | otherwise = text (show c)
524 pprHsString :: FastString -> SDoc
525 pprHsString fs = text (show (unpackFS fs))
529 %************************************************************************
531 \subsection{Other helper functions}
533 %************************************************************************
536 pprWithCommas :: (a -> SDoc) -> [a] -> SDoc
537 pprWithCommas pp xs = fsep (punctuate comma (map pp xs))
539 interppSP :: Outputable a => [a] -> SDoc
540 interppSP xs = sep (map ppr xs)
542 interpp'SP :: Outputable a => [a] -> SDoc
543 interpp'SP xs = sep (punctuate comma (map ppr xs))
545 pprQuotedList :: Outputable a => [a] -> SDoc
546 -- [x,y,z] ==> `x', `y', `z'
547 pprQuotedList xs = hsep (punctuate comma (map (quotes . ppr) xs))
551 %************************************************************************
553 \subsection{Printing numbers verbally}
555 %************************************************************************
557 @speakNth@ converts an integer to a verbal index; eg 1 maps to
561 speakNth :: Int -> SDoc
562 speakNth 1 = ptext SLIT("first")
563 speakNth 2 = ptext SLIT("second")
564 speakNth 3 = ptext SLIT("third")
565 speakNth 4 = ptext SLIT("fourth")
566 speakNth 5 = ptext SLIT("fifth")
567 speakNth 6 = ptext SLIT("sixth")
568 speakNth n = hcat [ int n, text suffix ]
570 suffix | n <= 20 = "th" -- 11,12,13 are non-std
571 | last_dig == 1 = "st"
572 | last_dig == 2 = "nd"
573 | last_dig == 3 = "rd"
576 last_dig = n `rem` 10
578 speakN :: Int -> SDoc
579 speakN 0 = ptext SLIT("none") -- E.g. "he has none"
580 speakN 1 = ptext SLIT("one") -- E.g. "he has one"
581 speakN 2 = ptext SLIT("two")
582 speakN 3 = ptext SLIT("three")
583 speakN 4 = ptext SLIT("four")
584 speakN 5 = ptext SLIT("five")
585 speakN 6 = ptext SLIT("six")
588 speakNOf :: Int -> SDoc -> SDoc
589 speakNOf 0 d = ptext SLIT("no") <+> d <> char 's' -- E.g. "no arguments"
590 speakNOf 1 d = ptext SLIT("one") <+> d -- E.g. "one argument"
591 speakNOf n d = speakN n <+> d <> char 's' -- E.g. "three arguments"
593 speakNTimes :: Int {- >=1 -} -> SDoc
594 speakNTimes t | t == 1 = ptext SLIT("once")
595 | t == 2 = ptext SLIT("twice")
596 | otherwise = speakN t <+> ptext SLIT("times")
598 plural :: [a] -> SDoc
599 plural [_] = empty -- a bit frightening, but there you are
604 %************************************************************************
606 \subsection{Error handling}
608 %************************************************************************
611 pprPanic, pprPgmError :: String -> SDoc -> a
612 pprTrace :: String -> SDoc -> a -> a
613 pprPanic = pprAndThen panic -- Throw an exn saying "bug in GHC"
615 pprPgmError = pprAndThen pgmError -- Throw an exn saying "bug in pgm being compiled"
616 -- (used for unusual pgm errors)
617 pprTrace = pprAndThen trace
619 pprPanic# :: String -> SDoc -> FastInt
620 pprPanic# heading pretty_msg = panic# (show (doc PprDebug))
622 doc = text heading <+> pretty_msg
624 pprAndThen :: (String -> a) -> String -> SDoc -> a
625 pprAndThen cont heading pretty_msg = cont (show (doc PprDebug))
627 doc = sep [text heading, nest 4 pretty_msg]
629 assertPprPanic :: String -> Int -> SDoc -> a
630 assertPprPanic file line msg
631 = panic (show (doc PprDebug))
633 doc = sep [hsep[text "ASSERT failed! file",
635 text "line", int line],
638 warnPprTrace :: Bool -> String -> Int -> SDoc -> a -> a
639 warnPprTrace False _file _line _msg x = x
640 warnPprTrace True file line msg x
641 = trace (show (doc PprDebug)) x
643 doc = sep [hsep [text "WARNING: file", text file, text "line", int line],