{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
module Control.Monad.Trace.Class (
MonadTrace(..),
Builder(..), Name, SpanID, TraceID, Reference(..), builder,
Span(..), Context(..),
Key, Value, tagDoubleValue, tagInt64Value, tagTextValue, logValue, logValueAt
) where
import Control.Monad.Trace.Internal
import Control.Monad.Except (ExceptT(..))
import Control.Monad.Identity (Identity(..))
import Control.Monad.Reader (ReaderT(..))
import qualified Control.Monad.RWS.Lazy as RWS.Lazy
import qualified Control.Monad.RWS.Strict as RWS.Strict
import qualified Control.Monad.State.Lazy as State.Lazy
import qualified Control.Monad.State.Strict as State.Strict
import Control.Monad.Trans.Class (MonadTrans, lift)
import qualified Control.Monad.Writer.Lazy as Writer.Lazy
import qualified Control.Monad.Writer.Strict as Writer.Strict
import qualified Data.Aeson as JSON
import Data.ByteString (ByteString)
import Data.Int (Int64)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Set (Set)
import qualified Data.Set as Set
import Data.String (IsString(..))
import Data.Text (Text)
import qualified Data.Text as T
import Data.Time.Clock.POSIX (POSIXTime)
class Monad m => MonadTrace m where
trace :: Builder -> m a -> m a
activeSpan :: m (Maybe Span)
default activeSpan :: (MonadTrace n, MonadTrans t, m ~ t n) => m (Maybe Span)
activeSpan = lift activeSpan
addSpanEntry :: Key -> Value -> m ()
default addSpanEntry :: (MonadTrace n, MonadTrans t, m ~ t n) => Key -> Value -> m ()
addSpanEntry key = lift . addSpanEntry key
instance (Monad m, MonadTrace m) => MonadTrace (ExceptT e m) where
trace name (ExceptT actn) = ExceptT $ trace name actn
instance (Monad m, MonadTrace m) => MonadTrace (ReaderT r m) where
trace name (ReaderT actn) = ReaderT $ \r -> trace name (actn r)
instance (Monad m, MonadTrace m, Monoid w) => MonadTrace (RWS.Lazy.RWST r w s m) where
trace name (RWS.Lazy.RWST actn) = RWS.Lazy.RWST $ \r s -> trace name (actn r s)
instance (Monad m, MonadTrace m, Monoid w) => MonadTrace (RWS.Strict.RWST r w s m) where
trace name (RWS.Strict.RWST actn) = RWS.Strict.RWST $ \r s -> trace name (actn r s)
instance (Monad m, MonadTrace m) => MonadTrace (State.Lazy.StateT s m) where
trace name (State.Lazy.StateT actn) = State.Lazy.StateT $ \s -> trace name (actn s)
instance (Monad m, MonadTrace m) => MonadTrace (State.Strict.StateT s m) where
trace name (State.Strict.StateT actn) = State.Strict.StateT $ \s -> trace name (actn s)
instance (Monad m, MonadTrace m, Monoid w) => MonadTrace (Writer.Lazy.WriterT w m) where
trace name (Writer.Lazy.WriterT actn) = Writer.Lazy.WriterT $ trace name actn
instance (Monad m, MonadTrace m, Monoid w) => MonadTrace (Writer.Strict.WriterT w m) where
trace name (Writer.Strict.WriterT actn) = Writer.Strict.WriterT $ trace name actn
instance MonadTrace Identity where
trace _ = id
activeSpan = pure Nothing
addSpanEntry _ _ = pure ()
data Builder = Builder
{ builderName :: !Name
, builderTraceID :: !(Maybe TraceID)
, builderSpanID :: !(Maybe SpanID)
, builderReferences :: !(Set Reference)
, builderTags :: !(Map Key JSON.Value)
, builderBaggages :: !(Map Key ByteString)
} deriving Show
builder :: Name -> Builder
builder name = Builder name Nothing Nothing Set.empty Map.empty Map.empty
instance IsString Builder where
fromString = builder . T.pack
tagDoubleValue :: Double -> Value
tagDoubleValue = TagValue . JSON.toJSON
tagInt64Value :: Integral a => a -> Value
tagInt64Value = TagValue . (JSON.toJSON @Int64) . fromIntegral
tagTextValue :: Text -> Value
tagTextValue = TagValue . JSON.toJSON
logValue :: JSON.ToJSON a => a -> Value
logValue v = LogValue (JSON.toJSON v) Nothing
logValueAt :: JSON.ToJSON a => POSIXTime -> a -> Value
logValueAt t v = LogValue (JSON.toJSON v) (Just t)