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
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 colGlobal, colLocal, 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, 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 type SDoc = 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 ctxt = d ctxt{sdocStyle=sty}
242 withPprStyleDoc :: PprStyle -> SDoc -> Doc
243 withPprStyleDoc sty d = d (initSDocContext sty)
245 pprDeeper :: SDoc -> SDoc
246 pprDeeper _ SDC{sdocStyle=PprUser _ (PartWay 0)} =
248 pprDeeper d ctx@SDC{sdocStyle=PprUser q (PartWay n)} =
249 d ctx{sdocStyle = PprUser q (PartWay (n-1))}
250 pprDeeper d other_sty =
253 pprDeeperList :: ([SDoc] -> SDoc) -> [SDoc] -> SDoc
254 -- Truncate a list that list that is longer than the current depth
255 pprDeeperList f ds ctx@SDC{sdocStyle=PprUser q (PartWay n)}
256 | n==0 = Pretty.text "..."
257 | otherwise = f (go 0 ds) ctx{sdocStyle = PprUser q (PartWay (n-1))}
260 go i (d:ds) | i >= n = [text "...."]
261 | otherwise = d : go (i+1) ds
263 pprDeeperList f ds other_sty
266 pprSetDepth :: Depth -> SDoc -> SDoc
267 pprSetDepth depth doc ctx@SDC{sdocStyle=PprUser q _} =
268 doc ctx{sdocStyle = PprUser q depth}
269 pprSetDepth _depth doc other_sty = doc other_sty
271 getPprStyle :: (PprStyle -> SDoc) -> SDoc
272 getPprStyle df sty = df (sdocStyle sty) sty
276 qualName :: PprStyle -> QueryQualifyName
277 qualName (PprUser (qual_name,_) _) m n = qual_name m n
278 qualName _other m _n = NameQual (moduleName m)
280 qualModule :: PprStyle -> QueryQualifyModule
281 qualModule (PprUser (_,qual_mod) _) m = qual_mod m
282 qualModule _other _m = True
284 codeStyle :: PprStyle -> Bool
285 codeStyle (PprCode _) = True
288 asmStyle :: PprStyle -> Bool
289 asmStyle (PprCode AsmStyle) = True
290 asmStyle _other = False
292 dumpStyle :: PprStyle -> Bool
293 dumpStyle PprDump = True
294 dumpStyle _other = False
296 debugStyle :: PprStyle -> Bool
297 debugStyle PprDebug = True
298 debugStyle _other = False
300 userStyle :: PprStyle -> Bool
301 userStyle (PprUser _ _) = True
302 userStyle _other = False
304 ifPprDebug :: SDoc -> SDoc -- Empty for non-debug style
305 ifPprDebug d ctx@SDC{sdocStyle=PprDebug} = d ctx
306 ifPprDebug _ _ = Pretty.empty
311 printSDoc :: SDoc -> PprStyle -> IO ()
313 Pretty.printDoc PageMode stdout (d (initSDocContext sty))
316 -- I'm not sure whether the direct-IO approach of Pretty.printDoc
317 -- above is better or worse than the put-big-string approach here
318 printErrs :: SDoc -> PprStyle -> IO ()
319 printErrs doc sty = do
320 Pretty.printDoc PageMode stderr (doc (initSDocContext sty))
323 printOutput :: Doc -> IO ()
324 printOutput doc = Pretty.printDoc PageMode stdout doc
326 printDump :: SDoc -> IO ()
327 printDump doc = hPrintDump stdout doc
329 hPrintDump :: Handle -> SDoc -> IO ()
330 hPrintDump h doc = do
331 Pretty.printDoc PageMode h (better_doc (initSDocContext defaultDumpStyle))
334 better_doc = doc $$ blankLine
336 printForUser :: Handle -> PrintUnqualified -> SDoc -> IO ()
337 printForUser handle unqual doc
338 = Pretty.printDoc PageMode handle (doc (initSDocContext (mkUserStyle unqual AllTheWay)))
340 printForUserPartWay :: Handle -> Int -> PrintUnqualified -> SDoc -> IO ()
341 printForUserPartWay handle d unqual doc
342 = Pretty.printDoc PageMode handle (doc (initSDocContext (mkUserStyle unqual (PartWay d))))
344 -- printForC, printForAsm do what they sound like
345 printForC :: Handle -> SDoc -> IO ()
346 printForC handle doc =
347 Pretty.printDoc LeftMode handle (doc (initSDocContext (PprCode CStyle)))
349 printForAsm :: Handle -> SDoc -> IO ()
350 printForAsm handle doc =
351 Pretty.printDoc LeftMode handle (doc (initSDocContext (PprCode AsmStyle)))
353 pprCode :: CodeStyle -> SDoc -> SDoc
354 pprCode cs d = withPprStyle (PprCode cs) d
356 mkCodeStyle :: CodeStyle -> PprStyle
357 mkCodeStyle = PprCode
359 -- Can't make SDoc an instance of Show because SDoc is just a function type
360 -- However, Doc *is* an instance of Show
361 -- showSDoc just blasts it out as a string
362 showSDoc :: SDoc -> String
363 showSDoc d = Pretty.showDocWith PageMode (d (initSDocContext defaultUserStyle))
365 renderWithStyle :: SDoc -> PprStyle -> String
366 renderWithStyle sdoc sty =
367 Pretty.render (sdoc (initSDocContext sty))
369 -- This shows an SDoc, but on one line only. It's cheaper than a full
370 -- showSDoc, designed for when we're getting results like "Foo.bar"
371 -- and "foo{uniq strictness}" so we don't want fancy layout anyway.
372 showSDocOneLine :: SDoc -> String
374 Pretty.showDocWith PageMode (d (initSDocContext defaultUserStyle))
376 showSDocForUser :: PrintUnqualified -> SDoc -> String
377 showSDocForUser unqual doc =
378 show (doc (initSDocContext (mkUserStyle unqual AllTheWay)))
380 showSDocUnqual :: SDoc -> String
381 -- Only used in the gruesome isOperator
383 show (d (initSDocContext (mkUserStyle neverQualify AllTheWay)))
385 showsPrecSDoc :: Int -> SDoc -> ShowS
386 showsPrecSDoc p d = showsPrec p (d (initSDocContext defaultUserStyle))
388 showSDocDump :: SDoc -> String
389 showSDocDump d = Pretty.showDocWith PageMode (d (initSDocContext PprDump))
391 showSDocDumpOneLine :: SDoc -> String
392 showSDocDumpOneLine d =
393 Pretty.showDocWith OneLineMode (d (initSDocContext PprDump))
395 showSDocDebug :: SDoc -> String
396 showSDocDebug d = show (d (initSDocContext PprDebug))
398 showPpr :: Outputable a => a -> String
399 showPpr = showSDoc . ppr
403 docToSDoc :: Doc -> SDoc
404 docToSDoc d = \_ -> d
408 text :: String -> SDoc
409 ftext :: FastString -> SDoc
410 ptext :: LitString -> SDoc
412 integer :: Integer -> SDoc
413 float :: Float -> SDoc
414 double :: Double -> SDoc
415 rational :: Rational -> SDoc
417 empty _sty = Pretty.empty
418 char c _sty = Pretty.char c
419 text s _sty = Pretty.text s
420 ftext s _sty = Pretty.ftext s
421 ptext s _sty = Pretty.ptext s
422 int n _sty = Pretty.int n
423 integer n _sty = Pretty.integer n
424 float n _sty = Pretty.float n
425 double n _sty = Pretty.double n
426 rational n _sty = Pretty.rational n
428 parens, braces, brackets, quotes, doubleQuotes, angleBrackets :: SDoc -> SDoc
430 parens d sty = Pretty.parens (d sty)
431 braces d sty = Pretty.braces (d sty)
432 brackets d sty = Pretty.brackets (d sty)
433 doubleQuotes d sty = Pretty.doubleQuotes (d sty)
434 angleBrackets d = char '<' <> d <> char '>'
436 cparen :: Bool -> SDoc -> SDoc
438 cparen b d sty = Pretty.cparen b (d sty)
440 -- quotes encloses something in single quotes...
441 -- but it omits them if the thing ends in a single quote
442 -- so that we don't get `foo''. Instead we just have foo'.
443 quotes d sty = case show pp_d of
445 _other -> Pretty.quotes pp_d
449 semi, comma, colon, equals, space, dcolon, arrow, underscore, dot :: SDoc
450 darrow, lparen, rparen, lbrack, rbrack, lbrace, rbrace, blankLine :: SDoc
452 blankLine _sty = Pretty.ptext (sLit "")
453 dcolon _sty = Pretty.ptext (sLit "::")
454 arrow _sty = Pretty.ptext (sLit "->")
455 darrow _sty = Pretty.ptext (sLit "=>")
456 semi _sty = Pretty.semi
457 comma _sty = Pretty.comma
458 colon _sty = Pretty.colon
459 equals _sty = Pretty.equals
460 space _sty = Pretty.space
461 underscore = char '_'
463 lparen _sty = Pretty.lparen
464 rparen _sty = Pretty.rparen
465 lbrack _sty = Pretty.lbrack
466 rbrack _sty = Pretty.rbrack
467 lbrace _sty = Pretty.lbrace
468 rbrace _sty = Pretty.rbrace
470 nest :: Int -> SDoc -> SDoc
471 -- ^ Indent 'SDoc' some specified amount
472 (<>) :: SDoc -> SDoc -> SDoc
473 -- ^ Join two 'SDoc' together horizontally without a gap
474 (<+>) :: SDoc -> SDoc -> SDoc
475 -- ^ Join two 'SDoc' together horizontally with a gap between them
476 ($$) :: SDoc -> SDoc -> SDoc
477 -- ^ Join two 'SDoc' together vertically; if there is
478 -- no vertical overlap it "dovetails" the two onto one line
479 ($+$) :: SDoc -> SDoc -> SDoc
480 -- ^ Join two 'SDoc' together vertically
482 nest n d sty = Pretty.nest n (d sty)
483 (<>) d1 d2 sty = (Pretty.<>) (d1 sty) (d2 sty)
484 (<+>) d1 d2 sty = (Pretty.<+>) (d1 sty) (d2 sty)
485 ($$) d1 d2 sty = (Pretty.$$) (d1 sty) (d2 sty)
486 ($+$) d1 d2 sty = (Pretty.$+$) (d1 sty) (d2 sty)
488 hcat :: [SDoc] -> SDoc
489 -- ^ Concatenate 'SDoc' horizontally
490 hsep :: [SDoc] -> SDoc
491 -- ^ Concatenate 'SDoc' horizontally with a space between each one
492 vcat :: [SDoc] -> SDoc
493 -- ^ Concatenate 'SDoc' vertically with dovetailing
494 sep :: [SDoc] -> SDoc
495 -- ^ Separate: is either like 'hsep' or like 'vcat', depending on what fits
496 cat :: [SDoc] -> SDoc
497 -- ^ Catenate: is either like 'hcat' or like 'vcat', depending on what fits
498 fsep :: [SDoc] -> SDoc
499 -- ^ A paragraph-fill combinator. It's much like sep, only it
500 -- keeps fitting things on one line until it can't fit any more.
501 fcat :: [SDoc] -> SDoc
502 -- ^ This behaves like 'fsep', but it uses '<>' for horizontal conposition rather than '<+>'
505 hcat ds sty = Pretty.hcat [d sty | d <- ds]
506 hsep ds sty = Pretty.hsep [d sty | d <- ds]
507 vcat ds sty = Pretty.vcat [d sty | d <- ds]
508 sep ds sty = Pretty.sep [d sty | d <- ds]
509 cat ds sty = Pretty.cat [d sty | d <- ds]
510 fsep ds sty = Pretty.fsep [d sty | d <- ds]
511 fcat ds sty = Pretty.fcat [d sty | d <- ds]
513 hang :: SDoc -- ^ The header
514 -> Int -- ^ Amount to indent the hung body
515 -> SDoc -- ^ The hung body, indented and placed below the header
517 hang d1 n d2 sty = Pretty.hang (d1 sty) n (d2 sty)
519 punctuate :: SDoc -- ^ The punctuation
520 -> [SDoc] -- ^ The list that will have punctuation added between every adjacent pair of elements
521 -> [SDoc] -- ^ Punctuated list
523 punctuate p (d:ds) = go d ds
526 go d (e:es) = (d <> p) : go e es
528 ppWhen, ppUnless :: Bool -> SDoc -> SDoc
529 ppWhen True doc = doc
530 ppWhen False _ = empty
532 ppUnless True _ = empty
533 ppUnless False doc = doc
535 -- | A colour\/style for use with 'coloured'.
536 newtype PprColour = PprColour String
541 colType = PprColour "\27[34m"
544 colBold = PprColour "\27[;1m"
546 colCoerc :: PprColour
547 colCoerc = PprColour "\27[34m"
549 colDataCon :: PprColour
550 colDataCon = PprColour "\27[31;1m"
552 colGlobal :: PprColour
553 colGlobal = PprColour "\27[32m"
555 colLocal :: PprColour
556 colLocal = PprColour "\27[35m"
558 colReset :: PprColour
559 colReset = PprColour "\27[0m"
561 -- | Apply the given colour\/style for the argument.
563 -- Only takes effect if colours are enabled.
564 coloured :: PprColour -> SDoc -> SDoc
565 -- TODO: coloured _ sdoc ctxt | coloursDisabled = sdoc ctxt
566 coloured col@(PprColour c) sdoc
567 ctx@SDC{ sdocLastColour = PprColour lc } =
568 Pretty.zeroWidthText c Pretty.<> sdoc ctx' Pretty.<> Pretty.zeroWidthText lc
570 ctx' = ctx{ sdocLastColour = col }
573 bold = coloured colBold
575 keyword :: SDoc -> SDoc
581 %************************************************************************
583 \subsection[Outputable-class]{The @Outputable@ class}
585 %************************************************************************
588 -- | Class designating that some type has an 'SDoc' representation
589 class Outputable a where
594 instance Outputable Bool where
595 ppr True = ptext (sLit "True")
596 ppr False = ptext (sLit "False")
598 instance Outputable Int where
601 instance Outputable Word16 where
602 ppr n = integer $ fromIntegral n
604 instance Outputable Word32 where
605 ppr n = integer $ fromIntegral n
607 instance Outputable Word where
608 ppr n = integer $ fromIntegral n
610 instance Outputable () where
613 instance (Outputable a) => Outputable [a] where
614 ppr xs = brackets (fsep (punctuate comma (map ppr xs)))
616 instance (Outputable a, Outputable b) => Outputable (a, b) where
617 ppr (x,y) = parens (sep [ppr x <> comma, ppr y])
619 instance Outputable a => Outputable (Maybe a) where
620 ppr Nothing = ptext (sLit "Nothing")
621 ppr (Just x) = ptext (sLit "Just") <+> ppr x
623 instance (Outputable a, Outputable b) => Outputable (Either a b) where
624 ppr (Left x) = ptext (sLit "Left") <+> ppr x
625 ppr (Right y) = ptext (sLit "Right") <+> ppr y
627 -- ToDo: may not be used
628 instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c) where
630 parens (sep [ppr x <> comma,
634 instance (Outputable a, Outputable b, Outputable c, Outputable d) =>
635 Outputable (a, b, c, d) where
637 parens (sep [ppr a <> comma,
642 instance (Outputable a, Outputable b, Outputable c, Outputable d, Outputable e) =>
643 Outputable (a, b, c, d, e) where
645 parens (sep [ppr a <> comma,
651 instance Outputable FastString where
652 ppr fs = ftext fs -- Prints an unadorned string,
653 -- no double quotes or anything
655 instance (Outputable key, Outputable elt) => Outputable (M.Map key elt) where
656 ppr m = ppr (M.toList m)
657 instance (Outputable elt) => Outputable (IM.IntMap elt) where
658 ppr m = ppr (IM.toList m)
661 %************************************************************************
663 \subsection{The @OutputableBndr@ class}
665 %************************************************************************
668 -- | 'BindingSite' is used to tell the thing that prints binder what
669 -- language construct is binding the identifier. This can be used
670 -- to decide how much info to print.
671 data BindingSite = LambdaBind | CaseBind | LetBind
673 -- | When we print a binder, we often want to print its type too.
674 -- The @OutputableBndr@ class encapsulates this idea.
675 class Outputable a => OutputableBndr a where
676 pprBndr :: BindingSite -> a -> SDoc
680 %************************************************************************
682 \subsection{Random printing helpers}
684 %************************************************************************
687 -- We have 31-bit Chars and will simply use Show instances of Char and String.
689 -- | Special combinator for showing character literals.
690 pprHsChar :: Char -> SDoc
691 pprHsChar c | c > '\x10ffff' = char '\\' <> text (show (fromIntegral (ord c) :: Word32))
692 | otherwise = text (show c)
694 -- | Special combinator for showing string literals.
695 pprHsString :: FastString -> SDoc
696 pprHsString fs = vcat (map text (showMultiLineString (unpackFS fs)))
698 ---------------------
699 -- Put a name in parens if it's an operator
700 pprPrefixVar :: Bool -> SDoc -> SDoc
701 pprPrefixVar is_operator pp_v
702 | is_operator = parens pp_v
705 -- Put a name in backquotes if it's not an operator
706 pprInfixVar :: Bool -> SDoc -> SDoc
707 pprInfixVar is_operator pp_v
709 | otherwise = char '`' <> pp_v <> char '`'
711 ---------------------
712 -- pprHsVar and pprHsInfix use the gruesome isOperator, which
713 -- in turn uses (showSDoc (ppr v)), rather than isSymOcc (getOccName v).
714 -- Reason: it means that pprHsVar doesn't need a NamedThing context,
715 -- which none of the HsSyn printing functions do
716 pprHsVar, pprHsInfix :: Outputable name => name -> SDoc
717 pprHsVar v = pprPrefixVar (isOperator pp_v) pp_v
719 pprHsInfix v = pprInfixVar (isOperator pp_v) pp_v
722 isOperator :: SDoc -> Bool
724 = case showSDocUnqual ppr_v of
725 ('(':_) -> False -- (), (,) etc
726 ('[':_) -> False -- []
727 ('$':c:_) -> not (isAlpha c) -- Don't treat $d as an operator
728 (':':c:_) -> not (isAlpha c) -- Don't treat :T as an operator
729 ('_':_) -> False -- Not an operator
730 (c:_) -> not (isAlpha c) -- Starts with non-alpha
733 pprFastFilePath :: FastString -> SDoc
734 pprFastFilePath path = text $ normalise $ unpackFS path
737 %************************************************************************
739 \subsection{Other helper functions}
741 %************************************************************************
744 pprWithCommas :: (a -> SDoc) -- ^ The pretty printing function to use
745 -> [a] -- ^ The things to be pretty printed
746 -> SDoc -- ^ 'SDoc' where the things have been pretty printed,
747 -- comma-separated and finally packed into a paragraph.
748 pprWithCommas pp xs = fsep (punctuate comma (map pp xs))
750 -- | Returns the seperated concatenation of the pretty printed things.
751 interppSP :: Outputable a => [a] -> SDoc
752 interppSP xs = sep (map ppr xs)
754 -- | Returns the comma-seperated concatenation of the pretty printed things.
755 interpp'SP :: Outputable a => [a] -> SDoc
756 interpp'SP xs = sep (punctuate comma (map ppr xs))
758 -- | Returns the comma-seperated concatenation of the quoted pretty printed things.
760 -- > [x,y,z] ==> `x', `y', `z'
761 pprQuotedList :: Outputable a => [a] -> SDoc
762 pprQuotedList = quotedList . map ppr
764 quotedList :: [SDoc] -> SDoc
765 quotedList xs = hsep (punctuate comma (map quotes xs))
767 quotedListWithOr :: [SDoc] -> SDoc
768 -- [x,y,z] ==> `x', `y' or `z'
769 quotedListWithOr xs@(_:_:_) = quotedList (init xs) <+> ptext (sLit "or") <+> quotes (last xs)
770 quotedListWithOr xs = quotedList xs
774 %************************************************************************
776 \subsection{Printing numbers verbally}
778 %************************************************************************
781 -- | Converts an integer to a verbal index:
783 -- > speakNth 1 = text "first"
784 -- > speakNth 5 = text "fifth"
785 -- > speakNth 21 = text "21st"
786 speakNth :: Int -> SDoc
787 speakNth 1 = ptext (sLit "first")
788 speakNth 2 = ptext (sLit "second")
789 speakNth 3 = ptext (sLit "third")
790 speakNth 4 = ptext (sLit "fourth")
791 speakNth 5 = ptext (sLit "fifth")
792 speakNth 6 = ptext (sLit "sixth")
793 speakNth n = hcat [ int n, text suffix ]
795 suffix | n <= 20 = "th" -- 11,12,13 are non-std
796 | last_dig == 1 = "st"
797 | last_dig == 2 = "nd"
798 | last_dig == 3 = "rd"
801 last_dig = n `rem` 10
803 -- | Converts an integer to a verbal multiplicity:
805 -- > speakN 0 = text "none"
806 -- > speakN 5 = text "five"
807 -- > speakN 10 = text "10"
808 speakN :: Int -> SDoc
809 speakN 0 = ptext (sLit "none") -- E.g. "he has none"
810 speakN 1 = ptext (sLit "one") -- E.g. "he has one"
811 speakN 2 = ptext (sLit "two")
812 speakN 3 = ptext (sLit "three")
813 speakN 4 = ptext (sLit "four")
814 speakN 5 = ptext (sLit "five")
815 speakN 6 = ptext (sLit "six")
818 -- | Converts an integer and object description to a statement about the
819 -- multiplicity of those objects:
821 -- > speakNOf 0 (text "melon") = text "no melons"
822 -- > speakNOf 1 (text "melon") = text "one melon"
823 -- > speakNOf 3 (text "melon") = text "three melons"
824 speakNOf :: Int -> SDoc -> SDoc
825 speakNOf 0 d = ptext (sLit "no") <+> d <> char 's'
826 speakNOf 1 d = ptext (sLit "one") <+> d -- E.g. "one argument"
827 speakNOf n d = speakN n <+> d <> char 's' -- E.g. "three arguments"
829 -- | Converts a strictly positive integer into a number of times:
831 -- > speakNTimes 1 = text "once"
832 -- > speakNTimes 2 = text "twice"
833 -- > speakNTimes 4 = text "4 times"
834 speakNTimes :: Int {- >=1 -} -> SDoc
835 speakNTimes t | t == 1 = ptext (sLit "once")
836 | t == 2 = ptext (sLit "twice")
837 | otherwise = speakN t <+> ptext (sLit "times")
839 -- | Determines the pluralisation suffix appropriate for the length of a list:
841 -- > plural [] = char 's'
842 -- > plural ["Hello"] = empty
843 -- > plural ["Hello", "World"] = char 's'
844 plural :: [a] -> SDoc
845 plural [_] = empty -- a bit frightening, but there you are
850 %************************************************************************
852 \subsection{Error handling}
854 %************************************************************************
858 pprPanic :: String -> SDoc -> a
859 -- ^ Throw an exception saying "bug in GHC"
860 pprPanic = pprAndThen panic
862 pprSorry :: String -> SDoc -> a
863 -- ^ Throw an exceptio saying "this isn't finished yet"
864 pprSorry = pprAndThen sorry
867 pprPgmError :: String -> SDoc -> a
868 -- ^ Throw an exception saying "bug in pgm being compiled" (used for unusual program errors)
869 pprPgmError = pprAndThen pgmError
872 pprTrace :: String -> SDoc -> a -> a
873 -- ^ If debug output is on, show some 'SDoc' on the screen
875 | opt_NoDebugOutput = x
876 | otherwise = pprAndThen trace str doc x
879 pprPanicFastInt :: String -> SDoc -> FastInt
880 -- ^ Specialization of pprPanic that can be safely used with 'FastInt'
881 pprPanicFastInt heading pretty_msg =
882 panicFastInt (show (doc (initSDocContext PprDebug)))
884 doc = text heading <+> pretty_msg
887 pprAndThen :: (String -> a) -> String -> SDoc -> a
888 pprAndThen cont heading pretty_msg =
889 cont (show (doc (initSDocContext PprDebug)))
891 doc = sep [text heading, nest 4 pretty_msg]
893 assertPprPanic :: String -> Int -> SDoc -> a
894 -- ^ Panic with an assertation failure, recording the given file and line number.
895 -- Should typically be accessed with the ASSERT family of macros
896 assertPprPanic file line msg
897 = panic (show (doc (initSDocContext PprDebug)))
899 doc = sep [hsep[text "ASSERT failed! file",
901 text "line", int line],
904 warnPprTrace :: Bool -> String -> Int -> SDoc -> a -> a
905 -- ^ Just warn about an assertion failure, recording the given file and line number.
906 -- Should typically be accessed with the WARN macros
907 warnPprTrace _ _file _line _msg x | opt_NoDebugOutput = x
908 warnPprTrace False _file _line _msg x = x
909 warnPprTrace True file line msg x
910 = trace (show (doc (initSDocContext defaultDumpStyle))) x
912 doc = sep [hsep [text "WARNING: file", text file, text "line", int line],