@@ -17,26 +17,26 @@ module HsBindgen.Util.Tracer (
17
17
, ShowCallStack (.. )
18
18
, TracerConf (.. )
19
19
, defaultTracerConf
20
+ , CustomLogLevel (.. )
20
21
-- | Trace with call stack
21
22
, TraceWithCallStack (.. )
22
23
, traceWithCallStack
23
24
, useTrace
24
25
-- | Tracers
25
- , mkTracer
26
26
, withTracerStdOut
27
27
, withTracerFile
28
- , withTracerQ
28
+ , withTracerCustom
29
29
) where
30
30
31
31
import Control.Applicative (ZipList (ZipList , getZipList ))
32
32
import Control.Monad (when )
33
33
import Control.Monad.IO.Class (MonadIO (liftIO ))
34
34
import Control.Tracer (Contravariant (contramap ), Tracer (Tracer ), emit ,
35
35
squelchUnless , traceWith )
36
+ import Data.IORef (IORef , modifyIORef , newIORef , readIORef )
36
37
import Data.Time (UTCTime , defaultTimeLocale , formatTime , getCurrentTime )
37
38
import Data.Time.Format (FormatTime )
38
39
import GHC.Stack (CallStack , prettyCallStack )
39
- import Language.Haskell.TH.Syntax (Quasi )
40
40
import System.Console.ANSI (Color (.. ), ColorIntensity (Vivid ),
41
41
ConsoleIntensity (BoldIntensity ),
42
42
ConsoleLayer (Foreground ),
@@ -92,7 +92,7 @@ alignSource = \case
92
92
class HasSource a where
93
93
getSource :: a -> Source
94
94
95
- data Verbosity = Verbosity ! Level | Quiet
95
+ newtype Verbosity = Verbosity { unwrapVerbosity :: Level }
96
96
deriving stock (Show , Eq )
97
97
98
98
{- ------------------------------------------------------------------------------
@@ -117,7 +117,15 @@ data TracerConf = TracerConf {
117
117
deriving stock (Show , Eq )
118
118
119
119
defaultTracerConf :: TracerConf
120
- defaultTracerConf = TracerConf (Verbosity Info ) DisableTimeStamp DisableCallStack
120
+ defaultTracerConf = TracerConf
121
+ { tVerbosity = (Verbosity Info )
122
+ , tShowTimeStamp = DisableTimeStamp
123
+ , tShowCallStack = DisableCallStack
124
+ }
125
+
126
+ -- | Sometimes, we want to change log levels. For example, we want to suppress
127
+ -- specific traces in tests.
128
+ data CustomLogLevel a = DefaultLogLevel | CustomLogLevel (a -> Level )
121
129
122
130
{- ------------------------------------------------------------------------------
123
131
Tracers
@@ -130,14 +138,42 @@ defaultTracerConf = TracerConf (Verbosity Info) DisableTimeStamp DisableCallStac
130
138
-- - the log level, and
131
139
-- - the source.
132
140
mkTracer :: forall m a . (MonadIO m , PrettyTrace a , HasDefaultLogLevel a , HasSource a )
133
- => AnsiColor -> TracerConf -> (String -> m () ) -> Tracer m (TraceWithCallStack a )
134
- mkTracer ansiColor (TracerConf {.. }) report =
135
- squelchUnless (isLogLevelHighEnough . tTrace) $ Tracer $ emit prettyReport
141
+ => AnsiColor
142
+ -> TracerConf
143
+ -> CustomLogLevel a
144
+ -> IORef Level
145
+ -> (String -> m () )
146
+ -> Tracer m (TraceWithCallStack a )
147
+ mkTracer ansiColor (TracerConf {.. }) customLogLevel maxLogLevelRef report =
148
+ squelchUnless (isLogLevelHighEnough . tTrace) $ Tracer $ emit $ traceAction
136
149
where
137
150
isLogLevelHighEnough :: a -> Bool
138
- isLogLevelHighEnough x = case tVerbosity of
139
- Quiet -> False
140
- Verbosity v -> getDefaultLogLevel x >= v
151
+ isLogLevelHighEnough trace = getLogLevel trace >= unwrapVerbosity tVerbosity
152
+
153
+ -- Log format:
154
+ -- [OPTIONAL TIMESTAMP] [LEVEL] [SOURCE] Message.
155
+ -- Indent subsequent lines.
156
+ -- OPTION CALL STACK.
157
+ traceAction :: TraceWithCallStack a -> m ()
158
+ traceAction TraceWithCallStack {.. } = do
159
+ updateMaxLogLevel level
160
+ time <- case tShowTimeStamp of
161
+ DisableTimeStamp -> pure Nothing
162
+ EnableTimeStamp -> Just <$> liftIO getCurrentTime
163
+ mapM_ report $ getZipList $ formatLines time level source <*> traces
164
+ when (tShowCallStack == EnableCallStack ) $
165
+ mapM_ (report . indent) $ lines $ prettyCallStack tCallStack
166
+ where level = getLogLevel tTrace
167
+ source = getSource tTrace
168
+ traces = ZipList $ lines $ prettyTrace tTrace
169
+
170
+ updateMaxLogLevel :: Level -> m ()
171
+ updateMaxLogLevel level = liftIO $ modifyIORef maxLogLevelRef $ max level
172
+
173
+ getLogLevel :: a -> Level
174
+ getLogLevel x = case customLogLevel of
175
+ DefaultLogLevel -> getDefaultLogLevel x
176
+ CustomLogLevel f -> f x
141
177
142
178
showTime :: FormatTime t => t -> String
143
179
showTime = formatTime defaultTimeLocale " %Y-%m-%d %H:%M:%S%3QZ"
@@ -167,47 +203,50 @@ mkTracer ansiColor (TracerConf {..}) report =
167
203
indent :: String -> String
168
204
indent = (" " <> )
169
205
170
- -- Log format:
171
- -- [OPTIONAL TIMESTAMP] [LEVEL] [SOURCE] Message.
172
- -- Indent subsequent lines.
173
- -- OPTION CALL STACK.
174
- prettyReport :: TraceWithCallStack a -> m ()
175
- prettyReport TraceWithCallStack {.. } = do
176
- time <- case tShowTimeStamp of
177
- DisableTimeStamp -> pure Nothing
178
- EnableTimeStamp -> Just <$> liftIO getCurrentTime
179
- mapM_ report $ getZipList $ formatLines time level source <*> traces
180
- when (tShowCallStack == EnableCallStack ) $
181
- mapM_ (report . indent) $ lines $ prettyCallStack tCallStack
182
- where level = getDefaultLogLevel tTrace
183
- source = getSource tTrace
184
- traces = ZipList $ lines $ prettyTrace tTrace
185
-
186
206
-- | Run an action with a tracer writing to 'stdout'. Use ANSI colors, if available.
187
- withTracerStdOut :: (PrettyTrace a , HasDefaultLogLevel a , HasSource a )
188
- => TracerConf -> (Tracer IO (TraceWithCallStack a ) -> IO b ) -> IO b
189
- withTracerStdOut tracerConf action = do
190
- supportsAnsiColor <- hSupportsANSIColor stdout
207
+ --
208
+ -- Also return the maximum log level of traces.
209
+ withTracerStdOut :: MonadIO m => (PrettyTrace a , HasDefaultLogLevel a , HasSource a )
210
+ => TracerConf
211
+ -> CustomLogLevel a
212
+ -> (Tracer m (TraceWithCallStack a ) -> m b )
213
+ -> m (b , Level )
214
+ withTracerStdOut tracerConf customLogLevel action = do
215
+ supportsAnsiColor <- liftIO $ hSupportsANSIColor stdout
191
216
let ansiColor = if supportsAnsiColor then EnableAnsiColor else DisableAnsiColor
192
- action $ mkTracer ansiColor tracerConf putStrLn
217
+ withIORef Debug $ \ ref ->
218
+ action $ mkTracer ansiColor tracerConf customLogLevel ref (liftIO . putStrLn )
193
219
194
220
-- | Run an action with a tracer writing to a file. Do not use ANSI colors.
221
+ --
222
+ -- Also return the maximum log level of traces.
195
223
withTracerFile
196
224
:: (PrettyTrace a , HasDefaultLogLevel a , HasSource a )
197
- => FilePath -> TracerConf -> (Tracer IO (TraceWithCallStack a ) -> IO b ) -> IO b
198
- withTracerFile file tracerConf action = withFile file AppendMode $ \ handle ->
199
- let tracer = mkTracer DisableAnsiColor tracerConf (hPutStrLn handle)
200
- in action tracer
201
-
202
- -- | Run an action with a tracer in TH mode. Do not use ANSI colors.
203
- withTracerQ :: forall m a b . (Quasi m , PrettyTrace a , HasDefaultLogLevel a , HasSource a )
204
- => TracerConf -> (Tracer m (TraceWithCallStack a ) -> m b ) -> m b
205
- withTracerQ tracerConf action = action $ mkTracer DisableAnsiColor tracerConf report
206
- where
207
- report :: String -> m ()
208
- -- Use 'putStrLn' instead of 'qReport', to avoid the "Template Haskell
209
- -- error:" prefix. We are not exclusively reporting errors.
210
- report = liftIO . putStrLn
225
+ => FilePath
226
+ -> TracerConf
227
+ -> CustomLogLevel a
228
+ -> (Tracer IO (TraceWithCallStack a ) -> IO b )
229
+ -> IO (b , Level )
230
+ withTracerFile file tracerConf customLogLevel action =
231
+ withFile file AppendMode $ \ handle ->
232
+ withIORef Debug $ \ ref ->
233
+ action $
234
+ mkTracer DisableAnsiColor tracerConf customLogLevel ref (hPutStrLn handle)
235
+
236
+ -- | Run an action with a tracer using a custom report function.
237
+ --
238
+ -- Also return the maximum log level of traces.
239
+ withTracerCustom
240
+ :: forall m a b . (MonadIO m , PrettyTrace a , HasDefaultLogLevel a , HasSource a )
241
+ => AnsiColor
242
+ -> TracerConf
243
+ -> CustomLogLevel a
244
+ -> (String -> m () )
245
+ -> (Tracer m (TraceWithCallStack a ) -> m b )
246
+ -> m (b , Level )
247
+ withTracerCustom ansiColor tracerConf customLogLevel report action =
248
+ withIORef Debug $ \ ref ->
249
+ action $ mkTracer ansiColor tracerConf customLogLevel ref report
211
250
212
251
{- ------------------------------------------------------------------------------
213
252
Trace with call stack
@@ -228,7 +267,7 @@ traceWithCallStack tracer stack trace =
228
267
--
229
268
-- > useDiagnostic :: Tracer IO (TraceWithCallStack Trace)
230
269
-- > -> Tracer IO (TraceWithCallStack Diagnostic)
231
- -- > useDiagnsotic = useTrace TraceDiagnostic
270
+ -- > useDiagnostic = useTrace TraceDiagnostic
232
271
useTrace :: (Contravariant c , Functor f ) => (b -> a ) -> c (f a ) -> c (f b )
233
272
useTrace = contramap . fmap
234
273
@@ -252,3 +291,10 @@ withColor EnableAnsiColor level = withColor' (getColorForLevel level)
252
291
253
292
resetColor :: String
254
293
resetColor = setSGRCode []
294
+
295
+ withIORef :: MonadIO m => b -> (IORef b -> m a ) -> m (a , b )
296
+ withIORef initialValue action = do
297
+ ref <- liftIO $ newIORef initialValue
298
+ actionResult <- action ref
299
+ refResult <- liftIO $ readIORef ref
300
+ pure (actionResult, refResult)
0 commit comments