@@ -19,15 +19,11 @@ module Control.Trace.Core (
19
19
(>$<) ,
20
20
) where
21
21
22
- import Control.Exception (
23
- Exception ,
24
- )
25
22
import Control.Monad.Catch (
26
23
ExitCase (.. ),
27
24
MonadCatch ,
28
25
MonadMask (generalBracket ),
29
26
MonadThrow ,
30
- try ,
31
27
)
32
28
import Control.Monad.IO.Class (
33
29
MonadIO (.. ),
@@ -45,43 +41,41 @@ import Data.Coerce
45
41
-- | A contravariant tracing abstraction
46
42
data Tracer msg = Tracer
47
43
{ -- | 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 () )
51
48
}
52
49
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
57
52
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)
60
57
61
58
instance Contravariant Tracer where
62
59
contramap f (Tracer logf traceF) = Tracer (logf . f) (traceF . f)
63
60
64
61
instance Monoid (Tracer msg ) where
65
- mempty = Tracer (\ _ -> pure () ) (const id )
62
+ mempty = Tracer (\ _ -> pure () ) (const $ pure $ const $ pure () )
66
63
67
64
instance Semigroup (Tracer msg ) where
68
65
l1 <> l2 =
69
66
Tracer
70
67
{ 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)
72
72
}
73
73
74
- -------------------------------------------------------------------------------
75
- -- Exceptions
76
-
77
74
class MonadIO m => MonadTrace m where
78
- tryM :: Exception e => m a -> m (Either e a )
79
75
bracketM :: IO a -> (a -> ExitCase b -> IO () ) -> (a -> m b ) -> m b
80
76
81
77
-- deriving via (MonadMaskInstance IO) instance MonadTrace IO
82
78
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 )
85
79
bracketM
86
80
:: forall a b . IO a -> (a -> ExitCase b -> IO () ) -> (a -> IO b ) -> IO b
87
81
bracketM = coerce (bracketM @ (MonadMaskInstance IO ) @ a @ b )
@@ -92,6 +86,5 @@ newtype MonadMaskInstance m a = MonadMaskInstance (m a)
92
86
(Applicative , Functor , Monad , MonadCatch , MonadIO , MonadMask , MonadThrow )
93
87
94
88
instance (MonadIO m , MonadMask m ) => MonadTrace (MonadMaskInstance m ) where
95
- tryM = try
96
89
bracketM acquire release =
97
90
fmap fst . generalBracket (liftIO acquire) ((liftIO . ) . release)
0 commit comments