-- | Timing effects.
module Box.Time
  ( sleep,
    stampNow,
    stampE,
    Gap,
    gaps,
    fromGaps,
    fromGapsNow,
    gapEffect,
    skip,
    replay,
    gapSkipEffect,
    speedEffect,
    speedSkipEffect,
  )
where

import Box.Connectors
import Box.Emitter
import Control.Applicative
import Control.Concurrent
import Control.Monad.State.Lazy
import Data.Bifunctor
import Data.Bool
import Data.Fixed (Fixed (MkFixed))
import Data.Time
import Prelude

-- $setup
-- >>> :set -XOverloadedStrings
-- >>> import Box
-- >>> import Prelude

-- | Sleep for x seconds.
sleep :: Double -> IO ()
sleep :: Gap -> IO ()
sleep Gap
x = Int -> IO ()
threadDelay (forall a b. (RealFrac a, Integral b) => a -> b
floor forall a b. (a -> b) -> a -> b
$ Gap
x forall a. Num a => a -> a -> a
* Gap
1e6)

-- | convenience conversion to Double
fromNominalDiffTime :: NominalDiffTime -> Double
fromNominalDiffTime :: NominalDiffTime -> Gap
fromNominalDiffTime NominalDiffTime
t = forall a. Num a => Integer -> a
fromInteger Integer
i forall a. Num a => a -> a -> a
* Gap
1e-12
  where
    (MkFixed Integer
i) = NominalDiffTime -> Fixed E12
nominalDiffTimeToSeconds NominalDiffTime
t

-- | convenience conversion from Double
toNominalDiffTime :: Double -> NominalDiffTime
toNominalDiffTime :: Gap -> NominalDiffTime
toNominalDiffTime Gap
x =
  let d0 :: Day
d0 = Integer -> Day
ModifiedJulianDay Integer
0
      days :: Integer
days = forall a b. (RealFrac a, Integral b) => a -> b
floor (Gap
x forall a. Fractional a => a -> a -> a
/ NominalDiffTime -> Gap
fromNominalDiffTime NominalDiffTime
nominalDay)
      secs :: Gap
secs = Gap
x forall a. Num a => a -> a -> a
- forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
days forall a. Num a => a -> a -> a
* NominalDiffTime -> Gap
fromNominalDiffTime NominalDiffTime
nominalDay
      t0 :: UTCTime
t0 = Day -> DiffTime -> UTCTime
UTCTime Day
d0 (Integer -> DiffTime
picosecondsToDiffTime Integer
0)
      t1 :: UTCTime
t1 = Day -> DiffTime -> UTCTime
UTCTime (Integer -> Day -> Day
addDays Integer
days Day
d0) (Integer -> DiffTime
picosecondsToDiffTime forall a b. (a -> b) -> a -> b
$ forall a b. (RealFrac a, Integral b) => a -> b
floor (Gap
secs forall a. Fractional a => a -> a -> a
/ Gap
1.0e-12))
   in UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
t1 UTCTime
t0

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

-- | Add the current time stamp.
--
-- @
-- > toListM . stampE <$|> (qList [1..3])
-- [(2022-08-30 01:55:16.517127,1),(2022-08-30 01:55:16.517132,2),(2022-08-30 01:55:16.517135,3)]
-- @
stampE ::
  Emitter IO a ->
  Emitter IO (LocalTime, a)
stampE :: forall a. Emitter IO a -> Emitter IO (LocalTime, a)
stampE = forall (m :: * -> *) a b.
Monad m =>
(a -> m (Maybe b)) -> Emitter m a -> Emitter m b
witherE (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> IO (LocalTime, a)
stampNow)

-- | Usually represents seconds.
type Gap = Double

-- | Convert stamped emitter to gap between emits in seconds
--
-- > toListM <$|> (gaps =<< (fromGapsNow =<< (qList (zip (0:repeat 1) [1..4]))))
-- > [(0.0,1),(1.0,2),(1.0,3),(1.0,4)]
gaps :: Emitter IO (LocalTime, a) -> CoEmitter IO (Gap, a)
gaps :: forall a. Emitter IO (LocalTime, a) -> CoEmitter IO (Gap, a)
gaps Emitter IO (LocalTime, a)
e = forall s a. s -> Emitter (StateT s IO) a -> CoEmitter IO a
evalEmitter forall a. Maybe a
Nothing forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. m (Maybe a) -> Emitter m a
Emitter forall a b. (a -> b) -> a -> b
$ do
  Maybe (LocalTime, a)
r <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ 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 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
    Just (LocalTime, a)
a' -> do
      Maybe LocalTime
t' <- forall s (m :: * -> *). MonadState s m => m s
get
      let delta :: LocalTime -> Gap
delta LocalTime
u = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Gap
0 (NominalDiffTime -> Gap
fromNominalDiffTime forall b c a. (b -> c) -> (a -> b) -> a -> c
. LocalTime -> LocalTime -> NominalDiffTime
diffLocalTime LocalTime
u) Maybe LocalTime
t'
      forall s (m :: * -> *). MonadState s m => s -> m ()
