packages feed

metrics 0.3.0.2 → 0.4.0.1

raw patch · 20 files changed

+292/−166 lines, 20 filesdep +HUnitdep +transformersdep +transformers-basedep −mtldep −unixdep ~base

Dependencies added: HUnit, transformers, transformers-base, unix-compat

Dependencies removed: mtl, unix

Dependency ranges changed: base

Files

metrics.cabal view
@@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/  name:                metrics-version:             0.3.0.2+version:             0.4.0.1 synopsis:            High-performance application metric tracking description:   A port of Coda Hale's excellent metrics library for the JVM@@ -53,17 +53,18 @@    -- other-modules:          -- other-extensions:    -  build-depends:       base < 5,+  build-depends:       base >=4.8 && < 5,                        unordered-containers,                        text,-                       mtl,+                       transformers,                        vector,                        primitive,                        mwc-random,-                       unix,+                       transformers-base,                        vector-algorithms,                        containers,                        time,+                       unix-compat,                        lens,                        ansi-terminal,                        bytestring@@ -79,9 +80,10 @@                        metrics,                        async,                        mwc-random,-                       unix,+                       HUnit,                        QuickCheck,                        primitive,                        lens   default-language:    Haskell2010   ghc-options:         -rtsopts -threaded -with-rtsopts=-N+
src/Data/Metrics/Counter.hs view
@@ -1,4 +1,6 @@-{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE UndecidableInstances  #-} -- | -- Module      : Data.Metrics.Counter -- Copyright   : (c) Ian Duncan 2013@@ -25,6 +27,7 @@   decrement',   module Data.Metrics.Types ) where+import Control.Monad.Base import Control.Monad.Primitive import qualified Data.HashMap.Strict as H import Data.Metrics.Internal@@ -34,34 +37,44 @@ -- | A basic atomic counter. newtype Counter m = Counter { fromCounter :: MV m Int } -instance PrimMonad m => Count m (Counter m) where-  count (Counter ref) = readMutVar ref+instance (MonadBase b m, PrimMonad b) => Count b m (Counter b) where+  count (Counter ref) = liftBase $ readMutVar ref+  {-# INLINEABLE count #-} -instance PrimMonad m => Value m (Counter m) Int where-  value (Counter ref) = readMutVar ref+instance (MonadBase b m, PrimMonad b) => Value b m (Counter b) Int where+  value (Counter ref) = liftBase $ readMutVar ref+  {-# INLINEABLE value #-} -instance PrimMonad m => Set m (Counter m) Int where-  set (Counter ref) x = updateRef ref (const x)+instance (MonadBase b m, PrimMonad b) => Set b m (Counter b) Int where+  set (Counter ref) x = liftBase $ updateRef ref (const x)+  {-# INLINEABLE set #-} -instance PrimMonad m => Clear m (Counter m) where+instance (MonadBase b m, PrimMonad b) => Clear b m (Counter b) where   clear c = set c 0+  {-# INLINEABLE clear #-}  -- | Create a new counter.-counter :: (Functor m, PrimMonad m) => m (Counter m)-counter = fmap Counter $ newMutVar 0+counter :: (MonadBase b m, PrimMonad b) => m (Counter b)+counter = liftBase $ fmap Counter $ newMutVar 0+{-# INLINEABLE counter #-}  -- | Bump up a counter by 1. increment :: PrimMonad m => Counter m -> m () increment = flip increment' 1+{-# INLINEABLE increment #-}  -- | Add an arbitrary amount to a counter. increment' :: PrimMonad m => Counter m -> Int -> m () increment' (Counter ref) x = updateRef ref (+ x)+{-# INLINEABLE increment' #-}  -- | Decrease the value of a counter by 1. decrement :: PrimMonad m => Counter m -> m () decrement = flip decrement' 1+{-# INLINEABLE decrement #-}  -- | Subtract an arbitrary amount from a counter. decrement' :: PrimMonad m => Counter m -> Int -> m () decrement' (Counter ref) x = updateRef ref (subtract x)+{-# INLINEABLE decrement' #-}+
src/Data/Metrics/Gauge.hs view
@@ -1,5 +1,6 @@-{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleInstances     #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE UndecidableInstances  #-} -- | A module representing a "Gauge", which is simply an action that returns the instantaneous measure of a value for charting. -- -- The action that provides the gauge's value may be replaced using "set", or read using "value".@@ -20,8 +21,8 @@ ) where import Control.Applicative import Control.Monad+import Control.Monad.Base import Control.Monad.Primitive-import qualified Data.HashMap.Strict as H import Data.Metrics.Internal import Data.Metrics.Types import Data.Primitive.MutVar@@ -30,16 +31,18 @@ newtype Gauge m = Gauge { fromGauge :: MV m (m Double) }  -- | Create a new gauge from the given action.-gauge :: PrimMonad m => m Double -> m (Gauge m)+gauge :: (MonadBase b m, PrimMonad b) => b Double -> m (Gauge b) gauge m = do-  r <- newMutVar m+  r <- liftBase $ newMutVar m   return $ Gauge r -instance (PrimMonad m) => Value m (Gauge m) Double where-  value (Gauge r) = join $ readMutVar r+instance (MonadBase b m, PrimMonad b) => Value b m (Gauge b) Double where+  value (Gauge r) = liftBase $ join $ readMutVar r+  {-# INLINEABLE value #-} -instance (PrimMonad m) => Set m (Gauge m) (m Double) where-  set (Gauge r) = updateRef r . const+instance (MonadBase b m, PrimMonad b) => Set b m (Gauge b) (b Double) where+  set (Gauge r) = liftBase . updateRef r . const+  {-# INLINEABLE set #-}  -- | Compose multiple actions to create a ratio. Useful for graphing percentage information, e. g. --@@ -49,3 +52,4 @@ -- @ ratio :: Applicative f => f Double -> f Double -> f Double ratio x y = (/) <$> x <*> y+
src/Data/Metrics/Histogram.hs view
@@ -1,5 +1,7 @@+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances  #-} -- | Histogram metrics allow you to measure not just easy things like the min, mean, max, and standard deviation of values, but also quantiles like the median or 95th percentile. -- -- Traditionally, the way the median (or any other quantile) is calculated is to take the entire data set, sort it, and take the value in the middle (or 1% from the end, for the 99th percentile). This works for small data sets, or batch processing systems, but not for high-throughput, low-latency services.@@ -10,66 +12,81 @@   histogram,   exponentiallyDecayingHistogram,   uniformHistogram,+  uniformSampler,   module Data.Metrics.Types ) where-import Control.Monad.Primitive+import           Control.Monad.Base+import           Control.Monad.Primitive import qualified Data.Metrics.Histogram.Internal as P-import Data.Metrics.Internal-import Data.Metrics.Types-import Data.Metrics.Reservoir (Reservoir)-import Data.Metrics.Reservoir.Uniform (unsafeReservoir)-import Data.Metrics.Reservoir.ExponentiallyDecaying (reservoir)-import Data.Primitive.MutVar-import Data.Time.Clock-import Data.Time.Clock.POSIX-import System.Random.MWC+import           Data.Metrics.Internal+import           Data.Metrics.Types+import           Data.Metrics.Reservoir (Reservoir)+import           Data.Metrics.Reservoir.Uniform (unsafeReservoir)+import           Data.Metrics.Reservoir.ExponentiallyDecaying (reservoir)+import           Data.Primitive.MutVar+import           Data.Time.Clock+import           Data.Time.Clock.POSIX+import           System.Random.MWC  -- | A measure of the distribution of values in a stream of data. data Histogram m = Histogram-  { fromHistogram :: MV m P.Histogram-  , histogramGetSeconds :: m NominalDiffTime+  { fromHistogram       :: !(MV m P.Histogram)+  , histogramGetSeconds :: !(m NominalDiffTime)   } -instance PrimMonad m => Clear m (Histogram m) where-  clear h = do+instance (MonadBase b m, PrimMonad b) => Clear b m (Histogram b) where+  clear h = liftBase $ do     t <- histogramGetSeconds h     updateRef (fromHistogram h) $ P.clear t+  {-# INLINEABLE clear #-} -instance PrimMonad m => Update m (Histogram m) Double where-  update h x = do+instance (MonadBase b m, PrimMonad b) => Update b m (Histogram b) Double where+  update h x = liftBase $ do     t <- histogramGetSeconds h     updateRef (fromHistogram h) $ P.update x t+  {-# INLINEABLE update #-} -instance PrimMonad m => Count m (Histogram m) where-  count h = readMutVar (fromHistogram h) >>= return . P.count+instance (MonadBase b m, PrimMonad b) => Count b m (Histogram b) where+  count h = liftBase $ fmap P.count $ readMutVar (fromHistogram h)+  {-# INLINEABLE count #-} -instance PrimMonad m => Statistics m (Histogram m) where-  mean h = applyWithRef (fromHistogram h) P.mean-  stddev h = applyWithRef (fromHistogram h) P.stddev-  variance h = applyWithRef (fromHistogram h) P.variance-  maxVal h = readMutVar (fromHistogram h) >>= return . P.maxVal-  minVal h = readMutVar (fromHistogram h) >>= return . P.minVal+instance (MonadBase b m, PrimMonad b) => Statistics b m (Histogram b) where+  mean h = liftBase $ applyWithRef (fromHistogram h) P.mean+  {-# INLINEABLE mean #-} -instance PrimMonad m => TakeSnapshot m (Histogram m) where-  snapshot h = applyWithRef (fromHistogram h) P.snapshot+  stddev h = liftBase $ applyWithRef (fromHistogram h) P.stddev+  {-# INLINEABLE stddev #-} +  variance h = liftBase $ applyWithRef (fromHistogram h) P.variance+  {-# INLINEABLE variance #-}++  maxVal h = liftBase $ fmap P.maxVal $ readMutVar (fromHistogram h)+  {-# INLINEABLE maxVal #-}++  minVal h = liftBase $ fmap P.minVal $ readMutVar (fromHistogram h)+  {-# INLINEABLE minVal #-}++instance (MonadBase b m, PrimMonad b) => TakeSnapshot b m (Histogram b) where+  snapshot h = liftBase $ applyWithRef (fromHistogram h) P.snapshot+  {-# INLINEABLE snapshot #-}+ -- | Create a histogram using a custom time data supplier function and a custom reservoir.-histogram :: PrimMonad m => m NominalDiffTime -> Reservoir -> m (Histogram m)+histogram :: (MonadBase b m, PrimMonad b) => b NominalDiffTime -> Reservoir -> m (Histogram b) histogram t r = do-  v <- newMutVar $ P.histogram r+  v <- liftBase $ newMutVar $ P.histogram r   return $ Histogram v t  -- | A histogram that gives all entries an equal likelihood of being evicted. -- -- Probably not what you want for most time-series data.-uniformHistogram :: Seed -> IO (Histogram IO)-uniformHistogram s = histogram getPOSIXTime $ unsafeReservoir s 1028+uniformHistogram :: MonadBase IO m => Seed -> m (Histogram IO)+uniformHistogram s = liftBase $ histogram getPOSIXTime $ unsafeReservoir s 1028  -- | The recommended histogram type. It provides a fast histogram that -- probabilistically evicts older entries using a weighting system. This -- ensures that snapshots remain relatively fresh.-exponentiallyDecayingHistogram :: IO (Histogram IO)-exponentiallyDecayingHistogram = do+exponentiallyDecayingHistogram :: MonadBase IO m => m (Histogram IO)+exponentiallyDecayingHistogram = liftBase $ do   t <- getPOSIXTime   s <- createSystemRandom >>= save   histogram getPOSIXTime $ reservoir 0.015 1028 t s@@ -77,5 +94,3 @@ uniformSampler :: Seed -> P.Histogram uniformSampler s = P.histogram (unsafeReservoir s 1028) -nan :: Double-nan = 0 / 0
src/Data/Metrics/Histogram/Internal.hs view
@@ -22,11 +22,11 @@ -- | A pure histogram that maintains a bounded reservoir of samples and basic statistical data about the samples. data Histogram = Histogram   { histogramReservoir :: !R.Reservoir-  , histogramCount :: !Int-  , histogramMinVal :: !Double-  , histogramMaxVal :: !Double-  , histogramSum :: !Double-  , histogramVariance :: !(Double, Double)+  , histogramCount     :: {-# UNPACK #-} !Int+  , histogramMinVal    :: {-# UNPACK #-} !Double+  , histogramMaxVal    :: {-# UNPACK #-} !Double+  , histogramSum       :: {-# UNPACK #-} !Double+  , histogramVariance  :: {-# UNPACK #-} !(Double, Double)   }  -- | Create a histogram using a custom reservoir.@@ -48,6 +48,7 @@       , histogramSum = 0       , histogramVariance = (-1, 0)       }+{-# INLINEABLE clear #-}  -- | Update statistics and the reservoir with a new sample. update :: Double -> NominalDiffTime -> Histogram -> Histogram@@ -64,12 +65,15 @@       where          updatedCount = succ $ histogramCount s         updatedReservoir = R.update v t $ histogramReservoir s+{-# INLINEABLE update #-}  updateMin :: Double -> Double -> Double updateMin ox x = if isNaN ox || ox > x then x else ox+{-# INLINE updateMin #-}  updateMax :: Double -> Double -> Double updateMax ox x = if isNaN ox || ox < x then x else ox+{-# INLINE updateMax #-}  -- | Get the average of all samples since the histogram was created. mean :: Histogram -> Double@@ -78,15 +82,17 @@     go s = if histogramCount s > 0       then histogramSum s / fromIntegral (histogramCount s)       else 0+{-# INLINEABLE mean #-}  -- | Get the standard deviation of all samples. stddev :: Histogram -> Double stddev = go   where     go s = if c > 0-      then (calculateVariance c $ snd $ histogramVariance s) ** 0.5+      then sqrt $ calculateVariance c $ snd $ histogramVariance s       else 0       where c = histogramCount s+{-# INLINEABLE stddev #-}  -- | Get the variance of all samples. variance :: Histogram -> Double@@ -96,6 +102,7 @@       then 0       else calculateVariance c $ snd $ histogramVariance s       where c = histogramCount s+{-# INLINEABLE variance #-}  -- | Get the minimum value of all samples. minVal :: Histogram -> Double@@ -112,9 +119,11 @@ -- | Get a snapshot of the current reservoir's samples. snapshot :: Histogram -> Snapshot snapshot = R.snapshot . histogramReservoir+{-# INLINEABLE snapshot #-}  calculateVariance :: Int -> Double -> Double calculateVariance c v = if c <= 1 then 0 else v / (fromIntegral c - 1)+{-# INLINEABLE calculateVariance #-}  updateVariance :: Int -> Double -> (Double, Double) -> (Double, Double) updateVariance _ !c (-1, y) = (c, 0)@@ -124,3 +133,5 @@     diff = c - x     !l = x + diff / c'     !r = y + diff * (c - l)+{-# INLINEABLE updateVariance #-}+
src/Data/Metrics/Internal.hs view
@@ -18,6 +18,7 @@ updateRef r f = do   b <- atomicModifyMutVar r (\x -> let (a, b) = (f x, ()) in (a, a `seq` b))   b `seq` return b+{-# INLINE updateRef #-}  -- | Strictly apply a function on a MutVar while blocking other access to it. --@@ -26,6 +27,7 @@ applyWithRef r f = do   b <- atomicModifyMutVar r (\x -> let app = f x in let (a, b) = (x, app) in (a, a `seq` b))   b `seq` return b+{-# INLINE applyWithRef #-}  -- | A function which combines the previous two, updating a value atomically -- and then returning some value calculated with the update in a single step.@@ -37,6 +39,7 @@     let (a, b) = (appA, appB) in     (a, a `seq` b)   b `seq` return b+{-# INLINE updateAndApplyToRef #-}  -- | MutVar (PrimState m) is a little verbose. type MV m = MutVar (PrimState m)
src/Data/Metrics/Meter.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE UndecidableInstances  #-} -- | A meter measures the rate at which a set of events occur: -- -- Meters measure the rate of the events in a few different ways. The mean rate is the average rate of events. It’s generally useful for trivia, but as it represents the total rate for your application’s entire lifetime (e.g., the total number of requests handled, divided by the number of seconds the process has been running), it doesn’t offer a sense of recency. Luckily, meters also record three different exponentially-weighted moving average rates: the 1-, 5-, and 15-minute moving averages.@@ -10,9 +11,12 @@   meter,   mark,   mark',+  mkMeter,+  fromMeter,   module Data.Metrics.Types ) where import Control.Lens+import Control.Monad.Base import Control.Monad.Primitive import Data.Primitive.MutVar import Data.Time.Clock@@ -26,36 +30,46 @@  -- | A measure of the /rate/ at which a set of events occurs. data Meter m = Meter-  { fromMeter :: !(MV m P.Meter)+  { fromMeter       :: !(MV m P.Meter)   , meterGetSeconds :: !(m NominalDiffTime)   } -instance PrimMonad m => Rate m (Meter m) where-  oneMinuteRate m = do+instance (MonadBase b m, PrimMonad b) => Rate b m (Meter b) where+  oneMinuteRate m = liftBase $ do     t <- meterGetSeconds m     updateAndApplyToRef (fromMeter m) (P.tickIfNecessary t) (A.rate . P.oneMinuteAverage)-  fiveMinuteRate m = do+  {-# INLINEABLE oneMinuteRate #-}++  fiveMinuteRate m = liftBase $ do     t <- meterGetSeconds m     updateAndApplyToRef (fromMeter m) (P.tickIfNecessary t) (A.rate . P.fiveMinuteAverage)-  fifteenMinuteRate m = do+  {-# INLINEABLE fiveMinuteRate #-}++  fifteenMinuteRate m = liftBase $ do     t <- meterGetSeconds m     updateAndApplyToRef (fromMeter m) (P.tickIfNecessary t) (A.rate . P.fifteenMinuteAverage)-  meanRate m = do+  {-# INLINEABLE fifteenMinuteRate #-}++  meanRate m = liftBase $ do     t <- meterGetSeconds m     applyWithRef (fromMeter m) $ P.meanRate t+  {-# INLINEABLE meanRate #-} -instance PrimMonad m => Count m (Meter m) where-  count m = readMutVar (fromMeter m) >>= return . view P.count+instance (MonadBase b m, PrimMonad m) => Count b m (Meter m) where+  count = fmap (view P.count) . readMutVar . fromMeter+  {-# INLINEABLE count #-}  -- | Register multiple occurrences of an event. mark' :: PrimMonad m => Meter m -> Int -> m () mark' m x = do   t <- meterGetSeconds m   updateRef (fromMeter m) (P.mark t x)+{-# INLINEABLE mark' #-}  -- | Register a single occurrence of an event. mark :: PrimMonad m => Meter m -> m () mark = flip mark' 1+{-# INLINEABLE mark #-}  -- | Create a new meter using an exponentially weighted moving average meter :: IO (Meter IO)
src/Data/Metrics/Meter/Internal.hs view
@@ -13,7 +13,8 @@   fiveMinuteAverage,   fifteenMinuteAverage,   tickIfNecessary,-  count+  count,+  lastTick ) where import Control.Lens import Control.Lens.TH@@ -21,7 +22,7 @@ import qualified Data.Metrics.MovingAverage as M  data Meter = Meter-  { meterCount             :: !Int+  { meterCount             :: {-# UNPACK #-} !Int   , meterOneMinuteRate     :: !M.MovingAverage   , meterFiveMinuteRate    :: !M.MovingAverage   , meterFifteenMinuteRate :: !M.MovingAverage@@ -52,6 +53,7 @@   where     updateMeter = M.update $ fromIntegral c     ticked = tickIfNecessary t m+{-# INLINEABLE mark #-}  clear :: NominalDiffTime -> Meter -> Meter clear t =@@ -61,9 +63,11 @@   (oneMinuteRate %~ M.clear) .   (fiveMinuteRate %~ M.clear) .   (fifteenMinuteRate %~ M.clear)+{-# INLINEABLE clear #-}  tick :: Meter -> Meter tick = (oneMinuteRate %~ M.tick) . (fiveMinuteRate %~ M.tick) . (fifteenMinuteRate %~ M.tick)+{-# INLINEABLE tick #-}  tickIfNecessary :: NominalDiffTime -> Meter -> Meter tickIfNecessary new d = if age >= 5@@ -73,6 +77,7 @@     age = new - meterLastTick d     swapped = meterLastTick d < new     latest = Prelude.max (meterLastTick d) new+{-# INLINEABLE tickIfNecessary #-}  meanRate :: NominalDiffTime -> Meter -> Double meanRate t d = if c == 0@@ -82,6 +87,7 @@     c = meterCount d     start = meterStartTime d     elapsed = fromEnum t - fromEnum start+{-# INLINEABLE meanRate #-}  oneMinuteAverage :: Meter -> M.MovingAverage oneMinuteAverage = meterOneMinuteRate
src/Data/Metrics/MovingAverage.hs view
@@ -26,16 +26,20 @@ -- | Reset a moving average back to a starting state. clear :: MovingAverage -> MovingAverage clear (MovingAverage c u t r s) = MovingAverage c u t r (c s)+{-# INLINEABLE clear #-}  -- | Get the current rate of the moving average. rate :: MovingAverage -> Double rate (MovingAverage _ _ _ r s) = r s+{-# INLINEABLE rate #-}  -- | Update the average based upon an interval specified by the -- moving average implementation. tick :: MovingAverage -> MovingAverage tick (MovingAverage c u t r s) = MovingAverage c u t r (t s)+{-# INLINEABLE tick #-}  -- | Update the average with the specified value. update :: Double -> MovingAverage -> MovingAverage update x (MovingAverage c u t r s) = MovingAverage c u t r (u x s)+{-# INLINEABLE update #-}
src/Data/Metrics/MovingAverage/ExponentiallyWeighted.hs view
@@ -39,17 +39,18 @@ -- -- This type encapsulates the state needed for the exponentially weighted "MovingAverage" implementation. data ExponentiallyWeightedMovingAverage = ExponentiallyWeightedMovingAverage-  { exponentiallyWeightedMovingAverageUncounted   :: !Double-  , exponentiallyWeightedMovingAverageCurrentRate :: !Double+  { exponentiallyWeightedMovingAverageUncounted   :: {-# UNPACK #-} !Double+  , exponentiallyWeightedMovingAverageCurrentRate :: {-# UNPACK #-} !Double   , exponentiallyWeightedMovingAverageInitialized :: !Bool-  , exponentiallyWeightedMovingAverageInterval    :: !Double-  , exponentiallyWeightedMovingAverageAlpha       :: !Double+  , exponentiallyWeightedMovingAverageInterval    :: {-# UNPACK #-} !Double+  , exponentiallyWeightedMovingAverageAlpha       :: {-# UNPACK #-} !Double   } deriving (Show)  makeFields ''ExponentiallyWeightedMovingAverage  makeAlpha :: Double -> Minutes -> Double makeAlpha i m = 1 - exp (negate i / 60 / fromIntegral m)+{-# INLINE makeAlpha #-}  -- | Create a new "MovingAverage" with 5 second tick intervals for a one-minute window. new1MinuteMovingAverage :: MA.MovingAverage@@ -76,20 +77,24 @@ -- | Reset the moving average rate to zero. clear :: ExponentiallyWeightedMovingAverage -> ExponentiallyWeightedMovingAverage clear = (initialized .~ False) . (currentRate .~ 0) . (uncounted .~ 0)+{-# INLINEABLE clear #-}  -- | Get the current rate of the "ExponentiallyWeightedMovingAverage" for the given window. rate :: ExponentiallyWeightedMovingAverage -> Double rate e = (e ^. currentRate) * (e ^. interval)+{-# INLINEABLE rate #-}  -- | Create a new "ExpontiallyWeightedMovingAverage" with the given tick interval and averaging window. empty :: Double -- ^ The interval in seconds between ticks   -> Minutes -- ^ The duration in minutes which the moving average covers   -> ExponentiallyWeightedMovingAverage empty i m = ExponentiallyWeightedMovingAverage 0 0 False i $ makeAlpha i m+{-# INLINEABLE empty #-}  -- | Update the moving average based upon the given value update :: Double -> ExponentiallyWeightedMovingAverage -> ExponentiallyWeightedMovingAverage update = (uncounted +~)+{-# INLINEABLE update #-}  -- | Update the moving average as if the given interval between ticks has passed. tick :: ExponentiallyWeightedMovingAverage -> ExponentiallyWeightedMovingAverage@@ -99,3 +104,4 @@     updateRate a = if a ^. initialized       then currentRate +~ ((a ^. alpha) * (instantRate - a ^. currentRate)) $ a       else currentRate .~ instantRate $ a+{-# INLINEABLE tick #-}
src/Data/Metrics/Registry.hs view
@@ -49,7 +49,7 @@       Nothing -> do         c <- m         putMVar (metrics r) $! H.insert t (MetricCounter c) hm-        return $! Just c+        return $ Just c       Just im -> do         putMVar (metrics r) hm         return $! case im of@@ -63,7 +63,7 @@       Nothing -> do         g <- m         putMVar (metrics r) $! H.insert t (MetricGauge g) hm-        return $! Just g+        return $ Just g       Just im -> do         putMVar (metrics r) hm         return $! case im of@@ -77,7 +77,7 @@       Nothing -> do         h <- m         putMVar (metrics r) $! H.insert t (MetricHistogram h) hm-        return $! Just h+        return $ Just h       Just im -> do         putMVar (metrics r) hm         return $! case im of@@ -91,7 +91,7 @@       Nothing -> do         mv <- m         putMVar (metrics r) $! H.insert t (MetricMeter mv) hm-        return $! Just mv+        return $ Just mv       Just im -> do         putMVar (metrics r) hm         return $! case im of@@ -105,7 +105,7 @@       Nothing -> do         mv <- m         putMVar (metrics r) $! H.insert t (MetricTimer mv) hm-        return $! Just mv+        return $ Just mv       Just im -> do         putMVar (metrics r) hm         return $! case im of
src/Data/Metrics/Reservoir.hs view
@@ -29,17 +29,21 @@ -- | Reset a reservoir to its initial state. clear :: NominalDiffTime -> Reservoir -> Reservoir clear t (Reservoir c size ss u st) = Reservoir c size ss u (c t st)+{-# INLINEABLE clear #-}  -- | Get the current number of elements in the reservoir size :: Reservoir -> Int size (Reservoir _ size _ _ st) = size st+{-# INLINEABLE size #-}  -- | Get a copy of all elements in the reservoir. snapshot :: Reservoir -> Snapshot snapshot (Reservoir _ _ ss _ st) = ss st+{-# INLINEABLE snapshot #-}  -- | Update a reservoir with a new value. -- -- N.B. for some reservoir types, the latest value is not guaranteed to be retained in the reservoir. update :: Double -> NominalDiffTime -> Reservoir -> Reservoir update x t (Reservoir c size ss u st) = Reservoir c size ss u (u x t st)+{-# INLINEABLE update #-}
src/Data/Metrics/Reservoir/ExponentiallyDecaying.hs view
@@ -32,7 +32,7 @@ import Data.Primitive.MutVar import qualified Data.Vector.Unboxed as V import Data.Word-import System.Posix.Time+import System.PosixCompat.Time import System.Posix.Types import System.Random.MWC @@ -47,7 +47,7 @@   { exponentiallyDecayingReservoirInnerSize        :: {-# UNPACK #-} !Int   , exponentiallyDecayingReservoirAlpha            :: {-# UNPACK #-} !Double   , exponentiallyDecayingReservoirRescaleThreshold :: {-# UNPACK #-} !Word64-  , exponentiallyDecayingReservoirInnerReservoir   :: {-# UNPACK #-} !(M.Map Double Double)+  , exponentiallyDecayingReservoirInnerReservoir   :: !(M.Map Double Double)   , exponentiallyDecayingReservoirCount            :: {-# UNPACK #-} !Int   , exponentiallyDecayingReservoirStartTime        :: {-# UNPACK #-} !Word64   , exponentiallyDecayingReservoirNextScaleTime    :: {-# UNPACK #-} !Word64@@ -87,6 +87,7 @@       where         t' = truncate t         t'' = t' + c ^. rescaleThreshold+{-# INLINEABLE clear #-}  -- | Get the current size of the reservoir. size :: ExponentiallyDecayingReservoir -> Int@@ -96,6 +97,7 @@       where         c = r ^. count         s = r ^. innerSize+{-# INLINEABLE size #-}  -- | Get a snapshot of the current reservoir snapshot :: ExponentiallyDecayingReservoir -> Snapshot@@ -103,9 +105,11 @@   let svals = V.fromList $ M.elems $ r ^. innerReservoir   mvals <- V.unsafeThaw svals   takeSnapshot mvals+{-# INLINEABLE snapshot #-}  weight :: Double -> Word64 -> Double weight alpha t = exp (alpha * fromIntegral t)+{-# INLINE weight #-}  -- | \"A common feature of the above techniques—indeed, the key technique that -- allows us to track the decayed weights efficiently – is that they maintain@@ -134,6 +138,7 @@     adjustKey x = x * exp (-_alpha * fromIntegral diff)     adjustedReservoir = M.mapKeys adjustKey $ c ^. innerReservoir     _alpha = c ^. alpha+{-# INLINEABLE rescale #-}  -- | Insert a new sample into the reservoir. This may cause old sample values to be evicted -- based upon the probabilistic weighting given to the key at insertion time.@@ -163,4 +168,5 @@       p <- uniform g       s' <- save g       return (p :: Double, s')+{-# INLINEABLE update #-}
src/Data/Metrics/Reservoir/Uniform.hs view
@@ -79,6 +79,7 @@       v' <- I.thaw v       V.set v' 0       I.unsafeFreeze v'+{-# INLINEABLE clear #-}  -- | Reset the reservoir to empty by performing an in-place modification of the reservoir. unsafeClear :: NominalDiffTime -> UniformReservoir -> UniformReservoir@@ -89,12 +90,14 @@       v' <- I.unsafeThaw v       V.set v' 0       I.unsafeFreeze v'+{-# INLINEABLE unsafeClear #-}  -- | Get the current size of the reservoir size :: UniformReservoir -> Int size = go   where     go c = min (c ^. count) (I.length $ c ^. innerReservoir)+{-# INLINEABLE size #-}  -- | Take a snapshot of the reservoir by doing an in-place unfreeze. --@@ -105,6 +108,7 @@     go c = runST $ do       v' <- I.unsafeThaw $ c ^. innerReservoir       S.takeSnapshot $ V.slice 0 (size c) v'+{-# INLINEABLE snapshot #-}  -- | Perform an update of the reservoir by copying the internal vector. O(n) update :: Double -> NominalDiffTime -> UniformReservoir -> UniformReservoir@@ -126,6 +130,7 @@           v'' <- I.unsafeFreeze v'           s <- save g           return (s, v'')+{-# INLINEABLE update #-}  -- | Perform an in-place update of the reservoir. O(1) unsafeUpdate :: Double -> NominalDiffTime -> UniformReservoir -> UniformReservoir@@ -147,4 +152,5 @@           v'' <- I.unsafeFreeze v'           s <- save g           return (s, v'')+{-# INLINEABLE unsafeUpdate #-}
src/Data/Metrics/Snapshot.hs view
@@ -12,7 +12,6 @@   takeSnapshot ) where import Control.Monad.Primitive-import Data.Primitive.MutVar import Data.Vector.Algorithms.Intro import qualified Data.Vector.Unboxed as I import qualified Data.Vector.Unboxed.Mutable as V@@ -42,30 +41,31 @@ p999Q = 0.999  clamp :: Double -> Double-clamp x = if x > 1-  then 1-  else if x < 0-    then 0-    else x+clamp x | x > 1 = 1+        | x < 0 = 0+        | otherwise = x+{-# INLINE clamp #-}  -- | A utility function for snapshotting data from an unsorted "MVector" of samples. -- -- NB: this function uses "unsafeFreeze" under the hood, so be sure that the vector being -- snapshotted is not used after calling this function. takeSnapshot :: PrimMonad m => V.MVector (PrimState m) Double -> m Snapshot-takeSnapshot v = V.clone v >>= \v' -> sort v' >> I.unsafeFreeze v' >>= return . Snapshot+takeSnapshot v = fmap Snapshot (V.clone v >>= \v' -> sort v' >> I.unsafeFreeze v')  -- | Calculate an arbitrary quantile value for a "Snapshot".--- Values below zero or greater than one will be clamped to the range [0, 1]+-- Values below zero or greater than one will be clamped to the range [0, 1].+-- Returns 0 if no values are in the snapshot quantile :: Double -> Snapshot -> Double-quantile quantile (Snapshot s) = if pos > fromIntegral (I.length s)-  then I.last s-  else if pos' < 1-    then I.head s-    else lower + (pos - fromIntegral (floor pos :: Int)) * (upper - lower)+quantile quant (Snapshot s)+    | I.length s == 0 = 0+    | pos > fromIntegral (I.length s) = I.last s+    | pos' < 1 = I.head s+    | otherwise =+        lower + (pos - fromIntegral (floor pos :: Int)) * (upper - lower)   where-    q = clamp quantile-    pos = q * (1 + (fromIntegral $ I.length s))+    q = clamp quant+    pos = q * (1 + fromIntegral (I.length s))     pos' = truncate pos     lower = I.unsafeIndex s (pos' - 1)     upper = I.unsafeIndex s pos'@@ -97,4 +97,5 @@ -- | Calculate the 99.9th percentile of a "Snapshot" get999thPercentile :: Snapshot -> Double get999thPercentile = quantile p999Q+
src/Data/Metrics/Timer.hs view
@@ -1,7 +1,9 @@-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TemplateHaskell        #-}+{-# LANGUAGE MultiParamTypeClasses  #-}+{-# LANGUAGE FlexibleContexts       #-}+{-# LANGUAGE FlexibleInstances      #-} {-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE UndecidableInstances   #-} -- | A timer is basically a histogram of the duration of a type of event and a meter of the rate of its occurrence. module Data.Metrics.Timer (   Timer,@@ -13,6 +15,7 @@ import Control.Applicative import Control.Lens import Control.Lens.TH+import Control.Monad.Base import Control.Monad.Primitive import qualified Data.Metrics.MovingAverage.ExponentiallyWeighted as E import qualified Data.Metrics.Histogram.Internal as H@@ -28,54 +31,56 @@  -- | A measure of time statistics for the duration of an event data Timer m = Timer-  { fromTimer :: !(MutVar (PrimState m) P.Timer) -- ^ A reference to the pure timer internals-  , timerGetTime :: !(m NominalDiffTime) -- ^ The function that provides time differences for the timer. In practice, this is usually just "getPOSIXTime"+  { fromTimer    :: !(MutVar (PrimState m) P.Timer)+  -- ^ A reference to the pure timer internals+  , timerGetTime :: !(m NominalDiffTime)+  -- ^ The function that provides time differences for the timer. In practice, this is usually just "getPOSIXTime"   }  makeFields ''Timer -instance PrimMonad m => Clear m (Timer m) where-  clear t = do+instance (MonadBase b m, PrimMonad b) => Clear b m (Timer b) where+  clear t = liftBase $ do     ts <- timerGetTime t     updateRef (fromTimer t) $ P.clear ts -instance PrimMonad m => Update m (Timer m) Double where-  update t x = do+instance (MonadBase b m, PrimMonad b) => Update b m (Timer b) Double where+  update t x = liftBase $ do     ts <- timerGetTime t     updateRef (fromTimer t) $ P.update ts x -instance PrimMonad m => Count m (Timer m) where-  count t = readMutVar (fromTimer t) >>= return . P.count+instance (MonadBase b m, PrimMonad b) => Count b m (Timer b) where+  count t = liftBase $ fmap P.count $ readMutVar (fromTimer t) -instance (Functor m, PrimMonad m) => Statistics m (Timer m) where-  mean t = applyWithRef (fromTimer t) P.mean-  stddev t = applyWithRef (fromTimer t) P.stddev-  variance t = applyWithRef (fromTimer t) P.variance-  maxVal t = P.maxVal <$> readMutVar (fromTimer t)-  minVal t = P.minVal <$> readMutVar (fromTimer t)+instance (MonadBase b m, PrimMonad b) => Statistics b m (Timer b) where+  mean t = liftBase $ applyWithRef (fromTimer t) P.mean+  stddev t = liftBase $ applyWithRef (fromTimer t) P.stddev+  variance t = liftBase $ applyWithRef (fromTimer t) P.variance+  maxVal t = liftBase $ P.maxVal <$> readMutVar (fromTimer t)+  minVal t = liftBase $ P.minVal <$> readMutVar (fromTimer t) -instance PrimMonad m => Rate m (Timer m) where-  oneMinuteRate t = do+instance (MonadBase b m, PrimMonad b) => Rate b m (Timer b) where+  oneMinuteRate t = liftBase $ do     ts <- timerGetTime t     updateAndApplyToRef (fromTimer t) (P.tickIfNecessary ts) P.oneMinuteRate-  fiveMinuteRate t = do+  fiveMinuteRate t = liftBase $ do     ts <- timerGetTime t     updateAndApplyToRef (fromTimer t) (P.tickIfNecessary ts) P.fiveMinuteRate-  fifteenMinuteRate t = do+  fifteenMinuteRate t = liftBase $ do     ts <- timerGetTime t     updateAndApplyToRef (fromTimer t) (P.tickIfNecessary ts) P.fifteenMinuteRate-  meanRate t = do+  meanRate t = liftBase $ do     ts <- timerGetTime t     applyWithRef (fromTimer t) (P.meanRate ts) -instance PrimMonad m => TakeSnapshot m (Timer m) where-  snapshot t = applyWithRef (fromTimer t) P.snapshot+instance (MonadBase b m, PrimMonad b) => TakeSnapshot b m (Timer b) where+  snapshot t = liftBase $ applyWithRef (fromTimer t) P.snapshot  -- | Create a timer using a custom function for retrieving the current time. -- -- This is mostly exposed for testing purposes: prefer using "timer" if possible.-mkTimer :: PrimMonad m => m NominalDiffTime -> Seed -> m (Timer m)-mkTimer mt s = do+mkTimer :: (MonadBase b m, PrimMonad b) => b NominalDiffTime -> Seed -> m (Timer b)+mkTimer mt s = liftBase $ do   t <- mt   let ewmaMeter = M.meterData (E.movingAverage 5) t   let histogram = H.histogram $ R.reservoir 0.015 1028 t s@@ -85,19 +90,19 @@ -- | Create a standard "Timer" with an  -- exponentially weighted moving average -- and an exponentially decaying histogram-timer :: IO (Timer IO)-timer = do+timer :: MonadBase IO m => m (Timer IO)+timer = liftBase $ do   s <- withSystemRandom (asGenIO $ save)   mkTimer getPOSIXTime s  -- | Execute an action and record statistics about the -- duration of the event and the rate of event occurrence.-time :: Timer IO -> IO a -> IO a+time :: MonadBase IO m => Timer IO -> m a -> m a time t m = do   let gt = t ^. getTime-  ts <- gt+  ts <- liftBase gt   r <- m-  tf <- gt+  tf <- liftBase gt   update t $ realToFrac $ tf - ts   return r
src/Data/Metrics/Timer/Internal.hs view
@@ -16,7 +16,7 @@ import qualified Data.Metrics.Snapshot as S  data Timer = Timer-  { timerMeter :: !M.Meter+  { timerMeter     :: !M.Meter   , timerHistogram :: !H.Histogram   } @@ -24,43 +24,57 @@  tickIfNecessary :: NominalDiffTime -> Timer -> Timer tickIfNecessary t = meter %~ M.tickIfNecessary t+{-# INLINE tickIfNecessary #-}  snapshot :: Timer -> S.Snapshot snapshot = H.snapshot . timerHistogram+{-# INLINEABLE snapshot #-}  oneMinuteRate :: Timer -> Double oneMinuteRate = A.rate . M.oneMinuteAverage . timerMeter+{-# INLINEABLE oneMinuteRate #-}  fiveMinuteRate :: Timer -> Double fiveMinuteRate = A.rate . M.fiveMinuteAverage . timerMeter+{-# INLINEABLE fiveMinuteRate #-}  fifteenMinuteRate :: Timer -> Double fifteenMinuteRate = A.rate . M.fifteenMinuteAverage . timerMeter+{-# INLINEABLE fifteenMinuteRate #-}  meanRate :: NominalDiffTime -> Timer -> Double meanRate t = M.meanRate t . timerMeter+{-# INLINEABLE meanRate #-}  count :: Timer -> Int count = H.count . view histogram+{-# INLINEABLE count #-}  clear :: NominalDiffTime -> Timer -> Timer clear t = (histogram %~ H.clear t) . (meter %~ M.clear t)+{-# INLINEABLE clear #-}  update :: NominalDiffTime -> Double -> Timer -> Timer update t x = (histogram %~ H.update x t) . (meter %~ M.mark t 1)+{-# INLINEABLE update #-}  mean :: Timer -> Double mean = H.mean . timerHistogram+{-# INLINEABLE mean #-}  stddev :: Timer -> Double stddev = H.stddev . timerHistogram+{-# INLINEABLE stddev #-}  variance :: Timer -> Double variance = H.variance . timerHistogram+{-# INLINEABLE variance #-}  maxVal :: Timer -> Double maxVal = H.maxVal . timerHistogram+{-# INLINEABLE maxVal #-}  minVal :: Timer -> Double minVal = H.minVal . timerHistogram+{-# INLINEABLE minVal #-}
src/Data/Metrics/Types.hs view
@@ -1,9 +1,11 @@ {-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE MultiParamTypeClasses  #-}+{-# LANGUAGE KindSignatures         #-} -- | The main accessors for common stateful metric implementation data. module Data.Metrics.Types where import Control.Concurrent.MVar import Control.Monad.Primitive+import Data.Functor.Identity import Data.HashMap.Strict (HashMap) import Data.Metrics.Internal import Data.Metrics.Snapshot@@ -15,12 +17,12 @@ type Minutes = Int  -- | Get the current count for the given metric.-class Count m a | a -> m where+class Count (b :: * -> *) m a | m -> b, a -> b where   -- | retrieve a count   count :: a -> m Int  -- | Provides statistics from a histogram that tracks the standard moving average rates.-class Rate m a | a -> m where+class Rate (b :: * -> *) m a | m -> b, a -> b where   -- | Get the average rate of occurrence for some sort of event for the past minute.   oneMinuteRate :: a -> m Double   -- | Get the average rate of occurrence for some sort of event for the past five minutes.@@ -31,23 +33,23 @@   meanRate :: a -> m Double  -- | Gets the current value from a simple metric (i.e. a "Counter" or a "Gauge")-class Value m a v | a -> m v where+class Value (b :: * -> *) m a v | m -> b, a -> b v where   value :: a -> m v  -- | Update a metric by performing wholesale replacement of a value.-class Set m a v | a -> m v where+class Set (b :: * -> *) m a v | m -> b, a -> b v where   -- | Replace the current value of a simple metric (i.e. a "Counter" or a "Gauge")   set :: a -> v -> m ()  -- | Provides a way to reset metrics. This might be useful in a development environment -- or to periodically get a clean state for long-running processes.-class Clear m a | a -> m where+class Clear (b :: * -> *) m a | m -> b, a -> b where   -- | Reset the metric to an 'empty' state. In practice, this should be   -- equivalent to creating a new metric of the same type in-place.   clear :: a -> m ()  -- | Provides the main interface for retrieving statistics tabulated by a histogram.-class Statistics m a | a -> m where+class Statistics (b :: * -> *) m a | m -> b, a -> b where   -- | Gets the highest value encountered thus far.   maxVal :: a -> m Double   -- | Gets the lowest value encountered thus far.@@ -61,11 +63,12 @@   variance :: a -> m Double  -- | Update statistics tracked by a metric with a new sample.-class Update m a v | a -> m v where+class Update (b :: * -> *) m a v | m -> b, a -> b v where   -- | Feed a metric another value.   update :: a -> v -> m ()  -- | Take a snapshot (a sorted vector) of samples used for calculating quantile data.-class TakeSnapshot m a | a -> m where+class TakeSnapshot (b :: * -> *) m a | m -> b, a -> b where   -- | Get a sample of the values currently in a histogram or type that contains a histogram.   snapshot :: a -> m Snapshot+
tests/HistogramTest.hs view
@@ -1,11 +1,10 @@ module HistogramTest where import Control.Concurrent.Async-import Data.Metrics.Histogram.Internal+import Control.Monad+import Data.Metrics.Histogram import Data.Metrics.Snapshot-import Data.Metrics.Types import System.Random.MWC-import System.Posix.Time-import Test.QuickCheck+import Test.HUnit  histogramTests :: [Test] histogramTests =@@ -37,9 +36,9 @@  withExponential :: (Histogram IO -> IO a) -> IO a withExponential f = do-  seed <- withSystemRandom (asGenIO save)-  t <- epochTime-  h <- exponentiallyDecayingHistogram t seed+  -- seed <- withSystemRandom (asGenIO save)+  -- t <- epochTime+  h <- exponentiallyDecayingHistogram -- t seed   f h  uniformTest :: Assertable a => String -> (Histogram IO -> IO a) -> Test@@ -72,14 +71,14 @@ testUniformSampleMeanThreaded :: Test testUniformSampleMeanThreaded = uniformTest "async uniform mean value" $ \h -> do   let task = update h 5 >> update h 10-  asyncs <- sequence $ replicate 10 (async $ task)+  asyncs <- replicateM 10 (async task)   mapM_ wait asyncs   x <- mean h   assert $ x == 7.5  testUniformSample2000 :: Test testUniformSample2000 = uniformTest "uniform sample 2000" $ \h -> do-  mapM_ (update h $) [0..1999]+  mapM_ (update h) [0..1999]   x <- maxVal h   assert $ x == 1999 @@ -89,14 +88,14 @@  testUniformSampleSnapshot :: Test testUniformSampleSnapshot = uniformTest "uniform snapshot" $ \h -> do-  mapM_ (update h $) [0..99]+  mapM_ (update h) [0..99]   s <- snapshot h   assert $ median s == 49.5  testUniformSampleSnapshotThreaded :: Test testUniformSampleSnapshotThreaded = uniformTest "async uniform snapshot" $ \h -> do-  let task = mapM_ (update h $) [0..99]-  asyncs <- sequence $ replicate 10 (async $ task)+  let task = mapM_ (update h) [0..99]+  asyncs <- replicateM 10 (async task)   mapM_ wait asyncs   s <- snapshot h   assertEqual "median" 49.5 $ median s@@ -125,14 +124,14 @@ testExponentialSampleMeanThreaded :: Test testExponentialSampleMeanThreaded = exponentialTest "mean threaded" $ \h -> do   let task = update h 5 >> update h 10-  asyncs <- sequence $ replicate 10 (async $ task)+  asyncs <- replicateM 10 (async task)   mapM_ wait asyncs   x <- mean h   assertEqual "mean" 7.5 x  testExponentialSample2000 :: Test testExponentialSample2000 = exponentialTest "sample 2000" $ \h -> do-  mapM_ (update h $) [0..1999]+  mapM_ (update h) [0..1999]   x <- maxVal h   assertEqual "max" 1999 x @@ -142,14 +141,14 @@  testExponentialSampleSnapshot :: Test testExponentialSampleSnapshot = exponentialTest "snapshot" $ \h -> do-    mapM_ (update h $) [0..99]+    mapM_ (update h) [0..99]     s <- snapshot h     assertEqual "median" 49.5 $ median s  testExponentialSampleSnapshotThreaded :: Test testExponentialSampleSnapshotThreaded = exponentialTest "async snapshot" $ \h -> do-  let task = mapM_ (update h $) [0..99]-  asyncs <- sequence $ replicate 10 (async $ task)+  let task = mapM_ (update h) [0..99]+  asyncs <- replicateM 10 (async task)   mapM_ wait asyncs   s <- snapshot h   assertEqual "median" 49.5 $ median s
tests/MeterTest.hs view
@@ -1,10 +1,12 @@ {-# LANGUAGE Rank2Types #-} module MeterTest where+import Control.Lens import Control.Monad import Control.Monad.Primitive import Control.Monad.ST import Data.Metrics.Internal-import Data.Metrics.Meter.Internal+import Data.Metrics.Meter+import Data.Metrics.Meter.Internal (lastTick) import Data.Metrics.Types import Data.Primitive.MutVar import Data.STRef@@ -12,30 +14,36 @@ import Test.QuickCheck.Monadic import System.Posix.Types + smallCount :: Gen Int smallCount = choose (0, 10000) -increment1s :: forall s. STRef s EpochTime -> ST s EpochTime++increment1s :: Num a => STRef s a -> ST s a increment1s r = do-  modifySTRef r succ-  t <- readSTRef r-  return t+  modifySTRef r (+ 1)+  readSTRef r + run1sMeter :: (forall s. Meter (ST s) -> ST s a) -> a run1sMeter f = runST $ do   r <- newSTRef 0   m <- mkMeter $ increment1s r   f m + meterCountTest :: Property meterCountTest = label "mark increments count" $ monadicST $ do   x <- pick smallCount-  let c = run1sMeter $ \m -> (replicateM_ x $ mark m) >> count m+  let c = run1sMeter $ \m -> do+        replicateM_ x (mark m)+        count m   assert $ x == c -- testMeter -- testMeterThreaded -- testOneMinuteRate + testTicks = runST $ do   r <- newSTRef 0   m <- mkMeter $ increment1s r@@ -46,4 +54,6 @@   mark m   md <- readMutVar (fromMeter m)   x <- readSTRef r-  return $ (meterLastTick md, x)+  return $ (md ^. lastTick, x)++