2 % (c) The University of Glasgow 2006
3 % (c) The GRASP Project, Glasgow University, 1992-1998
7 -- | This module defines classes and functions for pretty-printing. It also
8 -- exports a number of helpful debugging and other utilities such as 'trace' and 'panic'.
10 -- The interface to this module is very similar to the standard Hughes-PJ pretty printing
11 -- module, except that it exports a number of additional functions that are rarely used,
12 -- and works over the 'SDoc' type.
15 Outputable(..), OutputableBndr(..),
17 -- * Pretty printing combinators
18 SDoc, runSDoc, initSDocContext,
20 interppSP, interpp'SP, pprQuotedList, pprWithCommas, quotedListWithOr,
24 int, integer, float, double, rational,
25 parens, cparen, brackets, braces, quotes, doubleQuotes, angleBrackets,
26 semi, comma, colon, dcolon, space, equals, dot, arrow, darrow,
27 lparen, rparen, lbrack, rbrack, lbrace, rbrace, underscore,
29 (<>), (<+>), hcat, hsep,
33 hang, punctuate, ppWhen, ppUnless,
34 speakNth, speakNTimes, speakN, speakNOf, plural,
36 coloured, PprColour, colType, colCoerc, colDataCon,
37 colBinder, bold, keyword,
39 -- * Converting 'SDoc' into strings and outputing it
40 printSDoc, printErrs, printOutput, hPrintDump, printDump,
41 printForC, printForAsm, printForUser, printForUserPartWay,
43 showSDoc, showSDocOneLine,
44 showSDocForUser, showSDocDebug, showSDocDump, showSDocDumpOneLine,
46 showSDocUnqual, showsPrecSDoc,
49 pprInfixVar, pprPrefixVar,
50 pprHsChar, pprHsString, pprHsInfix, pprHsVar,
53 -- * Controlling the style in which output is printed
56 PprStyle, CodeStyle(..), PrintUnqualified, alwaysQualify, neverQualify,
58 getPprStyle, withPprStyle, withPprStyleDoc,
59 pprDeeper, pprDeeperList, pprSetDepth,
60 codeStyle, userStyle, debugStyle, dumpStyle, asmStyle,
61 ifPprDebug, qualName, qualModule,
62 mkErrStyle, defaultErrStyle, defaultDumpStyle, defaultUserStyle,
63 mkUserStyle, cmdlineParserStyle, Depth(..),
65 -- * Error handling and debugging utilities
66 pprPanic, pprSorry, assertPprPanic, pprPanicFastInt, pprPgmError,
67 pprTrace, pprDefiniteTrace, warnPprTrace,
68 trace, pgmError, panic, sorry, panicFastInt, assertPanic
71 import {-# SOURCE #-} Module( Module, ModuleName, moduleName )
72 import {-# SOURCE #-} OccName( OccName )
77 import qualified Pretty
78 import Pretty ( Doc, Mode(..) )
82 import qualified Data.Map as M
83 import qualified Data.IntMap as IM
85 import System.IO ( Handle, stderr, stdout, hFlush )
86 import System.FilePath
89 #if __GLASGOW_HASKELL__ >= 701
90 import GHC.Show ( showMultiLineString )
92 showMultiLineString :: String -> [String]
94 showMultiLineString s = [ showList s "" ]
100 %************************************************************************
102 \subsection{The @PprStyle@ data type}
104 %************************************************************************
109 = PprUser PrintUnqualified Depth
110 -- Pretty-print in a way that will make sense to the
111 -- ordinary user; must be very close to Haskell
113 -- Assumes printing tidied code: non-system names are
114 -- printed without uniques.
117 -- Print code; either C or assembler
119 | PprDump -- For -ddump-foo; less verbose than PprDebug.
120 -- Does not assume tidied code: non-external names
121 -- are printed with uniques.
123 | PprDebug -- Full debugging output
125 data CodeStyle = CStyle -- The format of labels differs for C and assembler
128 data Depth = AllTheWay
129 | PartWay Int -- 0 => stop
132 -- -----------------------------------------------------------------------------
133 -- Printing original names
135 -- When printing code that contains original names, we need to map the
136 -- original names back to something the user understands. This is the
137 -- purpose of the pair of functions that gets passed around
138 -- when rendering 'SDoc'.
140 -- | given an /original/ name, this function tells you which module
141 -- name it should be qualified with when printing for the user, if
142 -- any. For example, given @Control.Exception.catch@, which is in scope
143 -- as @Exception.catch@, this fuction will return @Just "Exception"@.
144 -- Note that the return value is a ModuleName, not a Module, because
145 -- in source code, names are qualified by ModuleNames.
146 type QueryQualifyName = Module -> OccName -> QualifyName
148 -- See Note [Printing original names] in HscTypes
149 data QualifyName -- given P:M.T
150 = NameUnqual -- refer to it as "T"
151 | NameQual ModuleName -- refer to it as "X.T" for the supplied X
153 -- it is not in scope at all, but M.T is not bound in the current
154 -- scope, so we can refer to it as "M.T"
156 -- it is not in scope at all, and M.T is already bound in the
157 -- current scope, so we must refer to it as "P:M.T"
160 -- | For a given module, we need to know whether to print it with
161 -- a package name to disambiguate it.
162 type QueryQualifyModule = Module -> Bool
164 type PrintUnqualified = (QueryQualifyName, QueryQualifyModule)
166 alwaysQualifyNames :: QueryQualifyName
167 alwaysQualifyNames m _ = NameQual (moduleName m)
169 neverQualifyNames :: QueryQualifyName
170 neverQualifyNames _ _ = NameUnqual
172 alwaysQualifyModules :: QueryQualifyModule
173 alwaysQualifyModules _ = True
175 neverQualifyModules :: QueryQualifyModule
176 neverQualifyModules _ = False
178 alwaysQualify, neverQualify :: PrintUnqualified
179 alwaysQualify = (alwaysQualifyNames, alwaysQualifyModules)
180 neverQualify = (neverQualifyNames, neverQualifyModules)
182 defaultUserStyle, defaultDumpStyle :: PprStyle
184 defaultUserStyle = mkUserStyle alwaysQualify AllTheWay
186 defaultDumpStyle | opt_PprStyle_Debug = PprDebug
187 | otherwise = PprDump
189 -- | Style for printing error messages
190 mkErrStyle :: PrintUnqualified -> PprStyle
191 mkErrStyle qual = mkUserStyle qual (PartWay opt_PprUserLength)
193 defaultErrStyle :: PprStyle
194 -- Default style for error messages
195 -- It's a bit of a hack because it doesn't take into account what's in scope
196 -- Only used for desugarer warnings, and typechecker errors in interface sigs
198 | opt_PprStyle_Debug = mkUserStyle alwaysQualify AllTheWay
199 | otherwise = mkUserStyle alwaysQualify (PartWay opt_PprUserLength)
201 mkUserStyle :: PrintUnqualified -> Depth -> PprStyle
202 mkUserStyle unqual depth
203 | opt_PprStyle_Debug = PprDebug
204 | otherwise = PprUser unqual depth
206 cmdlineParserStyle :: PprStyle
207 cmdlineParserStyle = PprUser alwaysQualify AllTheWay
210 Orthogonal to the above printing styles are (possibly) some
211 command-line flags that affect printing (often carried with the
212 style). The most likely ones are variations on how much type info is
215 The following test decides whether or not we are actually generating
216 code (either C or assembly), or generating interface files.
218 %************************************************************************
220 \subsection{The @SDoc@ data type}
222 %************************************************************************
225 newtype SDoc = SDoc { runSDoc :: SDocContext -> Doc }
227 data SDocContext = SDC
228 { sdocStyle :: !PprStyle
229 , sdocLastColour :: !PprColour
230 -- ^ The most recently used colour. This allows nesting colours.
233 initSDocContext :: PprStyle -> SDocContext
234 initSDocContext sty = SDC
236 , sdocLastColour = colReset
239 withPprStyle :: PprStyle -> SDoc -> SDoc
240 withPprStyle sty d = SDoc $ \ctxt -> runSDoc d ctxt{sdocStyle=sty}
242 withPprStyleDoc :: PprStyle -> SDoc -> Doc
243 withPprStyleDoc sty d = runSDoc d (initSDocContext sty)
245 pprDeeper :: SDoc -> SDoc
246 pprDeeper d = SDoc $ \ctx -> case ctx of
247 SDC{sdocStyle=PprUser _ (PartWay 0)} -> Pretty.text "..."
248 SDC{sdocStyle=PprUser q (PartWay n)} ->
249 runSDoc d ctx{sdocStyle = PprUser q (PartWay (n-1))}
252 pprDeeperList :: ([SDoc] -> SDoc) -> [SDoc] -> SDoc
253 -- Truncate a list that list that is longer than the current depth
254 pprDeeperList f ds = SDoc work
256 work ctx@SDC{sdocStyle=PprUser q (PartWay n)}
257 | n==0 = Pretty.text "..."
259 runSDoc (f (go 0 ds)) ctx{sdocStyle = PprUser q (PartWay (n-1))}
262 go i (d:ds) | i >= n = [text "...."]
263 | otherwise = d : go (i+1) ds
264 work other_ctx = runSDoc (f ds) other_ctx
266 pprSetDepth :: Depth -> SDoc -> SDoc
267 pprSetDepth depth doc = SDoc $ \ctx -> case ctx of
268 SDC{sdocStyle=PprUser q _} ->
269 runSDoc doc ctx{sdocStyle = PprUser q depth}
273 getPprStyle :: (PprStyle -> SDoc) -> SDoc
274 getPprStyle df = SDoc $ \ctx -> runSDoc (df (sdocStyle ctx)) ctx
278 qualName :: PprStyle -> QueryQualifyName
279 qualName (PprUser (qual_name,_) _) m n = qual_name m n
280 qualName _other m _n = NameQual (moduleName m)
282 qualModule :: PprStyle -> QueryQualifyModule
283 qualModule (PprUser (_,qual_mod) _) m = qual_mod m
284 qualModule _other _m = True
286 codeStyle :: PprStyle -> Bool
287 codeStyle (PprCode _) = True
290 asmStyle :: PprStyle -> Bool
291 asmStyle (PprCode AsmStyle) = True
292 asmStyle _other = False
294 dumpStyle :: PprStyle -> Bool
295 dumpStyle PprDump = True
296 dumpStyle _other = False
298 debugStyle :: PprStyle -> Bool
299 debugStyle PprDebug = True
300 debugStyle _other = False
302 userStyle :: PprStyle -> Bool
303 userStyle (PprUser _ _) = True
304 userStyle _other = False
306 ifPprDebug :: SDoc -> SDoc -- Empty for non-debug style
307 ifPprDebug d = SDoc $ \ctx -> case ctx of
308 SDC{sdocStyle=PprDebug} -> runSDoc d ctx
314 printSDoc :: SDoc -> PprStyle -> IO ()
316 Pretty.printDoc PageMode stdout (runSDoc d (initSDocContext sty))
319 -- I'm not sure whether the direct-IO approach of Pretty.printDoc
320 -- above is better or worse than the put-big-string approach here
321 printErrs :: SDoc -> PprStyle -> IO ()
322 printErrs doc sty = do
323 Pretty.printDoc PageMode stderr (runSDoc doc (initSDocContext sty))
326 printOutput :: Doc -> IO ()
327 printOutput doc = Pretty.printDoc PageMode stdout doc
329 printDump :: SDoc -> IO ()
330 printDump doc = hPrintDump stdout doc
332 hPrintDump :: Handle -> SDoc -> IO ()
333 hPrintDump h doc = do
334 Pretty.printDoc PageMode h
335 (runSDoc better_doc (initSDocContext defaultDumpStyle))
338 better_doc = doc $$ blankLine
340 printForUser :: Handle -> PrintUnqualified -> SDoc -> IO ()
341 printForUser handle unqual doc
342 = Pretty.printDoc PageMode handle
343 (runSDoc doc (initSDocContext (mkUserStyle unqual AllTheWay)))
345 printForUserPartWay :: Handle -> Int -> PrintUnqualified -> SDoc -> IO ()
346 printForUserPartWay handle d unqual doc
347 = Pretty.printDoc PageMode handle
348 (runSDoc doc (initSDocContext (mkUserStyle unqual (PartWay d))))
350 -- printForC, printForAsm do what they sound like
351 printForC :: Handle -> SDoc -> IO ()
352 printForC handle doc =
353 Pretty.printDoc LeftMode handle
354 (runSDoc doc (initSDocContext (PprCode CStyle)))
356 printForAsm :: Handle -> SDoc -> IO ()
357 printForAsm handle doc =
358 Pretty.printDoc LeftMode handle
359 (runSDoc doc (initSDocContext (PprCode AsmStyle)))
361 pprCode :: CodeStyle -> SDoc -> SDoc
362 pprCode cs d = withPprStyle (PprCode cs) d
364 mkCodeStyle :: CodeStyle -> PprStyle
365 mkCodeStyle = PprCode
367 -- Can't make SDoc an instance of Show because SDoc is just a function type
368 -- However, Doc *is* an instance of Show
369 -- showSDoc just blasts it out as a string
370 showSDoc :: SDoc -> String
372 Pretty.showDocWith PageMode
373 (runSDoc d (initSDocContext defaultUserStyle))
375 renderWithStyle :: SDoc -> PprStyle -> String
376 renderWithStyle sdoc sty =
377 Pretty.render (runSDoc sdoc (initSDocContext sty))
379 -- This shows an SDoc, but on one line only. It's cheaper than a full
380 -- showSDoc, designed for when we're getting results like "Foo.bar"
381 -- and "foo{uniq strictness}" so we don't want fancy layout anyway.
382 showSDocOneLine :: SDoc -> String
384 Pretty.showDocWith PageMode
385 (runSDoc d (initSDocContext defaultUserStyle))
387 showSDocForUser :: PrintUnqualified -> SDoc -> String
388 showSDocForUser unqual doc =
389 show (runSDoc doc (initSDocContext (mkUserStyle unqual AllTheWay)))
391 showSDocUnqual :: SDoc -> String
392 -- Only used in the gruesome isOperator
394 show (runSDoc d (initSDocContext (mkUserStyle neverQualify AllTheWay)))
396 showsPrecSDoc :: Int -> SDoc -> ShowS
397 showsPrecSDoc p d = showsPrec p (runSDoc d (initSDocContext defaultUserStyle))
399 showSDocDump :: SDoc -> String
401 Pretty.showDocWith PageMode (runSDoc d (initSDocContext PprDump))
403 showSDocDumpOneLine :: SDoc -> String
404 showSDocDumpOneLine d =
405 Pretty.showDocWith OneLineMode (runSDoc d (initSDocContext PprDump))
407 showSDocDebug :: SDoc -> String
408 showSDocDebug d = show (runSDoc d (initSDocContext PprDebug))
410 showPpr :: Outputable a => a -> String
411 showPpr = showSDoc . ppr
415 docToSDoc :: Doc -> SDoc
416 docToSDoc d = SDoc (\_ -> d)
420 text :: String -> SDoc
421 ftext :: FastString -> SDoc
422 ptext :: LitString -> SDoc
424 integer :: Integer -> SDoc
425 float :: Float -> SDoc
426 double :: Double -> SDoc
427 rational :: Rational -> SDoc
429 empty = docToSDoc $ Pretty.empty
430 char c = docToSDoc $ Pretty.char c
431 text s = docToSDoc $ Pretty.text s
432 ftext s = docToSDoc $ Pretty.ftext s
433 ptext s = docToSDoc $ Pretty.ptext s
434 int n = docToSDoc $ Pretty.int n
435 integer n = docToSDoc $ Pretty.integer n
436 float n = docToSDoc $ Pretty.float n
437 double n = docToSDoc $ Pretty.double n
438 rational n = docToSDoc $ Pretty.rational n
440 parens, braces, brackets, quotes, doubleQuotes, angleBrackets :: SDoc -> SDoc
442 parens d = SDoc $ Pretty.parens . runSDoc d
443 braces d = SDoc $ Pretty.braces . runSDoc d
444 brackets d = SDoc $ Pretty.brackets . runSDoc d
445 doubleQuotes d = SDoc $ Pretty.doubleQuotes . runSDoc d
446 angleBrackets d = char '<' <> d <> char '>'
448 cparen :: Bool -> SDoc -> SDoc
450 cparen b d = SDoc $ Pretty.cparen b . runSDoc d
452 -- quotes encloses something in single quotes...
453 -- but it omits them if the thing ends in a single quote
454 -- so that we don't get `foo''. Instead we just have foo'.
455 quotes d = SDoc $ \sty ->
456 let pp_d = runSDoc d sty in
459 _other -> Pretty.quotes pp_d
461 semi, comma, colon, equals, space, dcolon, arrow, underscore, dot :: SDoc
462 darrow, lparen, rparen, lbrack, rbrack, lbrace, rbrace, blankLine :: SDoc
464 blankLine = docToSDoc $ Pretty.ptext (sLit "")
465 dcolon = docToSDoc $ Pretty.ptext (sLit "::")
466 arrow = docToSDoc $ Pretty.ptext (sLit "->")
467 darrow = docToSDoc $ Pretty.ptext (sLit "=>")
468 semi = docToSDoc $ Pretty.semi
469 comma = docToSDoc $ Pretty.comma
470 colon = docToSDoc $ Pretty.colon
471 equals = docToSDoc $ Pretty.equals
472 space = docToSDoc $ Pretty.space
473 underscore = char '_'
475 lparen = docToSDoc $ Pretty.lparen
476 rparen = docToSDoc $ Pretty.rparen
477 lbrack = docToSDoc $ Pretty.lbrack
478 rbrack = docToSDoc $ Pretty.rbrack
479 lbrace = docToSDoc $ Pretty.lbrace
480 rbrace = docToSDoc $ Pretty.rbrace
482 nest :: Int -> SDoc -> SDoc
483 -- ^ Indent 'SDoc' some specified amount
484 (<>) :: SDoc -> SDoc -> SDoc
485 -- ^ Join two 'SDoc' together horizontally without a gap
486 (<+>) :: SDoc -> SDoc -> SDoc
487 -- ^ Join two 'SDoc' together horizontally with a gap between them
488 ($$) :: SDoc -> SDoc -> SDoc
489 -- ^ Join two 'SDoc' together vertically; if there is
490 -- no vertical overlap it "dovetails" the two onto one line
491 ($+$) :: SDoc -> SDoc -> SDoc
492 -- ^ Join two 'SDoc' together vertically
494 nest n d = SDoc $ Pretty.nest n . runSDoc d
495 (<>) d1 d2 = SDoc $ \sty -> (Pretty.<>) (runSDoc d1 sty) (runSDoc d2 sty)
496 (<+>) d1 d2 = SDoc $ \sty -> (Pretty.<+>) (runSDoc d1 sty) (runSDoc d2 sty)
497 ($$) d1 d2 = SDoc $ \sty -> (Pretty.$$) (runSDoc d1 sty) (runSDoc d2 sty)
498 ($+$) d1 d2 = SDoc $ \sty -> (Pretty.$+$) (runSDoc d1 sty) (runSDoc d2 sty)
500 hcat :: [SDoc] -> SDoc
501 -- ^ Concatenate 'SDoc' horizontally
502 hsep :: [SDoc] -> SDoc
503 -- ^ Concatenate 'SDoc' horizontally with a space between each one
504 vcat :: [SDoc] -> SDoc
505 -- ^ Concatenate 'SDoc' vertically with dovetailing
506 sep :: [SDoc] -> SDoc
507 -- ^ Separate: is either like 'hsep' or like 'vcat', depending on what fits
508 cat :: [SDoc] -> SDoc
509 -- ^ Catenate: is either like 'hcat' or like 'vcat', depending on what fits
510 fsep :: [SDoc] -> SDoc
511 -- ^ A paragraph-fill combinator. It's much like sep, only it
512 -- keeps fitting things on one line until it can't fit any more.
513 fcat :: [SDoc] -> SDoc
514 -- ^ This behaves like 'fsep', but it uses '<>' for horizontal conposition rather than '<+>'
517 hcat ds = SDoc $ \sty -> Pretty.hcat [runSDoc d sty | d <- ds]
518 hsep ds = SDoc $ \sty -> Pretty.hsep [runSDoc d sty | d <- ds]
519 vcat ds = SDoc $ \sty -> Pretty.vcat [runSDoc d sty | d <- ds]
520 sep ds = SDoc $ \sty -> Pretty.sep [runSDoc d sty | d <- ds]
521 cat ds = SDoc $ \sty -> Pretty.cat [runSDoc d sty | d <- ds]
522 fsep ds = SDoc $ \sty -> Pretty.fsep [runSDoc d sty | d <- ds]
523 fcat ds = SDoc $ \sty -> Pretty.fcat [runSDoc d sty | d <- ds]
525 hang :: SDoc -- ^ The header
526 -> Int -- ^ Amount to indent the hung body
527 -> SDoc -- ^ The hung body, indented and placed below the header
529 hang d1 n d2 = SDoc $ \sty -> Pretty.hang (runSDoc d1 sty) n (runSDoc d2 sty)
531 punctuate :: SDoc -- ^ The punctuation
532 -> [SDoc] -- ^ The list that will have punctuation added between every adjacent pair of elements
533 -> [SDoc] -- ^ Punctuated list
535 punctuate p (d:ds) = go d ds
538 go d (e:es) = (d <> p) : go e es
540 ppWhen, ppUnless :: Bool -> SDoc -> SDoc
541 ppWhen True doc = doc
542 ppWhen False _ = empty
544 ppUnless True _ = empty
545 ppUnless False doc = doc
547 -- | A colour\/style for use with 'coloured'.
548 newtype PprColour = PprColour String
553 colType = PprColour "\27[34m"
556 colBold = PprColour "\27[;1m"
558 colCoerc :: PprColour
559 colCoerc = PprColour "\27[34m"
561 colDataCon :: PprColour
562 colDataCon = PprColour "\27[31m"
564 colBinder :: PprColour
565 colBinder = PprColour "\27[32m"
567 colReset :: PprColour
568 colReset = PprColour "\27[0m"
570 -- | Apply the given colour\/style for the argument.
572 -- Only takes effect if colours are enabled.
573 coloured :: PprColour -> SDoc -> SDoc
574 -- TODO: coloured _ sdoc ctxt | coloursDisabled = sdoc ctxt
575 coloured col@(PprColour c) sdoc =
576 SDoc $ \ctx@SDC{ sdocLastColour = PprColour lc } ->
577 let ctx' = ctx{ sdocLastColour = col } in
578 Pretty.zeroWidthText c Pretty.<> runSDoc sdoc ctx' Pretty.<> Pretty.zeroWidthText lc
581 bold = coloured colBold
583 keyword :: SDoc -> SDoc
589 %************************************************************************
591 \subsection[Outputable-class]{The @Outputable@ class}
593 %************************************************************************
596 -- | Class designating that some type has an 'SDoc' representation
597 class Outputable a where
602 instance Outputable Bool where
603 ppr True = ptext (sLit "True")
604 ppr False = ptext (sLit "False")
606 instance Outputable Int where
609 instance Outputable Word16 where
610 ppr n = integer $ fromIntegral n
612 instance Outputable Word32 where
613 ppr n = integer $ fromIntegral n
615 instance Outputable Word where
616 ppr n = integer $ fromIntegral n
618 instance Outputable () where
621 instance (Outputable a) => Outputable [a] where
622 ppr xs = brackets (fsep (punctuate comma (map ppr xs)))
624 instance (Outputable a, Outputable b) => Outputable (a, b) where
625 ppr (x,y) = parens (sep [ppr x <> comma, ppr y])
627 instance Outputable a => Outputable (Maybe a) where
628 ppr Nothing = ptext (sLit "Nothing")
629 ppr (Just x) = ptext (sLit "Just") <+> ppr x
631 instance (Outputable a, Outputable b) => Outputable (Either a b) where
632 ppr (Left x) = ptext (sLit "Left") <+> ppr x
633 ppr (Right y) = ptext (sLit "Right") <+> ppr y
635 -- ToDo: may not be used
636 instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c) where
638 parens (sep [ppr x <> comma,
642 instance (Outputable a, Outputable b, Outputable c, Outputable d) =>
643 Outputable (a, b, c, d) where
645 parens (sep [ppr a <> comma,
650 instance (Outputable a, Outputable b, Outputable c, Outputable d, Outputable e) =>
651 Outputable (a, b, c, d, e) where
653 parens (sep [ppr a <> comma,
659 instance Outputable FastString where
660 ppr fs = ftext fs -- Prints an unadorned string,
661 -- no double quotes or anything
663 instance (Outputable key, Outputable elt) => Outputable (M.Map key elt) where
664 ppr m = ppr (M.toList m)
665 instance (Outputable elt) => Outputable (IM.IntMap elt) where
666 ppr m = ppr (IM.toList m)
669 %************************************************************************
671 \subsection{The @OutputableBndr@ class}
673 %************************************************************************
676 -- | 'BindingSite' is used to tell the thing that prints binder what
677 -- language construct is binding the identifier. This can be used
678 -- to decide how much info to print.
679 data BindingSite = LambdaBind | CaseBind | LetBind
681 -- | When we print a binder, we often want to print its type too.
682 -- The @OutputableBndr@ class encapsulates this idea.
683 class Outputable a => OutputableBndr a where
684 pprBndr :: BindingSite -> a -> SDoc
688 %************************************************************************
690 \subsection{Random printing helpers}
692 %************************************************************************
695 -- We have 31-bit Chars and will simply use Show instances of Char and String.
697 -- | Special combinator for showing character literals.
698 pprHsChar :: Char -> SDoc
699 pprHsChar c | c > '\x10ffff' = char '\\' <> text (show (fromIntegral (ord c) :: Word32))
700 | otherwise = text (show c)
702 -- | Special combinator for showing string literals.
703 pprHsString :: FastString -> SDoc
704 pprHsString fs = vcat (map text (showMultiLineString (unpackFS fs)))
706 ---------------------
707 -- Put a name in parens if it's an operator
708 pprPrefixVar :: Bool -> SDoc -> SDoc
709 pprPrefixVar is_operator pp_v
710 | is_operator = parens pp_v
713 -- Put a name in backquotes if it's not an operator
714 pprInfixVar :: Bool -> SDoc -> SDoc
715 pprInfixVar is_operator pp_v
717 | otherwise = char '`' <> pp_v <> char '`'
719 ---------------------
720 -- pprHsVar and pprHsInfix use the gruesome isOperator, which
721 -- in turn uses (showSDoc (ppr v)), rather than isSymOcc (getOccName v).
722 -- Reason: it means that pprHsVar doesn't need a NamedThing context,
723 -- which none of the HsSyn printing functions do
724 pprHsVar, pprHsInfix :: Outputable name => name -> SDoc
725 pprHsVar v = pprPrefixVar (isOperator pp_v) pp_v
727 pprHsInfix v = pprInfixVar (isOperator pp_v) pp_v
730 isOperator :: SDoc -> Bool
732 = case showSDocUnqual ppr_v of
733 ('(':_) -> False -- (), (,) etc
734 ('[':_) -> False -- []
735 ('$':c:_) -> not (isAlpha c) -- Don't treat $d as an operator
736 (':':c:_) -> not (isAlpha c) -- Don't treat :T as an operator
737 ('_':_) -> False -- Not an operator
738 (c:_) -> not (isAlpha c) -- Starts with non-alpha
741 pprFastFilePath :: FastString -> SDoc
742 pprFastFilePath path = text $ normalise $ unpackFS path
745 %************************************************************************
747 \subsection{Other helper functions}
749 %************************************************************************
752 pprWithCommas :: (a -> SDoc) -- ^ The pretty printing function to use
753 -> [a] -- ^ The things to be pretty printed
754 -> SDoc -- ^ 'SDoc' where the things have been pretty printed,
755 -- comma-separated and finally packed into a paragraph.
756 pprWithCommas pp xs = fsep (punctuate comma (map pp xs))
758 -- | Returns the seperated concatenation of the pretty printed things.
759 interppSP :: Outputable a => [a] -> SDoc
760 interppSP xs = sep (map ppr xs)
762 -- | Returns the comma-seperated concatenation of the pretty printed things.
763 interpp'SP :: Outputable a => [a] -> SDoc
764 interpp'SP xs = sep (punctuate comma (map ppr xs))
766 -- | Returns the comma-seperated concatenation of the quoted pretty printed things.
768 -- > [x,y,z] ==> `x', `y', `z'
769 pprQuotedList :: Outputable a => [a] -> SDoc
770 pprQuotedList = quotedList . map ppr
772 quotedList :: [SDoc] -> SDoc
773 quotedList xs = hsep (punctuate comma (map quotes xs))
775 quotedListWithOr :: [SDoc] -> SDoc
776 -- [x,y,z] ==> `x', `y' or `z'
777 quotedListWithOr xs@(_:_:_) = quotedList (init xs) <+> ptext (sLit "or") <+> quotes (last xs)
778 quotedListWithOr xs = quotedList xs
782 %************************************************************************
784 \subsection{Printing numbers verbally}
786 %************************************************************************
789 -- | Converts an integer to a verbal index:
791 -- > speakNth 1 = text "first"
792 -- > speakNth 5 = text "fifth"
793 -- > speakNth 21 = text "21st"
794 speakNth :: Int -> SDoc
795 speakNth 1 = ptext (sLit "first")
796 speakNth 2 = ptext (sLit "second")
797 speakNth 3 = ptext (sLit "third")
798 speakNth 4 = ptext (sLit "fourth")
799 speakNth 5 = ptext (sLit "fifth")
800 speakNth 6 = ptext (sLit "sixth")
801 speakNth n = hcat [ int n, text suffix ]
803 suffix | n <= 20 = "th" -- 11,12,13 are non-std
804 | last_dig == 1 = "st"
805 | last_dig == 2 = "nd"
806 | last_dig == 3 = "rd"
809 last_dig = n `rem` 10
811 -- | Converts an integer to a verbal multiplicity:
813 -- > speakN 0 = text "none"
814 -- > speakN 5 = text "five"
815 -- > speakN 10 = text "10"
816 speakN :: Int -> SDoc
817 speakN 0 = ptext (sLit "none") -- E.g. "he has none"
818 speakN 1 = ptext (sLit "one") -- E.g. "he has one"
819 speakN 2 = ptext (sLit "two")
820 speakN 3 = ptext (sLit "three")
821 speakN 4 = ptext (sLit "four")
822 speakN 5 = ptext (sLit "five")
823 speakN 6 = ptext (sLit "six")
826 -- | Converts an integer and object description to a statement about the
827 -- multiplicity of those objects:
829 -- > speakNOf 0 (text "melon") = text "no melons"
830 -- > speakNOf 1 (text "melon") = text "one melon"
831 -- > speakNOf 3 (text "melon") = text "three melons"
832 speakNOf :: Int -> SDoc -> SDoc
833 speakNOf 0 d = ptext (sLit "no") <+> d <> char 's'
834 speakNOf 1 d = ptext (sLit "one") <+> d -- E.g. "one argument"
835 speakNOf n d = speakN n <+> d <> char 's' -- E.g. "three arguments"
837 -- | Converts a strictly positive integer into a number of times:
839 -- > speakNTimes 1 = text "once"
840 -- > speakNTimes 2 = text "twice"
841 -- > speakNTimes 4 = text "4 times"
842 speakNTimes :: Int {- >=1 -} -> SDoc
843 speakNTimes t | t == 1 = ptext (sLit "once")
844 | t == 2 = ptext (sLit "twice")
845 | otherwise = speakN t <+> ptext (sLit "times")
847 -- | Determines the pluralisation suffix appropriate for the length of a list:
849 -- > plural [] = char 's'
850 -- > plural ["Hello"] = empty
851 -- > plural ["Hello", "World"] = char 's'
852 plural :: [a] -> SDoc
853 plural [_] = empty -- a bit frightening, but there you are
858 %************************************************************************
860 \subsection{Error handling}
862 %************************************************************************
866 pprPanic :: String -> SDoc -> a
867 -- ^ Throw an exception saying "bug in GHC"
868 pprPanic = pprAndThen panic
870 pprSorry :: String -> SDoc -> a
871 -- ^ Throw an exceptio saying "this isn't finished yet"
872 pprSorry = pprAndThen sorry
875 pprPgmError :: String -> SDoc -> a
876 -- ^ Throw an exception saying "bug in pgm being compiled" (used for unusual program errors)
877 pprPgmError = pprAndThen pgmError
880 pprTrace :: String -> SDoc -> a -> a
881 -- ^ If debug output is on, show some 'SDoc' on the screen
883 | opt_NoDebugOutput = x
884 | otherwise = pprAndThen trace str doc x
886 pprDefiniteTrace :: String -> SDoc -> a -> a
887 -- ^ Same as pprTrace, but show even if -dno-debug-output is on
888 pprDefiniteTrace str doc x = pprAndThen trace str doc x
890 pprPanicFastInt :: String -> SDoc -> FastInt
891 -- ^ Specialization of pprPanic that can be safely used with 'FastInt'
892 pprPanicFastInt heading pretty_msg =
893 panicFastInt (show (runSDoc doc (initSDocContext PprDebug)))
895 doc = text heading <+> pretty_msg
898 pprAndThen :: (String -> a) -> String -> SDoc -> a
899 pprAndThen cont heading pretty_msg =
900 cont (show (runSDoc doc (initSDocContext PprDebug)))
902 doc = sep [text heading, nest 4 pretty_msg]
904 assertPprPanic :: String -> Int -> SDoc -> a
905 -- ^ Panic with an assertation failure, recording the given file and line number.
906 -- Should typically be accessed with the ASSERT family of macros
907 assertPprPanic file line msg
908 = panic (show (runSDoc doc (initSDocContext PprDebug)))
910 doc = sep [hsep[text "ASSERT failed! file",
912 text "line", int line],
915 warnPprTrace :: Bool -> String -> Int -> SDoc -> a -> a
916 -- ^ Just warn about an assertion failure, recording the given file and line number.
917 -- Should typically be accessed with the WARN macros
918 warnPprTrace _ _file _line _msg x | opt_NoDebugOutput = x
919 warnPprTrace False _file _line _msg x = x
920 warnPprTrace True file line msg x
921 = trace (show (runSDoc doc (initSDocContext defaultDumpStyle))) x
923 doc = sep [hsep [text "WARNING: file", text file, text "line", int line],