{-# 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,
) where

import Control.Exception (SomeException)
import qualified Control.Exception as EUnsafe
import Control.Monad.IO.Unlift
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 = genericConstrName . 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 (M1 x) = genericConstrName x


instance (HasConstructor x, HasConstructor y) => HasConstructor (x :+: y) where
  genericConstrName (L1 l) = genericConstrName l
  genericConstrName (R1 r) = genericConstrName r


instance (Constructor c) => HasConstructor (C1 c f) where
  genericConstrName = conName


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


-- | Get an int representation of a thread id
getThreadId :: ThreadId -> Int
getThreadId (ThreadId tid#) = fromIntegral $ c_getThreadId (unsafeCoerce# tid#)
{-# INLINE getThreadId #-}


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


instance forall a. (Show a) => Show (AppendOnlyBoundedCollection a) where
  showsPrec d AppendOnlyBoundedCollection {collection = c, maxSize = m, dropped = r} =
    let vec = Builder.build c :: V.Vector a
    in showParen (d > 10) $
        showString "AppendOnlyBoundedCollection {collection = "
          . shows vec
          . showString ", maxSize = "
          . shows m
          . showString ", dropped = "
          . shows r
          . showString "}"


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


appendOnlyBoundedCollectionValues :: AppendOnlyBoundedCollection a -> V.Vector a
appendOnlyBoundedCollectionValues (AppendOnlyBoundedCollection a _ _) = Builder.build a


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


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


appendToBoundedCollection :: AppendOnlyBoundedCollection a -> a -> AppendOnlyBoundedCollection a
appendToBoundedCollection c@(AppendOnlyBoundedCollection b ms d) x =
  if appendOnlyBoundedCollectionSize c < ms
    then AppendOnlyBoundedCollection (b <> Builder.singleton x) ms d
    else AppendOnlyBoundedCollection b ms (d + 1)


{- | 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 before after thing = withRunInIO $ \run -> EUnsafe.mask $ \restore -> do
  x <- run before
  res1 <- EUnsafe.try $ restore $ run $ thing x
  case res1 of
    Left (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 <-
        EUnsafe.try $ EUnsafe.uninterruptibleMask_ $ run $ after (Just e1) x
      EUnsafe.throwIO e1
    Right y -> do
      _ <- EUnsafe.uninterruptibleMask_ $ run $ after Nothing x
      return y