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