1{- 2(c) The University of Glasgow 2006-2012 3(c) The GRASP Project, Glasgow University, 1992-1998 4-} 5 6-- | This module defines classes and functions for pretty-printing. It also 7-- exports a number of helpful debugging and other utilities such as 'trace' and 'panic'. 8-- 9-- The interface to this module is very similar to the standard Hughes-PJ pretty printing 10-- module, except that it exports a number of additional functions that are rarely used, 11-- and works over the 'SDoc' type. 12module Outputable ( 13 -- * Type classes 14 Outputable(..), OutputableBndr(..), 15 16 -- * Pretty printing combinators 17 SDoc, runSDoc, initSDocContext, 18 docToSDoc, 19 interppSP, interpp'SP, 20 pprQuotedList, pprWithCommas, quotedListWithOr, quotedListWithNor, 21 pprWithBars, 22 empty, isEmpty, nest, 23 char, 24 text, ftext, ptext, ztext, 25 int, intWithCommas, integer, word, float, double, rational, doublePrec, 26 parens, cparen, brackets, braces, quotes, quote, 27 doubleQuotes, angleBrackets, 28 semi, comma, colon, dcolon, space, equals, dot, vbar, 29 arrow, larrow, darrow, arrowt, larrowt, arrowtt, larrowtt, 30 lparen, rparen, lbrack, rbrack, lbrace, rbrace, underscore, 31 blankLine, forAllLit, kindType, bullet, 32 (<>), (<+>), hcat, hsep, 33 ($$), ($+$), vcat, 34 sep, cat, 35 fsep, fcat, 36 hang, hangNotEmpty, punctuate, ppWhen, ppUnless, 37 speakNth, speakN, speakNOf, plural, isOrAre, doOrDoes, 38 unicodeSyntax, 39 40 coloured, keyword, 41 42 -- * Converting 'SDoc' into strings and outputing it 43 printSDoc, printSDocLn, printForUser, printForUserPartWay, 44 printForC, bufLeftRenderSDoc, 45 pprCode, mkCodeStyle, 46 showSDoc, showSDocUnsafe, showSDocOneLine, 47 showSDocForUser, showSDocDebug, showSDocDump, showSDocDumpOneLine, 48 showSDocUnqual, showPpr, 49 renderWithStyle, 50 51 pprInfixVar, pprPrefixVar, 52 pprHsChar, pprHsString, pprHsBytes, 53 54 primFloatSuffix, primCharSuffix, primWordSuffix, primDoubleSuffix, 55 primInt64Suffix, primWord64Suffix, primIntSuffix, 56 57 pprPrimChar, pprPrimInt, pprPrimWord, pprPrimInt64, pprPrimWord64, 58 59 pprFastFilePath, pprFilePathString, 60 61 -- * Controlling the style in which output is printed 62 BindingSite(..), 63 64 PprStyle, CodeStyle(..), PrintUnqualified(..), 65 QueryQualifyName, QueryQualifyModule, QueryQualifyPackage, 66 reallyAlwaysQualify, reallyAlwaysQualifyNames, 67 alwaysQualify, alwaysQualifyNames, alwaysQualifyModules, 68 neverQualify, neverQualifyNames, neverQualifyModules, 69 alwaysQualifyPackages, neverQualifyPackages, 70 QualifyName(..), queryQual, 71 sdocWithDynFlags, sdocWithPlatform, 72 updSDocDynFlags, 73 getPprStyle, withPprStyle, withPprStyleDoc, setStyleColoured, 74 pprDeeper, pprDeeperList, pprSetDepth, 75 codeStyle, userStyle, debugStyle, dumpStyle, asmStyle, 76 qualName, qualModule, qualPackage, 77 mkErrStyle, defaultErrStyle, defaultDumpStyle, mkDumpStyle, defaultUserStyle, 78 mkUserStyle, cmdlineParserStyle, Depth(..), 79 80 ifPprDebug, whenPprDebug, getPprDebug, 81 82 -- * Error handling and debugging utilities 83 pprPanic, pprSorry, assertPprPanic, pprPgmError, 84 pprTrace, pprTraceDebug, pprTraceWith, pprTraceIt, warnPprTrace, 85 pprSTrace, pprTraceException, pprTraceM, 86 trace, pgmError, panic, sorry, assertPanic, 87 pprDebugAndThen, callStackDoc, 88 ) where 89 90import GhcPrelude 91 92import {-# SOURCE #-} DynFlags( DynFlags, hasPprDebug, hasNoDebugOutput, 93 targetPlatform, pprUserLength, pprCols, 94 useUnicode, useUnicodeSyntax, useStarIsType, 95 shouldUseColor, unsafeGlobalDynFlags, 96 shouldUseHexWordLiterals ) 97import {-# SOURCE #-} Module( UnitId, Module, ModuleName, moduleName ) 98import {-# SOURCE #-} OccName( OccName ) 99 100import BufWrite (BufHandle) 101import FastString 102import qualified Pretty 103import Util 104import GHC.Platform 105import qualified PprColour as Col 106import Pretty ( Doc, Mode(..) ) 107import Panic 108import GHC.Serialized 109import GHC.LanguageExtensions (Extension) 110 111import Data.ByteString (ByteString) 112import qualified Data.ByteString as BS 113import Data.Char 114import qualified Data.Map as M 115import Data.Int 116import qualified Data.IntMap as IM 117import Data.Set (Set) 118import qualified Data.Set as Set 119import Data.String 120import Data.Word 121import System.IO ( Handle ) 122import System.FilePath 123import Text.Printf 124import Numeric (showFFloat) 125import Data.Graph (SCC(..)) 126import Data.List (intersperse) 127 128import GHC.Fingerprint 129import GHC.Show ( showMultiLineString ) 130import GHC.Stack ( callStack, prettyCallStack ) 131import Control.Monad.IO.Class 132import Exception 133 134{- 135************************************************************************ 136* * 137\subsection{The @PprStyle@ data type} 138* * 139************************************************************************ 140-} 141 142data PprStyle 143 = PprUser PrintUnqualified Depth Coloured 144 -- Pretty-print in a way that will make sense to the 145 -- ordinary user; must be very close to Haskell 146 -- syntax, etc. 147 -- Assumes printing tidied code: non-system names are 148 -- printed without uniques. 149 150 | PprDump PrintUnqualified 151 -- For -ddump-foo; less verbose than PprDebug, but more than PprUser 152 -- Does not assume tidied code: non-external names 153 -- are printed with uniques. 154 155 | PprDebug -- Full debugging output 156 157 | PprCode CodeStyle 158 -- Print code; either C or assembler 159 160data CodeStyle = CStyle -- The format of labels differs for C and assembler 161 | AsmStyle 162 163data Depth = AllTheWay 164 | PartWay Int -- 0 => stop 165 166data Coloured 167 = Uncoloured 168 | Coloured 169 170-- ----------------------------------------------------------------------------- 171-- Printing original names 172 173-- | When printing code that contains original names, we need to map the 174-- original names back to something the user understands. This is the 175-- purpose of the triple of functions that gets passed around 176-- when rendering 'SDoc'. 177data PrintUnqualified = QueryQualify { 178 queryQualifyName :: QueryQualifyName, 179 queryQualifyModule :: QueryQualifyModule, 180 queryQualifyPackage :: QueryQualifyPackage 181} 182 183-- | Given a `Name`'s `Module` and `OccName`, decide whether and how to qualify 184-- it. 185type QueryQualifyName = Module -> OccName -> QualifyName 186 187-- | For a given module, we need to know whether to print it with 188-- a package name to disambiguate it. 189type QueryQualifyModule = Module -> Bool 190 191-- | For a given package, we need to know whether to print it with 192-- the component id to disambiguate it. 193type QueryQualifyPackage = UnitId -> Bool 194 195-- See Note [Printing original names] in HscTypes 196data QualifyName -- Given P:M.T 197 = NameUnqual -- It's in scope unqualified as "T" 198 -- OR nothing called "T" is in scope 199 200 | NameQual ModuleName -- It's in scope qualified as "X.T" 201 202 | NameNotInScope1 -- It's not in scope at all, but M.T is not bound 203 -- in the current scope, so we can refer to it as "M.T" 204 205 | NameNotInScope2 -- It's not in scope at all, and M.T is already bound in 206 -- the current scope, so we must refer to it as "P:M.T" 207 208instance Outputable QualifyName where 209 ppr NameUnqual = text "NameUnqual" 210 ppr (NameQual _mod) = text "NameQual" -- can't print the mod without module loops :( 211 ppr NameNotInScope1 = text "NameNotInScope1" 212 ppr NameNotInScope2 = text "NameNotInScope2" 213 214reallyAlwaysQualifyNames :: QueryQualifyName 215reallyAlwaysQualifyNames _ _ = NameNotInScope2 216 217-- | NB: This won't ever show package IDs 218alwaysQualifyNames :: QueryQualifyName 219alwaysQualifyNames m _ = NameQual (moduleName m) 220 221neverQualifyNames :: QueryQualifyName 222neverQualifyNames _ _ = NameUnqual 223 224alwaysQualifyModules :: QueryQualifyModule 225alwaysQualifyModules _ = True 226 227neverQualifyModules :: QueryQualifyModule 228neverQualifyModules _ = False 229 230alwaysQualifyPackages :: QueryQualifyPackage 231alwaysQualifyPackages _ = True 232 233neverQualifyPackages :: QueryQualifyPackage 234neverQualifyPackages _ = False 235 236reallyAlwaysQualify, alwaysQualify, neverQualify :: PrintUnqualified 237reallyAlwaysQualify 238 = QueryQualify reallyAlwaysQualifyNames 239 alwaysQualifyModules 240 alwaysQualifyPackages 241alwaysQualify = QueryQualify alwaysQualifyNames 242 alwaysQualifyModules 243 alwaysQualifyPackages 244neverQualify = QueryQualify neverQualifyNames 245 neverQualifyModules 246 neverQualifyPackages 247 248defaultUserStyle :: DynFlags -> PprStyle 249defaultUserStyle dflags = mkUserStyle dflags neverQualify AllTheWay 250 251defaultDumpStyle :: DynFlags -> PprStyle 252 -- Print without qualifiers to reduce verbosity, unless -dppr-debug 253defaultDumpStyle dflags 254 | hasPprDebug dflags = PprDebug 255 | otherwise = PprDump neverQualify 256 257mkDumpStyle :: DynFlags -> PrintUnqualified -> PprStyle 258mkDumpStyle dflags print_unqual 259 | hasPprDebug dflags = PprDebug 260 | otherwise = PprDump print_unqual 261 262defaultErrStyle :: DynFlags -> PprStyle 263-- Default style for error messages, when we don't know PrintUnqualified 264-- It's a bit of a hack because it doesn't take into account what's in scope 265-- Only used for desugarer warnings, and typechecker errors in interface sigs 266-- NB that -dppr-debug will still get into PprDebug style 267defaultErrStyle dflags = mkErrStyle dflags neverQualify 268 269-- | Style for printing error messages 270mkErrStyle :: DynFlags -> PrintUnqualified -> PprStyle 271mkErrStyle dflags qual = 272 mkUserStyle dflags qual (PartWay (pprUserLength dflags)) 273 274cmdlineParserStyle :: DynFlags -> PprStyle 275cmdlineParserStyle dflags = mkUserStyle dflags alwaysQualify AllTheWay 276 277mkUserStyle :: DynFlags -> PrintUnqualified -> Depth -> PprStyle 278mkUserStyle dflags unqual depth 279 | hasPprDebug dflags = PprDebug 280 | otherwise = PprUser unqual depth Uncoloured 281 282setStyleColoured :: Bool -> PprStyle -> PprStyle 283setStyleColoured col style = 284 case style of 285 PprUser q d _ -> PprUser q d c 286 _ -> style 287 where 288 c | col = Coloured 289 | otherwise = Uncoloured 290 291instance Outputable PprStyle where 292 ppr (PprUser {}) = text "user-style" 293 ppr (PprCode {}) = text "code-style" 294 ppr (PprDump {}) = text "dump-style" 295 ppr (PprDebug {}) = text "debug-style" 296 297{- 298Orthogonal to the above printing styles are (possibly) some 299command-line flags that affect printing (often carried with the 300style). The most likely ones are variations on how much type info is 301shown. 302 303The following test decides whether or not we are actually generating 304code (either C or assembly), or generating interface files. 305 306************************************************************************ 307* * 308\subsection{The @SDoc@ data type} 309* * 310************************************************************************ 311-} 312 313-- | Represents a pretty-printable document. 314-- 315-- To display an 'SDoc', use 'printSDoc', 'printSDocLn', 'bufLeftRenderSDoc', 316-- or 'renderWithStyle'. Avoid calling 'runSDoc' directly as it breaks the 317-- abstraction layer. 318newtype SDoc = SDoc { runSDoc :: SDocContext -> Doc } 319 320data SDocContext = SDC 321 { sdocStyle :: !PprStyle 322 , sdocLastColour :: !Col.PprColour 323 -- ^ The most recently used colour. This allows nesting colours. 324 , sdocDynFlags :: !DynFlags 325 } 326 327instance IsString SDoc where 328 fromString = text 329 330-- The lazy programmer's friend. 331instance Outputable SDoc where 332 ppr = id 333 334initSDocContext :: DynFlags -> PprStyle -> SDocContext 335initSDocContext dflags sty = SDC 336 { sdocStyle = sty 337 , sdocLastColour = Col.colReset 338 , sdocDynFlags = dflags 339 } 340 341withPprStyle :: PprStyle -> SDoc -> SDoc 342withPprStyle sty d = SDoc $ \ctxt -> runSDoc d ctxt{sdocStyle=sty} 343 344-- | This is not a recommended way to render 'SDoc', since it breaks the 345-- abstraction layer of 'SDoc'. Prefer to use 'printSDoc', 'printSDocLn', 346-- 'bufLeftRenderSDoc', or 'renderWithStyle' instead. 347withPprStyleDoc :: DynFlags -> PprStyle -> SDoc -> Doc 348withPprStyleDoc dflags sty d = runSDoc d (initSDocContext dflags sty) 349 350pprDeeper :: SDoc -> SDoc 351pprDeeper d = SDoc $ \ctx -> case ctx of 352 SDC{sdocStyle=PprUser _ (PartWay 0) _} -> Pretty.text "..." 353 SDC{sdocStyle=PprUser q (PartWay n) c} -> 354 runSDoc d ctx{sdocStyle = PprUser q (PartWay (n-1)) c} 355 _ -> runSDoc d ctx 356 357-- | Truncate a list that is longer than the current depth. 358pprDeeperList :: ([SDoc] -> SDoc) -> [SDoc] -> SDoc 359pprDeeperList f ds 360 | null ds = f [] 361 | otherwise = SDoc work 362 where 363 work ctx@SDC{sdocStyle=PprUser q (PartWay n) c} 364 | n==0 = Pretty.text "..." 365 | otherwise = 366 runSDoc (f (go 0 ds)) ctx{sdocStyle = PprUser q (PartWay (n-1)) c} 367 where 368 go _ [] = [] 369 go i (d:ds) | i >= n = [text "...."] 370 | otherwise = d : go (i+1) ds 371 work other_ctx = runSDoc (f ds) other_ctx 372 373pprSetDepth :: Depth -> SDoc -> SDoc 374pprSetDepth depth doc = SDoc $ \ctx -> 375 case ctx of 376 SDC{sdocStyle=PprUser q _ c} -> 377 runSDoc doc ctx{sdocStyle = PprUser q depth c} 378 _ -> 379 runSDoc doc ctx 380 381getPprStyle :: (PprStyle -> SDoc) -> SDoc 382getPprStyle df = SDoc $ \ctx -> runSDoc (df (sdocStyle ctx)) ctx 383 384sdocWithDynFlags :: (DynFlags -> SDoc) -> SDoc 385sdocWithDynFlags f = SDoc $ \ctx -> runSDoc (f (sdocDynFlags ctx)) ctx 386 387sdocWithPlatform :: (Platform -> SDoc) -> SDoc 388sdocWithPlatform f = sdocWithDynFlags (f . targetPlatform) 389 390updSDocDynFlags :: (DynFlags -> DynFlags) -> SDoc -> SDoc 391updSDocDynFlags upd doc 392 = SDoc $ \ctx -> runSDoc doc (ctx { sdocDynFlags = upd (sdocDynFlags ctx) }) 393 394qualName :: PprStyle -> QueryQualifyName 395qualName (PprUser q _ _) mod occ = queryQualifyName q mod occ 396qualName (PprDump q) mod occ = queryQualifyName q mod occ 397qualName _other mod _ = NameQual (moduleName mod) 398 399qualModule :: PprStyle -> QueryQualifyModule 400qualModule (PprUser q _ _) m = queryQualifyModule q m 401qualModule (PprDump q) m = queryQualifyModule q m 402qualModule _other _m = True 403 404qualPackage :: PprStyle -> QueryQualifyPackage 405qualPackage (PprUser q _ _) m = queryQualifyPackage q m 406qualPackage (PprDump q) m = queryQualifyPackage q m 407qualPackage _other _m = True 408 409queryQual :: PprStyle -> PrintUnqualified 410queryQual s = QueryQualify (qualName s) 411 (qualModule s) 412 (qualPackage s) 413 414codeStyle :: PprStyle -> Bool 415codeStyle (PprCode _) = True 416codeStyle _ = False 417 418asmStyle :: PprStyle -> Bool 419asmStyle (PprCode AsmStyle) = True 420asmStyle _other = False 421 422dumpStyle :: PprStyle -> Bool 423dumpStyle (PprDump {}) = True 424dumpStyle _other = False 425 426debugStyle :: PprStyle -> Bool 427debugStyle PprDebug = True 428debugStyle _other = False 429 430userStyle :: PprStyle -> Bool 431userStyle (PprUser {}) = True 432userStyle _other = False 433 434getPprDebug :: (Bool -> SDoc) -> SDoc 435getPprDebug d = getPprStyle $ \ sty -> d (debugStyle sty) 436 437ifPprDebug :: SDoc -> SDoc -> SDoc 438-- ^ Says what to do with and without -dppr-debug 439ifPprDebug yes no = getPprDebug $ \ dbg -> if dbg then yes else no 440 441whenPprDebug :: SDoc -> SDoc -- Empty for non-debug style 442-- ^ Says what to do with -dppr-debug; without, return empty 443whenPprDebug d = ifPprDebug d empty 444 445-- | The analog of 'Pretty.printDoc_' for 'SDoc', which tries to make sure the 446-- terminal doesn't get screwed up by the ANSI color codes if an exception 447-- is thrown during pretty-printing. 448printSDoc :: Mode -> DynFlags -> Handle -> PprStyle -> SDoc -> IO () 449printSDoc mode dflags handle sty doc = 450 Pretty.printDoc_ mode cols handle (runSDoc doc ctx) 451 `finally` 452 Pretty.printDoc_ mode cols handle 453 (runSDoc (coloured Col.colReset empty) ctx) 454 where 455 cols = pprCols dflags 456 ctx = initSDocContext dflags sty 457 458-- | Like 'printSDoc' but appends an extra newline. 459printSDocLn :: Mode -> DynFlags -> Handle -> PprStyle -> SDoc -> IO () 460printSDocLn mode dflags handle sty doc = 461 printSDoc mode dflags handle sty (doc $$ text "") 462 463printForUser :: DynFlags -> Handle -> PrintUnqualified -> SDoc -> IO () 464printForUser dflags handle unqual doc 465 = printSDocLn PageMode dflags handle 466 (mkUserStyle dflags unqual AllTheWay) doc 467 468printForUserPartWay :: DynFlags -> Handle -> Int -> PrintUnqualified -> SDoc 469 -> IO () 470printForUserPartWay dflags handle d unqual doc 471 = printSDocLn PageMode dflags handle 472 (mkUserStyle dflags unqual (PartWay d)) doc 473 474-- | Like 'printSDocLn' but specialized with 'LeftMode' and 475-- @'PprCode' 'CStyle'@. This is typically used to output C-- code. 476printForC :: DynFlags -> Handle -> SDoc -> IO () 477printForC dflags handle doc = 478 printSDocLn LeftMode dflags handle (PprCode CStyle) doc 479 480-- | An efficient variant of 'printSDoc' specialized for 'LeftMode' that 481-- outputs to a 'BufHandle'. 482bufLeftRenderSDoc :: DynFlags -> BufHandle -> PprStyle -> SDoc -> IO () 483bufLeftRenderSDoc dflags bufHandle sty doc = 484 Pretty.bufLeftRender bufHandle (runSDoc doc (initSDocContext dflags sty)) 485 486pprCode :: CodeStyle -> SDoc -> SDoc 487pprCode cs d = withPprStyle (PprCode cs) d 488 489mkCodeStyle :: CodeStyle -> PprStyle 490mkCodeStyle = PprCode 491 492-- Can't make SDoc an instance of Show because SDoc is just a function type 493-- However, Doc *is* an instance of Show 494-- showSDoc just blasts it out as a string 495showSDoc :: DynFlags -> SDoc -> String 496showSDoc dflags sdoc = renderWithStyle dflags sdoc (defaultUserStyle dflags) 497 498-- showSDocUnsafe is unsafe, because `unsafeGlobalDynFlags` might not be 499-- initialised yet. 500showSDocUnsafe :: SDoc -> String 501showSDocUnsafe sdoc = showSDoc unsafeGlobalDynFlags sdoc 502 503showPpr :: Outputable a => DynFlags -> a -> String 504showPpr dflags thing = showSDoc dflags (ppr thing) 505 506showSDocUnqual :: DynFlags -> SDoc -> String 507-- Only used by Haddock 508showSDocUnqual dflags sdoc = showSDoc dflags sdoc 509 510showSDocForUser :: DynFlags -> PrintUnqualified -> SDoc -> String 511-- Allows caller to specify the PrintUnqualified to use 512showSDocForUser dflags unqual doc 513 = renderWithStyle dflags doc (mkUserStyle dflags unqual AllTheWay) 514 515showSDocDump :: DynFlags -> SDoc -> String 516showSDocDump dflags d = renderWithStyle dflags d (defaultDumpStyle dflags) 517 518showSDocDebug :: DynFlags -> SDoc -> String 519showSDocDebug dflags d = renderWithStyle dflags d PprDebug 520 521renderWithStyle :: DynFlags -> SDoc -> PprStyle -> String 522renderWithStyle dflags sdoc sty 523 = let s = Pretty.style{ Pretty.mode = PageMode, 524 Pretty.lineLength = pprCols dflags } 525 in Pretty.renderStyle s $ runSDoc sdoc (initSDocContext dflags sty) 526 527-- This shows an SDoc, but on one line only. It's cheaper than a full 528-- showSDoc, designed for when we're getting results like "Foo.bar" 529-- and "foo{uniq strictness}" so we don't want fancy layout anyway. 530showSDocOneLine :: DynFlags -> SDoc -> String 531showSDocOneLine dflags d 532 = let s = Pretty.style{ Pretty.mode = OneLineMode, 533 Pretty.lineLength = pprCols dflags } in 534 Pretty.renderStyle s $ 535 runSDoc d (initSDocContext dflags (defaultUserStyle dflags)) 536 537showSDocDumpOneLine :: DynFlags -> SDoc -> String 538showSDocDumpOneLine dflags d 539 = let s = Pretty.style{ Pretty.mode = OneLineMode, 540 Pretty.lineLength = irrelevantNCols } in 541 Pretty.renderStyle s $ 542 runSDoc d (initSDocContext dflags (defaultDumpStyle dflags)) 543 544irrelevantNCols :: Int 545-- Used for OneLineMode and LeftMode when number of cols isn't used 546irrelevantNCols = 1 547 548isEmpty :: DynFlags -> SDoc -> Bool 549isEmpty dflags sdoc = Pretty.isEmpty $ runSDoc sdoc dummySDocContext 550 where dummySDocContext = initSDocContext dflags PprDebug 551 552docToSDoc :: Doc -> SDoc 553docToSDoc d = SDoc (\_ -> d) 554 555empty :: SDoc 556char :: Char -> SDoc 557text :: String -> SDoc 558ftext :: FastString -> SDoc 559ptext :: PtrString -> SDoc 560ztext :: FastZString -> SDoc 561int :: Int -> SDoc 562integer :: Integer -> SDoc 563word :: Integer -> SDoc 564float :: Float -> SDoc 565double :: Double -> SDoc 566rational :: Rational -> SDoc 567 568empty = docToSDoc $ Pretty.empty 569char c = docToSDoc $ Pretty.char c 570 571text s = docToSDoc $ Pretty.text s 572{-# INLINE text #-} -- Inline so that the RULE Pretty.text will fire 573 574ftext s = docToSDoc $ Pretty.ftext s 575ptext s = docToSDoc $ Pretty.ptext s 576ztext s = docToSDoc $ Pretty.ztext s 577int n = docToSDoc $ Pretty.int n 578integer n = docToSDoc $ Pretty.integer n 579float n = docToSDoc $ Pretty.float n 580double n = docToSDoc $ Pretty.double n 581rational n = docToSDoc $ Pretty.rational n 582word n = sdocWithDynFlags $ \dflags -> 583 -- See Note [Print Hexadecimal Literals] in Pretty.hs 584 if shouldUseHexWordLiterals dflags 585 then docToSDoc $ Pretty.hex n 586 else docToSDoc $ Pretty.integer n 587 588-- | @doublePrec p n@ shows a floating point number @n@ with @p@ 589-- digits of precision after the decimal point. 590doublePrec :: Int -> Double -> SDoc 591doublePrec p n = text (showFFloat (Just p) n "") 592 593parens, braces, brackets, quotes, quote, 594 doubleQuotes, angleBrackets :: SDoc -> SDoc 595 596parens d = SDoc $ Pretty.parens . runSDoc d 597braces d = SDoc $ Pretty.braces . runSDoc d 598brackets d = SDoc $ Pretty.brackets . runSDoc d 599quote d = SDoc $ Pretty.quote . runSDoc d 600doubleQuotes d = SDoc $ Pretty.doubleQuotes . runSDoc d 601angleBrackets d = char '<' <> d <> char '>' 602 603cparen :: Bool -> SDoc -> SDoc 604cparen b d = SDoc $ Pretty.maybeParens b . runSDoc d 605 606-- 'quotes' encloses something in single quotes... 607-- but it omits them if the thing begins or ends in a single quote 608-- so that we don't get `foo''. Instead we just have foo'. 609quotes d = 610 sdocWithDynFlags $ \dflags -> 611 if useUnicode dflags 612 then char '‘' <> d <> char '’' 613 else SDoc $ \sty -> 614 let pp_d = runSDoc d sty 615 str = show pp_d 616 in case (str, lastMaybe str) of 617 (_, Just '\'') -> pp_d 618 ('\'' : _, _) -> pp_d 619 _other -> Pretty.quotes pp_d 620 621semi, comma, colon, equals, space, dcolon, underscore, dot, vbar :: SDoc 622arrow, larrow, darrow, arrowt, larrowt, arrowtt, larrowtt :: SDoc 623lparen, rparen, lbrack, rbrack, lbrace, rbrace, blankLine :: SDoc 624 625blankLine = docToSDoc $ Pretty.text "" 626dcolon = unicodeSyntax (char '∷') (docToSDoc $ Pretty.text "::") 627arrow = unicodeSyntax (char '→') (docToSDoc $ Pretty.text "->") 628larrow = unicodeSyntax (char '←') (docToSDoc $ Pretty.text "<-") 629darrow = unicodeSyntax (char '⇒') (docToSDoc $ Pretty.text "=>") 630arrowt = unicodeSyntax (char '⤚') (docToSDoc $ Pretty.text ">-") 631larrowt = unicodeSyntax (char '⤙') (docToSDoc $ Pretty.text "-<") 632arrowtt = unicodeSyntax (char '⤜') (docToSDoc $ Pretty.text ">>-") 633larrowtt = unicodeSyntax (char '⤛') (docToSDoc $ Pretty.text "-<<") 634semi = docToSDoc $ Pretty.semi 635comma = docToSDoc $ Pretty.comma 636colon = docToSDoc $ Pretty.colon 637equals = docToSDoc $ Pretty.equals 638space = docToSDoc $ Pretty.space 639underscore = char '_' 640dot = char '.' 641vbar = char '|' 642lparen = docToSDoc $ Pretty.lparen 643rparen = docToSDoc $ Pretty.rparen 644lbrack = docToSDoc $ Pretty.lbrack 645rbrack = docToSDoc $ Pretty.rbrack 646lbrace = docToSDoc $ Pretty.lbrace 647rbrace = docToSDoc $ Pretty.rbrace 648 649forAllLit :: SDoc 650forAllLit = unicodeSyntax (char '∀') (text "forall") 651 652kindType :: SDoc 653kindType = sdocWithDynFlags $ \dflags -> 654 if useStarIsType dflags 655 then unicodeSyntax (char '★') (char '*') 656 else text "Type" 657 658bullet :: SDoc 659bullet = unicode (char '•') (char '*') 660 661unicodeSyntax :: SDoc -> SDoc -> SDoc 662unicodeSyntax unicode plain = sdocWithDynFlags $ \dflags -> 663 if useUnicode dflags && useUnicodeSyntax dflags 664 then unicode 665 else plain 666 667unicode :: SDoc -> SDoc -> SDoc 668unicode unicode plain = sdocWithDynFlags $ \dflags -> 669 if useUnicode dflags 670 then unicode 671 else plain 672 673nest :: Int -> SDoc -> SDoc 674-- ^ Indent 'SDoc' some specified amount 675(<>) :: SDoc -> SDoc -> SDoc 676-- ^ Join two 'SDoc' together horizontally without a gap 677(<+>) :: SDoc -> SDoc -> SDoc 678-- ^ Join two 'SDoc' together horizontally with a gap between them 679($$) :: SDoc -> SDoc -> SDoc 680-- ^ Join two 'SDoc' together vertically; if there is 681-- no vertical overlap it "dovetails" the two onto one line 682($+$) :: SDoc -> SDoc -> SDoc 683-- ^ Join two 'SDoc' together vertically 684 685nest n d = SDoc $ Pretty.nest n . runSDoc d 686(<>) d1 d2 = SDoc $ \sty -> (Pretty.<>) (runSDoc d1 sty) (runSDoc d2 sty) 687(<+>) d1 d2 = SDoc $ \sty -> (Pretty.<+>) (runSDoc d1 sty) (runSDoc d2 sty) 688($$) d1 d2 = SDoc $ \sty -> (Pretty.$$) (runSDoc d1 sty) (runSDoc d2 sty) 689($+$) d1 d2 = SDoc $ \sty -> (Pretty.$+$) (runSDoc d1 sty) (runSDoc d2 sty) 690 691hcat :: [SDoc] -> SDoc 692-- ^ Concatenate 'SDoc' horizontally 693hsep :: [SDoc] -> SDoc 694-- ^ Concatenate 'SDoc' horizontally with a space between each one 695vcat :: [SDoc] -> SDoc 696-- ^ Concatenate 'SDoc' vertically with dovetailing 697sep :: [SDoc] -> SDoc 698-- ^ Separate: is either like 'hsep' or like 'vcat', depending on what fits 699cat :: [SDoc] -> SDoc 700-- ^ Catenate: is either like 'hcat' or like 'vcat', depending on what fits 701fsep :: [SDoc] -> SDoc 702-- ^ A paragraph-fill combinator. It's much like sep, only it 703-- keeps fitting things on one line until it can't fit any more. 704fcat :: [SDoc] -> SDoc 705-- ^ This behaves like 'fsep', but it uses '<>' for horizontal conposition rather than '<+>' 706 707 708hcat ds = SDoc $ \sty -> Pretty.hcat [runSDoc d sty | d <- ds] 709hsep ds = SDoc $ \sty -> Pretty.hsep [runSDoc d sty | d <- ds] 710vcat ds = SDoc $ \sty -> Pretty.vcat [runSDoc d sty | d <- ds] 711sep ds = SDoc $ \sty -> Pretty.sep [runSDoc d sty | d <- ds] 712cat ds = SDoc $ \sty -> Pretty.cat [runSDoc d sty | d <- ds] 713fsep ds = SDoc $ \sty -> Pretty.fsep [runSDoc d sty | d <- ds] 714fcat ds = SDoc $ \sty -> Pretty.fcat [runSDoc d sty | d <- ds] 715 716hang :: SDoc -- ^ The header 717 -> Int -- ^ Amount to indent the hung body 718 -> SDoc -- ^ The hung body, indented and placed below the header 719 -> SDoc 720hang d1 n d2 = SDoc $ \sty -> Pretty.hang (runSDoc d1 sty) n (runSDoc d2 sty) 721 722-- | This behaves like 'hang', but does not indent the second document 723-- when the header is empty. 724hangNotEmpty :: SDoc -> Int -> SDoc -> SDoc 725hangNotEmpty d1 n d2 = 726 SDoc $ \sty -> Pretty.hangNotEmpty (runSDoc d1 sty) n (runSDoc d2 sty) 727 728punctuate :: SDoc -- ^ The punctuation 729 -> [SDoc] -- ^ The list that will have punctuation added between every adjacent pair of elements 730 -> [SDoc] -- ^ Punctuated list 731punctuate _ [] = [] 732punctuate p (d:ds) = go d ds 733 where 734 go d [] = [d] 735 go d (e:es) = (d <> p) : go e es 736 737ppWhen, ppUnless :: Bool -> SDoc -> SDoc 738ppWhen True doc = doc 739ppWhen False _ = empty 740 741ppUnless True _ = empty 742ppUnless False doc = doc 743 744-- | Apply the given colour\/style for the argument. 745-- 746-- Only takes effect if colours are enabled. 747coloured :: Col.PprColour -> SDoc -> SDoc 748coloured col sdoc = 749 sdocWithDynFlags $ \dflags -> 750 if shouldUseColor dflags 751 then SDoc $ \ctx@SDC{ sdocLastColour = lastCol } -> 752 case ctx of 753 SDC{ sdocStyle = PprUser _ _ Coloured } -> 754 let ctx' = ctx{ sdocLastColour = lastCol `mappend` col } in 755 Pretty.zeroWidthText (Col.renderColour col) 756 Pretty.<> runSDoc sdoc ctx' 757 Pretty.<> Pretty.zeroWidthText (Col.renderColourAfresh lastCol) 758 _ -> runSDoc sdoc ctx 759 else sdoc 760 761keyword :: SDoc -> SDoc 762keyword = coloured Col.colBold 763 764{- 765************************************************************************ 766* * 767\subsection[Outputable-class]{The @Outputable@ class} 768* * 769************************************************************************ 770-} 771 772-- | Class designating that some type has an 'SDoc' representation 773class Outputable a where 774 ppr :: a -> SDoc 775 pprPrec :: Rational -> a -> SDoc 776 -- 0 binds least tightly 777 -- We use Rational because there is always a 778 -- Rational between any other two Rationals 779 780 ppr = pprPrec 0 781 pprPrec _ = ppr 782 783instance Outputable Char where 784 ppr c = text [c] 785 786instance Outputable Bool where 787 ppr True = text "True" 788 ppr False = text "False" 789 790instance Outputable Ordering where 791 ppr LT = text "LT" 792 ppr EQ = text "EQ" 793 ppr GT = text "GT" 794 795instance Outputable Int32 where 796 ppr n = integer $ fromIntegral n 797 798instance Outputable Int64 where 799 ppr n = integer $ fromIntegral n 800 801instance Outputable Int where 802 ppr n = int n 803 804instance Outputable Integer where 805 ppr n = integer n 806 807instance Outputable Word16 where 808 ppr n = integer $ fromIntegral n 809 810instance Outputable Word32 where 811 ppr n = integer $ fromIntegral n 812 813instance Outputable Word where 814 ppr n = integer $ fromIntegral n 815 816instance Outputable Float where 817 ppr f = float f 818 819instance Outputable Double where 820 ppr f = double f 821 822instance Outputable () where 823 ppr _ = text "()" 824 825instance (Outputable a) => Outputable [a] where 826 ppr xs = brackets (fsep (punctuate comma (map ppr xs))) 827 828instance (Outputable a) => Outputable (Set a) where 829 ppr s = braces (fsep (punctuate comma (map ppr (Set.toList s)))) 830 831instance (Outputable a, Outputable b) => Outputable (a, b) where 832 ppr (x,y) = parens (sep [ppr x <> comma, ppr y]) 833 834instance Outputable a => Outputable (Maybe a) where 835 ppr Nothing = text "Nothing" 836 ppr (Just x) = text "Just" <+> ppr x 837 838instance (Outputable a, Outputable b) => Outputable (Either a b) where 839 ppr (Left x) = text "Left" <+> ppr x 840 ppr (Right y) = text "Right" <+> ppr y 841 842-- ToDo: may not be used 843instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c) where 844 ppr (x,y,z) = 845 parens (sep [ppr x <> comma, 846 ppr y <> comma, 847 ppr z ]) 848 849instance (Outputable a, Outputable b, Outputable c, Outputable d) => 850 Outputable (a, b, c, d) where 851 ppr (a,b,c,d) = 852 parens (sep [ppr a <> comma, 853 ppr b <> comma, 854 ppr c <> comma, 855 ppr d]) 856 857instance (Outputable a, Outputable b, Outputable c, Outputable d, Outputable e) => 858 Outputable (a, b, c, d, e) where 859 ppr (a,b,c,d,e) = 860 parens (sep [ppr a <> comma, 861 ppr b <> comma, 862 ppr c <> comma, 863 ppr d <> comma, 864 ppr e]) 865 866instance (Outputable a, Outputable b, Outputable c, Outputable d, Outputable e, Outputable f) => 867 Outputable (a, b, c, d, e, f) where 868 ppr (a,b,c,d,e,f) = 869 parens (sep [ppr a <> comma, 870 ppr b <> comma, 871 ppr c <> comma, 872 ppr d <> comma, 873 ppr e <> comma, 874 ppr f]) 875 876instance (Outputable a, Outputable b, Outputable c, Outputable d, Outputable e, Outputable f, Outputable g) => 877 Outputable (a, b, c, d, e, f, g) where 878 ppr (a,b,c,d,e,f,g) = 879 parens (sep [ppr a <> comma, 880 ppr b <> comma, 881 ppr c <> comma, 882 ppr d <> comma, 883 ppr e <> comma, 884 ppr f <> comma, 885 ppr g]) 886 887instance Outputable FastString where 888 ppr fs = ftext fs -- Prints an unadorned string, 889 -- no double quotes or anything 890 891instance (Outputable key, Outputable elt) => Outputable (M.Map key elt) where 892 ppr m = ppr (M.toList m) 893instance (Outputable elt) => Outputable (IM.IntMap elt) where 894 ppr m = ppr (IM.toList m) 895 896instance Outputable Fingerprint where 897 ppr (Fingerprint w1 w2) = text (printf "%016x%016x" w1 w2) 898 899instance Outputable a => Outputable (SCC a) where 900 ppr (AcyclicSCC v) = text "NONREC" $$ (nest 3 (ppr v)) 901 ppr (CyclicSCC vs) = text "REC" $$ (nest 3 (vcat (map ppr vs))) 902 903instance Outputable Serialized where 904 ppr (Serialized the_type bytes) = int (length bytes) <+> text "of type" <+> text (show the_type) 905 906instance Outputable Extension where 907 ppr = text . show 908 909{- 910************************************************************************ 911* * 912\subsection{The @OutputableBndr@ class} 913* * 914************************************************************************ 915-} 916 917-- | 'BindingSite' is used to tell the thing that prints binder what 918-- language construct is binding the identifier. This can be used 919-- to decide how much info to print. 920-- Also see Note [Binding-site specific printing] in PprCore 921data BindingSite 922 = LambdaBind -- ^ The x in (\x. e) 923 | CaseBind -- ^ The x in case scrut of x { (y,z) -> ... } 924 | CasePatBind -- ^ The y,z in case scrut of x { (y,z) -> ... } 925 | LetBind -- ^ The x in (let x = rhs in e) 926 927-- | When we print a binder, we often want to print its type too. 928-- The @OutputableBndr@ class encapsulates this idea. 929class Outputable a => OutputableBndr a where 930 pprBndr :: BindingSite -> a -> SDoc 931 pprBndr _b x = ppr x 932 933 pprPrefixOcc, pprInfixOcc :: a -> SDoc 934 -- Print an occurrence of the name, suitable either in the 935 -- prefix position of an application, thus (f a b) or ((+) x) 936 -- or infix position, thus (a `f` b) or (x + y) 937 938 bndrIsJoin_maybe :: a -> Maybe Int 939 bndrIsJoin_maybe _ = Nothing 940 -- When pretty-printing we sometimes want to find 941 -- whether the binder is a join point. You might think 942 -- we could have a function of type (a->Var), but Var 943 -- isn't available yet, alas 944 945{- 946************************************************************************ 947* * 948\subsection{Random printing helpers} 949* * 950************************************************************************ 951-} 952 953-- We have 31-bit Chars and will simply use Show instances of Char and String. 954 955-- | Special combinator for showing character literals. 956pprHsChar :: Char -> SDoc 957pprHsChar c | c > '\x10ffff' = char '\\' <> text (show (fromIntegral (ord c) :: Word32)) 958 | otherwise = text (show c) 959 960-- | Special combinator for showing string literals. 961pprHsString :: FastString -> SDoc 962pprHsString fs = vcat (map text (showMultiLineString (unpackFS fs))) 963 964-- | Special combinator for showing bytestring literals. 965pprHsBytes :: ByteString -> SDoc 966pprHsBytes bs = let escaped = concatMap escape $ BS.unpack bs 967 in vcat (map text (showMultiLineString escaped)) <> char '#' 968 where escape :: Word8 -> String 969 escape w = let c = chr (fromIntegral w) 970 in if isAscii c 971 then [c] 972 else '\\' : show w 973 974-- Postfix modifiers for unboxed literals. 975-- See Note [Printing of literals in Core] in `basicTypes/Literal.hs`. 976primCharSuffix, primFloatSuffix, primIntSuffix :: SDoc 977primDoubleSuffix, primWordSuffix, primInt64Suffix, primWord64Suffix :: SDoc 978primCharSuffix = char '#' 979primFloatSuffix = char '#' 980primIntSuffix = char '#' 981primDoubleSuffix = text "##" 982primWordSuffix = text "##" 983primInt64Suffix = text "L#" 984primWord64Suffix = text "L##" 985 986-- | Special combinator for showing unboxed literals. 987pprPrimChar :: Char -> SDoc 988pprPrimInt, pprPrimWord, pprPrimInt64, pprPrimWord64 :: Integer -> SDoc 989pprPrimChar c = pprHsChar c <> primCharSuffix 990pprPrimInt i = integer i <> primIntSuffix 991pprPrimWord w = word w <> primWordSuffix 992pprPrimInt64 i = integer i <> primInt64Suffix 993pprPrimWord64 w = word w <> primWord64Suffix 994 995--------------------- 996-- Put a name in parens if it's an operator 997pprPrefixVar :: Bool -> SDoc -> SDoc 998pprPrefixVar is_operator pp_v 999 | is_operator = parens pp_v 1000 | otherwise = pp_v 1001 1002-- Put a name in backquotes if it's not an operator 1003pprInfixVar :: Bool -> SDoc -> SDoc 1004pprInfixVar is_operator pp_v 1005 | is_operator = pp_v 1006 | otherwise = char '`' <> pp_v <> char '`' 1007 1008--------------------- 1009pprFastFilePath :: FastString -> SDoc 1010pprFastFilePath path = text $ normalise $ unpackFS path 1011 1012-- | Normalise, escape and render a string representing a path 1013-- 1014-- e.g. "c:\\whatever" 1015pprFilePathString :: FilePath -> SDoc 1016pprFilePathString path = doubleQuotes $ text (escape (normalise path)) 1017 where 1018 escape [] = [] 1019 escape ('\\':xs) = '\\':'\\':escape xs 1020 escape (x:xs) = x:escape xs 1021 1022{- 1023************************************************************************ 1024* * 1025\subsection{Other helper functions} 1026* * 1027************************************************************************ 1028-} 1029 1030pprWithCommas :: (a -> SDoc) -- ^ The pretty printing function to use 1031 -> [a] -- ^ The things to be pretty printed 1032 -> SDoc -- ^ 'SDoc' where the things have been pretty printed, 1033 -- comma-separated and finally packed into a paragraph. 1034pprWithCommas pp xs = fsep (punctuate comma (map pp xs)) 1035 1036pprWithBars :: (a -> SDoc) -- ^ The pretty printing function to use 1037 -> [a] -- ^ The things to be pretty printed 1038 -> SDoc -- ^ 'SDoc' where the things have been pretty printed, 1039 -- bar-separated and finally packed into a paragraph. 1040pprWithBars pp xs = fsep (intersperse vbar (map pp xs)) 1041 1042-- | Returns the separated concatenation of the pretty printed things. 1043interppSP :: Outputable a => [a] -> SDoc 1044interppSP xs = sep (map ppr xs) 1045 1046-- | Returns the comma-separated concatenation of the pretty printed things. 1047interpp'SP :: Outputable a => [a] -> SDoc 1048interpp'SP xs = sep (punctuate comma (map ppr xs)) 1049 1050-- | Returns the comma-separated concatenation of the quoted pretty printed things. 1051-- 1052-- > [x,y,z] ==> `x', `y', `z' 1053pprQuotedList :: Outputable a => [a] -> SDoc 1054pprQuotedList = quotedList . map ppr 1055 1056quotedList :: [SDoc] -> SDoc 1057quotedList xs = fsep (punctuate comma (map quotes xs)) 1058 1059quotedListWithOr :: [SDoc] -> SDoc 1060-- [x,y,z] ==> `x', `y' or `z' 1061quotedListWithOr xs@(_:_:_) = quotedList (init xs) <+> text "or" <+> quotes (last xs) 1062quotedListWithOr xs = quotedList xs 1063 1064quotedListWithNor :: [SDoc] -> SDoc 1065-- [x,y,z] ==> `x', `y' nor `z' 1066quotedListWithNor xs@(_:_:_) = quotedList (init xs) <+> text "nor" <+> quotes (last xs) 1067quotedListWithNor xs = quotedList xs 1068 1069{- 1070************************************************************************ 1071* * 1072\subsection{Printing numbers verbally} 1073* * 1074************************************************************************ 1075-} 1076 1077intWithCommas :: Integral a => a -> SDoc 1078-- Prints a big integer with commas, eg 345,821 1079intWithCommas n 1080 | n < 0 = char '-' <> intWithCommas (-n) 1081 | q == 0 = int (fromIntegral r) 1082 | otherwise = intWithCommas q <> comma <> zeroes <> int (fromIntegral r) 1083 where 1084 (q,r) = n `quotRem` 1000 1085 zeroes | r >= 100 = empty 1086 | r >= 10 = char '0' 1087 | otherwise = text "00" 1088 1089-- | Converts an integer to a verbal index: 1090-- 1091-- > speakNth 1 = text "first" 1092-- > speakNth 5 = text "fifth" 1093-- > speakNth 21 = text "21st" 1094speakNth :: Int -> SDoc 1095speakNth 1 = text "first" 1096speakNth 2 = text "second" 1097speakNth 3 = text "third" 1098speakNth 4 = text "fourth" 1099speakNth 5 = text "fifth" 1100speakNth 6 = text "sixth" 1101speakNth n = hcat [ int n, text suffix ] 1102 where 1103 suffix | n <= 20 = "th" -- 11,12,13 are non-std 1104 | last_dig == 1 = "st" 1105 | last_dig == 2 = "nd" 1106 | last_dig == 3 = "rd" 1107 | otherwise = "th" 1108 1109 last_dig = n `rem` 10 1110 1111-- | Converts an integer to a verbal multiplicity: 1112-- 1113-- > speakN 0 = text "none" 1114-- > speakN 5 = text "five" 1115-- > speakN 10 = text "10" 1116speakN :: Int -> SDoc 1117speakN 0 = text "none" -- E.g. "he has none" 1118speakN 1 = text "one" -- E.g. "he has one" 1119speakN 2 = text "two" 1120speakN 3 = text "three" 1121speakN 4 = text "four" 1122speakN 5 = text "five" 1123speakN 6 = text "six" 1124speakN n = int n 1125 1126-- | Converts an integer and object description to a statement about the 1127-- multiplicity of those objects: 1128-- 1129-- > speakNOf 0 (text "melon") = text "no melons" 1130-- > speakNOf 1 (text "melon") = text "one melon" 1131-- > speakNOf 3 (text "melon") = text "three melons" 1132speakNOf :: Int -> SDoc -> SDoc 1133speakNOf 0 d = text "no" <+> d <> char 's' 1134speakNOf 1 d = text "one" <+> d -- E.g. "one argument" 1135speakNOf n d = speakN n <+> d <> char 's' -- E.g. "three arguments" 1136 1137-- | Determines the pluralisation suffix appropriate for the length of a list: 1138-- 1139-- > plural [] = char 's' 1140-- > plural ["Hello"] = empty 1141-- > plural ["Hello", "World"] = char 's' 1142plural :: [a] -> SDoc 1143plural [_] = empty -- a bit frightening, but there you are 1144plural _ = char 's' 1145 1146-- | Determines the form of to be appropriate for the length of a list: 1147-- 1148-- > isOrAre [] = text "are" 1149-- > isOrAre ["Hello"] = text "is" 1150-- > isOrAre ["Hello", "World"] = text "are" 1151isOrAre :: [a] -> SDoc 1152isOrAre [_] = text "is" 1153isOrAre _ = text "are" 1154 1155-- | Determines the form of to do appropriate for the length of a list: 1156-- 1157-- > doOrDoes [] = text "do" 1158-- > doOrDoes ["Hello"] = text "does" 1159-- > doOrDoes ["Hello", "World"] = text "do" 1160doOrDoes :: [a] -> SDoc 1161doOrDoes [_] = text "does" 1162doOrDoes _ = text "do" 1163 1164{- 1165************************************************************************ 1166* * 1167\subsection{Error handling} 1168* * 1169************************************************************************ 1170-} 1171 1172callStackDoc :: HasCallStack => SDoc 1173callStackDoc = 1174 hang (text "Call stack:") 1175 4 (vcat $ map text $ lines (prettyCallStack callStack)) 1176 1177pprPanic :: HasCallStack => String -> SDoc -> a 1178-- ^ Throw an exception saying "bug in GHC" 1179pprPanic s doc = panicDoc s (doc $$ callStackDoc) 1180 1181pprSorry :: String -> SDoc -> a 1182-- ^ Throw an exception saying "this isn't finished yet" 1183pprSorry = sorryDoc 1184 1185 1186pprPgmError :: String -> SDoc -> a 1187-- ^ Throw an exception saying "bug in pgm being compiled" (used for unusual program errors) 1188pprPgmError = pgmErrorDoc 1189 1190pprTraceDebug :: String -> SDoc -> a -> a 1191pprTraceDebug str doc x 1192 | debugIsOn && hasPprDebug unsafeGlobalDynFlags = pprTrace str doc x 1193 | otherwise = x 1194 1195pprTrace :: String -> SDoc -> a -> a 1196-- ^ If debug output is on, show some 'SDoc' on the screen 1197pprTrace str doc x 1198 | hasNoDebugOutput unsafeGlobalDynFlags = x 1199 | otherwise = 1200 pprDebugAndThen unsafeGlobalDynFlags trace (text str) doc x 1201 1202pprTraceM :: Applicative f => String -> SDoc -> f () 1203pprTraceM str doc = pprTrace str doc (pure ()) 1204 1205-- | @pprTraceWith desc f x@ is equivalent to @pprTrace desc (f x) x@. 1206-- This allows you to print details from the returned value as well as from 1207-- ambient variables. 1208pprTraceWith :: String -> (a -> SDoc) -> a -> a 1209pprTraceWith desc f x = pprTrace desc (f x) x 1210 1211-- | @pprTraceIt desc x@ is equivalent to @pprTrace desc (ppr x) x@ 1212pprTraceIt :: Outputable a => String -> a -> a 1213pprTraceIt desc x = pprTraceWith desc ppr x 1214 1215-- | @pprTraceException desc x action@ runs action, printing a message 1216-- if it throws an exception. 1217pprTraceException :: ExceptionMonad m => String -> SDoc -> m a -> m a 1218pprTraceException heading doc = 1219 handleGhcException $ \exc -> liftIO $ do 1220 putStrLn $ showSDocDump unsafeGlobalDynFlags (sep [text heading, nest 2 doc]) 1221 throwGhcExceptionIO exc 1222 1223-- | If debug output is on, show some 'SDoc' on the screen along 1224-- with a call stack when available. 1225pprSTrace :: HasCallStack => SDoc -> a -> a 1226pprSTrace doc = pprTrace "" (doc $$ callStackDoc) 1227 1228warnPprTrace :: HasCallStack => Bool -> String -> Int -> SDoc -> a -> a 1229-- ^ Just warn about an assertion failure, recording the given file and line number. 1230-- Should typically be accessed with the WARN macros 1231warnPprTrace _ _ _ _ x | not debugIsOn = x 1232warnPprTrace _ _file _line _msg x 1233 | hasNoDebugOutput unsafeGlobalDynFlags = x 1234warnPprTrace False _file _line _msg x = x 1235warnPprTrace True file line msg x 1236 = pprDebugAndThen unsafeGlobalDynFlags trace heading 1237 (msg $$ callStackDoc ) 1238 x 1239 where 1240 heading = hsep [text "WARNING: file", text file <> comma, text "line", int line] 1241 1242-- | Panic with an assertation failure, recording the given file and 1243-- line number. Should typically be accessed with the ASSERT family of macros 1244assertPprPanic :: HasCallStack => String -> Int -> SDoc -> a 1245assertPprPanic _file _line msg 1246 = pprPanic "ASSERT failed!" msg 1247 1248pprDebugAndThen :: DynFlags -> (String -> a) -> SDoc -> SDoc -> a 1249pprDebugAndThen dflags cont heading pretty_msg 1250 = cont (showSDocDump dflags doc) 1251 where 1252 doc = sep [heading, nest 2 pretty_msg] 1253