{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE StandaloneKindSignatures #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-unused-imports #-}
module OTel.API.Trace.Internal
  ( -- * Disclaimer
    -- $disclaimer
    TracingT(..)
  , mapTracingT

  , TracingBackend(..)
  , toTracingBackend

  , getTracingBackend
  , getTracer
  , shutdownTracerProvider
  , forceFlushTracerProvider
  ) where

import Control.Applicative (Alternative)
import Control.Exception.Safe (MonadCatch, MonadMask, MonadThrow, SomeException, withException)
import Control.Monad (MonadPlus)
import Control.Monad.Base (MonadBase)
import Control.Monad.Cont (MonadCont)
import Control.Monad.Except (MonadError)
import Control.Monad.IO.Class (MonadIO(liftIO))
import Control.Monad.IO.Unlift (MonadUnliftIO)
import Control.Monad.Logger.Aeson (MonadLogger, withThreadContext)
import Control.Monad.RWS.Class (MonadRWS)
import Control.Monad.Reader (MonadReader(ask, local, reader))
import Control.Monad.State (MonadState)
import Control.Monad.Trans.Class (MonadTrans(lift))
import Control.Monad.Trans.Control (MonadTransControl(..), MonadBaseControl)
import Control.Monad.Trans.Reader (ReaderT(..))
import Control.Monad.Trans.Resource (MonadResource)
import Control.Monad.Writer.Class (MonadWriter)
import Data.Kind (Type)
import Data.Monoid (Ap(..))
import OTel.API.Baggage.Core (MonadBaggage)
import OTel.API.Common
  ( AttrsFor(AttrsForSpan), KV(..), TimestampSource(..), AttrsBuilder, InstrumentationScope
  )
import OTel.API.Context (ContextT(..), ContextBackend, attachContextValue, getAttachedContext)
import OTel.API.Trace.Core
  ( MonadTracing(..), MonadTracingIO(..), SpanSpec(..)
  , Span(spanContext, spanFrozenAt, spanIsRecording), MutableSpan, contextBackendSpan
  , recordException
  )
import OTel.API.Trace.Core.Internal
  ( Tracer(..), TracerProvider(..), buildSpanUpdater, freezeSpan, unsafeModifyMutableSpan
  , unsafeReadMutableSpan
  )
import Prelude hiding (span)
import qualified Control.Exception.Safe as Safe
import qualified GHC.Stack as Stack

#if MIN_VERSION_mtl(2,3,0)
import Control.Monad.Accum (MonadAccum)
import Control.Monad.Select (MonadSelect)
#endif

type TracingT :: (Type -> Type) -> Type -> Type
newtype TracingT m a = TracingT
  { forall (m :: * -> *) a. TracingT m a -> TracingBackend -> m a
runTracingT :: TracingBackend -> m a
  } deriving
      ( Functor (TracingT m)
Functor (TracingT m) =>
(forall a. a -> TracingT m a)
-> (forall a b.
    TracingT m (a -> b) -> TracingT m a -> TracingT m b)
-> (forall a b c.
    (a -> b -> c) -> TracingT m a -> TracingT m b -> TracingT m c)
-> (forall a b. TracingT m a -> TracingT m b -> TracingT m b)
-> (forall a b. TracingT m a -> TracingT m b -> TracingT m a)
-> Applicative (TracingT m)
forall a. a -> TracingT m a
forall a b. TracingT m a -> TracingT m b -> TracingT m a
forall a b. TracingT m a -> TracingT m b -> TracingT m b
forall a b. TracingT m (a -> b) -> TracingT m a -> TracingT m b
forall a b c.
(a -> b -> c) -> TracingT m a -> TracingT m b -> TracingT m c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
forall (m :: * -> *). Applicative m => Functor (TracingT m)
forall (m :: * -> *) a. Applicative m => a -> TracingT m a
forall (m :: * -> *) a b.
Applicative m =>
TracingT m a -> TracingT m b -> TracingT m a
forall (m :: * -> *) a b.
Applicative m =>
TracingT m a -> TracingT m b -> TracingT m b
forall (m :: * -> *) a b.
Applicative m =>
TracingT m (a -> b) -> TracingT m a -> TracingT m b
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c) -> TracingT m a -> TracingT m b -> TracingT m c
$cpure :: forall (m :: * -> *) a. Applicative m => a -> TracingT m a
pure :: forall a. a -> TracingT m a
$c<*> :: forall (m :: * -> *) a b.
Applicative m =>
TracingT m (a -> b) -> TracingT m a -> TracingT m b
<*> :: forall a b. TracingT m (a -> b) -> TracingT m a -> TracingT m b
$cliftA2 :: forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c) -> TracingT m a -> TracingT m b -> TracingT m c
liftA2 :: forall a b c.
(a -> b -> c) -> TracingT m a -> TracingT m b -> TracingT m c
$c*> :: forall (m :: * -> *) a b.
Applicative m =>
TracingT m a -> TracingT m b -> TracingT m b
*> :: forall a b. TracingT m a -> TracingT m b -> TracingT m b
$c<* :: forall (m :: * -> *) a b.
Applicative m =>
TracingT m a -> TracingT m b -> TracingT m a
<* :: forall a b. TracingT m a -> TracingT m b -> TracingT m a
Applicative, (forall a b. (a -> b) -> TracingT m a -> TracingT m b)
-> (forall a b. a -> TracingT m b -> TracingT m a)
-> Functor (TracingT m)
forall a b. a -> TracingT m b -> TracingT m a
forall a b. (a -> b) -> TracingT m a -> TracingT m b
forall (m :: * -> *) a b.
Functor m =>
a -> TracingT m b -> TracingT m a
forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> TracingT m a -> TracingT m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> TracingT m a -> TracingT m b
fmap :: forall a b. (a -> b) -> TracingT m a -> TracingT m b
$c<$ :: forall (m :: * -> *) a b.
Functor m =>
a -> TracingT m b -> TracingT m a
<$ :: forall a b. a -> TracingT m b -> TracingT m a
Functor, Applicative (TracingT m)
Applicative (TracingT m) =>
(forall a b. TracingT m a -> (a -> TracingT m b) -> TracingT m b)
-> (forall a b. TracingT m a -> TracingT m b -> TracingT m b)
-> (forall a. a -> TracingT m a)
-> Monad (TracingT m)
forall a. a -> TracingT m a
forall a b. TracingT m a -> TracingT m b -> TracingT m b
forall a b. TracingT m a -> (a -> TracingT m b) -> TracingT m b
forall (m :: * -> *). Monad m => Applicative (TracingT m)
forall (m :: * -> *) a. Monad m => a -> TracingT m a
forall (m :: * -> *) a b.
Monad m =>
TracingT m a -> TracingT m b -> TracingT m b
forall (m :: * -> *) a b.
Monad m =>
TracingT m a -> (a -> TracingT m b) -> TracingT m b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall (m :: * -> *) a b.
Monad m =>
TracingT m a -> (a -> TracingT m b) -> TracingT m b
>>= :: forall a b. TracingT m a -> (a -> TracingT m b) -> TracingT m b
$c>> :: forall (m :: * -> *) a b.
Monad m =>
TracingT m a -> TracingT m b -> TracingT m b
>> :: forall a b. TracingT m a -> TracingT m b -> TracingT m b
$creturn :: forall (m :: * -> *) a. Monad m => a -> TracingT m a
return :: forall a. a -> TracingT m a
Monad, Monad (TracingT m)
Monad (TracingT m) =>
(forall a. String -> TracingT m a) -> MonadFail (TracingT m)
forall a. String -> TracingT m a
forall (m :: * -> *).
Monad m =>
(forall a. String -> m a) -> MonadFail m
forall (m :: * -> *). MonadFail m => Monad (TracingT m)
forall (m :: * -> *) a. MonadFail m => String -> TracingT m a
$cfail :: forall (m :: * -> *) a. MonadFail m => String -> TracingT m a
fail :: forall a. String -> TracingT m a
MonadFail, Monad (TracingT m)
Monad (TracingT m) =>
(forall a. IO a -> TracingT m a) -> MonadIO (TracingT m)
forall a. IO a -> TracingT m a
forall (m :: * -> *).
Monad m =>
(forall a. IO a -> m a) -> MonadIO m
forall (m :: * -> *). MonadIO m => Monad (TracingT m)
forall (m :: * -> *) a. MonadIO m => IO a -> TracingT m a
$cliftIO :: forall (m :: * -> *) a. MonadIO m => IO a -> TracingT m a
liftIO :: forall a. IO a -> TracingT m a
MonadIO -- @base@
      , Applicative (TracingT m)
