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 import {-# SOURCE #-} Module( Module, ModuleName, moduleName )
54 import {-# SOURCE #-} OccName( OccName )
56 import StaticFlags ( opt_PprStyle_Debug, opt_PprUserLength )
59 import qualified Pretty
60 import Pretty ( Doc, Mode(..) )
63 import Data.Word ( Word32 )
64 import System.IO ( Handle, stderr, stdout, hFlush )
65 import Data.Char ( ord )
69 %************************************************************************
71 \subsection{The @PprStyle@ data type}
73 %************************************************************************
78 = PprUser PrintUnqualified Depth
79 -- Pretty-print in a way that will make sense to the
80 -- ordinary user; must be very close to Haskell
82 -- Assumes printing tidied code: non-system names are
83 -- printed without uniques.
86 -- Print code; either C or assembler
88 | PprDump -- For -ddump-foo; less verbose than PprDebug.
89 -- Does not assume tidied code: non-external names
90 -- are printed with uniques.
92 | PprDebug -- Full debugging output
94 data CodeStyle = CStyle -- The format of labels differs for C and assembler
97 data Depth = AllTheWay
98 | PartWay Int -- 0 => stop
101 -- -----------------------------------------------------------------------------
102 -- Printing original names
104 -- When printing code that contains original names, we need to map the
105 -- original names back to something the user understands. This is the
106 -- purpose of the pair of functions that gets passed around
107 -- when rendering 'SDoc'.
109 -- | given an /original/ name, this function tells you which module
110 -- name it should be qualified with when printing for the user, if
111 -- any. For example, given @Control.Exception.catch@, which is in scope
112 -- as @Exception.catch@, this fuction will return @Just "Exception"@.
113 -- Note that the return value is a ModuleName, not a Module, because
114 -- in source code, names are qualified by ModuleNames.
115 type QueryQualifyName = Module -> OccName -> QualifyName
117 data QualifyName -- given P:M.T
118 = NameUnqual -- refer to it as "T"
119 | NameQual ModuleName -- refer to it as "X.T" for the supplied X
121 -- it is not in scope at all, but M.T is not bound in the current
122 -- scope, so we can refer to it as "M.T"
124 -- it is not in scope at all, and M.T is already bound in the
125 -- current scope, so we must refer to it as "P:M.T"
128 -- | For a given module, we need to know whether to print it with
129 -- a package name to disambiguate it.
130 type QueryQualifyModule = Module -> Bool
132 type PrintUnqualified = (QueryQualifyName, QueryQualifyModule)
134 alwaysQualifyNames :: QueryQualifyName
135 alwaysQualifyNames m _ = NameQual (moduleName m)
137 neverQualifyNames :: QueryQualifyName
138 neverQualifyNames _ _ = NameUnqual
140 alwaysQualifyModules :: QueryQualifyModule
141 alwaysQualifyModules _ = True
143 neverQualifyModules :: QueryQualifyModule
144 neverQualifyModules _ = False
146 type QueryQualifies = (QueryQualifyName, QueryQualifyModule)
148 alwaysQualify, neverQualify :: QueryQualifies
149 alwaysQualify = (alwaysQualifyNames, alwaysQualifyModules)
150 neverQualify = (neverQualifyNames, neverQualifyModules)
152 defaultUserStyle, defaultDumpStyle :: PprStyle
154 defaultUserStyle = mkUserStyle alwaysQualify AllTheWay
156 defaultDumpStyle | opt_PprStyle_Debug = PprDebug
157 | otherwise = PprDump
159 -- | Style for printing error messages
160 mkErrStyle :: PrintUnqualified -> PprStyle
161 mkErrStyle qual = mkUserStyle qual (PartWay opt_PprUserLength)
163 defaultErrStyle :: PprStyle
164 -- Default style for error messages
165 -- It's a bit of a hack because it doesn't take into account what's in scope
166 -- Only used for desugarer warnings, and typechecker errors in interface sigs
168 | opt_PprStyle_Debug = mkUserStyle alwaysQualify AllTheWay
169 | otherwise = mkUserStyle alwaysQualify (PartWay opt_PprUserLength)
171 mkUserStyle :: QueryQualifies -> Depth -> PprStyle
172 mkUserStyle unqual depth
173 | opt_PprStyle_Debug = PprDebug
174 | otherwise = PprUser unqual depth
177 Orthogonal to the above printing styles are (possibly) some
178 command-line flags that affect printing (often carried with the
179 style). The most likely ones are variations on how much type info is
182 The following test decides whether or not we are actually generating
183 code (either C or assembly), or generating interface files.
185 %************************************************************************
187 \subsection{The @SDoc@ data type}
189 %************************************************************************
192 type SDoc = PprStyle -> Doc
194 withPprStyle :: PprStyle -> SDoc -> SDoc
195 withPprStyle sty d _sty' = d sty
197 withPprStyleDoc :: PprStyle -> SDoc -> Doc
198 withPprStyleDoc sty d = d sty
200 pprDeeper :: SDoc -> SDoc
201 pprDeeper _ (PprUser _ (PartWay 0)) = Pretty.text "..."
202 pprDeeper d (PprUser q (PartWay n)) = d (PprUser q (PartWay (n-1)))
203 pprDeeper d other_sty = d other_sty
205 pprDeeperList :: ([SDoc] -> SDoc) -> [SDoc] -> SDoc
206 -- Truncate a list that list that is longer than the current depth
207 pprDeeperList f ds (PprUser q (PartWay n))
208 | n==0 = Pretty.text "..."
209 | otherwise = f (go 0 ds) (PprUser q (PartWay (n-1)))
212 go i (d:ds) | i >= n = [text "...."]
213 | otherwise = d : go (i+1) ds
215 pprDeeperList f ds other_sty
218 pprSetDepth :: Int -> SDoc -> SDoc
219 pprSetDepth n d (PprUser q _) = d (PprUser q (PartWay n))
220 pprSetDepth _n d other_sty = d other_sty
222 getPprStyle :: (PprStyle -> SDoc) -> SDoc
223 getPprStyle df sty = df sty sty
227 qualName :: PprStyle -> QueryQualifyName
228 qualName (PprUser (qual_name,_) _) m n = qual_name m n
229 qualName _other m _n = NameQual (moduleName m)
231 qualModule :: PprStyle -> QueryQualifyModule
232 qualModule (PprUser (_,qual_mod) _) m = qual_mod m
233 qualModule _other _m = True
235 codeStyle :: PprStyle -> Bool
236 codeStyle (PprCode _) = True
239 asmStyle :: PprStyle -> Bool
240 asmStyle (PprCode AsmStyle) = True
241 asmStyle _other = False
243 dumpStyle :: PprStyle -> Bool
244 dumpStyle PprDump = True
245 dumpStyle _other = False
247 debugStyle :: PprStyle -> Bool
248 debugStyle PprDebug = True
249 debugStyle _other = False
251 userStyle :: PprStyle -> Bool
252 userStyle (PprUser _ _) = True
253 userStyle _other = False
255 ifPprDebug :: SDoc -> SDoc -- Empty for non-debug style
256 ifPprDebug d sty@PprDebug = d sty
257 ifPprDebug _ _ = Pretty.empty
262 printSDoc :: SDoc -> PprStyle -> IO ()
264 Pretty.printDoc PageMode stdout (d sty)
267 -- I'm not sure whether the direct-IO approach of Pretty.printDoc
268 -- above is better or worse than the put-big-string approach here
269 printErrs :: Doc -> IO ()
270 printErrs doc = do Pretty.printDoc PageMode stderr doc
273 printDump :: SDoc -> IO ()
274 printDump doc = hPrintDump stdout doc
276 hPrintDump :: Handle -> SDoc -> IO ()
277 hPrintDump h doc = do
278 Pretty.printDoc PageMode h (better_doc defaultDumpStyle)
281 better_doc = doc $$ text ""
283 printForUser :: Handle -> PrintUnqualified -> SDoc -> IO ()
284 printForUser handle unqual doc
285 = Pretty.printDoc PageMode handle (doc (mkUserStyle unqual AllTheWay))
287 printForUserPartWay :: Handle -> Int -> PrintUnqualified -> SDoc -> IO ()
288 printForUserPartWay handle d unqual doc
289 = Pretty.printDoc PageMode handle (doc (mkUserStyle unqual (PartWay d)))
291 -- printForC, printForAsm do what they sound like
292 printForC :: Handle -> SDoc -> IO ()
293 printForC handle doc = Pretty.printDoc LeftMode handle (doc (PprCode CStyle))
295 printForAsm :: Handle -> SDoc -> IO ()
296 printForAsm handle doc = Pretty.printDoc LeftMode handle (doc (PprCode AsmStyle))
298 pprCode :: CodeStyle -> SDoc -> SDoc
299 pprCode cs d = withPprStyle (PprCode cs) d
301 mkCodeStyle :: CodeStyle -> PprStyle
302 mkCodeStyle = PprCode
304 -- Can't make SDoc an instance of Show because SDoc is just a function type
305 -- However, Doc *is* an instance of Show
306 -- showSDoc just blasts it out as a string
307 showSDoc :: SDoc -> String
308 showSDoc d = show (d defaultUserStyle)
310 showSDocForUser :: PrintUnqualified -> SDoc -> String
311 showSDocForUser unqual doc = show (doc (mkUserStyle unqual AllTheWay))
313 showSDocUnqual :: SDoc -> String
314 -- Only used in the gruesome HsExpr.isOperator
315 showSDocUnqual d = show (d (mkUserStyle neverQualify AllTheWay))
317 showsPrecSDoc :: Int -> SDoc -> ShowS
318 showsPrecSDoc p d = showsPrec p (d defaultUserStyle)
320 showSDocDump :: SDoc -> String
321 showSDocDump d = show (d PprDump)
323 showSDocDebug :: SDoc -> String
324 showSDocDebug d = show (d PprDebug)
328 docToSDoc :: Doc -> SDoc
329 docToSDoc d = \_ -> d
332 text :: String -> SDoc
334 ftext :: FastString -> SDoc
335 ptext :: LitString -> SDoc
337 integer :: Integer -> SDoc
338 float :: Float -> SDoc
339 double :: Double -> SDoc
340 rational :: Rational -> SDoc
342 empty _sty = Pretty.empty
343 text s _sty = Pretty.text s
344 char c _sty = Pretty.char c
345 ftext s _sty = Pretty.ftext s
346 ptext s _sty = Pretty.ptext s
347 int n _sty = Pretty.int n
348 integer n _sty = Pretty.integer n
349 float n _sty = Pretty.float n
350 double n _sty = Pretty.double n
351 rational n _sty = Pretty.rational n
353 parens, braces, brackets, quotes, doubleQuotes, angleBrackets :: SDoc -> SDoc
355 parens d sty = Pretty.parens (d sty)
356 braces d sty = Pretty.braces (d sty)
357 brackets d sty = Pretty.brackets (d sty)
358 doubleQuotes d sty = Pretty.doubleQuotes (d sty)
359 angleBrackets d = char '<' <> d <> char '>'
361 cparen :: Bool -> SDoc -> SDoc
363 cparen b d sty = Pretty.cparen b (d sty)
365 -- quotes encloses something in single quotes...
366 -- but it omits them if the thing ends in a single quote
367 -- so that we don't get `foo''. Instead we just have foo'.
368 quotes d sty = case show pp_d of
370 _other -> Pretty.quotes pp_d
374 semi, comma, colon, equals, space, dcolon, arrow, underscore, dot :: SDoc
375 lparen, rparen, lbrack, rbrack, lbrace, rbrace :: SDoc
377 semi _sty = Pretty.semi
378 comma _sty = Pretty.comma
379 colon _sty = Pretty.colon
380 equals _sty = Pretty.equals
381 space _sty = Pretty.space
382 dcolon _sty = Pretty.ptext (sLit "::")
383 arrow _sty = Pretty.ptext (sLit "->")
384 underscore = char '_'
386 lparen _sty = Pretty.lparen
387 rparen _sty = Pretty.rparen
388 lbrack _sty = Pretty.lbrack
389 rbrack _sty = Pretty.rbrack
390 lbrace _sty = Pretty.lbrace
391 rbrace _sty = Pretty.rbrace
393 nest :: Int -> SDoc -> SDoc
394 (<>), (<+>), ($$), ($+$) :: SDoc -> SDoc -> SDoc
396 nest n d sty = Pretty.nest n (d sty)
397 (<>) d1 d2 sty = (Pretty.<>) (d1 sty) (d2 sty)
398 (<+>) d1 d2 sty = (Pretty.<+>) (d1 sty) (d2 sty)
399 ($$) d1 d2 sty = (Pretty.$$) (d1 sty) (d2 sty)
400 ($+$) d1 d2 sty = (Pretty.$+$) (d1 sty) (d2 sty)
402 hcat, hsep, vcat, sep, cat, fsep, fcat :: [SDoc] -> SDoc
405 hcat ds sty = Pretty.hcat [d sty | d <- ds]
406 hsep ds sty = Pretty.hsep [d sty | d <- ds]
407 vcat ds sty = Pretty.vcat [d sty | d <- ds]
408 sep ds sty = Pretty.sep [d sty | d <- ds]
409 cat ds sty = Pretty.cat [d sty | d <- ds]
410 fsep ds sty = Pretty.fsep [d sty | d <- ds]
411 fcat ds sty = Pretty.fcat [d sty | d <- ds]
413 hang :: SDoc -> Int -> SDoc -> SDoc
415 hang d1 n d2 sty = Pretty.hang (d1 sty) n (d2 sty)
417 punctuate :: SDoc -> [SDoc] -> [SDoc]
419 punctuate p (d:ds) = go d ds
422 go d (e:es) = (d <> p) : go e es
426 %************************************************************************
428 \subsection[Outputable-class]{The @Outputable@ class}
430 %************************************************************************
433 class Outputable a where
438 instance Outputable Bool where
439 ppr True = ptext (sLit "True")
440 ppr False = ptext (sLit "False")
442 instance Outputable Int where
445 instance Outputable Word32 where
446 ppr n = integer $ fromIntegral n
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],