-- | Slow producers down to run at desired rates.
module Data.Machine.Regulated where
import Control.Concurrent (threadDelay)
import Control.Monad (when)
import Control.Monad.IO.Class (MonadIO(..))
import Data.Machine.Plan
import Data.Machine.Process
import Data.Machine.Type
import Data.Time.Clock (getCurrentTime, diffUTCTime)

-- | A pass-through process rate-limited to the given inter-step
-- period in seconds. This may be used to slow down an upstream
-- producer; it can not speed things up.
regulated :: MonadIO m => Double -> ProcessT m a a
regulated :: Double -> ProcessT m a a
regulated Double
target = PlanT (Is a) a m Any -> ProcessT m a a
forall (m :: * -> *) (k :: * -> *) o a.
Monad m =>
PlanT k o m a -> MachineT m k o
construct (PlanT (Is a) a m Any -> ProcessT m a a)
-> PlanT (Is a) a m Any -> ProcessT m a a
forall a b. (a -> b) -> a -> b
$ IO UTCTime -> PlanT (Is a) a m UTCTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime PlanT (Is a) a m UTCTime
-> (UTCTime -> PlanT (Is a) a m Any) -> PlanT (Is a) a m Any
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Double -> UTCTime -> PlanT (Is a) a m Any
forall (k :: * -> * -> *) (m :: * -> *) o b.
(Category k, MonadIO m) =>
Double -> UTCTime -> PlanT (k o) o m b
go Double
0
  where go :: Double -> UTCTime -> PlanT (k o) o m b
go Double
dt UTCTime
prevT =
          do PlanT (k o) o m o
forall (k :: * -> * -> *) i o. Category k => Plan (k i) o i
await PlanT (k o) o m o
-> (o -> PlanT (k o) o m ()) -> PlanT (k o) o m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= o -> PlanT (k o) o m ()
forall o (k :: * -> *). o -> Plan k o ()
yield
             UTCTime
t <- IO UTCTime -> PlanT (k o) o m UTCTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
             let e :: Double
e = Double
target Double -> Double -> Double
forall a. Num a => a -> a -> a
- NominalDiffTime -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac (UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
t UTCTime
prevT)
                 dt' :: Double
dt' = Double
dt Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
0.5 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
e
             Bool -> PlanT (k o) o m () -> PlanT (k o) o m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Double
dt' Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
0) (IO () -> PlanT (k o) o m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> PlanT (k o) o m ())
-> (Double -> IO ()) -> Double -> PlanT (k o) o m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> IO ()
threadDelay (Int -> IO ()) -> (Double -> Int) -> Double -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Int
forall a b. (RealFrac a, Integral b) => a -> b
round (Double -> PlanT (k o) o m ()) -> Double -> PlanT (k o) o m ()
forall a b. (a -> b) -> a -> b
$ Double
dt' Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
1000000)
             Double -> UTCTime -> PlanT (k o) o m b
go Double
dt' UTCTime
t