Applicative (TracingT m) =>
(forall a. TracingT m a)
-> (forall a. TracingT m a -> TracingT m a -> TracingT m a)
-> (forall a. TracingT m a -> TracingT m [a])
-> (forall a. TracingT m a -> TracingT m [a])
-> Alternative (TracingT m)
forall a. TracingT m a
forall a. TracingT m a -> TracingT m [a]
forall a. TracingT m a -> TracingT m a -> TracingT m a
forall (f :: * -> *).
Applicative f =>
(forall a. f a)
-> (forall a. f a -> f a -> f a)
-> (forall a. f a -> f [a])
-> (forall a. f a -> f [a])
-> Alternative f
forall (m :: * -> *). Alternative m => Applicative (TracingT m)
forall (m :: * -> *) a. Alternative m => TracingT m a
forall (m :: * -> *) a.
Alternative m =>
TracingT m a -> TracingT m [a]
forall (m :: * -> *) a.
Alternative m =>
TracingT m a -> TracingT m a -> TracingT m a
$cempty :: forall (m :: * -> *) a. Alternative m => TracingT m a
empty :: forall a. TracingT m a
$c<|> :: forall (m :: * -> *) a.
Alternative m =>
TracingT m a -> TracingT m a -> TracingT m a
<|> :: forall a. TracingT m a -> TracingT m a -> TracingT m a
$csome :: forall (m :: * -> *) a.
Alternative m =>
TracingT m a -> TracingT m [a]
some :: forall a. TracingT m a -> TracingT m [a]
$cmany :: forall (m :: * -> *) a.
Alternative m =>
TracingT m a -> TracingT m [a]
many :: forall a. TracingT m a -> TracingT m [a]
Alternative, Monad (TracingT m)
Alternative (TracingT m)
(Alternative (TracingT m), Monad (TracingT m)) =>
(forall a. TracingT m a)
-> (forall a. TracingT m a -> TracingT m a -> TracingT m a)
-> MonadPlus (TracingT m)
forall a. TracingT m a
forall a. TracingT m a -> TracingT m a -> TracingT m a
forall (m :: * -> *).
(Alternative m, Monad m) =>
(forall a. m a) -> (forall a. m a -> m a -> m a) -> MonadPlus m
forall (m :: * -> *). MonadPlus m => Monad (TracingT m)
forall (m :: * -> *). MonadPlus m => Alternative (TracingT m)
forall (m :: * -> *) a. MonadPlus m => TracingT m a
forall (m :: * -> *) a.
MonadPlus m =>
TracingT m a -> TracingT m a -> TracingT m a
$cmzero :: forall (m :: * -> *) a. MonadPlus m => TracingT m a
mzero :: forall a. TracingT m a
$cmplus :: forall (m :: * -> *) a.
MonadPlus m =>
TracingT m a -> TracingT m a -> TracingT m a
mplus :: forall a. TracingT m a -> TracingT m a -> TracingT m a
MonadPlus -- @base@
      , Monad (TracingT m)
