Derive more

.github/workflows/test.yml

@@ -2,13 +2,17 @@ name: Haskell CI
 on: [push]
 jobs:
   test:
-    runs-on: ubuntu-latest
+    runs-on: ${{ matrix.os }}
+    strategy:
+      matrix:
+        ghc: ['9.2', '9.0', '8.10', '8.8']
+        os: [ubuntu-latest, windows-latest]
     steps:
-    - uses: actions/checkout@v1
-    - uses: actions/setup-haskell@v1
+    - uses: actions/checkout@v2
+    - uses: haskell/actions/setup@v1
       with:
-        ghc-version: '8.6.5'
-        cabal-version: '3.0'
+        ghc-version: ${{ matrix.ghc }}
+        cabal-version: 'latest'
     - name: Install dependencies
       run: |
         cabal update

.gitignore

@@ -0,0 +1,2 @@
+.stack*
+stack.yaml.lock

README.md

@@ -1,4 +1,6 @@
-# Tracing [![Stackage LTS](https://stackage.org/package/tracing/badge/lts)](https://stackage.org/lts/package/tracing) [![Stackage Nightly](https://stackage.org/package/tracing/badge/nightly)](https://stackage.org/nightly/package/tracing) [![Hackage](https://img.shields.io/hackage/v/tracing.svg)](https://hackage.haskell.org/package/tracing) [![Build Status](https://travis-ci.org/mtth/tracing.svg?branch=master)](https://travis-ci.org/mtth/tracing)
+# Tracing [![Hackage](https://img.shields.io/hackage/v/tracing-control.svg)](https://hackage.haskell.org/package/tracing-control)
+
+**Important note**: this is a fork of the original [tracing](https://github.com/mtth/tracing) library in which `unliftio` has been replaced by `monad-control`.
 
 An [OpenTracing](https://opentracing.io/)-compliant, simple, and extensible
 distributed tracing library.

src/Control/Monad/Trace.hs

@@ -1,15 +1,21 @@
 {-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE ImpredicativeTypes #-}
+{-# LANGUAGE InstanceSigs #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}         -- For the MonadBaseControl instance.
 {-# LANGUAGE UndecidableInstances #-} -- For the MonadReader instance.
 
 -- | This module is useful mostly for tracing backend implementors. If you are only interested in
 -- adding tracing to an application, start at "Monitor.Tracing".
 module Control.Monad.Trace (
   -- * Tracers
   Tracer, newTracer,
-  runTraceT, runTraceT', TraceT,
+  runTraceT, runTraceT', TraceT(..),
 
   -- * Collected data
   -- | Tracers currently expose two pieces of data: completed spans and pending span count. Note
@@ -29,21 +35,26 @@ import Control.Monad.Trace.Class
 import Control.Monad.Trace.Internal
 
 import Control.Applicative ((<|>))
+import Control.Concurrent.STM.Lifted (TChan, TVar, atomically, modifyTVar', newTChanIO, newTVarIO, readTVar, writeTChan, writeTVar)
+import Control.Exception.Lifted (finally)
+import Control.Monad.Base (MonadBase, liftBase)
 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.Error.Class (MonadError)
+import Control.Monad.State.Class (MonadState)
 import Control.Monad.Trans.Class (MonadTrans, lift)
+import Control.Monad.Trans.Control (MonadBaseControl(..), RunInBase)
+import Control.Monad.Writer.Class (MonadWriter)
 import qualified Data.Aeson as JSON
+import Data.Coerce
 import Data.Foldable (for_)
 import Data.List (sortOn)
 import Data.Map.Strict (Map)
 import qualified Data.Map.Strict as Map
 import Data.Maybe (fromMaybe)
 import Data.Time.Clock (NominalDiffTime)
 import Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime)
-import UnliftIO (MonadUnliftIO, withRunInIO)
-import UnliftIO.Exception (finally)
-import UnliftIO.STM (TChan, TVar, atomically, modifyTVar', newTChanIO, newTVarIO, readTVar, writeTChan, writeTVar)
 
 -- | A collection of span tags.
 type Tags = Map Key JSON.Value
@@ -102,22 +113,36 @@ data Scope = Scope
 
 -- | A span generation monad.
 newtype TraceT m a = TraceT { traceTReader :: ReaderT (Maybe Scope) m a }
-  deriving (Functor, Applicative, Monad, MonadIO, MonadTrans)
+  deriving ( Functor, Applicative, Monad, MonadTrans
+           , MonadWriter w, MonadState s, MonadError e
+           , MonadIO, MonadBase b )
 
 instance MonadReader r m => MonadReader r (TraceT m) where
   ask = lift ask
   local f (TraceT (ReaderT g)) = TraceT $ ReaderT $ \r -> local f $ g r
 
-instance MonadUnliftIO m => MonadTrace (TraceT m) where
+-- Cannot be derived in GHC 8.0 due to type family.
+instance MonadBaseControl b m => MonadBaseControl b (TraceT m) where
+  type StM (TraceT m) a = StM (ReaderT Scope m) a
+  liftBaseWith :: forall a. (RunInBase (TraceT m) b -> b a) -> TraceT m a
+  liftBaseWith
+    = coerce @((RunInBase (ReaderT (Maybe Scope) m) b -> b a) -> ReaderT (Maybe Scope) m a)
+             liftBaseWith
+  restoreM :: forall a. StM (TraceT m) a -> TraceT m a
+  restoreM
+    = coerce @(StM (ReaderT (Maybe Scope) m) a -> ReaderT (Maybe Scope) m a)
+             restoreM
+
+instance (MonadIO m, MonadBaseControl IO m) => MonadTrace (TraceT m) where
   trace bldr (TraceT reader) = TraceT $ ask >>= \case
     Nothing -> reader
     Just parentScope -> do
       let
         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
         Nothing -> pure $ fromMaybe Never (spanSamplingDecision <$> mbParentSpn)
@@ -132,13 +157,12 @@ instance MonadUnliftIO m => MonadTrace (TraceT m) where
           logsTV <- newTVarIO []
           startTV <- 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
                 writeTVar startTV (Just start)
                 modifyTVar' (tracerPendingCount tracer) (+1)
-              local (const $ Just scope) reader
+              local (const $ Just $ Scope tracer (Just spn) (Just tagsTV) (Just logsTV)) reader
             cleanup = do
               end <- liftIO $ getPOSIXTime
               atomically $ readTVar startTV >>= \case
@@ -162,9 +186,6 @@ instance MonadUnliftIO m => MonadTrace (TraceT m) where
       time <- maybe (liftIO getPOSIXTime) pure mbTime
       atomically $ modifyTVar' tv ((time, key, val) :)
 
-instance MonadUnliftIO m => MonadUnliftIO (TraceT m) where
-  withRunInIO inner = TraceT $ withRunInIO $ \run -> inner (run . traceTReader)
-
 -- | 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

@@ -1,3 +1,4 @@
+{-# LANGUAGE FlexibleContexts #-}
 -- | This module provides convenience functionality to debug traces locally. For production use,
 -- prefer alternatives, e.g. "Monitor.Tracing.Zipkin".
 module Monitor.Tracing.Local (
@@ -6,10 +7,10 @@ module Monitor.Tracing.Local (
 
 import Control.Concurrent.STM (atomically, readTVar, readTChan, tryReadTChan)
 import Control.Monad.Fix (fix)
-import Control.Monad.IO.Class (liftIO)
+import Control.Monad.IO.Class (MonadIO, liftIO)
 import Control.Monad.Trace
+import Control.Monad.Trans.Control (MonadBaseControl)
 import Data.IORef (modifyIORef', newIORef, readIORef)
-import UnliftIO (MonadUnliftIO)
 
 -- | Runs a 'TraceT' action, returning any collected samples alongside its output. The samples are
 -- sorted chronologically by completion time (e.g. the head is the first span to complete).
@@ -22,7 +23,8 @@ import UnliftIO (MonadUnliftIO)
 -- > collectSpanSamples $ rootSpan alwaysSampled "parent" $ do
 -- >   forkIO $ childSpan "child" $ threadDelay 2000000 -- Asynchronous 2 second child span.
 -- >   threadDelay 1000000 -- Returns after one second, but the child span will still be sampled.
-collectSpanSamples :: MonadUnliftIO m => TraceT m a -> m (a, [Sample])
+collectSpanSamples :: (MonadIO m, MonadBaseControl IO m)
+                   => TraceT m a -> m (a, [Sample])
 collectSpanSamples actn = do
   tracer <- newTracer
   rv <- runTraceT actn tracer

src/Monitor/Tracing/Zipkin.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE OverloadedStrings #-}
@@ -43,9 +44,11 @@ import Control.Monad.Trace.Class
 
 import Control.Concurrent (forkIO, threadDelay)
 import Control.Concurrent.STM (atomically, tryReadTChan)
+import Control.Exception.Lifted (finally)
 import Control.Monad (forever, guard, void, when)
 import Control.Monad.Fix (fix)
 import Control.Monad.IO.Class (MonadIO, liftIO)
+import Control.Monad.Trans.Control (MonadBaseControl)
 import qualified Data.Aeson as JSON
 import Data.ByteString (ByteString)
 import qualified Data.ByteString.Char8 as BS
@@ -71,8 +74,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 UnliftIO (MonadUnliftIO)
-import UnliftIO.Exception (finally)
 
 -- | 'Zipkin' creation settings.
 data Settings = Settings
@@ -154,7 +155,8 @@ publish z =
   liftIO $ flushSpans (zipkinEndpoint z) (zipkinTracer z) (zipkinRequest z) (zipkinManager z)
 
 -- | Convenience method to start a 'Zipkin', run an action, and publish all spans before returning.
-with :: MonadUnliftIO m => Settings -> (Zipkin -> m a) -> m a
+with :: (MonadIO m, MonadBaseControl IO m)
+     => Settings -> (Zipkin -> m a) -> m a
 with settings f = do
   zipkin <- new settings
   f zipkin `finally` publish zipkin

stack-nightly.yaml

@@ -0,0 +1,64 @@
+# This file was automatically generated by 'stack init'
+#
+# Some commonly used options have been documented as comments in this file.
+# For advanced use and comprehensive documentation of the format, please see:
+# https://docs.haskellstack.org/en/stable/yaml_configuration/
+
+# Resolver to choose a 'specific' stackage snapshot or a compiler version.
+# A snapshot resolver dictates the compiler version and the set of packages
+# to be used for project dependencies. For example:
+#
+# resolver: lts-3.5
+# resolver: nightly-2015-09-21
+# resolver: ghc-7.10.2
+#
+# The location of a snapshot can be provided as a file or url. Stack assumes
+# a snapshot provided as a file might change, whereas a url resource does not.
+#
+# resolver: ./custom-snapshot.yaml
+# resolver: https://example.com/snapshots/2018-01-01.yaml
+resolver: nightly-2022-03-20
+
+# User packages to be built.
+# Various formats can be used as shown in the example below.
+#
+# packages:
+# - some-directory
+# - https://example.com/foo/bar/baz-0.0.2.tar.gz
+# - location:
+#    git: https://github.com/commercialhaskell/stack.git
+#    commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
+# - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a
+#  subdirs:
+#  - auto-update
+#  - wai
+packages:
+- .
+# Dependency packages to be pulled from upstream that are not in the resolver
+# using the same syntax as the packages field.
+# (e.g., acme-missiles-0.3)
+# extra-deps: []
+
+# Override default flag values for local packages and extra-deps
+# flags: {}
+
+# Extra package databases containing global packages
+# extra-package-dbs: []
+
+# Control whether we use the GHC we find on the path
+# system-ghc: true
+#
+# Require a specific version of stack, using version ranges
+# require-stack-version: -any # Default
+# require-stack-version: ">=1.9"
+#
+# Override the architecture used by stack, especially useful on Windows
+# arch: i386
+# arch: x86_64
+#
+# Extra directories used by stack for building
+# extra-include-dirs: [/path/to/dir]
+# extra-lib-dirs: [/path/to/dir]
+#
+# Allow a newer minor version of GHC than the snapshot specifies
+# compiler-check: newer-minor

stack.yaml

@@ -17,7 +17,7 @@
 #
 # resolver: ./custom-snapshot.yaml
 # resolver: https://example.com/snapshots/2018-01-01.yaml
-resolver: nightly-2021-04-02
+resolver: lts-19.0
 
 # User packages to be built.
 # Various formats can be used as shown in the example below.

test/Spec.hs

@@ -13,16 +13,19 @@ import Control.Monad.IO.Class (liftIO, MonadIO)
 import Control.Monad (void)
 import Control.Monad.Reader (MonadReader, Reader, ReaderT, ask, runReader, runReaderT)
 import Control.Monad.State.Strict (MonadState, StateT, evalStateT, get)
+import Data.IORef
 import qualified Data.Map.Strict as Map
 import Data.Text (Text)
 import qualified Data.Set as Set
 import Test.Hspec
 import Test.Hspec.QuickCheck
-import UnliftIO
-import UnliftIO.Concurrent
-import UnliftIO.STM
 
-collectSpans :: MonadUnliftIO m => TraceT m () -> m [Span]
+import Control.Monad.IO.Class (MonadIO)
+import Control.Monad.Trans.Control (MonadBaseControl)
+import Control.Concurrent.Lifted
+import Control.Concurrent.STM.Lifted
+
+collectSpans :: (MonadIO m, MonadBaseControl IO m) => TraceT m () -> m [Span]
 collectSpans actn = fmap sampleSpan . snd <$> collectSpanSamples actn
 
 main :: IO ()
@@ -102,6 +105,6 @@ main = hspec $ do
     it "should collect spans which are still pending after the action returns" $ do
       spans <- collectSpans $ rootSpan alwaysSampled "sleep-parent" $ do
         tmv <- newEmptyTMVarIO
-        void $ forkIO $ childSpan "sleep-child" $ atomically (putTMVar tmv ()) >> threadDelay 20000
+        void $ fork $ childSpan "sleep-child" $ atomically (putTMVar tmv ()) >> threadDelay 20000
         void $ atomically $ readTMVar tmv
       fmap spanName spans `shouldMatchList` ["sleep-parent", "sleep-child"]