{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RebindableSyntax #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# OPTIONS_GHC -fno-warn-type-defaults #-}

-- | timing effects
module Box.Time
  ( sleep,
    sleepUntil,
    Stamped (..),
    stampNow,
    stampE,
    emitOn,
    playback,
    simulate,
  )
where

import Box.Cont
import Box.Emitter
import Control.Monad.Conc.Class as C
import Data.Time
import NumHask.Prelude hiding (STM, atomically)
import NumHask.Space.Time

-- | sleep for x seconds
sleep :: (MonadConc m) => Double -> m ()
sleep :: Double -> m ()
sleep Double
x = Int -> m ()
forall (m :: * -> *). MonadConc m => Int -> m ()
C.threadDelay (Double -> Int
forall a b. QuotientField a b => a -> b
floor (Double -> Int) -> Double -> Int
forall a b. (a -> b) -> a -> b
$ Double
x Double -> Double -> Double
forall a. Multiplicative a => a -> a -> a
* Double
1e6)

-- | sleep until a certain time (in the future)
sleepUntil :: UTCTime -> IO ()
sleepUntil :: UTCTime -> IO ()
sleepUntil UTCTime
u = do
  UTCTime
t0 <- IO UTCTime
getCurrentTime
  Double -> IO ()
forall (m :: * -> *). MonadConc m => Double -> m ()
sleep (NominalDiffTime -> Double
fromNominalDiffTime (NominalDiffTime -> Double) -> NominalDiffTime -> Double
forall a b. (a -> b) -> a -> b
$ UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
u UTCTime
t0)

-- | A value with a UTCTime annotation.
data Stamped a = Stamped
  { Stamped a -> UTCTime
stamp :: !UTCTime,
    Stamped a -> a
value :: !a
  }
  deriving (Stamped a -> Stamped a -> Bool
(Stamped a -> Stamped a -> Bool)
-> (Stamped a -> Stamped a -> Bool) -> Eq (Stamped a)
forall a. Eq a => Stamped a -> Stamped a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Stamped a -> Stamped a -> Bool
$c/= :: forall a. Eq a => Stamped a -> Stamped a -> Bool
== :: Stamped a -> Stamped a -> Bool
$c== :: forall a. Eq a => Stamped a -> Stamped a -> Bool
Eq, Int -> Stamped a -> ShowS
[Stamped a] -> ShowS
Stamped a -> String
(Int -> Stamped a -> ShowS)
-> (Stamped a -> String)
-> ([Stamped a] -> ShowS)
-> Show (Stamped a)
forall a. Show a => Int -> Stamped a -> ShowS
forall a. Show a => [Stamped a] -> ShowS
forall a. Show a => Stamped a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Stamped a] -> ShowS
$cshowList :: forall a. Show a => [Stamped a] -> ShowS
show :: Stamped a -> String
$cshow :: forall a. Show a => Stamped a -> String
showsPrec :: Int -> Stamped a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Stamped a -> ShowS
Show, ReadPrec [Stamped a]
ReadPrec (Stamped a)
Int -> ReadS (Stamped a)
ReadS [Stamped a]
(Int -> ReadS (Stamped a))
-> ReadS [Stamped a]
-> ReadPrec (Stamped a)
-> ReadPrec [Stamped a]
-> Read (Stamped a)
forall a. Read a => ReadPrec [Stamped a]
forall a. Read a => ReadPrec (Stamped a)
forall a. Read a => Int -> ReadS (Stamped a)
forall a. Read a => ReadS [Stamped a]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Stamped a]
$creadListPrec :: forall a. Read a => ReadPrec [Stamped a]
readPrec :: ReadPrec (Stamped a)
$creadPrec :: forall a. Read a => ReadPrec (Stamped a)
readList :: ReadS [Stamped a]
$creadList :: forall a. Read a => ReadS [Stamped a]
readsPrec :: Int -> ReadS (Stamped a)
$creadsPrec :: forall a. Read a => Int -> ReadS (Stamped a)
Read)

-- | Add the current time
stampNow :: (MonadConc m, MonadIO m) => a -> m (LocalTime, a)
stampNow :: a -> m (LocalTime, a)
stampNow a
a = do
  UTCTime
t <- IO UTCTime -> m UTCTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
  (LocalTime, a) -> m (LocalTime, a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TimeZone -> UTCTime -> LocalTime
utcToLocalTime TimeZone
utc UTCTime
t, a
a)

-- | adding a time stamp
stampE ::
  (MonadConc m, MonadIO m) =>
  Emitter m a ->
  Emitter m (LocalTime, a)