Monad (TracingT m) =>
(forall a b. ((a -> TracingT m b) -> TracingT m a) -> TracingT m a)
-> MonadCont (TracingT m)
forall a b. ((a -> TracingT m b) -> TracingT m a) -> TracingT m a
forall (m :: * -> *).
Monad m =>
(forall a b. ((a -> m b) -> m a) -> m a) -> MonadCont m
forall (m :: * -> *). MonadCont m => Monad (TracingT m)
forall (m :: * -> *) a b.
MonadCont m =>
((a -> TracingT m b) -> TracingT m a) -> TracingT m a
$ccallCC :: forall (m :: * -> *) a b.
MonadCont m =>
((a -> TracingT m b) -> TracingT m a) -> TracingT m a
callCC :: forall a b. ((a -> TracingT m b) -> TracingT m a) -> TracingT m a
MonadCont, MonadError e, MonadState s, MonadWriter w -- @mtl@
#if MIN_VERSION_mtl(2,3,0)
      , MonadAccum w, MonadSelect r -- @mtl@
#endif
      , MonadThrow (TracingT m)
MonadThrow (TracingT m) =>
(forall e a.
 (HasCallStack, Exception e) =>
 TracingT m a -> (e -> TracingT m a) -> TracingT m a)
-> MonadCatch (TracingT m)
forall e a.
(HasCallStack, Exception e) =>
TracingT m a -> (e -> TracingT m a) -> TracingT m a
forall (m :: * -> *).
MonadThrow m =>
(forall e a.
 (HasCallStack, Exception e) =>
 m a -> (e -> m a) -> m a)
-> MonadCatch m
forall (m :: * -> *). MonadCatch m => MonadThrow (TracingT m)
forall (m :: * -> *) e a.
(MonadCatch m, HasCallStack, Exception e) =>
TracingT m a -> (e -> TracingT m a) -> TracingT m a
$ccatch :: forall (m :: * -> *) e a.
(MonadCatch m, HasCallStack, Exception e) =>
TracingT m a -> (e -> TracingT m a) -> TracingT m a
catch :: forall e a.
(HasCallStack, Exception e) =>
TracingT m a -> (e -> TracingT m a) -> TracingT m a
MonadCatch, MonadCatch (TracingT m)
MonadCatch (TracingT m) =>
(forall b.
 HasCallStack =>
 ((forall a. TracingT m a -> TracingT m a) -> TracingT m b)
 -> TracingT m b)
-> (forall b.
    HasCallStack =>
    ((forall a. TracingT m a -> TracingT m a) -> TracingT m b)
    -> TracingT m b)
-> (forall a b c.
    HasCallStack =>
    TracingT m a
    -> (a -> ExitCase b -> TracingT m c)
    -> (a -> TracingT m b)
    -> TracingT m (b, c))
-> MonadMask (TracingT m)
forall b.
HasCallStack =>
((forall a. TracingT m a -> TracingT m a) -> TracingT m b)
-> TracingT m b
forall a b c.
HasCallStack =>
TracingT m a
-> (a -> ExitCase b -> TracingT m c)
-> (a -> TracingT m b)
-> TracingT m (b, c)
forall (m :: * -> *). MonadMask m => MonadCatch (TracingT m)
forall (m :: * -> *) b.
(MonadMask m, HasCallStack) =>
((forall a. TracingT m a -> TracingT m a) -> TracingT m b)
-> TracingT m b
forall (m :: * -> *) a b c.
(MonadMask m, HasCallStack) =>
TracingT m a
-> (a -> ExitCase b -> TracingT m c)
-> (a -> TracingT m b)
-> TracingT m (b, c)
forall (m :: * -> *).
MonadCatch m =>
(forall b. HasCallStack => ((forall a. m a -> m a) -> m b) -> m b)
-> (forall b.
    HasCallStack =>
    ((forall a. m a -> m a) -> m b) -> m b)
-> (forall a b c.
    HasCallStack =>
    m a -> (a -> ExitCase b -> m c) -> (a -> m b) -> m (b, c))
-> MonadMask m
$cmask :: forall (m :: * -> *) b.
(MonadMask m, HasCallStack) =>
((forall a. TracingT m a -> TracingT m a) -> TracingT m b)
-> TracingT m b
mask :: forall b.
HasCallStack =>
((forall a. TracingT m a -> TracingT m a) -> TracingT m b)
-> TracingT m b
$cuninterruptibleMask :: forall (m :: * -> *) b.
(MonadMask m, HasCallStack) =>
((forall a. TracingT m a -> TracingT m a) -> TracingT m b)
-> TracingT m b
uninterruptibleMask :: forall b.
HasCallStack =>
((forall a. TracingT m a -> TracingT m a) -> TracingT m b)
-> TracingT m b
$cgeneralBracket :: forall (m :: * -> *) a b c.
(MonadMask m, HasCallStack) =>
TracingT m a
-> (a -> ExitCase b -> TracingT m c)
-> (a -> TracingT m b)
-> TracingT m (b, c)
generalBracket :: forall a b c.
HasCallStack =>
TracingT m a
-> (a -> ExitCase b -> TracingT m c)
-> (a -> TracingT m b)
-> TracingT m (b, c)
MonadMask, Monad (TracingT m)
Monad (TracingT m) =>
(forall e a. (HasCallStack, Exception e) => e -> TracingT m a)
-> MonadThrow (TracingT m)
forall e a. (HasCallStack, Exception e) => e -> TracingT m a
forall (m :: * -> *).
Monad m =>
(forall e a. (HasCallStack, Exception e) => e -> m a)
-> MonadThrow m
forall (m :: * -> *). MonadThrow m => Monad (TracingT m)
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> TracingT m a
$cthrowM :: forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> TracingT m a
throwM :: forall e a. (HasCallStack, Exception e) => e -> TracingT m a
MonadThrow -- @exceptions@
      , MonadIO (TracingT m)
