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, pprPanicFastInt, pprPgmError,
49 pprTrace, warnPprTrace,
50 trace, pgmError, panic, panicFastInt, 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 )
62 import qualified Pretty
63 import Pretty ( Doc, Mode(..) )
66 import Data.Word ( Word32 )
67 import System.IO ( Handle, stderr, stdout, hFlush )
68 import Data.Char ( ord )
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 QueryQualifyName = Module -> OccName -> QualifyName
120 data QualifyName -- given P:M.T
121 = NameUnqual -- refer to it as "T"
122 | NameQual ModuleName -- refer to it as "X.T" for the supplied X
124 -- it is not in scope at all, but M.T is not bound in the current
125 -- scope, so we can refer to it as "M.T"
127 -- it is not in scope at all, and M.T is already bound in the
128 -- current scope, so we must refer to it as "P:M.T"
131 -- | For a given module, we need to know whether to print it with
132 -- a package name to disambiguate it.
133 type QueryQualifyModule = Module -> Bool
135 type PrintUnqualified = (QueryQualifyName, QueryQualifyModule)
137 alwaysQualifyNames :: QueryQualifyName
138 alwaysQualifyNames m _ = NameQual (moduleName m)
140 neverQualifyNames :: QueryQualifyName
141 neverQualifyNames _ _ = NameUnqual
143 alwaysQualifyModules :: QueryQualifyModule
144 alwaysQualifyModules _ = True
146 neverQualifyModules :: QueryQualifyModule
147 neverQualifyModules _ = False
149 type QueryQualifies = (QueryQualifyName, QueryQualifyModule)
151 alwaysQualify, neverQualify :: QueryQualifies
152 alwaysQualify = (alwaysQualifyNames, alwaysQualifyModules)
153 neverQualify = (neverQualifyNames, neverQualifyModules)
155 defaultUserStyle, defaultDumpStyle :: PprStyle
157 defaultUserStyle = mkUserStyle alwaysQualify AllTheWay
159 defaultDumpStyle | opt_PprStyle_Debug = PprDebug
160 | otherwise = PprDump
162 -- | Style for printing error messages
163 mkErrStyle :: PrintUnqualified -> PprStyle
164 mkErrStyle qual = mkUserStyle qual (PartWay opt_PprUserLength)
166 defaultErrStyle :: PprStyle
167 -- Default style for error messages
168 -- It's a bit of a hack because it doesn't take into account what's in scope
169 -- Only used for desugarer warnings, and typechecker errors in interface sigs
171 | opt_PprStyle_Debug = mkUserStyle alwaysQualify AllTheWay
172 | otherwise = mkUserStyle alwaysQualify (PartWay opt_PprUserLength)
174 mkUserStyle :: QueryQualifies -> Depth -> PprStyle
175 mkUserStyle unqual depth
176 | opt_PprStyle_Debug = PprDebug
177 | otherwise = PprUser unqual depth
180 Orthogonal to the above printing styles are (possibly) some
181 command-line flags that affect printing (often carried with the
182 style). The most likely ones are variations on how much type info is
185 The following test decides whether or not we are actually generating
186 code (either C or assembly), or generating interface files.
188 %************************************************************************
190 \subsection{The @SDoc@ data type}
192 %************************************************************************
195 type SDoc = PprStyle -> Doc
197 withPprStyle :: PprStyle -> SDoc -> SDoc
198 withPprStyle sty d _sty' = d sty
200 withPprStyleDoc :: PprStyle -> SDoc -> Doc
201 withPprStyleDoc sty d = d sty
203 pprDeeper :: SDoc -> SDoc
204 pprDeeper _ (PprUser _ (PartWay 0)) = Pretty.text "..."
205 pprDeeper d (PprUser q (PartWay n)) = d (PprUser q (PartWay (n-1)))
206 pprDeeper d other_sty = d other_sty
208 pprDeeperList :: ([SDoc] -> SDoc) -> [SDoc] -> SDoc
209 -- Truncate a list that list that is longer than the current depth
210 pprDeeperList f ds (PprUser q (PartWay n))
211 | n==0 = Pretty.text "..."
212 | otherwise = f (go 0 ds) (PprUser q (PartWay (n-1)))
215 go i (d:ds) | i >= n = [text "...."]
216 | otherwise = d : go (i+1) ds
218 pprDeeperList f ds other_sty
221 pprSetDepth :: Int -> SDoc -> SDoc
222 pprSetDepth n d (PprUser q _) = d (PprUser q (PartWay n))
223 pprSetDepth _n d other_sty = d other_sty
225 getPprStyle :: (PprStyle -> SDoc) -> SDoc
226 getPprStyle df sty = df sty sty
230 qualName :: PprStyle -> QueryQualifyName
231 qualName (PprUser (qual_name,_) _) m n = qual_name m n
232 qualName _other m _n = NameQual (moduleName m)
234 qualModule :: PprStyle -> QueryQualifyModule
235 qualModule (PprUser (_,qual_mod) _) m = qual_mod m
236 qualModule _other _m = True
238 codeStyle :: PprStyle -> Bool
239 codeStyle (PprCode _) = True
242 asmStyle :: PprStyle -> Bool
243 asmStyle (PprCode AsmStyle) = True
244 asmStyle _other = False
246 dumpStyle :: PprStyle -> Bool
247 dumpStyle PprDump = True
248 dumpStyle _other = False
250 debugStyle :: PprStyle -> Bool
251 debugStyle PprDebug = True
252 debugStyle _other = False
254 userStyle :: PprStyle -> Bool
255 userStyle (PprUser _ _) = True
256 userStyle _other = False
258 ifPprDebug :: SDoc -> SDoc -- Empty for non-debug style
259 ifPprDebug d sty@PprDebug = d sty
260 ifPprDebug _ _ = Pretty.empty
265 printSDoc :: SDoc -> PprStyle -> IO ()
267 Pretty.printDoc PageMode stdout (d sty)
270 -- I'm not sure whether the direct-IO approach of Pretty.printDoc
271 -- above is better or worse than the put-big-string approach here
272 printErrs :: Doc -> IO ()
273 printErrs doc = do Pretty.printDoc PageMode stderr doc
276 printDump :: SDoc -> IO ()
277 printDump doc = hPrintDump stdout doc
279 hPrintDump :: Handle -> SDoc -> IO ()
280 hPrintDump h doc = do
281 Pretty.printDoc PageMode h (better_doc defaultDumpStyle)
284 better_doc = doc $$ text ""
286 printForUser :: Handle -> PrintUnqualified -> SDoc -> IO ()
287 printForUser handle unqual doc
288 = Pretty.printDoc PageMode handle (doc (mkUserStyle unqual AllTheWay))
290 printForUserPartWay :: Handle -> Int -> PrintUnqualified -> SDoc -> IO ()
291 printForUserPartWay handle d unqual doc
292 = Pretty.printDoc PageMode handle (doc (mkUserStyle unqual (PartWay d)))
294 -- printForC, printForAsm do what they sound like
295 printForC :: Handle -> SDoc -> IO ()
296 printForC handle doc = Pretty.printDoc LeftMode handle (doc (PprCode CStyle))
298 printForAsm :: Handle -> SDoc -> IO ()
299 printForAsm handle doc = Pretty.printDoc LeftMode handle (doc (PprCode AsmStyle))
301 pprCode :: CodeStyle -> SDoc -> SDoc
302 pprCode cs d = withPprStyle (PprCode cs) d
304 mkCodeStyle :: CodeStyle -> PprStyle
305 mkCodeStyle = PprCode
307 -- Can't make SDoc an instance of Show because SDoc is just a function type
308 -- However, Doc *is* an instance of Show
309 -- showSDoc just blasts it out as a string
310 showSDoc :: SDoc -> String
311 showSDoc d = show (d defaultUserStyle)
313 showSDocForUser :: PrintUnqualified -> SDoc -> String
314 showSDocForUser unqual doc = show (doc (mkUserStyle unqual AllTheWay))
316 showSDocUnqual :: SDoc -> String
317 -- Only used in the gruesome HsExpr.isOperator
318 showSDocUnqual d = show (d (mkUserStyle neverQualify AllTheWay))
320 showsPrecSDoc :: Int -> SDoc -> ShowS
321 showsPrecSDoc p d = showsPrec p (d defaultUserStyle)
323 showSDocDump :: SDoc -> String
324 showSDocDump d = show (d PprDump)
326 showSDocDebug :: SDoc -> String
327 showSDocDebug d = show (d PprDebug)
331 docToSDoc :: Doc -> SDoc
332 docToSDoc d = \_ -> d
335 text :: String -> SDoc
337 ftext :: FastString -> SDoc
338 ptext :: LitString -> SDoc
340 integer :: Integer -> SDoc
341 float :: Float -> SDoc
342 double :: Double -> SDoc
343 rational :: Rational -> SDoc
345 empty _sty = Pretty.empty
346 text s _sty = Pretty.text s
347 char c _sty = Pretty.char c
348 ftext s _sty = Pretty.ftext s
349 ptext s _sty = Pretty.ptext s
350 int n _sty = Pretty.int n
351 integer n _sty = Pretty.integer n
352 float n _sty = Pretty.float n
353 double n _sty = Pretty.double n
354 rational n _sty = Pretty.rational n
356 parens, braces, brackets, quotes, doubleQuotes, angleBrackets :: SDoc -> SDoc
358 parens d sty = Pretty.parens (d sty)
359 braces d sty = Pretty.braces (d sty)
360 brackets d sty = Pretty.brackets (d sty)
361 doubleQuotes d sty = Pretty.doubleQuotes (d sty)
362 angleBrackets d = char '<' <> d <> char '>'
364 cparen :: Bool -> SDoc -> SDoc
366 cparen b d sty = Pretty.cparen b (d sty)
368 -- quotes encloses something in single quotes...
369 -- but it omits them if the thing ends in a single quote
370 -- so that we don't get `foo''. Instead we just have foo'.
371 quotes d sty = case show pp_d of
373 _other -> Pretty.quotes pp_d
377 semi, comma, colon, equals, space, dcolon, arrow, underscore, dot :: SDoc
378 lparen, rparen, lbrack, rbrack, lbrace, rbrace :: SDoc
380 semi _sty = Pretty.semi
381 comma _sty = Pretty.comma
382 colon _sty = Pretty.colon
383 equals _sty = Pretty.equals
384 space _sty = Pretty.space
385 dcolon _sty = Pretty.ptext SLIT("::")
386 arrow _sty = Pretty.ptext SLIT("->")
387 underscore = char '_'
389 lparen _sty = Pretty.lparen
390 rparen _sty = Pretty.rparen
391 lbrack _sty = Pretty.lbrack
392 rbrack _sty = Pretty.rbrack
393 lbrace _sty = Pretty.lbrace
394 rbrace _sty = Pretty.rbrace
396 nest :: Int -> SDoc -> SDoc
397 (<>), (<+>), ($$), ($+$) :: SDoc -> SDoc -> SDoc
399 nest n d sty = Pretty.nest n (d sty)
400 (<>) d1 d2 sty = (Pretty.<>) (d1 sty) (d2 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)
405 hcat, hsep, vcat, sep, cat, fsep, fcat :: [SDoc] -> SDoc
408 hcat ds sty = Pretty.hcat [d sty | d <- ds]
409 hsep ds sty = Pretty.hsep [d sty | d <- ds]
410 vcat ds sty = Pretty.vcat [d sty | d <- ds]
411 sep ds sty = Pretty.sep [d sty | d <- ds]
412 cat ds sty = Pretty.cat [d sty | d <- ds]
413 fsep ds sty = Pretty.fsep [d sty | d <- ds]
414 fcat ds sty = Pretty.fcat [d sty | d <- ds]
416 hang :: SDoc -> Int -> SDoc -> SDoc
418 hang d1 n d2 sty = Pretty.hang (d1 sty) n (d2 sty)
420 punctuate :: SDoc -> [SDoc] -> [SDoc]
422 punctuate p (d:ds) = go d ds
425 go d (e:es) = (d <> p) : go e es
429 %************************************************************************
431 \subsection[Outputable-class]{The @Outputable@ class}
433 %************************************************************************
436 class Outputable a where
441 instance Outputable Bool where
442 ppr True = ptext SLIT("True")
443 ppr False = ptext SLIT("False")
445 instance Outputable Int where
448 instance Outputable () where
451 instance (Outputable a) => Outputable [a] where
452 ppr xs = brackets (fsep (punctuate comma (map ppr xs)))
454 instance (Outputable a, Outputable b) => Outputable (a, b) where
455 ppr (x,y) = parens (sep [ppr x <> comma, ppr y])
457 instance Outputable a => Outputable (Maybe a) where
458 ppr Nothing = ptext SLIT("Nothing")
459 ppr (Just x) = ptext SLIT("Just") <+> ppr x
461 instance (Outputable a, Outputable b) => Outputable (Either a b) where
462 ppr (Left x) = ptext SLIT("Left") <+> ppr x
463 ppr (Right y) = ptext SLIT("Right") <+> ppr y
465 -- ToDo: may not be used
466 instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c) where
468 parens (sep [ppr x <> comma,
472 instance (Outputable a, Outputable b, Outputable c, Outputable d) =>
473 Outputable (a, b, c, d) where
475 parens (sep [ppr a <> comma,
480 instance (Outputable a, Outputable b, Outputable c, Outputable d, Outputable e) =>
481 Outputable (a, b, c, d, e) where
483 parens (sep [ppr a <> comma,
489 instance Outputable FastString where
490 ppr fs = ftext fs -- Prints an unadorned string,
491 -- no double quotes or anything
495 %************************************************************************
497 \subsection{The @OutputableBndr@ class}
499 %************************************************************************
501 When we print a binder, we often want to print its type too.
502 The @OutputableBndr@ class encapsulates this idea.
504 @BindingSite@ is used to tell the thing that prints binder what
505 language construct is binding the identifier. This can be used
506 to decide how much info to print.
509 data BindingSite = LambdaBind | CaseBind | LetBind
511 class Outputable a => OutputableBndr a where
512 pprBndr :: BindingSite -> a -> SDoc
518 %************************************************************************
520 \subsection{Random printing helpers}
522 %************************************************************************
525 -- We have 31-bit Chars and will simply use Show instances
526 -- of Char and String.
528 pprHsChar :: Char -> SDoc
529 pprHsChar c | c > '\x10ffff' = char '\\' <> text (show (fromIntegral (ord c) :: Word32))
530 | otherwise = text (show c)
532 pprHsString :: FastString -> SDoc
533 pprHsString fs = text (show (unpackFS fs))
537 %************************************************************************
539 \subsection{Other helper functions}
541 %************************************************************************
544 pprWithCommas :: (a -> SDoc) -> [a] -> SDoc
545 pprWithCommas pp xs = fsep (punctuate comma (map pp xs))
547 interppSP :: Outputable a => [a] -> SDoc
548 interppSP xs = sep (map ppr xs)
550 interpp'SP :: Outputable a => [a] -> SDoc
551 interpp'SP xs = sep (punctuate comma (map ppr xs))
553 pprQuotedList :: Outputable a => [a] -> SDoc
554 -- [x,y,z] ==> `x', `y', `z'
555 pprQuotedList xs = hsep (punctuate comma (map (quotes . ppr) xs))
559 %************************************************************************
561 \subsection{Printing numbers verbally}
563 %************************************************************************
565 @speakNth@ converts an integer to a verbal index; eg 1 maps to
569 speakNth :: Int -> SDoc
570 speakNth 1 = ptext SLIT("first")
571 speakNth 2 = ptext SLIT("second")
572 speakNth 3 = ptext SLIT("third")
573 speakNth 4 = ptext SLIT("fourth")
574 speakNth 5 = ptext SLIT("fifth")
575 speakNth 6 = ptext SLIT("sixth")
576 speakNth n = hcat [ int n, text suffix ]
578 suffix | n <= 20 = "th" -- 11,12,13 are non-std
579 | last_dig == 1 = "st"
580 | last_dig == 2 = "nd"
581 | last_dig == 3 = "rd"
584 last_dig = n `rem` 10
586 speakN :: Int -> SDoc
587 speakN 0 = ptext SLIT("none") -- E.g. "he has none"
588 speakN 1 = ptext SLIT("one") -- E.g. "he has one"
589 speakN 2 = ptext SLIT("two")
590 speakN 3 = ptext SLIT("three")
591 speakN 4 = ptext SLIT("four")
592 speakN 5 = ptext SLIT("five")
593 speakN 6 = ptext SLIT("six")
596 speakNOf :: Int -> SDoc -> SDoc
597 speakNOf 0 d = ptext SLIT("no") <+> d <> char 's' -- E.g. "no arguments"
598 speakNOf 1 d = ptext SLIT("one") <+> d -- E.g. "one argument"
599 speakNOf n d = speakN n <+> d <> char 's' -- E.g. "three arguments"
601 speakNTimes :: Int {- >=1 -} -> SDoc
602 speakNTimes t | t == 1 = ptext SLIT("once")
603 | t == 2 = ptext SLIT("twice")
604 | otherwise = speakN t <+> ptext SLIT("times")
606 plural :: [a] -> SDoc
607 plural [_] = empty -- a bit frightening, but there you are
612 %************************************************************************
614 \subsection{Error handling}
616 %************************************************************************
619 pprPanic, pprPgmError :: String -> SDoc -> a
620 pprTrace :: String -> SDoc -> a -> a
621 pprPanic = pprAndThen panic -- Throw an exn saying "bug in GHC"
623 pprPgmError = pprAndThen pgmError -- Throw an exn saying "bug in pgm being compiled"
624 -- (used for unusual pgm errors)
625 pprTrace = pprAndThen trace
627 pprPanicFastInt :: String -> SDoc -> FastInt
628 pprPanicFastInt heading pretty_msg = panicFastInt (show (doc PprDebug))
630 doc = text heading <+> pretty_msg
632 pprAndThen :: (String -> a) -> String -> SDoc -> a
633 pprAndThen cont heading pretty_msg = cont (show (doc PprDebug))
635 doc = sep [text heading, nest 4 pretty_msg]
637 assertPprPanic :: String -> Int -> SDoc -> a
638 assertPprPanic file line msg
639 = panic (show (doc PprDebug))
641 doc = sep [hsep[text "ASSERT failed! file",
643 text "line", int line],
646 warnPprTrace :: Bool -> String -> Int -> SDoc -> a -> a
647 warnPprTrace False _file _line _msg x = x
648 warnPprTrace True file line msg x
649 = trace (show (doc PprDebug)) x
651 doc = sep [hsep [text "WARNING: file", text file, text "line", int line],