{-# LANGUAGE TupleSections #-}

module System.Metrics.Prometheus.Metric.Histogram
       ( Histogram
       , HistogramSample (..)
       , Buckets
       , UpperBound
       , new
       , observe
       , sample
       , observeAndSample
       ) where


import           Control.Applicative ((<$>))
import           Control.Monad       (void)
import           Data.Bool           (bool)
import           Data.IORef          (IORef, atomicModifyIORef', newIORef,
                                      readIORef)
import           Data.Map.Strict     (Map)
import qualified Data.Map.Strict     as Map


newtype Histogram = Histogram { Histogram -> IORef HistogramSample
unHistogram :: IORef HistogramSample }


type UpperBound = Double -- Inclusive upper bounds
type Buckets = Map UpperBound Double


data HistogramSample =
    HistogramSample
    { HistogramSample -> Buckets
histBuckets :: !Buckets
    , HistogramSample -> Double
histSum     :: !Double
    , HistogramSample -> Int
histCount   :: !Int
    }


new :: [UpperBound] -> IO Histogram
new :: [Double] -> IO Histogram
new [Double]
buckets = IORef HistogramSample -> Histogram
Histogram (IORef HistogramSample -> Histogram)
-> IO (IORef HistogramSample) -> IO Histogram
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HistogramSample -> IO (IORef HistogramSample)
forall a. a -> IO (IORef a)
newIORef HistogramSample
empty
  where
    empty :: HistogramSample
empty = Buckets -> Double -> Int -> HistogramSample
HistogramSample ([(Double, Double)] -> Buckets
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Double, Double)] -> Buckets) -> [(Double, Double)] -> Buckets
forall a b. (a -> b) -> a -> b
$ (Double -> (Double, Double)) -> [Double] -> [(Double, Double)]
forall a b. (a -> b) -> [a] -> [b]
map (, Double
0) (String -> Double
forall a. Read a => String -> a
read String
"Infinity" Double -> [Double] -> [Double]
forall a. a -> [a] -> [a]
: [Double]
buckets)) Double
zeroSum Int
zeroCount
    zeroSum :: Double
zeroSum = Double
0.0
    zeroCount :: Int
zeroCount = Int
0


observeAndSample :: Double -> Histogram -> IO HistogramSample
observeAndSample :: Double -> Histogram -> IO HistogramSample
observeAndSample Double
x = (IORef HistogramSample
 -> (HistogramSample -> (HistogramSample, HistogramSample))
 -> IO HistogramSample)
-> (HistogramSample -> (HistogramSample, HistogramSample))
-> IORef HistogramSample
-> IO HistogramSample
forall a b c. (a -> b -> c) -> b -> a -> c
flip IORef HistogramSample
-> (HistogramSample -> (HistogramSample, HistogramSample))
-> IO HistogramSample
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' HistogramSample -> (HistogramSample, HistogramSample)
update (IORef HistogramSample -> IO HistogramSample)
-> (Histogram -> IORef HistogramSample)
-> Histogram
-> IO HistogramSample
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Histogram -> IORef HistogramSample
unHistogram
  where
    update :: HistogramSample -> (HistogramSample, HistogramSample)
update HistogramSample
histData = (HistogramSample -> HistogramSample
hist' HistogramSample
histData, HistogramSample
histData)
    hist' :: HistogramSample -> HistogramSample
hist' HistogramSample
histData =
        HistogramSample
histData { histBuckets :: Buckets
histBuckets = Double -> Buckets -> Buckets
updateBuckets Double
x (Buckets -> Buckets) -> Buckets -> Buckets
forall a b. (a -> b) -> a -> b
$ HistogramSample -> Buckets
histBuckets HistogramSample
histData
                 , histSum :: Double
histSum = HistogramSample -> Double
histSum HistogramSample
histData Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
x
                 , histCount :: Int
histCount = HistogramSample -> Int
histCount HistogramSample
histData Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
                 }


observe :: Double -> Histogram -> IO ()
observe :: Double -> Histogram -> IO ()
observe Double
x = IO HistogramSample -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO HistogramSample -> IO ())
-> (Histogram -> IO HistogramSample) -> Histogram -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Histogram -> IO HistogramSample
observeAndSample Double
x


updateBuckets :: Double -> Buckets -> Buckets
updateBuckets :: Double -> Buckets -> Buckets
updateBuckets Double
x = (Double -> Double -> Double) -> Buckets -> Buckets
forall k a b. (k -> a -> b) -> Map k a -> Map k b
Map.mapWithKey Double -> Double -> Double
forall a. Num a => Double -> a -> a
updateBucket
  where updateBucket :: Double -> a -> a
updateBucket Double
key a
val = a -> a -> Bool -> a
forall a. a -> a -> Bool -> a
bool a
val (a
val a -> a -> a
forall a. Num a => a -> a -> a
+ a
1) (Double
x Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
<= Double
key)


sample :: Histogram -> IO HistogramSample
sample :: Histogram -> IO HistogramSample
sample = IORef HistogramSample -> IO HistogramSample
forall a. IORef a -> IO a
readIORef (IORef HistogramSample -> IO HistogramSample)
-> (Histogram -> IORef HistogramSample)
-> Histogram
-> IO HistogramSample
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Histogram -> IORef HistogramSample
unHistogram