{-# 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
    }
    deriving Int -> HistogramSample -> ShowS
[HistogramSample] -> ShowS
HistogramSample -> String
(Int -> HistogramSample -> ShowS)
-> (HistogramSample -> String)
-> ([HistogramSample] -> ShowS)
-> Show HistogramSample
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> HistogramSample -> ShowS
showsPrec :: Int -> HistogramSample -> ShowS
$cshow :: HistogramSample -> String
show :: HistogramSample -> String
$cshowList :: [HistogramSample] -> ShowS
showList :: [HistogramSample] -> ShowS
Show


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 -> HistogramSample
hist' HistogramSample
histData)
    hist' :: HistogramSample -> HistogramSample
hist' HistogramSample
histData =
        HistogramSample
histData
            { histBuckets = updateBuckets x $ histBuckets histData
            , histSum = histSum histData + x
            , histCount = histCount histData + 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