{-# 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 qualified Control.Concurrent as Concurrent (yield)
import Control.Monad.IO.Class

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

-- 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 ()
  }

-- 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 = forall (m :: Type -> Type) cl.
cl -> (Diff (Time cl) -> m ()) -> UnscheduleClock m cl
UnscheduleClock cl
cl forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO IO ()
Concurrent.yield

instance (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 :: cl
scheduleClock :: forall (m :: Type -> Type) cl. UnscheduleClock m cl -> cl
scheduleClock, Diff (Time cl) -> m ()
scheduleWait :: Diff (Time cl) -> m ()
scheduleWait :: forall (m :: Type -> Type) cl.
UnscheduleClock m cl -> Diff (Time cl) -> m ()
scheduleWait} = forall a. ScheduleT (Diff (Time cl)) m a -> m a
run forall a b. (a -> b) -> a -> b
$ forall (a :: Type -> Type -> Type) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (forall (m2 :: Type -> Type) (m1 :: Type -> Type) a b.
(Monad m2, Monad m1) =>
(forall c. m1 c -> m2 c) -> MSF m1 a b -> MSF m2 a b
morphS forall a. ScheduleT (Diff (Time cl)) m a -> m a
run) forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 = forall (m :: Type -> Type) diff a.
Monad m =>
(diff -> m ()) -> ScheduleT diff m a -> m a
runScheduleT Diff (Time cl) -> m ()
scheduleWait