stampE :: Emitter m a -> Emitter m (LocalTime, a)
stampE = (a -> m (Maybe (LocalTime, a)))
-> Emitter m a -> Emitter m (LocalTime, a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m (Maybe b)) -> Emitter m a -> Emitter m b
mapE (((LocalTime, a) -> Maybe (LocalTime, a))
-> m (LocalTime, a) -> m (Maybe (LocalTime, a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (LocalTime, a) -> Maybe (LocalTime, a)
forall a. a -> Maybe a
Just (m (LocalTime, a) -> m (Maybe (LocalTime, a)))
-> (a -> m (LocalTime, a)) -> a -> m (Maybe (LocalTime, a))
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. a -> m (LocalTime, a)
forall (m :: * -> *) a.
(MonadConc m, MonadIO m) =>
a -> m (LocalTime, a)
stampNow)

-- | wait until Stamped time before emitting
emitOn ::
  Emitter IO (LocalTime, a) ->
  Emitter IO a
emitOn :: Emitter IO (LocalTime, a) -> Emitter IO a
emitOn =
  ((LocalTime, a) -> IO (Maybe a))
-> Emitter IO (LocalTime, a) -> Emitter IO a
forall (m :: * -> *) a b.
Monad m =>
(a -> m (Maybe b)) -> Emitter m a -> Emitter m b
mapE
    ( \(LocalTime
l, a
a) -> do
        UTCTime -> IO ()
sleepUntil (TimeZone -> LocalTime -> UTCTime
localTimeToUTC TimeZone
utc LocalTime
l)
        Maybe a -> IO (Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe a -> IO (Maybe a)) -> Maybe a -> IO (Maybe a)
forall a b. (a -> b) -> a -> b
$ a -> Maybe a
forall a. a -> Maybe a
Just a
a
    )

-- | reset the emitter stamps to by in sync with the current time and adjust the speed
-- >>> let e1 = fromListE (zipWith (\x a -> Stamped (addUTCTime (fromDouble x) t) a) [0..5] [0..5])
playback :: Double -> Emitter IO (LocalTime, a) -> IO (Emitter IO (LocalTime, a))
playback :: Double
-> Emitter IO (LocalTime, a) -> IO (Emitter IO (LocalTime, a))
playback Double
speed Emitter IO (LocalTime, a)
e = do
  Maybe (LocalTime, a)
r <- Emitter IO (LocalTime, a) -> IO (Maybe (LocalTime, a))
forall (m :: * -> *) a. Emitter m a -> m (Maybe a)
emit Emitter IO (LocalTime, a)
e
  case Maybe (LocalTime, a)
r of
    Maybe (LocalTime, a)
Nothing -> Emitter IO (LocalTime, a) -> IO (Emitter IO (LocalTime, a))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Emitter IO (LocalTime, a)
forall a. Monoid a => a
mempty
    Just (LocalTime
l0, a
_) -> do
      UTCTime
t0 <- IO UTCTime
getCurrentTime
      let ua :: NominalDiffTime
ua = LocalTime -> LocalTime -> NominalDiffTime
diffLocalTime (TimeZone -> UTCTime -> LocalTime
utcToLocalTime TimeZone
utc UTCTime
t0) LocalTime
l0
      let delta :: LocalTime -> LocalTime
delta LocalTime
u = NominalDiffTime -> LocalTime -> LocalTime
addLocalTime NominalDiffTime
ua (LocalTime -> LocalTime) -> LocalTime -> LocalTime
forall a b. (a -> b) -> a -> b
$ NominalDiffTime -> LocalTime -> LocalTime
addLocalTime (Double -> NominalDiffTime
toNominalDiffTime (NominalDiffTime -> Double
fromNominalDiffTime (LocalTime -> LocalTime -> NominalDiffTime
diffLocalTime LocalTime
u LocalTime
l0) Double -> Double -> Double
forall a. Multiplicative a => a -> a -> a
* Double
speed)) LocalTime
l0
      Emitter IO (LocalTime, a) -> IO (Emitter IO (LocalTime, a))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (((LocalTime, a) -> IO (Maybe (LocalTime, a)))
-> Emitter IO (LocalTime, a) -> Emitter IO (LocalTime, a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m (Maybe b)) -> Emitter m a -> Emitter m b
mapE (\(LocalTime
l, a
a) -> Maybe (LocalTime, a) -> IO (Maybe (LocalTime, a))
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((LocalTime, a) -> Maybe (LocalTime, a)
forall a. a -> Maybe a
Just (LocalTime -> LocalTime
delta LocalTime
l, a
a))) Emitter IO (LocalTime, a)
e)

-- | simulate a delay from a (Stamped a) Emitter relative to the first timestamp
simulate :: Double -> Emitter IO (LocalTime, a) -> Cont IO (Emitter IO a)
simulate :: Double -> Emitter IO (LocalTime, a) -> Cont IO (Emitter IO a)
simulate Double
speed Emitter IO (LocalTime, a)
e = (forall r. (Emitter IO a -> IO r) -> IO r)
-> Cont IO (Emitter IO a)
forall (m :: * -> *) a. (forall r. (a -> m r) -> m r) -> Cont m a
Cont ((forall r. (Emitter IO a -> IO r) -> IO r)
 -> Cont IO (Emitter IO a))
-> (forall r. (Emitter IO a -> IO r) -> IO r)
-> Cont IO (Emitter IO a)
forall a b. (a -> b) -> a -> b
$ \Emitter IO a -> IO r
eaction -> do
  Emitter IO (LocalTime, a)
e' <- Double
-> Emitter IO (LocalTime, a) -> IO (Emitter IO (LocalTime, a))
forall a.
Double
-> Emitter IO (LocalTime, a) -> IO (Emitter IO (LocalTime, a))
playback Double
speed Emitter IO (LocalTime, a)
e
  Emitter IO a -> IO r
eaction (Emitter IO (LocalTime, a) -> Emitter IO a
forall a. Emitter IO (LocalTime, a) -> Emitter IO a
emitOn Emitter IO (LocalTime, a)
e')