--------------------------------------------------------------------------------
-- |
-- Module : Database.EventStore.Internal.Stopwatch
-- Copyright : (C) 2017 Yorick Laupa
-- License : (see the file LICENSE)
--
-- Maintainer : Yorick Laupa <yo.eight@gmail.com>
-- Stability : provisional
-- Portability : non-portable
--
--------------------------------------------------------------------------------
module Database.EventStore.Internal.Stopwatch
  ( Stopwatch
  , newStopwatch
  , stopwatchElapsed
  ) where

--------------------------------------------------------------------------------
import Data.Time

--------------------------------------------------------------------------------
import Database.EventStore.Internal.Prelude

--------------------------------------------------------------------------------
data Internal =
  Internal { Internal -> UTCTime
_lastTime :: !UTCTime
           , Internal -> NominalDiffTime
_acc      :: !NominalDiffTime
           }

--------------------------------------------------------------------------------
initInternal :: UTCTime -> Internal
initInternal :: UTCTime -> Internal
initInternal UTCTime
now = UTCTime -> NominalDiffTime -> Internal
Internal UTCTime
now NominalDiffTime
0

--------------------------------------------------------------------------------
update :: UTCTime -> Internal -> Internal
update :: UTCTime -> Internal -> Internal
update UTCTime
now (Internal UTCTime
before NominalDiffTime
acc) = UTCTime -> NominalDiffTime -> Internal
Internal UTCTime
now NominalDiffTime
acc'
  where
    acc' :: NominalDiffTime
acc' = NominalDiffTime
acc NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
+ UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
now UTCTime
before

--------------------------------------------------------------------------------
newtype Stopwatch = Stopwatch (MVar Internal)

--------------------------------------------------------------------------------
newStopwatch :: MonadBase IO m => m Stopwatch
newStopwatch :: m Stopwatch
newStopwatch =
  (MVar Internal -> Stopwatch) -> m (MVar Internal) -> m Stopwatch
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap MVar Internal -> Stopwatch
Stopwatch (m (MVar Internal) -> m Stopwatch)
-> (UTCTime -> m (MVar Internal)) -> UTCTime -> m Stopwatch
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Internal -> m (MVar Internal)
forall (m :: * -> *) a. MonadBase IO m => a -> m (MVar a)
newMVar (Internal -> m (MVar Internal))
-> (UTCTime -> Internal) -> UTCTime -> m (MVar Internal)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTCTime -> Internal
initInternal (UTCTime -> m Stopwatch) -> m UTCTime -> m Stopwatch
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO UTCTime -> m UTCTime
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase IO UTCTime
getCurrentTime

--------------------------------------------------------------------------------
stopwatchElapsed :: MonadBaseControl IO m => Stopwatch -> m NominalDiffTime
stopwatchElapsed :: Stopwatch -> m NominalDiffTime
stopwatchElapsed (Stopwatch MVar Internal
var) =
  MVar Internal
-> (Internal -> m (Internal, NominalDiffTime)) -> m NominalDiffTime
forall (m :: * -> *) a b.
MonadBaseControl IO m =>
MVar a -> (a -> m (a, b)) -> m b
modifyMVar MVar Internal
var ((Internal -> m (Internal, NominalDiffTime)) -> m NominalDiffTime)
-> (Internal -> m (Internal, NominalDiffTime)) -> m NominalDiffTime
forall a b. (a -> b) -> a -> b
$ \Internal
prev -> do
    UTCTime
now <- IO UTCTime -> m UTCTime
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase IO UTCTime
getCurrentTime
    let next :: Internal
next = UTCTime -> Internal -> Internal
update UTCTime
now Internal
prev
    (Internal, NominalDiffTime) -> m (Internal, NominalDiffTime)
forall (m :: * -> *) a. Monad m => a -> m a
return (Internal
next, Internal -> NominalDiffTime
_acc Internal
next)