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,
46 pprInfixVar, pprPrefixVar,
47 pprHsChar, pprHsString, pprHsInfix, pprHsVar,
50 pprPanic, assertPprPanic, pprPanicFastInt, pprPgmError,
51 pprTrace, warnPprTrace,
52 trace, pgmError, panic, panicFastInt, assertPanic
55 import {-# SOURCE #-} Module( Module, ModuleName, moduleName )
56 import {-# SOURCE #-} OccName( OccName )
61 import qualified Pretty
62 import Pretty ( Doc, Mode(..) )
63 import Char ( isAlpha )
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 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 of Char and String.
529 pprHsChar :: Char -> SDoc
530 pprHsChar c | c > '\x10ffff' = char '\\' <> text (show (fromIntegral (ord c) :: Word32))
531 | otherwise = text (show c)
533 pprHsString :: FastString -> SDoc
534 pprHsString fs = text (show (unpackFS fs))
536 ---------------------
537 -- Put a name in parens if it's an operator
538 pprPrefixVar :: Bool -> SDoc -> SDoc
539 pprPrefixVar is_operator pp_v
540 | is_operator = parens pp_v
543 -- Put a name in backquotes if it's not an operator
544 pprInfixVar :: Bool -> SDoc -> SDoc
545 pprInfixVar is_operator pp_v
547 | otherwise = char '`' <> pp_v <> char '`'
549 ---------------------
550 -- pprHsVar and pprHsInfix use the gruesome isOperator, which
551 -- in turn uses (showSDoc (ppr v)), rather than isSymOcc (getOccName v).
552 -- Reason: it means that pprHsVar doesn't need a NamedThing context,
553 -- which none of the HsSyn printing functions do
554 pprHsVar, pprHsInfix :: Outputable name => name -> SDoc
555 pprHsVar v = pprPrefixVar (isOperator pp_v) pp_v
557 pprHsInfix v = pprInfixVar (isOperator pp_v) pp_v
560 isOperator :: SDoc -> Bool
562 = case showSDocUnqual ppr_v of
563 ('(':_) -> False -- (), (,) etc
564 ('[':_) -> False -- []
565 ('$':c:_) -> not (isAlpha c) -- Don't treat $d as an operator
566 (':':c:_) -> not (isAlpha c) -- Don't treat :T as an operator
567 ('_':_) -> False -- Not an operator
568 (c:_) -> not (isAlpha c) -- Starts with non-alpha
573 %************************************************************************
575 \subsection{Other helper functions}
577 %************************************************************************
580 pprWithCommas :: (a -> SDoc) -> [a] -> SDoc
581 pprWithCommas pp xs = fsep (punctuate comma (map pp xs))
583 interppSP :: Outputable a => [a] -> SDoc
584 interppSP xs = sep (map ppr xs)
586 interpp'SP :: Outputable a => [a] -> SDoc
587 interpp'SP xs = sep (punctuate comma (map ppr xs))
589 pprQuotedList :: Outputable a => [a] -> SDoc
590 -- [x,y,z] ==> `x', `y', `z'
591 pprQuotedList xs = hsep (punctuate comma (map (quotes . ppr) xs))
595 %************************************************************************
597 \subsection{Printing numbers verbally}
599 %************************************************************************
601 @speakNth@ converts an integer to a verbal index; eg 1 maps to
605 speakNth :: Int -> SDoc
606 speakNth 1 = ptext (sLit "first")
607 speakNth 2 = ptext (sLit "second")
608 speakNth 3 = ptext (sLit "third")
609 speakNth 4 = ptext (sLit "fourth")
610 speakNth 5 = ptext (sLit "fifth")
611 speakNth 6 = ptext (sLit "sixth")
612 speakNth n = hcat [ int n, text suffix ]
614 suffix | n <= 20 = "th" -- 11,12,13 are non-std
615 | last_dig == 1 = "st"
616 | last_dig == 2 = "nd"
617 | last_dig == 3 = "rd"
620 last_dig = n `rem` 10
622 speakN :: Int -> SDoc
623 speakN 0 = ptext (sLit "none") -- E.g. "he has none"
624 speakN 1 = ptext (sLit "one") -- E.g. "he has one"
625 speakN 2 = ptext (sLit "two")
626 speakN 3 = ptext (sLit "three")
627 speakN 4 = ptext (sLit "four")
628 speakN 5 = ptext (sLit "five")
629 speakN 6 = ptext (sLit "six")
632 speakNOf :: Int -> SDoc -> SDoc
633 speakNOf 0 d = ptext (sLit "no") <+> d <> char 's' -- E.g. "no arguments"
634 speakNOf 1 d = ptext (sLit "one") <+> d -- E.g. "one argument"
635 speakNOf n d = speakN n <+> d <> char 's' -- E.g. "three arguments"
637 speakNTimes :: Int {- >=1 -} -> SDoc
638 speakNTimes t | t == 1 = ptext (sLit "once")
639 | t == 2 = ptext (sLit "twice")
640 | otherwise = speakN t <+> ptext (sLit "times")
642 plural :: [a] -> SDoc
643 plural [_] = empty -- a bit frightening, but there you are
648 %************************************************************************
650 \subsection{Error handling}
652 %************************************************************************
655 pprPanic, pprPgmError :: String -> SDoc -> a
656 pprTrace :: String -> SDoc -> a -> a
657 pprPanic = pprAndThen panic -- Throw an exn saying "bug in GHC"
659 pprPgmError = pprAndThen pgmError -- Throw an exn saying "bug in pgm being compiled"
660 -- (used for unusual pgm errors)
662 | opt_NoDebugOutput = x
663 | otherwise = pprAndThen trace str doc x
665 pprPanicFastInt :: String -> SDoc -> FastInt
666 pprPanicFastInt heading pretty_msg = panicFastInt (show (doc PprDebug))
668 doc = text heading <+> pretty_msg
670 pprAndThen :: (String -> a) -> String -> SDoc -> a
671 pprAndThen cont heading pretty_msg = cont (show (doc PprDebug))
673 doc = sep [text heading, nest 4 pretty_msg]
675 assertPprPanic :: String -> Int -> SDoc -> a
676 assertPprPanic file line msg
677 = panic (show (doc PprDebug))
679 doc = sep [hsep[text "ASSERT failed! file",
681 text "line", int line],
684 warnPprTrace :: Bool -> String -> Int -> SDoc -> a -> a
685 warnPprTrace _ _file _line _msg x | opt_NoDebugOutput = x
686 warnPprTrace False _file _line _msg x = x
687 warnPprTrace True file line msg x
688 = trace (show (doc PprDebug)) x
690 doc = sep [hsep [text "WARNING: file", text file, text "line", int line],