MonadIO (TracingT m) =>
(forall b.
 ((forall a. TracingT m a -> IO a) -> IO b) -> TracingT m b)
-> MonadUnliftIO (TracingT m)
forall b.
((forall a. TracingT m a -> IO a) -> IO b) -> TracingT m b
forall (m :: * -> *).
MonadIO m =>
(forall b. ((forall a. m a -> IO a) -> IO b) -> m b)
-> MonadUnliftIO m
forall (m :: * -> *). MonadUnliftIO m => MonadIO (TracingT m)
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. TracingT m a -> IO a) -> IO b) -> TracingT m b
$cwithRunInIO :: forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. TracingT m a -> IO a) -> IO b) -> TracingT m b
withRunInIO :: forall b.
((forall a. TracingT m a -> IO a) -> IO b) -> TracingT m b
MonadUnliftIO -- @unliftio-core@
      , MonadBase b -- @transformers-base@
      , MonadBaseControl b -- @monad-control@
      , Monad (TracingT m)
Monad (TracingT m) =>
(forall msg.
 ToLogStr msg =>
 Loc -> LogSource -> LogLevel -> msg -> TracingT m ())
-> MonadLogger (TracingT m)
forall msg.
ToLogStr msg =>
Loc -> LogSource -> LogLevel -> msg -> TracingT m ()
forall (m :: * -> *).
Monad m =>
(forall msg.
 ToLogStr msg =>
 Loc -> LogSource -> LogLevel -> msg -> m ())
-> MonadLogger m
forall (m :: * -> *). MonadLogger m => Monad (TracingT m)
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> LogSource -> LogLevel -> msg -> TracingT m ()
$cmonadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> LogSource -> LogLevel -> msg -> TracingT m ()
monadLoggerLog :: forall msg.
ToLogStr msg =>
Loc -> LogSource -> LogLevel -> msg -> TracingT m ()
MonadLogger -- @monad-logger@
      , MonadIO (TracingT m)
MonadIO (TracingT m) =>
(forall a. ResourceT IO a -> TracingT m a)
-> MonadResource (TracingT m)
forall a. ResourceT IO a -> TracingT m a
forall (m :: * -> *).
MonadIO m =>
(forall a. ResourceT IO a -> m a) -> MonadResource m
forall (m :: * -> *). MonadResource m => MonadIO (TracingT m)
forall (m :: * -> *) a.
MonadResource m =>
ResourceT IO a -> TracingT m a
$cliftResourceT :: forall (m :: * -> *) a.
MonadResource m =>
ResourceT IO a -> TracingT m a
liftResourceT :: forall a. ResourceT IO a -> TracingT m a
MonadResource -- @resourcet@
      , Monad (TracingT m)
