@@ -23,21 +23,20 @@ module HsBindgen.Util.Tracer (
23
23
, traceWithCallStack
24
24
, useTrace
25
25
-- | Tracers
26
- , mkTracer
27
26
, withTracerStdOut
28
27
, withTracerFile
29
- , withTracerQ
28
+ , withTracerCustom
30
29
) where
31
30
32
31
import Control.Applicative (ZipList (ZipList , getZipList ))
33
32
import Control.Monad (when )
34
33
import Control.Monad.IO.Class (MonadIO (liftIO ))
35
34
import Control.Tracer (Contravariant (contramap ), Tracer (Tracer ), emit ,
36
35
squelchUnless , traceWith )
36
+ import Data.IORef (IORef , modifyIORef , newIORef , readIORef )
37
37
import Data.Time (UTCTime , defaultTimeLocale , formatTime , getCurrentTime )
38
38
import Data.Time.Format (FormatTime )
39
39
import GHC.Stack (CallStack , prettyCallStack )
40
- import Language.Haskell.TH.Syntax (Quasi )
41
40
import System.Console.ANSI (Color (.. ), ColorIntensity (Vivid ),
42
41
ConsoleIntensity (BoldIntensity ),
43
42
ConsoleLayer (Foreground ),
@@ -93,7 +92,7 @@ alignSource = \case
93
92
class HasSource a where
94
93
getSource :: a -> Source
95
94
96
- data Verbosity = Verbosity ! Level | Quiet
95
+ newtype Verbosity = Verbosity { unwrapVerbosity :: Level }
97
96
deriving stock (Show , Eq )
98
97
99
98
{- ------------------------------------------------------------------------------
@@ -142,21 +141,40 @@ mkTracer :: forall m a. (MonadIO m, PrettyTrace a, HasDefaultLogLevel a, HasSour
142
141
=> AnsiColor
143
142
-> TracerConf
144
143
-> CustomLogLevel a
144
+ -> IORef Level
145
145
-> (String -> m () )
146
146
-> Tracer m (TraceWithCallStack a )
147
- mkTracer ansiColor (TracerConf {.. }) customLogLevel report =
148
- squelchUnless (isLogLevelHighEnough . tTrace) $ Tracer $ emit prettyReport
147
+ mkTracer ansiColor (TracerConf {.. }) customLogLevel maxLogLevelRef report =
148
+ squelchUnless (isLogLevelHighEnough . tTrace) $ Tracer $ emit $ traceAction
149
149
where
150
+ isLogLevelHighEnough :: a -> Bool
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
+
150
173
getLogLevel :: a -> Level
151
174
getLogLevel x = case customLogLevel of
152
175
DefaultLogLevel -> getDefaultLogLevel x
153
176
CustomLogLevel f -> f x
154
177
155
- isLogLevelHighEnough :: a -> Bool
156
- isLogLevelHighEnough x = case tVerbosity of
157
- Quiet -> False
158
- Verbosity v -> getLogLevel x >= v
159
-
160
178
showTime :: FormatTime t => t -> String
161
179
showTime = formatTime defaultTimeLocale " %Y-%m-%d %H:%M:%S%3QZ"
162
180
@@ -185,58 +203,50 @@ mkTracer ansiColor (TracerConf {..}) customLogLevel report =
185
203
indent :: String -> String
186
204
indent = (" " <> )
187
205
188
- -- Log format:
189
- -- [OPTIONAL TIMESTAMP] [LEVEL] [SOURCE] Message.
190
- -- Indent subsequent lines.
191
- -- OPTION CALL STACK.
192
- prettyReport :: TraceWithCallStack a -> m ()
193
- prettyReport TraceWithCallStack {.. } = do
194
- time <- case tShowTimeStamp of
195
- DisableTimeStamp -> pure Nothing
196
- EnableTimeStamp -> Just <$> liftIO getCurrentTime
197
- mapM_ report $ getZipList $ formatLines time level source <*> traces
198
- when (tShowCallStack == EnableCallStack ) $
199
- mapM_ (report . indent) $ lines $ prettyCallStack tCallStack
200
- where level = getLogLevel tTrace
201
- source = getSource tTrace
202
- traces = ZipList $ lines $ prettyTrace tTrace
203
-
204
206
-- | Run an action with a tracer writing to 'stdout'. Use ANSI colors, if available.
205
- withTracerStdOut :: (PrettyTrace a , HasDefaultLogLevel a , HasSource a )
207
+ --
208
+ -- Also return the maximum log level of traces.
209
+ withTracerStdOut :: MonadIO m => (PrettyTrace a , HasDefaultLogLevel a , HasSource a )
206
210
=> TracerConf
207
211
-> CustomLogLevel a
208
- -> (Tracer IO (TraceWithCallStack a ) -> IO b )
209
- -> IO b
212
+ -> (Tracer m (TraceWithCallStack a ) -> m b )
213
+ -> m ( b , Level )
210
214
withTracerStdOut tracerConf customLogLevel action = do
211
- supportsAnsiColor <- hSupportsANSIColor stdout
215
+ supportsAnsiColor <- liftIO $ hSupportsANSIColor stdout
212
216
let ansiColor = if supportsAnsiColor then EnableAnsiColor else DisableAnsiColor
213
- action $ mkTracer ansiColor tracerConf customLogLevel putStrLn
217
+ withIORef Debug $ \ ref ->
218
+ action $ mkTracer ansiColor tracerConf customLogLevel ref (liftIO . putStrLn )
214
219
215
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.
216
223
withTracerFile
217
224
:: (PrettyTrace a , HasDefaultLogLevel a , HasSource a )
218
225
=> FilePath
219
226
-> TracerConf
220
227
-> CustomLogLevel a
221
228
-> (Tracer IO (TraceWithCallStack a ) -> IO b )
222
- -> IO b
223
- withTracerFile file tracerConf customLogLevel action = withFile file AppendMode $ \ handle ->
224
- let tracer = mkTracer DisableAnsiColor tracerConf customLogLevel (hPutStrLn handle)
225
- in action tracer
226
-
227
- -- | Run an action with a tracer in TH mode. Do not use ANSI colors.
228
- withTracerQ :: forall m a b . (Quasi m , PrettyTrace a , HasDefaultLogLevel a , HasSource a )
229
- => TracerConf
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
230
243
-> CustomLogLevel a
244
+ -> (String -> m () )
231
245
-> (Tracer m (TraceWithCallStack a ) -> m b )
232
- -> m b
233
- withTracerQ tracerConf customLogLevel action =
234
- action $ mkTracer DisableAnsiColor tracerConf customLogLevel report
235
- where
236
- report :: String -> m ()
237
- -- Use 'putStrLn' instead of 'qReport', to avoid the "Template Haskell
238
- -- error:" prefix. We are not exclusively reporting errors.
239
- report = liftIO . putStrLn
246
+ -> m (b , Level )
247
+ withTracerCustom ansiColor tracerConf customLogLevel report action =
248
+ withIORef Debug $ \ ref ->
249
+ action $ mkTracer ansiColor tracerConf customLogLevel ref report
240
250
241
251
{- ------------------------------------------------------------------------------
242
252
Trace with call stack
@@ -257,7 +267,7 @@ traceWithCallStack tracer stack trace =
257
267
--
258
268
-- > useDiagnostic :: Tracer IO (TraceWithCallStack Trace)
259
269
-- > -> Tracer IO (TraceWithCallStack Diagnostic)
260
- -- > useDiagnsotic = useTrace TraceDiagnostic
270
+ -- > useDiagnostic = useTrace TraceDiagnostic
261
271
useTrace :: (Contravariant c , Functor f ) => (b -> a ) -> c (f a ) -> c (f b )
262
272
useTrace = contramap . fmap
263
273
@@ -281,3 +291,10 @@ withColor EnableAnsiColor level = withColor' (getColorForLevel level)
281
291
282
292
resetColor :: String
283
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