1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
|
-- | Printing related functions that depend on session state (DynFlags)
module GHC.Driver.Ppr
( showSDoc
, showSDocUnsafe
, showSDocForUser
, showSDocDebug
, showSDocDump
, showPpr
, showPprUnsafe
, pprDebugAndThen
, printForUser
, printForC
-- ** Trace
, warnPprTrace
, pprTrace
, pprTraceWithFlags
, pprTraceM
, pprTraceDebug
, pprTraceIt
, pprSTrace
, pprTraceException
)
where
import GHC.Prelude
import {-# SOURCE #-} GHC.Driver.Session
import {-# SOURCE #-} GHC.Unit.State
import GHC.Utils.Exception
import GHC.Utils.Constants (debugIsOn)
import GHC.Utils.Misc
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.GlobalVars
import GHC.Utils.Ppr ( Mode(..) )
import System.IO ( Handle )
import Control.Monad.IO.Class
-- | Show a SDoc as a String with the default user style
showSDoc :: DynFlags -> SDoc -> String
showSDoc dflags sdoc = renderWithContext (initSDocContext dflags defaultUserStyle) sdoc
showPpr :: Outputable a => DynFlags -> a -> String
showPpr dflags thing = showSDoc dflags (ppr thing)
-- | Allows caller to specify the PrintUnqualified to use
showSDocForUser :: DynFlags -> UnitState -> PrintUnqualified -> SDoc -> String
showSDocForUser dflags unit_state unqual doc = renderWithContext (initSDocContext dflags sty) doc'
where
sty = mkUserStyle unqual AllTheWay
doc' = pprWithUnitState unit_state doc
showSDocDump :: SDocContext -> SDoc -> String
showSDocDump ctx d = renderWithContext ctx (withPprStyle defaultDumpStyle d)
showSDocDebug :: DynFlags -> SDoc -> String
showSDocDebug dflags d = renderWithContext ctx d
where
ctx = (initSDocContext dflags defaultDumpStyle)
{ sdocPprDebug = True
}
printForUser :: DynFlags -> Handle -> PrintUnqualified -> Depth -> SDoc -> IO ()
printForUser dflags handle unqual depth doc
= printSDocLn ctx (PageMode False) handle doc
where ctx = initSDocContext dflags (mkUserStyle unqual depth)
-- | Like 'printSDocLn' but specialized with 'LeftMode' and
-- @'PprCode' 'CStyle'@. This is typically used to output C-- code.
printForC :: DynFlags -> Handle -> SDoc -> IO ()
printForC dflags handle doc =
printSDocLn ctx LeftMode handle doc
where ctx = initSDocContext dflags (PprCode CStyle)
pprDebugAndThen :: SDocContext -> (String -> a) -> SDoc -> SDoc -> a
pprDebugAndThen ctx cont heading pretty_msg
= cont (showSDocDump ctx doc)
where
doc = sep [heading, nest 2 pretty_msg]
-- | If debug output is on, show some 'SDoc' on the screen
pprTraceWithFlags :: DynFlags -> String -> SDoc -> a -> a
pprTraceWithFlags dflags str doc x
| hasNoDebugOutput dflags = x
| otherwise = pprDebugAndThen (initSDocContext dflags defaultDumpStyle)
trace (text str) doc x
-- | If debug output is on, show some 'SDoc' on the screen
pprTrace :: String -> SDoc -> a -> a
pprTrace str doc x
| unsafeHasNoDebugOutput = x
| otherwise = pprDebugAndThen defaultSDocContext trace (text str) doc x
pprTraceM :: Applicative f => String -> SDoc -> f ()
pprTraceM str doc = pprTrace str doc (pure ())
pprTraceDebug :: String -> SDoc -> a -> a
pprTraceDebug str doc x
| debugIsOn && unsafeHasPprDebug = pprTrace str doc x
| otherwise = x
-- | @pprTraceWith desc f x@ is equivalent to @pprTrace desc (f x) x@.
-- This allows you to print details from the returned value as well as from
-- ambient variables.
pprTraceWith :: String -> (a -> SDoc) -> a -> a
pprTraceWith desc f x = pprTrace desc (f x) x
-- | @pprTraceIt desc x@ is equivalent to @pprTrace desc (ppr x) x@
pprTraceIt :: Outputable a => String -> a -> a
pprTraceIt desc x = pprTraceWith desc ppr x
-- | @pprTraceException desc x action@ runs action, printing a message
-- if it throws an exception.
pprTraceException :: ExceptionMonad m => String -> SDoc -> m a -> m a
pprTraceException heading doc =
handleGhcException $ \exc -> liftIO $ do
putStrLn $ showSDocDump defaultSDocContext (sep [text heading, nest 2 doc])
throwGhcExceptionIO exc
-- | If debug output is on, show some 'SDoc' on the screen along
-- with a call stack when available.
pprSTrace :: HasCallStack => SDoc -> a -> a
pprSTrace doc = pprTrace "" (doc $$ callStackDoc)
-- | Just warn about an assertion failure, recording the given file and line number.
warnPprTrace :: HasCallStack => Bool -> SDoc -> a -> a
warnPprTrace _ _ x | not debugIsOn = x
warnPprTrace _ _msg x | unsafeHasNoDebugOutput = x
warnPprTrace False _msg x = x
warnPprTrace True msg x
= pprDebugAndThen defaultSDocContext trace (text "WARNING:")
(msg $$ callStackDoc )
x
|