put (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> a
fst (LocalTime, a)
a')
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first LocalTime -> Gap
delta (LocalTime, a)
a'

-- | Convert gaps in seconds to stamps starting from an initial supplied 'LocalTime'
fromGaps :: LocalTime -> Emitter IO (Gap, a) -> CoEmitter IO (LocalTime, a)
fromGaps :: forall a.
LocalTime -> Emitter IO (Gap, a) -> CoEmitter IO (LocalTime, a)
fromGaps LocalTime
t0 Emitter IO (Gap, a)
e = forall s a. s -> Emitter (StateT s IO) a -> CoEmitter IO a
evalEmitter LocalTime
t0 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. m (Maybe a) -> Emitter m a
Emitter forall a b. (a -> b) -> a -> b
$ do
  Maybe (Gap, a)
r <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Emitter m a -> m (Maybe a)
emit Emitter IO (Gap, a)
e
  case Maybe (Gap, a)
r of
    Maybe (Gap, a)
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
    Just (Gap, a)
a' -> do
      LocalTime
t' <- forall s (m :: * -> *). MonadState s m => m s
get
      let t'' :: LocalTime
t'' = NominalDiffTime -> LocalTime -> LocalTime
addLocalTime (Gap -> NominalDiffTime
toNominalDiffTime (forall a b. (a, b) -> a
fst (Gap, a)
a')) LocalTime
t'
      forall s (m :: * -> *). MonadState s m => s -> m ()
put LocalTime
t''
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (LocalTime
t'', forall a b. (a, b) -> b
snd (Gap, a)
a')

-- | Convert gaps in seconds to stamps starting with current time
--
-- > toListM <$|> (fromGapsNow =<< (qList (zip (0:repeat 1) [1..4])))
-- > [(2022-08-30 22:57:33.835228,1),(2022-08-30 22:57:34.835228,2),(2022-08-30 22:57:35.835228,3),(2022-08-30 22:57:36.835228,4)]
fromGapsNow :: Emitter IO (Gap, a) -> CoEmitter IO (LocalTime, a)
fromGapsNow :: forall a. Emitter IO (Gap, a) -> CoEmitter IO (LocalTime, a)
fromGapsNow Emitter IO (Gap, a)
e = do
  UTCTime
t0 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
  forall a.
LocalTime -> Emitter IO (Gap, a) -> CoEmitter IO (LocalTime, a)
fromGaps (TimeZone -> UTCTime -> LocalTime
utcToLocalTime TimeZone
utc UTCTime
t0) Emitter IO (Gap, a)
e

-- | Convert a (Gap,a) emitter to an a emitter, with delays between emits of the gap.
gapEffect ::
  Emitter IO (Gap, a) ->
  Emitter IO a
gapEffect :: forall a. Emitter IO (Gap, a) -> Emitter IO a
gapEffect Emitter IO (Gap, a)
as =
  forall (m :: * -> *) a. m (Maybe a) -> Emitter m a
Emitter forall a b. (a -> b) -> a -> b
$ do
    Maybe (Gap, a)
a <- forall (m :: * -> *) a. Emitter m a -> m (Maybe a)
emit Emitter IO (Gap, a)
as
    case Maybe (Gap, a)
a of
      (Just (Gap
s, a
a')) -> Gap -> IO ()
sleep Gap
s forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> Maybe a
Just a
a')
      Maybe (Gap, a)
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing

-- | Using the Gap emitter, adjust the Gap for a (Gap, a) emitter
speedEffect ::
  Emitter IO Gap ->
  Emitter IO (Gap, a) ->
  Emitter IO a
speedEffect :: forall a. Emitter IO Gap -> Emitter IO (Gap, a) -> Emitter IO a
speedEffect Emitter IO Gap
speeds Emitter IO (Gap, a)
as =
  forall (m :: * -> *) a. m (Maybe a) -> Emitter m a
Emitter forall a b. (a -> b) -> a -> b
$ do
    Maybe Gap
s <- forall (m :: * -> *) a. Emitter m a -> m (Maybe a)
emit Emitter IO Gap
speeds
    Maybe (Gap, a)
a <- forall (m :: * -> *) a. Emitter m a -> m (Maybe a)
emit Emitter IO (Gap, a)
as
    case (Maybe Gap
s, Maybe (Gap, a)
a) of
      (Just Gap
s', Just (Gap
g, a
a')) -> Gap -> IO ()
sleep (Gap
g forall a. Fractional a => a -> a -> a
/ Gap
s') forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> Maybe a
Just a
a')
      (Maybe Gap, Maybe (Gap, a))
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing

-- | Only add a Gap effect if greater than the Int emitter
--
-- effect is similar to a fast-forward of the first n emits
gapSkipEffect ::
  Emitter IO Int ->
  Emitter IO Gap ->
  CoEmitter IO Gap
gapSkipEffect :: Emitter IO Int -> Emitter IO Gap -> CoEmitter IO Gap
gapSkipEffect Emitter IO Int
n Emitter IO Gap
e = forall s a. s -> Emitter (StateT s IO) a -> CoEmitter IO a
evalEmitter Int
0 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. m (Maybe a) -> Emitter m a
Emitter forall a b. (a -> b) -> a -> b
$ do
  Maybe Int
n' <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Emitter m a -> m (Maybe a)
emit Emitter IO Int
n
  Maybe Gap
e' <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Emitter m a -> m (Maybe a)
emit Emitter IO Gap
e
  Int
count <- forall s (m :: * -> *). MonadState s m => m s
get
  forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (Int
1 +)
  case (Maybe Int
n', Maybe Gap
e') of
    (Maybe Int
_, Maybe Gap
Nothing) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
    (Maybe Int
Nothing, Maybe Gap
_) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
    (Just Int
n'', Just Gap
e'') ->
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (forall a. a -> a -> Bool -> a
bool Gap
e'' Gap
0 (Int
n'' forall a. Ord a => a -> a -> Bool
>= Int
count))

-- | Only add a Gap if greater than the Int emitter
--
-- effect is similar to a fast-forward of the first n emits
speedSkipEffect ::
  Emitter IO (Int, Gap) ->
  Emitter IO (Gap, a) ->
  CoEmitter IO a
speedSkipEffect :: forall a.
Emitter IO (Int, Gap) -> Emitter IO (Gap, a) -> CoEmitter IO a
speedSkipEffect Emitter IO (Int, Gap)
p Emitter IO (Gap, a)
e = forall s a. s -> Emitter (StateT s IO) a -> CoEmitter IO a
evalEmitter Int
0 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. m (Maybe a) -> Emitter m a
Emitter forall a b. (a -> b) -> a -> b
$ do
  Maybe (Int, Gap)
p' <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Emitter m a -> m (Maybe a)
emit Emitter IO (Int, Gap)
p
  Maybe (Gap, a)
e' <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Emitter m a -> m (Maybe a)
emit Emitter IO (Gap, a)
e
  Int
count <- forall s (m :: * -> *). MonadState s m => m s
get
  forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (Int
1 +)
  case (Maybe (Int, Gap)
p', Maybe (Gap, a)
e') of
    (Maybe (Int, Gap)
_, Maybe (Gap, a)
Nothing) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
    (Maybe (Int, Gap)
Nothing, Maybe (Gap, a)
_) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
    (Just (Int
n, Gap
s), Just (Gap
g, a
a)) ->
      forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ Gap -> IO ()
sleep (forall a. a -> a -> Bool -> a
bool (Gap
g forall a. Fractional a => a -> a -> a
/ Gap
s) Gap
0 (Int
n forall a. Ord a => a -> a -> Bool
>= Int
count)) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> Maybe a
Just a
a)

-- | Ignore the first n gaps and immediately emit them.
skip :: Int -> Emitter IO (Gap, a) -> CoEmitter IO (Gap, a)
skip :: forall a. Int -> Emitter IO (Gap, a) -> CoEmitter IO (Gap, a)
skip Int
sk Emitter IO (Gap, a)
e = forall s a. s -> Emitter (StateT s IO) a -> CoEmitter IO a
evalEmitter (Int
sk forall a. Num a => a -> a -> a
+ Int
1) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. m (Maybe a) -> Emitter m a
Emitter forall a b. (a -> b) -> a -> b
$ do
  Int
skip' <- forall s (m :: * -> *). MonadState s m => m s
get
  Maybe (Gap, a)
e' <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Emitter m a -> m (Maybe a)
emit Emitter IO (Gap, a)
e
  case Maybe (Gap, a)
e' of
    Maybe (Gap, a)
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
    Just (Gap
secs, a
a) -> do
      case Int
skip' of
        Int
0 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> Maybe a
Just (Gap
secs, a
a))
        Int
_ -> do
          forall s (m :: * -> *). MonadState s m => s -> m ()
put (Int
skip' forall a. Num a => a -> a -> a
- Int
1)
          forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> Maybe a
Just (Gap
0, a
a))

-- | Replay a stamped emitter, adjusting the speed of the replay.
--
-- > toListM . stampE <$|> (replay 0.1 1 =<< (fromGapsNow =<< (qList (zip (0:repeat 1) [1..4]))))
-- > [(2022-08-31 02:29:39.643831,1),(2022-08-31 02:29:39.643841,2),(2022-08-31 02:29:39.746998,3),(2022-08-31 02:29:39.849615,4)]
replay :: Double -> Int -> Emitter IO (LocalTime, a) -> CoEmitter IO a
replay :: forall a. Gap -> Int -> Emitter IO (LocalTime, a) -> CoEmitter IO a
replay Gap
speed Int
sk Emitter IO (LocalTime, a)
e = forall a. Emitter IO (Gap, a) -> Emitter IO a
gapEffect forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Gap
speed *)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall a. Int -> Emitter IO (Gap, a) -> CoEmitter IO (Gap, a)
skip Int
sk forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a. Emitter IO (LocalTime, a) -> CoEmitter IO (Gap, a)
gaps Emitter IO (LocalTime, a)
e)