Skip to content

Commit efa22bc

Browse files
Pepe Iborrafacebook-github-bot
authored andcommitted
refactor
Summary: `traceMsg_` could not easily be used to trace asynchronous computations like: https://www.internalfb.com/code/fbsource/[4a571cb146aa]/fbcode/glean/client/hs/Glean/Remote.hs?lines=541-547 Refactored it to be more flexible while keeping the existing api Reviewed By: josefs Differential Revision: D55980077 fbshipit-source-id: d10c77641223049dbf35b941960eea4695d07542
1 parent 46c795b commit efa22bc

File tree

3 files changed

+31
-47
lines changed

3 files changed

+31
-47
lines changed

common/util/Control/Trace/Core.hs

Lines changed: 15 additions & 22 deletions
Original file line numberDiff line numberDiff line change
@@ -19,15 +19,11 @@ module Control.Trace.Core (
1919
(>$<),
2020
) where
2121

22-
import Control.Exception (
23-
Exception,
24-
)
2522
import Control.Monad.Catch (
2623
ExitCase (..),
2724
MonadCatch,
2825
MonadMask (generalBracket),
2926
MonadThrow,
30-
try,
3127
)
3228
import Control.Monad.IO.Class (
3329
MonadIO (..),
@@ -45,43 +41,41 @@ import Data.Coerce
4541
-- | A contravariant tracing abstraction
4642
data Tracer msg = Tracer
4743
{ -- | Log a message
48-
logMsg_ :: forall m. (HasCallStack, MonadTrace m) => msg -> m ()
49-
, -- | Trace the begin and end of a computation
50-
traceMsg_ :: forall a m. (HasCallStack, MonadTrace m) => msg -> m a -> m a
44+
logMsg_ :: msg -> IO ()
45+
, -- | Starts a trace and returns an action to end it
46+
traceMsg_
47+
:: forall a. HasCallStack => msg -> IO (ExitCase a -> IO ())
5148
}
5249

53-
-- Explicit record accessors to preserve call stacks
54-
55-
logMsg :: (HasCallStack, MonadTrace m) => Tracer msg -> msg -> m ()
56-
logMsg logger msg = withFrozenCallStack $ logMsg_ logger msg
50+
logMsg :: (HasCallStack, MonadIO m) => Tracer msg -> msg -> m ()
51+
logMsg logger msg = withFrozenCallStack $ liftIO $ logMsg_ logger msg
5752

58-
traceMsg :: (HasCallStack, MonadTrace m) => Tracer msg -> msg -> m a -> m a
59-
traceMsg logger msg act = withFrozenCallStack $ traceMsg_ logger msg act
53+
traceMsg ::
54+
(HasCallStack, MonadTrace m) => Tracer msg -> msg -> m a -> m a
55+
traceMsg logger msg act = withFrozenCallStack $
56+
bracketM (traceMsg_ logger msg) id (const act)
6057

6158
instance Contravariant Tracer where
6259
contramap f (Tracer logf traceF) = Tracer (logf . f) (traceF . f)
6360

6461
instance Monoid (Tracer msg) where
65-
mempty = Tracer (\_ -> pure ()) (const id)
62+
mempty = Tracer (\_ -> pure ()) (const $ pure $ const $ pure ())
6663

6764
instance Semigroup (Tracer msg) where
6865
l1 <> l2 =
6966
Tracer
7067
{ logMsg_ = \m -> logMsg_ l1 m *> logMsg_ l2 m
71-
, traceMsg_ = \msg -> traceMsg_ l1 msg . traceMsg_ l2 msg
68+
, traceMsg_ = \msg -> do
69+
end1 <- traceMsg_ l1 msg
70+
end2 <- traceMsg_ l2 msg
71+
return (\res -> end2 res >> end1 res)
7272
}
7373

74-
-------------------------------------------------------------------------------
75-
-- Exceptions
76-
7774
class MonadIO m => MonadTrace m where
78-
tryM :: Exception e => m a -> m (Either e a)
7975
bracketM :: IO a -> (a -> ExitCase b -> IO ()) -> (a -> m b) -> m b
8076

8177
-- deriving via (MonadMaskInstance IO) instance MonadTrace IO
8278
instance MonadTrace IO where
83-
tryM :: forall e a . Exception e => IO a -> IO (Either e a)
84-
tryM = coerce (tryM @(MonadMaskInstance IO) @e @a)
8579
bracketM
8680
:: forall a b . IO a -> (a -> ExitCase b -> IO ()) -> (a -> IO b) -> IO b
8781
bracketM = coerce (bracketM @(MonadMaskInstance IO) @a @b)
@@ -92,6 +86,5 @@ newtype MonadMaskInstance m a = MonadMaskInstance (m a)
9286
(Applicative, Functor, Monad, MonadCatch, MonadIO, MonadMask, MonadThrow)
9387

9488
instance (MonadIO m, MonadMask m) => MonadTrace (MonadMaskInstance m) where
95-
tryM = try
9689
bracketM acquire release =
9790
fmap fst . generalBracket (liftIO acquire) ((liftIO .) . release)

common/util/Control/Trace/Eventlog.hs

Lines changed: 1 addition & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -18,7 +18,6 @@ import Control.Monad.Catch (
1818
),
1919
)
2020
import Control.Trace.Core (
21-
MonadTrace (..),
2221
Tracer (traceMsg_),
2322
)
2423
import Data.ByteString (ByteString)
@@ -46,8 +45,7 @@ eventlogTracer
4645
| userTracingEnabled = mempty {traceMsg_ = trace}
4746
| otherwise = mempty
4847
where
49-
trace :: MonadTrace m => Trace -> m b -> m b
50-
trace Trace {..} act = bracketM acquire release (const act)
48+
trace Trace {..} = release <$> acquire
5149
where
5250
acquire = beginSpan name
5351
release sp res = do

