{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StrictData #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UnboxedTuples #-}
{-# LANGUAGE UnliftedFFITypes #-}

-----------------------------------------------------------------------------

-----------------------------------------------------------------------------

{- |
 Module      :  OpenTelemetry.Util
 Copyright   :  (c) Ian Duncan, 2021
 License     :  BSD-3
 Description :  Convenience functions to simplify common instrumentation needs.
 Maintainer  :  Ian Duncan
 Stability   :  experimental
 Portability :  non-portable (GHC extensions)
-}
module OpenTelemetry.Util (
  constructorName,
  HasConstructor,
  getThreadId,
  bracketError,

  -- * Data structures
  AppendOnlyBoundedCollection,
  emptyAppendOnlyBoundedCollection,
  appendToBoundedCollection,
  appendOnlyBoundedCollectionSize,
  appendOnlyBoundedCollectionValues,
  appendOnlyBoundedCollectionDroppedElementCount,
  FrozenBoundedCollection,
  frozenBoundedCollection,
  frozenBoundedCollectionValues,
  frozenBoundedCollectionDroppedElementCount,
) where

import Control.Exception (SomeException)
import qualified Control.Exception as EUnsafe
import Control.Monad.IO.Unlift
import Data.Foldable
import Data.Kind
import qualified Data.Vector as V
import Foreign.C (CInt (..))
import GHC.Base (Addr#)
import GHC.Conc (ThreadId (ThreadId))
import GHC.Exts (unsafeCoerce#)
import GHC.Generics
import VectorBuilder.Builder (Builder)
import qualified VectorBuilder.Builder as Builder
import qualified VectorBuilder.Vector as Builder


{- | Useful for annotating which constructor in an ADT was chosen

 @since 0.1.0.0
-}
constructorName :: (HasConstructor (Rep a), Generic a) => a -> String
constructorName :: forall a. (HasConstructor (Rep a), Generic a) => a -> String
constructorName = forall (f :: * -> *) x. HasConstructor f => f x -> String
genericConstrName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a x. Generic a => a -> Rep a x
from


-- | Detect a constructor from any datatype which derives 'Generic'
class HasConstructor (f :: Type -> Type) where
  genericConstrName :: f x -> String


instance (HasConstructor f) => HasConstructor (D1 c f) where
  genericConstrName :: forall x. D1 c f x -> String
genericConstrName (M1 f x
x) = forall (f :: * -> *) x. HasConstructor f => f x -> String
genericConstrName f x
x


instance (HasConstructor x, HasConstructor y) => HasConstructor (x :+: y) where
  genericConstrName :: forall x. (:+:) x y x -> String
genericConstrName (L1 x x
l) = forall (f :: * -> *) x. HasConstructor f => f x -> String
genericConstrName x x
l
  genericConstrName (R1 y x
r) = forall (f :: * -> *) x. HasConstructor f => f x -> String
genericConstrName y x
r


instance (Constructor c) => HasConstructor (C1 c f) where
  genericConstrName :: forall x. C1 c f x -> String
genericConstrName = forall {k} (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> String
conName


foreign import ccall unsafe "rts_getThreadId" c_getThreadId :: Addr# -> CInt


-- | Get an int representation of a thread id
getThreadId :: ThreadId -> Int
getThreadId :: ThreadId -> Int
getThreadId (ThreadId ThreadId#
tid#) = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Addr# -> CInt
c_getThreadId (unsafeCoerce# :: forall a b. a -> b
unsafeCoerce# ThreadId#
tid#)
{-# INLINE getThreadId #-}


data AppendOnlyBoundedCollection a = AppendOnlyBoundedCollection
  { forall a. AppendOnlyBoundedCollection a -> Builder a
collection :: Builder a
  , forall a. AppendOnlyBoundedCollection a -> Int
maxSize :: {-# UNPACK #-} !Int
  , forall a. AppendOnlyBoundedCollection a -> Int
dropped :: {-# UNPACK #-} !Int
  }


instance forall a. (Show a) => Show (AppendOnlyBoundedCollection a) where
  showsPrec :: Int -> AppendOnlyBoundedCollection a -> ShowS
showsPrec Int
d AppendOnlyBoundedCollection {$sel:collection:AppendOnlyBoundedCollection :: forall a. AppendOnlyBoundedCollection a -> Builder a
collection = Builder a
c, $sel:maxSize:AppendOnlyBoundedCollection :: forall a. AppendOnlyBoundedCollection a -> Int
maxSize = Int
m, $sel:dropped:AppendOnlyBoundedCollection :: forall a. AppendOnlyBoundedCollection a -> Int
dropped = Int
r} =
    let vec :: Vector a
vec = forall (vector :: * -> *) element.
Vector vector element =>
Builder element -> vector element
Builder.build Builder a
c :: V.Vector a
     in Bool -> ShowS -> ShowS
showParen (Int
d forall a. Ord a => a -> a -> Bool
> Int
10) forall a b. (a -> b) -> a -> b
$
          String -> ShowS
showString String
"AppendOnlyBoundedCollection {collection = "
            forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> ShowS
shows Vector a
vec
            forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
", maxSize = "
            forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> ShowS
shows Int
m
            forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
", dropped = "
            forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> ShowS
shows Int
r
            forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"}"


-- | Initialize a bounded collection that admits a maximum size
emptyAppendOnlyBoundedCollection
  :: Int
  -- ^ Maximum size
  -> AppendOnlyBoundedCollection a
emptyAppendOnlyBoundedCollection :: forall a. Int -> AppendOnlyBoundedCollection a
emptyAppendOnlyBoundedCollection Int
s = forall a. Builder a -> Int -> Int -> AppendOnlyBoundedCollection a
AppendOnlyBoundedCollection forall a. Monoid a => a
mempty Int
s Int
0


appendOnlyBoundedCollectionValues :: AppendOnlyBoundedCollection a -> V.Vector a
appendOnlyBoundedCollectionValues :: forall a. AppendOnlyBoundedCollection a -> Vector a
appendOnlyBoundedCollectionValues (AppendOnlyBoundedCollection Builder a
a Int
_ Int
_) = forall (vector :: * -> *) element.
Vector vector element =>
Builder element -> vector element
Builder.build Builder a
a


appendOnlyBoundedCollectionSize :: AppendOnlyBoundedCollection a -> Int
appendOnlyBoundedCollectionSize :: forall a. AppendOnlyBoundedCollection a -> Int
appendOnlyBoundedCollectionSize (AppendOnlyBoundedCollection Builder a
b Int
_ Int
_) = forall element. Builder element -> Int
Builder.size Builder a
b


appendOnlyBoundedCollectionDroppedElementCount :: AppendOnlyBoundedCollection a -> Int
appendOnlyBoundedCollectionDroppedElementCount :: forall a. AppendOnlyBoundedCollection a -> Int
appendOnlyBoundedCollectionDroppedElementCount (AppendOnlyBoundedCollection Builder a
_ Int
_ Int
d) = Int
d


appendToBoundedCollection :: AppendOnlyBoundedCollection a -> a -> AppendOnlyBoundedCollection a
appendToBoundedCollection :: forall a.
AppendOnlyBoundedCollection a -> a -> AppendOnlyBoundedCollection a
appendToBoundedCollection c :: AppendOnlyBoundedCollection a
c@(AppendOnlyBoundedCollection Builder a
b Int
ms Int
d) a
x =
  if forall a. AppendOnlyBoundedCollection a -> Int
appendOnlyBoundedCollectionSize AppendOnlyBoundedCollection a
c forall a. Ord a => a -> a -> Bool
< Int
ms
    then forall a. Builder a -> Int -> Int -> AppendOnlyBoundedCollection a
AppendOnlyBoundedCollection (Builder a
b forall a. Semigroup a => a -> a -> a
<> forall element. element -> Builder element
Builder.singleton a
x) Int
ms Int
d
    else forall a. Builder a -> Int -> Int -> AppendOnlyBoundedCollection a
AppendOnlyBoundedCollection Builder a
b Int
ms (Int
d forall a. Num a => a -> a -> a
+ Int
1)


data FrozenBoundedCollection a = FrozenBoundedCollection
  { forall a. FrozenBoundedCollection a -> Vector a
collection :: !(V.Vector a)
  , forall a. FrozenBoundedCollection a -> Int
dropped :: !Int
  }
  deriving (Int -> FrozenBoundedCollection a -> ShowS
forall a. Show a => Int -> FrozenBoundedCollection a -> ShowS
forall a. Show a => [FrozenBoundedCollection a] -> ShowS
forall a. Show a => FrozenBoundedCollection a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FrozenBoundedCollection a] -> ShowS
$cshowList :: forall a. Show a => [FrozenBoundedCollection a] -> ShowS
show :: FrozenBoundedCollection a -> String
$cshow :: forall a. Show a => FrozenBoundedCollection a -> String
showsPrec :: Int -> FrozenBoundedCollection a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> FrozenBoundedCollection a -> ShowS
Show)


frozenBoundedCollection :: (Foldable f) => Int -> f a -> FrozenBoundedCollection a
frozenBoundedCollection :: forall (f :: * -> *) a.
Foldable f =>
Int -> f a -> FrozenBoundedCollection a
frozenBoundedCollection Int
maxSize_ f a
coll = forall a. Vector a -> Int -> FrozenBoundedCollection a
FrozenBoundedCollection (forall a. Int -> [a] -> Vector a
V.fromListN Int
maxSize_ forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> [a]
toList f a
coll) (Int
collLength forall a. Num a => a -> a -> a
- Int
maxSize_)
  where
    collLength :: Int
collLength = forall (t :: * -> *) a. Foldable t => t a -> Int
length f a
coll


frozenBoundedCollectionValues :: FrozenBoundedCollection a -> V.Vector a
frozenBoundedCollectionValues :: forall a. FrozenBoundedCollection a -> Vector a
frozenBoundedCollectionValues (FrozenBoundedCollection Vector a
coll Int
_) = Vector a
coll


frozenBoundedCollectionDroppedElementCount :: FrozenBoundedCollection a -> Int
frozenBoundedCollectionDroppedElementCount :: forall a. FrozenBoundedCollection a -> Int
frozenBoundedCollectionDroppedElementCount (FrozenBoundedCollection Vector a
_ Int
dropped_) = Int
dropped_


{- | Like 'Context.Exception.bracket', but provides the @after@ function with information about
 uncaught exceptions.

 @since 0.1.0.0
-}
bracketError :: (MonadUnliftIO m) => m a -> (Maybe SomeException -> a -> m b) -> (a -> m c) -> m c
bracketError :: forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> (Maybe SomeException -> a -> m b) -> (a -> m c) -> m c
bracketError m a
before Maybe SomeException -> a -> m b
after a -> m c
thing = forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO forall a b. (a -> b) -> a -> b
$ \forall a. m a -> IO a
run -> forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
EUnsafe.mask forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
restore -> do
  a
x <- forall a. m a -> IO a
run m a
before
  Either SomeException c
res1 <- forall e a. Exception e => IO a -> IO (Either e a)
EUnsafe.try forall a b. (a -> b) -> a -> b
$ forall a. IO a -> IO a
restore forall a b. (a -> b) -> a -> b
$ forall a. m a -> IO a
run forall a b. (a -> b) -> a -> b
$ a -> m c
thing a
x
  case Either SomeException c
res1 of
    Left (SomeException
e1 :: SomeException) -> do
      -- explicitly ignore exceptions from after. We know that
      -- no async exceptions were thrown there, so therefore
      -- the stronger exception must come from thing
      --
      -- https://github.com/fpco/safe-exceptions/issues/2
      Either SomeException b
_ :: Either SomeException b <-
        forall e a. Exception e => IO a -> IO (Either e a)
EUnsafe.try forall a b. (a -> b) -> a -> b
$ forall a. IO a -> IO a
EUnsafe.uninterruptibleMask_ forall a b. (a -> b) -> a -> b
$ forall a. m a -> IO a
run forall a b. (a -> b) -> a -> b
$ Maybe SomeException -> a -> m b
after (forall a. a -> Maybe a
Just SomeException
e1) a
x
      forall e a. Exception e => e -> IO a
EUnsafe.throwIO SomeException
e1
    Right c
y -> do
      b
_ <- forall a. IO a -> IO a
EUnsafe.uninterruptibleMask_ forall a b. (a -> b) -> a -> b
$ forall a. m a -> IO a
run forall a b. (a -> b) -> a -> b
$ Maybe SomeException -> a -> m b
after forall a. Maybe a
Nothing a
x
      forall (m :: * -> *) a. Monad m => a -> m a
return c
y