TracingT m Baggage
Monad (TracingT m) =>
TracingT m Baggage
-> (forall a. Baggage -> TracingT m a -> TracingT m a)
-> MonadBaggage (TracingT m)
forall a. Baggage -> TracingT m a -> TracingT m a
forall (m :: * -> *).
Monad m =>
m Baggage -> (forall a. Baggage -> m a -> m a) -> MonadBaggage m
forall (m :: * -> *). MonadBaggage m => Monad (TracingT m)
forall (m :: * -> *). MonadBaggage m => TracingT m Baggage
forall (m :: * -> *) a.
MonadBaggage m =>
Baggage -> TracingT m a -> TracingT m a
$cgetBaggage :: forall (m :: * -> *). MonadBaggage m => TracingT m Baggage
getBaggage :: TracingT m Baggage
$csetBaggage :: forall (m :: * -> *) a.
MonadBaggage m =>
Baggage -> TracingT m a -> TracingT m a
setBaggage :: forall a. Baggage -> TracingT m a -> TracingT m a
MonadBaggage -- @otel-api-baggage-core@
      ) via (ReaderT TracingBackend m)
    deriving
      ( MonadTrans TracingT
MonadTrans TracingT =>
(forall (m :: * -> *) a.
 Monad m =>
 (Run TracingT -> m a) -> TracingT m a)
-> (forall (m :: * -> *) a.
    Monad m =>
    m (StT TracingT a) -> TracingT m a)
-> MonadTransControl TracingT
forall (m :: * -> *) a.
Monad m =>
m (StT TracingT a) -> TracingT m a
forall (m :: * -> *) a.
Monad m =>
(Run TracingT -> m a) -> TracingT m a
forall (t :: (* -> *) -> * -> *).
MonadTrans t =>
(forall (m :: * -> *) a. Monad m => (Run t -> m a) -> t m a)
-> (forall (m :: * -> *) a. Monad m => m (StT t a) -> t m a)
-> MonadTransControl t
$cliftWith :: forall (m :: * -> *) a.
Monad m =>
(Run TracingT -> m a) -> TracingT m a
liftWith :: forall (m :: * -> *) a.
Monad m =>
(Run TracingT -> m a) -> TracingT m a
$crestoreT :: forall (m :: * -> *) a.
Monad m =>
m (StT TracingT a) -> TracingT m a
restoreT :: forall (m :: * -> *) a.
Monad m =>
m (StT TracingT a) -> TracingT m a
MonadTransControl -- @monad-control@
      ) via (ReaderT TracingBackend)
    deriving
      ( NonEmpty (TracingT m a) -> TracingT m a
TracingT m a -> TracingT m a -> TracingT m a
(TracingT m a -> TracingT m a -> TracingT m a)
-> (NonEmpty (TracingT m a) -> TracingT m a)
-> (forall b. Integral b => b -> TracingT m a -> TracingT m a)
-> Semigroup (TracingT m a)
forall b. Integral b => b -> TracingT m a -> TracingT m a
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
forall (m :: * -> *) a.
(Applicative m, Semigroup a) =>
NonEmpty (TracingT m a) -> TracingT m a
forall (m :: * -> *) a.
(Applicative m, Semigroup a) =>
TracingT m a -> TracingT m a -> TracingT m a
forall (m :: * -> *) a b.
(Applicative m, Semigroup a, Integral b) =>
b -> TracingT m a -> TracingT m a
$c<> :: forall (m :: * -> *) a.
(Applicative m, Semigroup a) =>
TracingT m a -> TracingT m a -> TracingT m a
<> :: TracingT m a -> TracingT m a -> TracingT m a
$csconcat :: forall (m :: * -> *) a.
(Applicative m, Semigroup a) =>
NonEmpty (TracingT m a) -> TracingT m a
sconcat :: NonEmpty (TracingT m a) -> TracingT m a
$cstimes :: forall (m :: * -> *) a b.
(Applicative m, Semigroup a, Integral b) =>
b -> TracingT m a -> TracingT m a
stimes :: forall b. Integral b => b -> TracingT m a -> TracingT m a
Semigroup, Semigroup (TracingT m a)
TracingT m a
Semigroup (TracingT m a) =>
TracingT m a
-> (TracingT m a -> TracingT m a -> TracingT m a)
-> ([TracingT m a] -> TracingT m a)
-> Monoid (TracingT m a)
[TracingT m a] -> TracingT m a
TracingT m a -> TracingT m a -> TracingT m a
forall a.
Semigroup a =>
a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
forall (m :: * -> *) a.
(Applicative m, Monoid a) =>
Semigroup (TracingT m a)
forall (m :: * -> *) a. (Applicative m, Monoid a) => TracingT m a
forall (m :: * -> *) a.
(Applicative m, Monoid a) =>
[TracingT m a] -> TracingT m a
forall (m :: * -> *) a.
(Applicative m, Monoid a) =>
TracingT m a -> TracingT m a -> TracingT m a
$cmempty :: forall (m :: * -> *) a. (Applicative m, Monoid a) => TracingT m a
mempty :: TracingT m a
$cmappend :: forall (m :: * -> *) a.
(Applicative m, Monoid a) =>
TracingT m a -> TracingT m a -> TracingT m a
mappend :: TracingT m a -> TracingT m a -> TracingT m a
$cmconcat :: forall (m :: * -> *) a.
(Applicative m, Monoid a) =>
[TracingT m a] -> TracingT m a
mconcat :: [TracingT m a] -> TracingT m a
Monoid -- @base@
      ) via (Ap (ReaderT TracingBackend m) a)

-- On GHC 9.6.2/transformers-0.6.0.1, including this 'MonadTrans' instance
-- in the cleaner way above, e.g.:
--
--   deriving
--     ( MonadTrans -- @transformers@
--     , MonadTransControl -- @monad-control@
--     ) via (ReaderT TracingBackend)
--
-- produces a redundant constraint warning:
--
-- error: [GHC-30606] [-Wredundant-constraints, Werror=redundant-constraints]
--       • Redundant constraint: Monad m
--       • When deriving the instance for (MonadTrans TracingT)
--      |
--   75 |       ( MonadTrans -- @transformers@
--      |         ^^^^^^^^^^
--
-- Strangely, doing the same style of deriving but using @-XStandaloneDeriving@
-- does not produce this warning.
deriving via (ReaderT TracingBackend) instance MonadTrans TracingT

instance (MonadReader r m) => MonadReader r (TracingT m) where
  ask :: TracingT m r
ask = m r -> TracingT m r
forall (m :: * -> *) a. Monad m => m a -> TracingT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m r
forall r (m :: * -> *). MonadReader r m => m r
ask
  reader :: forall a. (r -> a) -> TracingT m a
reader = m a -> TracingT m a
forall (m :: * -> *) a. Monad m => m a -> TracingT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> TracingT m a)
-> ((r -> a) -> m a) -> (r -> a) -> TracingT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (r -> a) -> m a
forall a. (r -> a) -> m a
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
reader
  local :: forall a. (r -> r) -> TracingT m a -> TracingT m a
local = (m a -> m a) -> TracingT m a -> TracingT m a
forall (m :: * -> *) (n :: * -> *) a b.
(m a -> n b) -> TracingT m a -> TracingT n b
mapTracingT ((m a -> m a) -> TracingT m a -> TracingT m a)
-> ((r -> r) -> m a -> m a)
-> (r -> r)
-> TracingT m a
-> TracingT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (r -> r) -> m a -> m a
forall a. (r -> r) -> m a -> m a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local

instance (MonadRWS r w s m) => MonadRWS r w s (TracingT m)

