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
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)
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
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
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)
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)
type Gap = Double
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'
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')
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
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
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
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))
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)
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 :: 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)