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