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