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 Word32 where
449 ppr n = integer $ fromIntegral n
451 instance Outputable () where
454 instance (Outputable a) => Outputable [a] where
455 ppr xs = brackets (fsep (punctuate comma (map ppr xs)))
457 instance (Outputable a, Outputable b) => Outputable (a, b) where
458 ppr (x,y) = parens (sep [ppr x <> comma, ppr y])
460 instance Outputable a => Outputable (Maybe a) where
461 ppr Nothing = ptext SLIT("Nothing")
462 ppr (Just x) = ptext SLIT("Just") <+> ppr x
464 instance (Outputable a, Outputable b) => Outputable (Either a b) where
465 ppr (Left x) = ptext SLIT("Left") <+> ppr x
466 ppr (Right y) = ptext SLIT("Right") <+> ppr y
468 -- ToDo: may not be used
469 instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c) where
471 parens (sep [ppr x <> comma,
475 instance (Outputable a, Outputable b, Outputable c, Outputable d) =>
476 Outputable (a, b, c, d) where
478 parens (sep [ppr a <> comma,
483 instance (Outputable a, Outputable b, Outputable c, Outputable d, Outputable e) =>
484 Outputable (a, b, c, d, e) where
486 parens (sep [ppr a <> comma,
492 instance Outputable FastString where
493 ppr fs = ftext fs -- Prints an unadorned string,
494 -- no double quotes or anything
498 %************************************************************************
500 \subsection{The @OutputableBndr@ class}
502 %************************************************************************
504 When we print a binder, we often want to print its type too.
505 The @OutputableBndr@ class encapsulates this idea.
507 @BindingSite@ is used to tell the thing that prints binder what
508 language construct is binding the identifier. This can be used
509 to decide how much info to print.
512 data BindingSite = LambdaBind | CaseBind | LetBind
514 class Outputable a => OutputableBndr a where
515 pprBndr :: BindingSite -> a -> SDoc
521 %************************************************************************
523 \subsection{Random printing helpers}
525 %************************************************************************
528 -- We have 31-bit Chars and will simply use Show instances
529 -- of Char and String.
531 pprHsChar :: Char -> SDoc
532 pprHsChar c | c > '\x10ffff' = char '\\' <> text (show (fromIntegral (ord c) :: Word32))
533 | otherwise = text (show c)
535 pprHsString :: FastString -> SDoc
536 pprHsString fs = text (show (unpackFS fs))
540 %************************************************************************
542 \subsection{Other helper functions}
544 %************************************************************************
547 pprWithCommas :: (a -> SDoc) -> [a] -> SDoc
548 pprWithCommas pp xs = fsep (punctuate comma (map pp xs))
550 interppSP :: Outputable a => [a] -> SDoc
551 interppSP xs = sep (map ppr xs)
553 interpp'SP :: Outputable a => [a] -> SDoc
554 interpp'SP xs = sep (punctuate comma (map ppr xs))
556 pprQuotedList :: Outputable a => [a] -> SDoc
557 -- [x,y,z] ==> `x', `y', `z'
558 pprQuotedList xs = hsep (punctuate comma (map (quotes . ppr) xs))
562 %************************************************************************
564 \subsection{Printing numbers verbally}
566 %************************************************************************
568 @speakNth@ converts an integer to a verbal index; eg 1 maps to
572 speakNth :: Int -> SDoc
573 speakNth 1 = ptext SLIT("first")
574 speakNth 2 = ptext SLIT("second")
575 speakNth 3 = ptext SLIT("third")
576 speakNth 4 = ptext SLIT("fourth")
577 speakNth 5 = ptext SLIT("fifth")
578 speakNth 6 = ptext SLIT("sixth")
579 speakNth n = hcat [ int n, text suffix ]
581 suffix | n <= 20 = "th" -- 11,12,13 are non-std
582 | last_dig == 1 = "st"
583 | last_dig == 2 = "nd"
584 | last_dig == 3 = "rd"
587 last_dig = n `rem` 10
589 speakN :: Int -> SDoc
590 speakN 0 = ptext SLIT("none") -- E.g. "he has none"
591 speakN 1 = ptext SLIT("one") -- E.g. "he has one"
592 speakN 2 = ptext SLIT("two")
593 speakN 3 = ptext SLIT("three")
594 speakN 4 = ptext SLIT("four")
595 speakN 5 = ptext SLIT("five")
596 speakN 6 = ptext SLIT("six")
599 speakNOf :: Int -> SDoc -> SDoc
600 speakNOf 0 d = ptext SLIT("no") <+> d <> char 's' -- E.g. "no arguments"
601 speakNOf 1 d = ptext SLIT("one") <+> d -- E.g. "one argument"
602 speakNOf n d = speakN n <+> d <> char 's' -- E.g. "three arguments"
604 speakNTimes :: Int {- >=1 -} -> SDoc
605 speakNTimes t | t == 1 = ptext SLIT("once")
606 | t == 2 = ptext SLIT("twice")
607 | otherwise = speakN t <+> ptext SLIT("times")
609 plural :: [a] -> SDoc
610 plural [_] = empty -- a bit frightening, but there you are
615 %************************************************************************
617 \subsection{Error handling}
619 %************************************************************************
622 pprPanic, pprPgmError :: String -> SDoc -> a
623 pprTrace :: String -> SDoc -> a -> a
624 pprPanic = pprAndThen panic -- Throw an exn saying "bug in GHC"
626 pprPgmError = pprAndThen pgmError -- Throw an exn saying "bug in pgm being compiled"
627 -- (used for unusual pgm errors)
628 pprTrace = pprAndThen trace
630 pprPanicFastInt :: String -> SDoc -> FastInt
631 pprPanicFastInt heading pretty_msg = panicFastInt (show (doc PprDebug))
633 doc = text heading <+> pretty_msg
635 pprAndThen :: (String -> a) -> String -> SDoc -> a
636 pprAndThen cont heading pretty_msg = cont (show (doc PprDebug))
638 doc = sep [text heading, nest 4 pretty_msg]
640 assertPprPanic :: String -> Int -> SDoc -> a
641 assertPprPanic file line msg
642 = panic (show (doc PprDebug))
644 doc = sep [hsep[text "ASSERT failed! file",
646 text "line", int line],
649 warnPprTrace :: Bool -> String -> Int -> SDoc -> a -> a
650 warnPprTrace False _file _line _msg x = x
651 warnPprTrace True file line msg x
652 = trace (show (doc PprDebug)) x
654 doc = sep [hsep [text "WARNING: file", text file, text "line", int line],