Drop usage of stm-lifted (#9)

src/Control/Monad/Trace.hs

@@ -41,15 +41,14 @@ import Control.Monad.Trace.Class
 import Control.Monad.Trace.Internal
 
 import Control.Applicative ((<|>))
-import Control.Monad.STM (retry)
-import Control.Concurrent.STM.Lifted
+import Control.Concurrent.STM (STM, TVar, retry, atomically, readTVar, writeTVar, modifyTVar, modifyTVar', newTVarIO)
 import Control.Exception.Lifted
 import Control.Monad (when)
 import Control.Monad.IO.Class (MonadIO, liftIO)
 import Control.Monad.Reader (ReaderT(ReaderT), ask, asks, local, runReaderT)
 import Control.Monad.Reader.Class (MonadReader)
 import Control.Monad.Trans.Class (MonadTrans, lift)
-import Control.Monad.Base (MonadBase)
+import Control.Monad.Base (MonadBase, liftBase)
 import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow)
 import Control.Monad.Trans.Control
 import Control.Monad.Except (MonadError)
@@ -195,10 +194,10 @@ instance (MonadBaseControl IO m, MonadIO m) => MonadTrace (TraceT m) where
         mbParentSpn = scopeSpan parentScope
         mbParentCtx = spanContext <$> mbParentSpn
         mbTraceID = contextTraceID <$> mbParentCtx
-      spanID <- maybe (liftIO randomSpanID) pure $ builderSpanID bldr
-      traceID <- maybe (liftIO randomTraceID) pure $ builderTraceID bldr <|> mbTraceID
+      spanID <- maybe (liftBase randomSpanID) pure $ builderSpanID bldr
+      traceID <- maybe (liftBase randomTraceID) pure $ builderTraceID bldr <|> mbTraceID
       sampling <- case builderSamplingPolicy bldr of
-        Just policy -> liftIO policy
+        Just policy -> liftBase policy
         Nothing -> pure $ fromMaybe Never (spanSamplingDecision <$> mbParentSpn)
       let
         baggages = fromMaybe Map.empty $ contextBaggages <$> mbParentCtx
@@ -207,20 +206,20 @@ instance (MonadBaseControl IO m, MonadIO m) => MonadTrace (TraceT m) where
         tracer = scopeTracer parentScope
       if spanIsSampled spn
         then do
-          tagsTV <- newTVarIO $ builderTags bldr
-          logsTV <- newTVarIO []
-          startTV <- newTVarIO Nothing -- To detect whether an exception happened during span setup.
+          tagsTV <- liftBase . newTVarIO $ builderTags bldr
+          logsTV <- liftBase $ newTVarIO []
+          startTV <- liftBase $ newTVarIO Nothing -- To detect whether an exception happened during span setup.
           let
             scope = Scope tracer (Just spn) (Just tagsTV) (Just logsTV)
             run = do
-              start <- liftIO $ getPOSIXTime
-              atomically $ do
+              start <- liftBase getPOSIXTime
+              liftBase . atomically $ do
                 writeTVar startTV (Just start)
                 modifyTVar' (tracerPendingCount tracer) (+1)
               local (const $ Just scope) reader
             cleanup = do
-              end <- liftIO $ getPOSIXTime
-              atomically $ readTVar startTV >>= \case
+              end <- liftBase getPOSIXTime
+              liftBase . atomically $ readTVar startTV >>= \case
                 Nothing -> pure () -- The action was interrupted before the span was pending.
                 Just start -> do
                   modifyTVar' (tracerPendingCount tracer) (\n -> n - 1)
@@ -234,12 +233,12 @@ instance (MonadBaseControl IO m, MonadIO m) => MonadTrace (TraceT m) where
 
   addSpanEntry key (TagValue val) = TraceT $ do
     mbTV <- asks (>>= scopeTags)
-    ReaderT $ \_ -> for_ mbTV $ \tv -> atomically $ modifyTVar' tv $ Map.insert key val
+    ReaderT $ \_ -> for_ mbTV $ \tv -> liftBase . atomically $ modifyTVar' tv $ Map.insert key val
   addSpanEntry key (LogValue val mbTime)  = TraceT $ do
     mbTV <- asks (>>= scopeLogs)
     ReaderT $ \_ -> for_ mbTV $ \tv -> do
-      time <- maybe (liftIO getPOSIXTime) pure mbTime
-      atomically $ modifyTVar' tv ((time, key, val) :)
+      time <- maybe (liftBase getPOSIXTime) pure mbTime
+      liftBase . atomically $ modifyTVar' tv ((time, key, val) :)
 
 -- | Trace an action, sampling its generated spans. This method is thread-safe and can be used to
 -- trace multiple actions concurrently.

src/Monitor/Tracing/Local.hs

@@ -7,7 +7,7 @@ module Monitor.Tracing.Local (
 
 import Control.Monad.Trace
 
-import Control.Concurrent.STM.Lifted (atomically, readTVar)
+import Control.Concurrent.STM (atomically, readTVar)
 import Control.Monad.Fix (fix)
 import Control.Monad.IO.Class (MonadIO, liftIO)
 import Control.Monad.Trans.Control (MonadBaseControl)

src/Monitor/Tracing/Zipkin.hs

@@ -45,10 +45,11 @@ import Control.Monad.Trace.Class
 
 import Control.Concurrent (threadDelay)
 import Control.Concurrent.Lifted (fork)
-import Control.Concurrent.STM.Lifted (atomically)
+import Control.Concurrent.STM (atomically)
 import Control.Exception (SomeException)
 import Control.Exception.Lifted (finally, try)
 import Control.Monad (forever, guard, unless, void)
+import Control.Monad.Base (liftBase)
 import Control.Monad.IO.Class (MonadIO, liftIO)
 import Control.Monad.Trans.Control (MonadBaseControl)
 import qualified Data.Aeson as JSON
@@ -75,7 +76,6 @@ import Data.Time.Clock.POSIX (POSIXTime)
 import Network.HTTP.Client (Manager, Request)
 import qualified Network.HTTP.Client as HTTP
 import Network.Socket (HostName, PortNumber)
-import Control.Monad.Base (liftBase)
 
 -- | 'Zipkin' creation settings.
 data Settings = Settings

test/Spec.hs

@@ -10,7 +10,7 @@ import Monitor.Tracing.Local (collectSpanSamples)
 import qualified Monitor.Tracing.Zipkin as ZPK
 
 import Control.Concurrent.Lifted
-import Control.Concurrent.STM.Lifted
+import Control.Concurrent.STM
 import Control.Monad.IO.Class (liftIO, MonadIO)
 import Control.Monad (void)
 import Control.Monad.Reader (MonadReader, Reader, ReaderT, ask, runReader, runReaderT)
@@ -101,8 +101,8 @@ main = hspec $ do
 
   describe "collectSpanSamples" $ do
     it "should collect spans which are still pending after the action returns" $ do
-      spans <- collectSpans $ rootSpan alwaysSampled "sleep-parent" $ do
-        tmv <- newEmptyTMVarIO
-        void $ fork $ childSpan "sleep-child" $ atomically (putTMVar tmv ()) >> threadDelay 20000
-        void $ atomically $ readTMVar tmv
+      spans <- collectSpans . rootSpan alwaysSampled "sleep-parent" $ do
+        tmv <- liftIO newEmptyTMVarIO
+        void . fork . childSpan "sleep-child" . liftIO $ atomically (putTMVar tmv ()) >> threadDelay 20000
+        void . liftIO $ atomically $ readTMVar tmv
       fmap spanName spans `shouldMatchList` ["sleep-parent", "sleep-child"]

tracing.cabal

@@ -45,7 +45,6 @@ library
     , mtl >= 2.2
     , network >= 2.8
     , random >= 1.1
-    , stm-lifted >= 2.5
     , stm >= 2.5
     , text >= 1.2
     , time >= 1.8 && < 1.10
@@ -65,7 +64,7 @@ test-suite tracing-test
     , lifted-base >= 0.2.3
     , monad-control >= 1.0
     , mtl
-    , stm-lifted >= 2.5
+    , stm
     , text
     , tracing
   ghc-options: -threaded -rtsopts -with-rtsopts=-N