instance (MonadIO m, MonadMask m) => MonadTracing (TracingT m) where
  traceCS :: forall a.
CallStack
-> SpanSpec -> (MutableSpan -> TracingT m a) -> TracingT m a
traceCS CallStack
cs SpanSpec
spanSpec MutableSpan -> TracingT m a
action =
    (TracingBackend -> m a) -> TracingT m a
forall (m :: * -> *) a. (TracingBackend -> m a) -> TracingT m a
TracingT \TracingBackend
tracingBackend -> do
      (ContextT MutableSpan m a -> ContextBackend MutableSpan -> m a)
-> ContextBackend MutableSpan -> ContextT MutableSpan m a -> m a
forall a b c. (a -> b -> c) -> b -> a -> c
flip ContextT MutableSpan m a -> ContextBackend MutableSpan -> m a
forall c (m :: * -> *) a. ContextT c m a -> ContextBackend c -> m a
runContextT (TracingBackend -> ContextBackend MutableSpan
tracingBackendContextBackend TracingBackend
tracingBackend) do
        Context
parentCtx <- ContextT MutableSpan m Context
forall (m :: * -> *) a.
(MonadIO m, MonadThrow m) =>
ContextT a m Context
getAttachedContext
        (MutableSpan
mutableSpan, [Pair]
spanContextMeta) <- do
          IO (MutableSpan, [Pair])
-> ContextT MutableSpan m (MutableSpan, [Pair])
forall a. IO a -> ContextT MutableSpan m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (MutableSpan, [Pair])
 -> ContextT MutableSpan m (MutableSpan, [Pair]))
-> IO (MutableSpan, [Pair])
-> ContextT MutableSpan m (MutableSpan, [Pair])
forall a b. (a -> b) -> a -> b
$ Tracer
-> CallStack -> Context -> SpanSpec -> IO (MutableSpan, [Pair])
tracerStartSpan (TracingBackend -> Tracer
tracingBackendTracer TracingBackend
tracingBackend) CallStack
cs Context
parentCtx SpanSpec
spanSpec
        MutableSpan -> ContextT MutableSpan m a -> ContextT MutableSpan m a
forall (m :: * -> *) a b.
(MonadIO m, MonadMask m) =>
a -> ContextT a m b -> ContextT a m b
attachContextValue MutableSpan
mutableSpan do
          [Pair] -> ContextT MutableSpan m a -> ContextT MutableSpan m a
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
[Pair] -> m a -> m a
withThreadContext [Pair]
spanContextMeta do
            a
result <- do
              m a -> ContextT MutableSpan m a
forall (m :: * -> *) a. Monad m => m a -> ContextT MutableSpan m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TracingT m a -> TracingBackend -> m a
forall (m :: * -> *) a. TracingT m a -> TracingBackend -> m a
runTracingT (MutableSpan -> TracingT m a
action MutableSpan
mutableSpan) TracingBackend
tracingBackend) ContextT MutableSpan m a
-> (SomeException -> ContextT MutableSpan m ())
-> ContextT MutableSpan m a
forall (m :: * -> *) e a b.
(HasCallStack, MonadMask m, Exception e) =>
m a -> (e -> m b) -> m a
`withException` \SomeException
e -> do
                IO () -> ContextT MutableSpan m ()
forall a. IO a -> ContextT MutableSpan m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ContextT MutableSpan m ())
-> IO () -> ContextT MutableSpan m ()
forall a b. (a -> b) -> a -> b
$ Tracer -> MutableSpan -> SomeException -> IO ()
handler (TracingBackend -> Tracer
tracingBackendTracer TracingBackend
tracingBackend) MutableSpan
mutableSpan SomeException
e
            IO () -> ContextT MutableSpan m ()
forall a. IO a -> ContextT MutableSpan m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ContextT MutableSpan m ())
-> IO () -> ContextT MutableSpan m ()
forall a b. (a -> b) -> a -> b
$ Tracer -> MutableSpan -> IO ()
processSpan (TracingBackend -> Tracer
tracingBackendTracer TracingBackend
tracingBackend) MutableSpan
mutableSpan
            a -> ContextT MutableSpan m a
forall a. a -> ContextT MutableSpan m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
result
    where
    processSpan :: Tracer -> MutableSpan -> IO ()
    processSpan :: Tracer -> MutableSpan -> IO ()
processSpan Tracer
tracer MutableSpan
mutableSpan = do
      Span AttrsBuilder
span <- MutableSpan -> IO (Span AttrsBuilder)
unsafeReadMutableSpan MutableSpan
mutableSpan
      Timestamp
