{-# LANGUAGE TypeFamilies, DataKinds, ScopedTypeVariables #-}
{-# LANGUAGE OverloadedStrings #-}

module System.Metrics.ExtraTrackers
( Timestamp

, TimerMagnitude(..)
, Timer(..)
, timed
) where

import qualified Data.Text as T
import Control.Monad.IO.Class
import Data.Proxy
import Data.Time.Clock.POSIX
import Data.Typeable
import GHC.TypeLits
import System.CPUTime
import System.Metrics
import System.Metrics.Distribution as TD
import System.Metrics.Label as TL

import System.Metrics.Extensible

newtype Timestamp = Timestamp Label

instance TrackerLike Timestamp where
  type TrackAction Timestamp m = m ()
  track :: metric Timestamp name -> TrackAction Timestamp m
track metric Timestamp name
metric = do
    Timestamp Label
l <- metric Timestamp name -> m Timestamp
forall (m :: * -> *) tracker (name :: Symbol)
       (metric :: * -> Symbol -> *).
(MonadMetrics m, TrackerLike tracker, KnownSymbol name,
 Typeable metric, Ord (metric tracker name)) =>
metric tracker name -> m tracker
getTracker metric Timestamp name
metric
    IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
      UTCTime
utc <- IO UTCTime
getCurrentTime
      Label -> Text -> IO ()
TL.set Label
l (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ UTCTime -> String
forall a. Show a => a -> String
show UTCTime
utc
  createTracker :: Text -> Store -> IO Timestamp
createTracker Text
name Store
store = Label -> Timestamp
Timestamp (Label -> Timestamp) -> IO Label -> IO Timestamp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Store -> IO Label
createLabel Text
name Store
store


newtype Timer (magn :: TimerMagnitude) = Timer { Timer magn -> Distribution
getTimerDistribution :: Distribution }

data TimerMagnitude = Msecs | Usecs | Nsecs deriving (Typeable)

class MagnitudeOps (magn :: TimerMagnitude) where
  toString :: Proxy magn -> T.Text
  secFraction :: Proxy magn -> Double

instance MagnitudeOps 'Msecs where
  toString :: Proxy 'Msecs -> Text
toString Proxy 'Msecs
_ = Text
"ms"
  secFraction :: Proxy 'Msecs -> Double
secFraction Proxy 'Msecs
_ = Double
1e-3

instance MagnitudeOps 'Usecs where
  toString :: Proxy 'Usecs -> Text
toString Proxy 'Usecs
_ = Text
"us"
  secFraction :: Proxy 'Usecs -> Double
secFraction Proxy 'Usecs
_ = Double
1e-6

instance MagnitudeOps 'Nsecs where
  toString :: Proxy 'Nsecs -> Text
toString Proxy 'Nsecs
_ = Text
"ns"
  secFraction :: Proxy 'Nsecs -> Double
secFraction Proxy 'Nsecs
_ = Double
1e-9

instance (Typeable magn, MagnitudeOps magn) => TrackerLike (Timer magn) where
  type TrackAction (Timer magn) m = Double -> m ()
  track :: metric (Timer magn) name -> TrackAction (Timer magn) m
track metric (Timer magn) name
metric Double
timing = do
    Timer Distribution
timer <- metric (Timer magn) name -> m (Timer magn)
forall (m :: * -> *) tracker (name :: Symbol)
       (metric :: * -> Symbol -> *).
(MonadMetrics m, TrackerLike tracker, KnownSymbol name,
 Typeable metric, Ord (metric tracker name)) =>
metric tracker name -> m tracker
getTracker metric (Timer magn) name
metric
    IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Distribution -> Double -> IO ()
TD.add Distribution
timer Double
timing
  createTracker :: Text -> Store -> IO (Timer magn)
createTracker Text
name Store
store = Distribution -> Timer magn
forall (magn :: TimerMagnitude). Distribution -> Timer magn
Timer (Distribution -> Timer magn) -> IO Distribution -> IO (Timer magn)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Store -> IO Distribution
createDistribution (Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Proxy magn -> Text
forall (magn :: TimerMagnitude).
MagnitudeOps magn =>
Proxy magn -> Text
toString (Proxy magn
forall k (t :: k). Proxy t
Proxy :: Proxy magn)) Store
store

-- Returns the number of picoseconds
time :: MonadIO m => m a -> m (Integer, a)
time :: m a -> m (Integer, a)
time m a
act = do
  Integer
start <- IO Integer -> m Integer
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Integer
getCPUTime
  a
res <- m a
act
  Integer
end <- IO Integer -> m Integer
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Integer
getCPUTime
  (Integer, a) -> m (Integer, a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Integer
end Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
start, a
res)

timed :: forall m metric magn name a.
         (MonadMetrics m, KnownSymbol name, Typeable metric, Typeable magn, MagnitudeOps magn, Ord (metric (Timer magn) name))
      => metric (Timer magn) name
      -> m a
      -> m a
timed :: metric (Timer magn) name -> m a -> m a
timed metric (Timer magn) name
metric m a
act = do
  (Integer
cpuTime, a
res) <- m a -> m (Integer, a)
forall (m :: * -> *) a. MonadIO m => m a -> m (Integer, a)
time m a
act
  metric (Timer magn) name -> TrackAction (Timer magn) m
forall tracker (m :: * -> *) (name :: Symbol)
       (metric :: * -> Symbol -> *).
(TrackerLike tracker, MonadMetrics m, KnownSymbol name,
 Typeable metric, Ord (metric tracker name)) =>
metric tracker name -> TrackAction tracker m
track metric (Timer magn) name
metric (Double -> m ()) -> Double -> m ()
forall a b. (a -> b) -> a -> b
$ Integer -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
cpuTime Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ (Double
1e12 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Proxy magn -> Double
forall (magn :: TimerMagnitude).
MagnitudeOps magn =>
Proxy magn -> Double
secFraction (Proxy magn
forall k (t :: k). Proxy t
Proxy :: Proxy magn))
  a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
res