{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}

-- | A "'Busy'" clock that ticks without waiting.
module FRP.Rhine.Clock.Realtime.Busy where

-- base
import Control.Arrow
import Control.Monad.IO.Class

-- time
import Data.Time.Clock

-- automaton
import Data.Automaton (constM)

-- rhine
import FRP.Rhine.Clock
import FRP.Rhine.Clock.Proxy

{- |
A clock that ticks without waiting.
All time passed between ticks amounts to computation time,
side effects, time measurement and framework overhead.
-}
data Busy = Busy

instance (MonadIO m) => Clock m Busy where
  type Time Busy = UTCTime
  type Tag Busy = ()

  initClock :: Busy -> RunningClockInit m (Time Busy) (Tag Busy)
initClock Busy
_ = do
    UTCTime
initialTime <- IO UTCTime -> m UTCTime
forall a. IO a -> m a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
    (Automaton m () (UTCTime, ()), UTCTime)
-> m (Automaton m () (UTCTime, ()), UTCTime)
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return
      ( m UTCTime -> Automaton m () UTCTime
forall (m :: Type -> Type) b a. Functor m => m b -> Automaton m a b
constM (IO UTCTime -> m UTCTime
forall a. IO a -> m a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime)
          Automaton m () UTCTime
-> Automaton m () () -> Automaton m () (UTCTime, ())
forall b c c'.
Automaton m b c -> Automaton m b c' -> Automaton m b (c, c')
forall (a :: Type -> Type -> Type) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& (() -> ()) -> Automaton m () ()
forall b c. (b -> c) -> Automaton m b c
forall (a :: Type -> Type -> Type) b c.
Arrow a =>
(b -> c) -> a b c
arr (() -> () -> ()
forall a b. a -> b -> a
const ())
      , UTCTime
initialTime
      )

instance GetClockProxy Busy