{-# 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,
    Stamped (..),
    stampNow,
    stampE,
    emitIn,
    replay,
  )
where

import Box.Codensity
import Box.Emitter
import Control.Applicative
import Control.Monad.Conc.Class as C
import Control.Monad.IO.Class
import Data.Fixed (Fixed (MkFixed))
import Data.Time
import Prelude

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

-- | 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. (RealFrac a, Integral b) => a -> b
floor (Double -> Int) -> Double -> Int
forall a b. (a -> b) -> a -> b
$ Double
x Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
1e6)

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

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

-- | Add the current time stamp.
--
-- @
-- > process (toListM . stampE) (qList [1..3])
-- [(2022-02-09 01:18:00.293883,1),(2022-02-09 01:18:00.293899,2),(2022-02-09 01:18:00.293903,3)]
-- @
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
witherE (((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 b c a. (b -> c) -> (a -> b) -> a -> c
. a -> m (LocalTime, a)
forall (m :: * -> *) a.
(MonadConc m, MonadIO m) =>
a -> m (LocalTime, a)
stampNow)

-- | Wait s seconds before emitting
emitIn ::
  Emitter IO (Double, a) ->
  Emitter IO a
emitIn :: Emitter IO (Double, a) -> Emitter IO a
emitIn =
  ((Double, a) -> IO (Maybe a))
-> Emitter IO (Double, a) -> Emitter IO a
forall (m :: * -> *) a b.
Monad m =>
(a -> m (Maybe b)) -> Emitter m a -> Emitter m b
witherE
    ( \(Double
s, a
a) -> do
        Double -> IO ()
forall (m :: * -> *). MonadConc m => Double -> m ()
sleep Double
s
        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
    )

-- | Convert emitter stamps to adjusted speed delays
delay :: (Monad m, Alternative m) => Double -> Emitter m (LocalTime, b) -> m (Emitter m (Double, b))
delay :: Double -> Emitter m (LocalTime, b) -> m (Emitter m (Double, b))
delay Double
speed Emitter m (LocalTime, b)
e = do
  Maybe (LocalTime, b)
r <- Emitter m (LocalTime, b) -> m (Maybe (LocalTime, b))
forall (m :: * -> *) a. Emitter m a -> m (Maybe a)
emit Emitter m (LocalTime, b)
e
  case Maybe (LocalTime, b)
r of
    Maybe (LocalTime, b)
Nothing -> Emitter m (Double, b) -> m (Emitter m (Double, b))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Emitter m (Double, b)
forall a. Monoid a => a
mempty
    Just (LocalTime
t0, b
_) -> do
      let delta :: LocalTime -> Double
delta LocalTime
u = NominalDiffTime -> Double
fromNominalDiffTime (NominalDiffTime -> Double) -> NominalDiffTime -> Double
forall a b. (a -> b) -> a -> b
$ LocalTime -> LocalTime -> NominalDiffTime
diffLocalTime LocalTime
u LocalTime
t0 NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* Double -> NominalDiffTime
toNominalDiffTime Double
speed
      Emitter m (Double, b) -> m (Emitter m (Double, b))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (((LocalTime, b) -> m (Maybe (Double, b)))
-> Emitter m (LocalTime, b) -> Emitter m (Double, b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m (Maybe b)) -> Emitter m a -> Emitter m b
witherE (\(LocalTime
l, b
a) -> Maybe (Double, b) -> m (Maybe (Double, b))
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Double, b) -> Maybe (Double, b)
forall a. a -> Maybe a
Just (LocalTime -> Double
delta LocalTime
l, b
a))) Emitter m (LocalTime, b)
e)

-- | Replay a stamped emitter, adjusting the speed of the replay.
--
-- @
-- > glueN 4 showStdout <$|> replay 1 (Emitter $ sleep 0.1 >> Just <$> stampNow ())
-- @
replay :: Double -> Emitter IO (LocalTime, a) -> CoEmitter IO a
replay :: Double -> Emitter IO (LocalTime, a) -> CoEmitter IO a
replay Double
speed Emitter IO (LocalTime, a)
e = (forall b. (Emitter IO a -> IO b) -> IO b) -> CoEmitter IO a
forall k (m :: k -> *) a.
(forall (b :: k). (a -> m b) -> m b) -> Codensity m a
Codensity ((forall b. (Emitter IO a -> IO b) -> IO b) -> CoEmitter IO a)
-> (forall b. (Emitter IO a -> IO b) -> IO b) -> CoEmitter IO a
forall a b. (a -> b) -> a -> b
$ \Emitter IO a -> IO b
eaction -> do
  Emitter IO (Double, a)
e' <- Double -> Emitter IO (LocalTime, a) -> IO (Emitter IO (Double, a))
forall (m :: * -> *) b.
(Monad m, Alternative m) =>
Double -> Emitter m (LocalTime, b) -> m (Emitter m (Double, b))
delay Double
speed Emitter IO (LocalTime, a)
e
  Emitter IO a -> IO b
eaction (Emitter IO (Double, a) -> Emitter IO a
forall a. Emitter IO (Double, a) -> Emitter IO a
emitIn Emitter IO (Double, a)
e')