{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE UndecidableInstances #-}

-- | A clock that removes the 'ScheduleT' transformer from the stack by interpreting its actions in a monad
module FRP.Rhine.Clock.Unschedule where

-- base
import Control.Arrow
import Control.Concurrent qualified as Concurrent (yield)
import Control.Monad.IO.Class

-- monad-schedule
import Control.Monad.Schedule.Trans

-- automaton
import Data.Automaton (hoistS)

-- rhine
import FRP.Rhine.Clock

{- | If @cl@ is a 'Clock' in 'ScheduleT diff m', apply 'UnscheduleClock'
  to get a clock in 'm'.
-}
data UnscheduleClock m cl = UnscheduleClock
  { forall (m :: Type -> Type) cl. UnscheduleClock m cl -> cl
scheduleClock :: cl
  , forall (m :: Type -> Type) cl.
UnscheduleClock m cl -> Diff (Time cl) -> m ()
scheduleWait :: Diff (Time cl) -> m ()
  }

{- | Remove a 'ScheduleT' layer from the monad transformer stack of the clock.

The 'yield' action is interpreted as thread yielding in 'IO'.
-}
unyieldClock :: cl -> UnscheduleClock IO cl
unyieldClock :: forall cl. cl -> UnscheduleClock IO cl
unyieldClock cl
cl = cl -> (Diff (Time cl) -> IO ()) -> UnscheduleClock IO cl
forall (m :: Type -> Type) cl.
cl -> (Diff (Time cl) -> m ()) -> UnscheduleClock m cl
UnscheduleClock cl
cl ((Diff (Time cl) -> IO ()) -> UnscheduleClock IO cl)
-> (Diff (Time cl) -> IO ()) -> UnscheduleClock IO cl
forall a b. (a -> b) -> a -> b
$ IO () -> Diff (Time cl) -> IO ()
forall a b. a -> b -> a
const (IO () -> Diff (Time cl) -> IO ())
-> IO () -> Diff (Time cl) -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO ()
forall a. IO a -> IO a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO IO ()
Concurrent.yield

instance (TimeDomain (Time cl), Clock (ScheduleT (Diff (Time cl)) m) cl, Monad m) => Clock m (UnscheduleClock m cl) where
  type Tag (UnscheduleClock _ cl) = Tag cl
  type Time (UnscheduleClock _ cl) = Time cl
  initClock :: UnscheduleClock m cl
-> RunningClockInit
     m (Time (UnscheduleClock m cl)) (Tag (UnscheduleClock m cl))
initClock UnscheduleClock {cl
scheduleClock :: forall (m :: Type -> Type) cl. UnscheduleClock m cl -> cl
scheduleClock :: cl
scheduleClock, Diff (Time cl) -> m ()
scheduleWait :: forall (m :: Type -> Type) cl.
UnscheduleClock m cl -> Diff (Time cl) -> m ()
scheduleWait :: Diff (Time cl) -> m ()
scheduleWait} = ScheduleT
  (Diff (Time cl))
  m
  (RunningClock
     m (Time (UnscheduleClock m cl)) (Tag (UnscheduleClock m cl)),
   Time (UnscheduleClock m cl))
-> RunningClockInit
     m (Time (UnscheduleClock m cl)) (Tag (UnscheduleClock m cl))
forall a. ScheduleT (Diff (Time cl)) m a -> m a
run (ScheduleT
   (Diff (Time cl))
   m
   (RunningClock
      m (Time (UnscheduleClock m cl)) (Tag (UnscheduleClock m cl)),
    Time (UnscheduleClock m cl))
 -> RunningClockInit
      m (Time (UnscheduleClock m cl)) (Tag (UnscheduleClock m cl)))
-> ScheduleT
     (Diff (Time cl))
     m
     (RunningClock
        m (Time (UnscheduleClock m cl)) (Tag (UnscheduleClock m cl)),
      Time (UnscheduleClock m cl))
-> RunningClockInit
     m (Time (UnscheduleClock m cl)) (Tag (UnscheduleClock m cl))
forall a b. (a -> b) -> a -> b
$ (Automaton (ScheduleT (Diff (Time cl)) m) () (Time cl, Tag cl)
 -> RunningClock m (Time cl) (Tag cl))
-> (Automaton (ScheduleT (Diff (Time cl)) m) () (Time cl, Tag cl),
    Time cl)
-> (RunningClock m (Time cl) (Tag cl), Time cl)
forall b c d. (b -> c) -> (b, d) -> (c, d)
forall (a :: Type -> Type -> Type) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first ((forall a. ScheduleT (Diff (Time cl)) m a -> m a)
-> Automaton (ScheduleT (Diff (Time cl)) m) () (Time cl, Tag cl)
-> RunningClock m (Time cl) (Tag cl)
forall (m :: Type -> Type) (n :: Type -> Type) a b.
Monad m =>
(forall x. m x -> n x) -> Automaton m a b -> Automaton n a b
hoistS ScheduleT (Diff (Time cl)) m x -> m x
forall a. ScheduleT (Diff (Time cl)) m a -> m a
run) ((Automaton (ScheduleT (Diff (Time cl)) m) () (Time cl, Tag cl),
  Time cl)
 -> (RunningClock m (Time cl) (Tag cl), Time cl))
-> FreeT
     (Wait (Diff (Time cl)))
     m
     (Automaton (ScheduleT (Diff (Time cl)) m) () (Time cl, Tag cl),
      Time cl)
-> FreeT
     (Wait (Diff (Time cl)))
     m
     (RunningClock m (Time cl) (Tag cl), Time cl)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> cl
-> FreeT
     (Wait (Diff (Time cl)))
     m
     (Automaton (ScheduleT (Diff (Time cl)) m) () (Time cl, Tag cl),
      Time cl)
forall (m :: Type -> Type) cl.
Clock m cl =>
cl -> RunningClockInit m (Time cl) (Tag cl)
initClock cl
scheduleClock
    where
      run :: ScheduleT (Diff (Time cl)) m a -> m a
      run :: forall a. ScheduleT (Diff (Time cl)) m a -> m a
run = (Diff (Time cl) -> m ())
-> FreeT (Wait (Diff (Time cl))) m a -> m a
forall (m :: Type -> Type) diff a.
Monad m =>
(diff -> m ()) -> ScheduleT diff m a -> m a
runScheduleT Diff (Time cl) -> m ()
scheduleWait