timestamp <- IO Timestamp
now
      -- N.B. We set the span's 'spanFrozenAt' field both in the value copy we
      -- pass to the span processors' on-span-end method and in the mutable
      -- span. The former is important so that a span processor's on-span-start
      -- method has a reliable means of understanding if any spans it's tracking
      -- have ended or not. We could alternatively set the timestamp in the
      -- mutable span before passing the copy to the span processors, but the
      -- current flow requires that we only update the reference once, where we
      -- include both the timestamp and 'spanIsRecording'. Any recording spans
      -- must be seen as recording for span processors to receive them, so we
      -- don't set 'spanIsRecording' until after span processors have received
      -- the span.
      IO () -> IO ()
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
        (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Span Attrs -> IO ()
tracerProcessSpan
        (Span Attrs -> IO ()) -> Span Attrs -> IO ()
forall a b. (a -> b) -> a -> b
$ Timestamp
-> AttrsLimits 'AttrsForSpanLink
-> AttrsLimits 'AttrsForSpanEvent
-> AttrsLimits 'AttrsForSpan
-> Span AttrsBuilder
-> Span Attrs
freezeSpan Timestamp
timestamp AttrsLimits 'AttrsForSpanLink
spanLinkAttrsLimits AttrsLimits 'AttrsForSpanEvent
spanEventAttrsLimits AttrsLimits 'AttrsForSpan
spanAttrsLimits Span AttrsBuilder
span
            { spanFrozenAt = Just timestamp
            }
      MutableSpan
-> (Span AttrsBuilder -> (Span AttrsBuilder, ())) -> IO ()
forall a.
MutableSpan
-> (Span AttrsBuilder -> (Span AttrsBuilder, a)) -> IO a
unsafeModifyMutableSpan MutableSpan
mutableSpan \Span AttrsBuilder
s ->
        (Span AttrsBuilder
s { spanIsRecording = False, spanFrozenAt = Just timestamp }, ())
      where
      Tracer
        { tracerNow :: Tracer -> IO Timestamp
tracerNow = IO Timestamp
now
        , Span Attrs -> IO ()
tracerProcessSpan :: Span Attrs -> IO ()
tracerProcessSpan :: Tracer -> Span Attrs -> IO ()
tracerProcessSpan
        , tracerSpanAttrsLimits :: Tracer -> AttrsLimits 'AttrsForSpan
tracerSpanAttrsLimits = AttrsLimits 'AttrsForSpan
spanAttrsLimits
        , tracerSpanEventAttrsLimits :: Tracer -> AttrsLimits 'AttrsForSpanEvent
tracerSpanEventAttrsLimits = AttrsLimits 'AttrsForSpanEvent
spanEventAttrsLimits
        , tracerSpanLinkAttrsLimits :: Tracer -> AttrsLimits 'AttrsForSpanLink
tracerSpanLinkAttrsLimits = AttrsLimits 'AttrsForSpanLink
spanLinkAttrsLimits
        } = Tracer
tracer

    handler :: Tracer -> MutableSpan -> SomeException -> IO ()
    handler :: Tracer -> MutableSpan -> SomeException -> IO ()
handler Tracer
tracer MutableSpan
mutableSpan SomeException
someEx = do
      Span AttrsBuilder -> Span AttrsBuilder
spanUpdater <- do
        IO Timestamp
-> UpdateSpanSpec -> IO (Span AttrsBuilder -> Span AttrsBuilder)
forall (m :: * -> *).
Monad m =>
m Timestamp
-> UpdateSpanSpec -> m (Span AttrsBuilder -> Span AttrsBuilder)
buildSpanUpdater IO Timestamp
now (UpdateSpanSpec -> IO (Span AttrsBuilder -> Span AttrsBuilder))
-> UpdateSpanSpec -> IO (Span AttrsBuilder -> Span AttrsBuilder)
forall a b. (a -> b) -> a -> b
$ SomeException
-> Bool
-> TimestampSource
-> AttrsBuilder 'AttrsForSpanEvent
-> UpdateSpanSpec
recordException SomeException
someEx Bool
True TimestampSource
TimestampSourceNow AttrsBuilder 'AttrsForSpanEvent
forall a. Monoid a => a
mempty
      MutableSpan
-> (Span AttrsBuilder -> (Span AttrsBuilder, ())) -> IO ()
forall a.
MutableSpan
-> (Span AttrsBuilder -> (Span AttrsBuilder, a)) -> IO a
unsafeModifyMutableSpan MutableSpan
mutableSpan \Span AttrsBuilder
s ->
        (Span AttrsBuilder -> Span AttrsBuilder
spanUpdater Span AttrsBuilder
s, ())
      -- N.B. It is important that we finish the span after recording the
      -- exception and not the other way around, because the span is no longer
      -- recording after it is ended.
      Tracer -> MutableSpan -> IO ()
processSpan Tracer
tracer MutableSpan
mutableSpan
      where
      Tracer { tracerNow :: Tracer -> IO Timestamp
tracerNow = IO Timestamp
now } = Tracer
tracer

  getSpanContext :: MutableSpan -> TracingT m SpanContext
getSpanContext MutableSpan
mutableSpan = do
    IO SpanContext -> TracingT m SpanContext
forall a. IO a -> TracingT m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO SpanContext -> TracingT m SpanContext)
-> IO SpanContext -> TracingT m SpanContext
forall a b. (a -> b) -> a -> b
$ (Span AttrsBuilder -> SpanContext)
-> IO (Span AttrsBuilder) -> IO SpanContext
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Span AttrsBuilder -> SpanContext
forall (attrs :: AttrsFor -> *). Span attrs -> SpanContext
spanContext (IO (Span AttrsBuilder) -> IO SpanContext)
-> IO (Span AttrsBuilder) -> IO SpanContext
forall a b. (a -> b) -> a -> b
$ MutableSpan -> IO (Span AttrsBuilder)
unsafeReadMutableSpan MutableSpan
mutableSpan

  updateSpan :: MutableSpan -> UpdateSpanSpec -> TracingT m ()
updateSpan MutableSpan
mutableSpan UpdateSpanSpec
updateSpanSpec =
    (TracingBackend -> m ()) -> TracingT m ()
forall (m :: * -> *) a. (TracingBackend -> m a) -> TracingT m a
TracingT \TracingBackend
tracingBackend -> do
      IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO do
        Span AttrsBuilder -> Span AttrsBuilder
spanUpdater <- do
          IO Timestamp
