module Blucontrol.Main.Control (
  loopRecolor
) where

import Control.Monad
import Control.Monad.Base
import Control.Monad.Trans.Control
import Unsafe.Coerce

import Blucontrol.Monad.ApplyValue
import Blucontrol.Monad.Control
import Blucontrol.Monad.PrepareValue

-- | Run the loop, using `prepareValue`, `applyValue` and `doInbetween`.
loopRecolor :: (ControlConstraint mc (StM mp (StM ma ())), MonadBaseControl IO mc, MonadBaseControl IO mp, MonadBaseControl IO ma, MonadApplyValue ma, MonadControl mc, MonadPrepareValue mp)
            => RunInBase mc IO
            -> RunInBase mp IO
            -> RunInBase ma IO
            -> (PreparedValue mp -> ApplicableValue ma)
            -> IO ()
loopRecolor :: forall (mc :: * -> *) (mp :: * -> *) (ma :: * -> *).
(ControlConstraint mc (StM mp (StM ma ())), MonadBaseControl IO mc,
 MonadBaseControl IO mp, MonadBaseControl IO ma, MonadApplyValue ma,
 MonadControl mc, MonadPrepareValue mp) =>
RunInBase mc IO
-> RunInBase mp IO
-> RunInBase ma IO
-> (PreparedValue mp -> ApplicableValue ma)
-> IO ()
loopRecolor RunInBase mc IO
runC RunInBase mp IO
runP RunInBase ma IO
runA PreparedValue mp -> ApplicableValue ma
coerceValue = do

      -- Use `preparedValue` and give the result to `applyValue`.
      -- Then use the result of `applyValue` and give it to `doInbetween` including the monadic state.
      -- The argument is an initial monadic state.
  let doRecolor :: StM mc (StM mp (StM ma Any)) -> IO (StM mc (StM mp (StM ma Any)))
doRecolor StM mc (StM mp (StM ma Any))
x =
        mc (StM mp (StM ma Any)) -> IO (StM mc (StM mp (StM ma Any)))
RunInBase mc IO
runC (mc (StM mp (StM ma Any)) -> IO (StM mc (StM mp (StM ma Any))))
-> mc (StM mp (StM ma Any)) -> IO (StM mc (StM mp (StM ma Any)))
forall a b. (a -> b) -> a -> b
$ do
          StM mp (StM ma Any)
x1 <- StM mc (StM mp (StM ma Any)) -> mc (StM mp (StM ma Any))
forall a. StM mc a -> mc a
forall (b :: * -> *) (m :: * -> *) a.
MonadBaseControl b m =>
StM m a -> m a
restoreM StM mc (StM mp (StM ma Any))
x
          StM mp (StM ma Any)
x4 <- IO (StM mp (StM ma Any)) -> mc (StM mp (StM ma Any))
forall α. IO α -> mc α
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO (StM mp (StM ma Any)) -> mc (StM mp (StM ma Any)))
-> IO (StM mp (StM ma Any)) -> mc (StM mp (StM ma Any))
forall a b. (a -> b) -> a -> b
$ do
            mp (StM ma Any) -> IO (StM mp (StM ma Any))
RunInBase mp IO
runP (mp (StM ma Any) -> IO (StM mp (StM ma Any)))
-> mp (StM ma Any) -> IO (StM mp (StM ma Any))
forall a b. (a -> b) -> a -> b
$ do
              StM ma Any
x2 <- StM mp (StM ma Any) -> mp (StM ma Any)
forall a. StM mp a -> mp a
forall (b :: * -> *) (m :: * -> *) a.
MonadBaseControl b m =>
StM m a -> m a
restoreM StM mp (StM ma Any)
x1
              ApplicableValue ma
value <- PreparedValue mp -> ApplicableValue ma
coerceValue (PreparedValue mp -> ApplicableValue ma)
-> mp (PreparedValue mp) -> mp (ApplicableValue ma)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> mp (PreparedValue mp)
forall (m :: * -> *). MonadPrepareValue m => m (PreparedValue m)
preparedValue
              IO (StM ma Any) -> mp (StM ma Any)
forall α. IO α -> mp α
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO (StM ma Any) -> mp (StM ma Any))
-> IO (StM ma Any) -> mp (StM ma Any)
forall a b. (a -> b) -> a -> b
$ ma Any -> IO (StM ma Any)
RunInBase ma IO
runA (ma Any -> IO (StM ma Any)) -> ma Any -> IO (StM ma Any)
forall a b. (a -> b) -> a -> b
$ do
                Any
x3 <- StM ma Any -> ma Any
forall a. StM ma a -> ma a
forall (b :: * -> *) (m :: * -> *) a.
MonadBaseControl b m =>
StM m a -> m a
restoreM StM ma Any
x2
                ApplicableValue ma -> ma ()
forall (m :: * -> *).
MonadApplyValue m =>
ApplicableValue m -> m ()
applyValue ApplicableValue ma
value
                Any -> ma Any
forall a. a -> ma a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Any
x3
          let currentRecolorValue :: IO (StM mp (StM ma ()))
currentRecolorValue =
                mp (StM ma ()) -> IO (StM mp (StM ma ()))
RunInBase mp IO
runP (mp (StM ma ()) -> IO (StM mp (StM ma ())))
-> mp (StM ma ()) -> IO (StM mp (StM ma ()))
forall a b. (a -> b) -> a -> b
$ do
                  -- TODO: `unsafeCoerce` is necessary because of GHC limitations with type families.
                  -- `unsafeCoerce` will act like `id`.
                  StM ma Any
