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