common/util/Control/Trace/VLog.hs

Lines changed: 15 additions & 22 deletions
Original file line numberDiff line numberDiff line change
@@ -68,30 +68,24 @@ vlogTracerWithPriority = Tracer {..}
6868
S p s -> String.vlog p s
6969
Skip -> error "unreachable"
7070

71-
traceMsg_ :: (HasCallStack, MonadTrace m) => TraceWithPriority -> m b -> m b
72-
traceMsg_ Skip act = act
73-
traceMsg_ msg act = withFrozenCallStack $ do
71+
traceMsg_ msg =
7472
case msg of
75-
T p t ->
76-
bracketM
77-
(vlog p ("BEGIN " <> t))
78-
( \() res -> case res of
73+
T p t -> do
74+
vlog p ("BEGIN " <> t)
75+
return ( \res -> case res of
7976
ExitCaseSuccess {} -> vlog p ("END " <> t)
8077
ExitCaseAbort {} -> vlog p ("ABORTED " <> t)
8178
ExitCaseException e -> vlog p ("FAILED " <> t <> ": " <> showt e)
82-
)
83-
(\() -> act)
84-
S p t ->
85-
bracketM
86-
(String.vlog p ("BEGIN " <> t))
87-
( \() res -> case res of
79+
)
80+
S p t -> do
81+
String.vlog p ("BEGIN " <> t)
82+
return ( \res -> case res of
8883
ExitCaseSuccess {} -> String.vlog p ("END " <> t)
8984
ExitCaseAbort {} -> String.vlog p ("ABORTED " <> t)
9085
ExitCaseException e ->
9186
String.vlog p ("FAILED " <> t <> ": " <> show e)
92-
)
93-
(\() -> act)
94-
Skip -> error "unreachable"
87+
)
88+
Skip -> return $ const $ return ()
9589

9690
vlogTracer ::
9791
forall a.
@@ -104,16 +98,15 @@ vlogTracer ::
10498
Tracer a
10599
vlogTracer beginend log_ prio = Tracer {..}
106100
where
107-
logMsg_ :: (HasCallStack, MonadIO m) => a -> m ()
101+
logMsg_ :: a -> IO ()
108102
logMsg_ msg =
109-
withFrozenCallStack $
110103
let p = prio msg
111104
in when (p >= 0) $ vlog p $ log_ msg
112105

113-
traceMsg_ :: (HasCallStack, MonadTrace m) => a -> m b -> m b
114-
traceMsg_ msg act = withFrozenCallStack $ do
106+
traceMsg_ :: a -> IO (ExitCase b -> IO ())
107+
traceMsg_ msg = do
115108
let p = prio msg
116109
(b, e) = beginend msg
117110
if p >= 0
118-
then bracketM (vlog p b) (\() res -> vlog p (e $ mkSome res)) (\() -> act)
119-
else act
111+
then vlog p b >> return (\res -> vlog p (e $ mkSome res))
112+
else return $ const $ return ()

0 commit comments

Comments
 (0)