x5 <- StM mp (StM ma Any) -> mp (StM ma Any)
forall a. StM mp a -> mp a
forall (b :: * -> *) (m :: * -> *) a.
MonadBaseControl b m =>
StM m a -> m a
restoreM (StM mp (StM ma Any) -> mp (StM ma Any))
-> StM mp (StM ma Any) -> mp (StM ma Any)
forall a b. (a -> b) -> a -> b
$ StM mp (StM ma Any) -> StM mp (StM ma Any)
forall a b. a -> b
unsafeCoerce StM mp (StM ma Any)
x4
                  IO (StM ma ()) -> mp (StM ma ())
forall α. IO α -> mp α
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO (StM ma ()) -> mp (StM ma ()))
-> IO (StM ma ()) -> mp (StM ma ())
forall a b. (a -> b) -> a -> b
$ ma () -> IO (StM ma ())
RunInBase ma IO
runA (ma () -> IO (StM ma ())) -> ma () -> IO (StM ma ())
forall a b. (a -> b) -> a -> b
$ ma Any -> ma ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ma Any -> ma ()) -> ma Any -> ma ()
forall a b. (a -> b) -> a -> b
$ StM ma Any -> ma Any
forall a. StM ma a -> ma a
forall (b :: * -> *) (m :: * -> *) a.
MonadBaseControl b m =>
StM m a -> m a
restoreM StM ma Any
x5
          StM mp (StM ma ())
currentRecolorValue' <- IO (StM mp (StM ma ())) -> mc (StM mp (StM ma ()))
forall α. IO α -> mc α
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase IO (StM mp (StM ma ()))
currentRecolorValue
          StM mp (StM ma ()) -> mc ()
forall a. ControlConstraint mc a => a -> mc ()
forall (m :: * -> *) a.
(MonadControl m, ControlConstraint m a) =>
a -> m ()
doInbetween StM mp (StM ma ())
currentRecolorValue'
          StM mp (StM ma Any) -> mc (StM mp (StM ma Any))
forall a. a -> mc a
forall (f :: * -> *) a. Applicative f => a -> f a
pure StM mp (StM ma Any)
x4

      -- Run `doLoopRecolor` in a recursive loop while passing the monadic state explicitly.
      doLoopRecolor :: StM mc (StM mp (StM ma Any)) -> IO ()
doLoopRecolor StM mc (StM mp (StM ma Any))
x = StM mc (StM mp (StM ma Any)) -> IO ()
doLoopRecolor (StM mc (StM mp (StM ma Any)) -> IO ())
-> IO (StM mc (StM mp (StM ma Any))) -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO (StM mc (StM mp (StM ma Any)))
-> IO (StM mc (StM mp (StM ma Any)))
forall α. IO α -> IO α
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (StM mc (StM mp (StM ma Any)) -> IO (StM mc (StM mp (StM ma Any)))
doRecolor StM mc (StM mp (StM ma Any))
x)

  -- Initialize the monadic state.
  StM mc (StM mp (StM ma Any))
initStM <- mc (StM mp (StM ma Any)) -> IO (StM mc (StM mp (StM ma Any)))
RunInBase mc IO
runC (mc (StM mp (StM ma Any)) -> IO (StM mc (StM mp (StM ma Any))))
-> mc (StM mp (StM ma Any)) -> IO (StM mc (StM mp (StM ma Any)))
forall a b. (a -> b) -> a -> b
$ IO (StM mp (StM ma Any)) -> mc (StM mp (StM ma Any))
forall α. IO α -> mc α
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO (StM mp (StM ma Any)) -> mc (StM mp (StM ma Any)))
-> IO (StM mp (StM ma Any)) -> mc (StM mp (StM ma Any))
forall a b. (a -> b) -> a -> b
$ mp (StM ma Any) -> IO (StM mp (StM ma Any))
RunInBase mp IO
runP (mp (StM ma Any) -> IO (StM mp (StM ma Any)))
-> mp (StM ma Any) -> IO (StM mp (StM ma Any))
forall a b. (a -> b) -> a -> b
$ IO (StM ma Any) -> mp (StM ma Any)
forall α. IO α -> mp α
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO (StM ma Any) -> mp (StM ma Any))
-> IO (StM ma Any) -> mp (StM ma Any)
forall a b. (a -> b) -> a -> b
$ ma Any -> IO (StM ma Any)
RunInBase ma IO
runA (ma Any -> IO (StM ma Any)) -> ma Any -> IO (StM ma Any)
forall a b. (a -> b) -> a -> b
$ Any -> ma Any
forall a. a -> ma a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Any
forall a. HasCallStack => a
undefined

  -- Start an infinite loop.
  -- TODO: `unsafeCoerce` is necessary because of GHC limitations with type families.
  -- `unsafeCoerce` will act like `id`.
  StM mc (StM mp (StM ma Any)) -> IO ()
doLoopRecolor (StM mc (StM mp (StM ma Any)) -> IO ())
-> StM mc (StM mp (StM ma Any)) -> IO ()
forall a b. (a -> b) -> a -> b
$ StM mc (StM mp (StM ma Any)) -> StM mc (StM mp (StM ma Any))
forall a b. a -> b
unsafeCoerce StM mc (StM mp (StM ma Any))
initStM