-> UpdateSpanSpec -> IO (Span AttrsBuilder -> Span AttrsBuilder)
forall (m :: * -> *).
Monad m =>
m Timestamp
-> UpdateSpanSpec -> m (Span AttrsBuilder -> Span AttrsBuilder)
buildSpanUpdater (Tracer -> IO Timestamp
tracerNow (Tracer -> IO Timestamp) -> Tracer -> IO Timestamp
forall a b. (a -> b) -> a -> b
$ TracingBackend -> Tracer
tracingBackendTracer TracingBackend
tracingBackend) UpdateSpanSpec
updateSpanSpec
        MutableSpan
-> (Span AttrsBuilder -> (Span AttrsBuilder, ())) -> IO ()
forall a.
MutableSpan
-> (Span AttrsBuilder -> (Span AttrsBuilder, a)) -> IO a
unsafeModifyMutableSpan MutableSpan
mutableSpan \Span AttrsBuilder
s ->
          (Span AttrsBuilder -> Span AttrsBuilder
spanUpdater Span AttrsBuilder
s, ())

instance (MonadIO m, MonadMask m) => MonadTracingIO (TracingT m) where
  askTracerIO :: TracingT m Tracer
askTracerIO = (TracingBackend -> m Tracer) -> TracingT m Tracer
forall (m :: * -> *) a. (TracingBackend -> m a) -> TracingT m a
TracingT ((TracingBackend -> m Tracer) -> TracingT m Tracer)
-> (TracingBackend -> m Tracer) -> TracingT m Tracer
forall a b. (a -> b) -> a -> b
$ Tracer -> m Tracer
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Tracer -> m Tracer)
-> (TracingBackend -> Tracer) -> TracingBackend -> m Tracer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TracingBackend -> Tracer
tracingBackendTracer

mapTracingT
  :: forall m n a b
   . (m a -> n b)
  -> TracingT m a
  -> TracingT n b
mapTracingT :: forall (m :: * -> *) (n :: * -> *) a b.
(m a -> n b) -> TracingT m a -> TracingT n b
mapTracingT m a -> n b
f TracingT m a
action = (TracingBackend -> n b) -> TracingT n b
forall (m :: * -> *) a. (TracingBackend -> m a) -> TracingT m a
TracingT ((TracingBackend -> n b) -> TracingT n b)
-> (TracingBackend -> n b) -> TracingT n b
forall a b. (a -> b) -> a -> b
$ m a -> n b
f (m a -> n b) -> (TracingBackend -> m a) -> TracingBackend -> n b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TracingT m a -> TracingBackend -> m a
forall (m :: * -> *) a. TracingT m a -> TracingBackend -> m a
runTracingT TracingT m a
action
{-# INLINE mapTracingT #-}

data TracingBackend = TracingBackend
  { TracingBackend -> Tracer
tracingBackendTracer :: Tracer
  , TracingBackend -> ContextBackend MutableSpan
tracingBackendContextBackend :: ContextBackend MutableSpan
  }

toTracingBackend :: Tracer -> TracingBackend
toTracingBackend :: Tracer -> TracingBackend
toTracingBackend Tracer
tracer =
  TracingBackend
    { tracingBackendTracer :: Tracer
tracingBackendTracer = Tracer
tracer
    , tracingBackendContextBackend :: ContextBackend MutableSpan
tracingBackendContextBackend = ContextBackend MutableSpan
contextBackendSpan
    }

getTracingBackend
  :: forall m
   . (MonadIO m)
  => TracerProvider
  -> InstrumentationScope
  -> m TracingBackend
getTracingBackend :: forall (m :: * -> *).
MonadIO m =>
TracerProvider -> InstrumentationScope -> m TracingBackend
getTracingBackend TracerProvider
tracerProvider InstrumentationScope
instScope =
  (Tracer -> TracingBackend) -> m Tracer -> m TracingBackend
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Tracer -> TracingBackend
toTracingBackend (m Tracer -> m TracingBackend) -> m Tracer -> m TracingBackend
forall a b. (a -> b) -> a -> b
$ TracerProvider -> InstrumentationScope -> m Tracer
forall (m :: * -> *).
MonadIO m =>
TracerProvider -> InstrumentationScope -> m Tracer
getTracer TracerProvider
tracerProvider InstrumentationScope
instScope

getTracer
  :: forall m
   . (MonadIO m)
  => TracerProvider
  -> InstrumentationScope
  -> m Tracer
getTracer :: forall (m :: * -> *).
MonadIO m =>
TracerProvider -> InstrumentationScope -> m Tracer
getTracer TracerProvider
tracerProvider = IO Tracer -> m Tracer
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Tracer -> m Tracer)
-> (InstrumentationScope -> IO Tracer)
-> InstrumentationScope
-> m Tracer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TracerProvider -> InstrumentationScope -> IO Tracer
tracerProviderGetTracer TracerProvider
tracerProvider

shutdownTracerProvider :: forall m. (MonadIO m) => TracerProvider -> m ()
shutdownTracerProvider :: forall (m :: * -> *). MonadIO m => TracerProvider -> m ()
shutdownTracerProvider = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ())
-> (TracerProvider -> IO ()) -> TracerProvider -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TracerProvider -> IO ()
tracerProviderShutdown

forceFlushTracerProvider :: forall m. (MonadIO m) => TracerProvider -> m ()
forceFlushTracerProvider :: forall (m :: * -> *). MonadIO m => TracerProvider -> m ()
forceFlushTracerProvider = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ())
-> (TracerProvider -> IO ()) -> TracerProvider -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TracerProvider -> IO ()
tracerProviderForceFlush


-- $disclaimer
--
-- In general, changes to this module will not be reflected in the library's
-- version updates. Direct use of this module should be done with utmost care,
-- otherwise invariants will easily be violated.