module Blucontrol.Main.Control (
  loopRecolor
) where

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

import Blucontrol.Monad.Control
import Blucontrol.Monad.Gamma
import Blucontrol.Monad.Recolor

-- | Run the loop, using `gamma`, `recolor` and `doInbetween`.
loopRecolor :: (MonadBaseControl IO m, MonadBaseControl IO g, MonadBaseControl IO r, MonadControl m, MonadGamma g, MonadRecolor r, ControlConstraint m (StM g (StM r ())))
            => RunInBase m IO
            -> RunInBase g IO
            -> RunInBase r IO
            -> (GammaValue g -> RecolorValue r)
            -> IO ()
loopRecolor :: RunInBase m IO
-> RunInBase g IO
-> RunInBase r IO
-> (GammaValue g -> RecolorValue r)
-> IO ()
loopRecolor RunInBase m IO
runC RunInBase g IO
runG RunInBase r IO
runR GammaValue g -> RecolorValue r
coerceValue = do

      -- Use `gamma` and give the result to `recolor`.
      -- Then use the result of `recolor` and give it to `doInbetween` including the monadic state.
      -- The argument is an initial monadic state.
  let doRecolorGamma :: StM m (StM g (StM r Any)) -> IO (StM m (StM g (StM r Any)))
doRecolorGamma StM m (StM g (StM r Any))
x =
        m (StM g (StM r Any)) -> IO (StM m (StM g (StM r Any)))
RunInBase m IO
runC (m (StM g (StM r Any)) -> IO (StM m (StM g (StM r Any))))
-> m (StM g (StM r Any)) -> IO (StM m (StM g (StM r Any)))
forall a b. (a -> b) -> a -> b
$ do
          StM g (StM r Any)
x1 <- StM m (StM g (StM r Any)) -> m (StM g (StM r Any))
forall (b :: * -> *) (m :: * -> *) a.
MonadBaseControl b m =>
StM m a -> m a
restoreM StM m (StM g (StM r Any))
x
          StM g (StM r Any)
x4 <- IO (StM g (StM r Any)) -> m (StM g (StM r Any))
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO (StM g (StM r Any)) -> m (StM g (StM r Any)))
-> IO (StM g (StM r Any)) -> m (StM g (StM r Any))
forall a b. (a -> b) -> a -> b
$ do
            g (StM r Any) -> IO (StM g (StM r Any))
RunInBase g IO
runG (g (StM r Any) -> IO (StM g (StM r Any)))
-> g (StM r Any) -> IO (StM g (StM r Any))
forall a b. (a -> b) -> a -> b
$ do
              StM r Any
x2 <- StM g (StM r Any) -> g (StM r Any)
forall (b :: * -> *) (m :: * -> *) a.
MonadBaseControl b m =>
StM m a -> m a
restoreM StM g (StM r Any)
x1
              RecolorValue r
value <- GammaValue g -> RecolorValue r
coerceValue (GammaValue g -> RecolorValue r)
-> g (GammaValue g) -> g (RecolorValue r)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> g (GammaValue g)
forall (m :: * -> *). MonadGamma m => m (GammaValue m)
gamma
              IO (StM r Any) -> g (StM r Any)
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO (StM r Any) -> g (StM r Any))
-> IO (StM r Any) -> g (StM r Any)
forall a b. (a -> b) -> a -> b
$ r Any -> IO (StM r Any)
RunInBase r IO
runR (r Any -> IO (StM r Any)) -> r Any -> IO (StM r Any)
forall a b. (a -> b) -> a -> b
$ do
                Any
x3 <- StM r Any -> r Any
forall (b :: * -> *) (m :: * -> *) a.
MonadBaseControl b m =>
StM m a -> m a
restoreM StM r Any
x2
                RecolorValue r -> r ()
forall (m :: * -> *). MonadRecolor m => RecolorValue m -> m ()
recolor RecolorValue r
value
                Any -> r Any
forall (f :: * -> *) a. Applicative f => a -> f a
pure Any
x3
          let currentRecolorValue :: IO (StM g (StM r ()))
currentRecolorValue =
                g (StM r ()) -> IO (StM g (StM r ()))
RunInBase g IO
runG (g (StM r ()) -> IO (StM g (StM r ())))
-> g (StM r ()) -> IO (StM g (StM r ()))
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 r Any
x5 <- StM g (StM r Any) -> g (StM r Any)
forall (b :: * -> *) (m :: * -> *) a.
MonadBaseControl b m =>
StM m a -> m a
restoreM (StM g (StM r Any) -> g (StM r Any))
-> StM g (StM r Any) -> g (StM r Any)
forall a b. (a -> b) -> a -> b
$ StM g (StM r Any) -> StM g (StM r Any)
forall a b. a -> b
unsafeCoerce StM g (StM r Any)
x4
                  IO (StM r ()) -> g (StM r ())
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO (StM r ()) -> g (StM r ())) -> IO (StM r ()) -> g (StM r ())
forall a b. (a -> b) -> a -> b
$ r () -> IO (StM r ())
RunInBase r IO
runR (r () -> IO (StM r ())) -> r () -> IO (StM r ())
forall a b. (a -> b) -> a -> b
$ r Any -> r ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (r Any -> r ()) -> r Any -> r ()
forall a b. (a -> b) -> a -> b
$ StM r Any -> r Any
forall (b :: * -> *) (m :: * -> *) a.
MonadBaseControl b m =>
StM m a -> m a
restoreM StM r Any
x5
          StM g (StM r ())
currentRecolorValue' <- IO (StM g (StM r ())) -> m (StM g (StM r ()))
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase IO (StM g (StM r ()))
currentRecolorValue
          StM g (StM r ()) -> m ()
forall (m :: * -> *) a.
(MonadControl m, ControlConstraint m a) =>
a -> m ()
doInbetween StM g (StM r ())
currentRecolorValue'
          StM g (StM r Any) -> m (StM g (StM r Any))
forall (f :: * -> *) a. Applicative f => a -> f a
pure StM g (StM r Any)
x4

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

  -- Initialize the monadic state.
  StM m (StM g (StM r Any))
initStM <- m (StM g (StM r Any)) -> IO (StM m (StM g (StM r Any)))
RunInBase m IO
runC (m (StM g (StM r Any)) -> IO (StM m (StM g (StM r Any))))
-> m (StM g (StM r Any)) -> IO (StM m (StM g (StM r Any)))
forall a b. (a -> b) -> a -> b
$ IO (StM g (StM r Any)) -> m (StM g (StM r Any))
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO (StM g (StM r Any)) -> m (StM g (StM r Any)))
-> IO (StM g (StM r Any)) -> m (StM g (StM r Any))
forall a b. (a -> b) -> a -> b
$ g (StM r Any) -> IO (StM g (StM r Any))
RunInBase g IO
runG (g (StM r Any) -> IO (StM g (StM r Any)))
-> g (StM r Any) -> IO (StM g (StM r Any))
forall a b. (a -> b) -> a -> b
$ IO (StM r Any) -> g (StM r Any)
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO (StM r Any) -> g (StM r Any))
-> IO (StM r Any) -> g (StM r Any)
forall a b. (a -> b) -> a -> b
$ r Any -> IO (StM r Any)
RunInBase r IO
runR (r Any -> IO (StM r Any)) -> r Any -> IO (StM r Any)
forall a b. (a -> b) -> a -> b
$ Any -> r Any
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 m (StM g (StM r Any)) -> IO ()
doLoopRecolor (StM m (StM g (StM r Any)) -> IO ())
-> StM m (StM g (StM r Any)) -> IO ()
forall a b. (a -> b) -> a -> b
$ StM m (StM g (StM r Any)) -> StM m (StM g (StM r Any))
forall a b. a -> b
unsafeCoerce StM m (StM g (StM r Any))
initStM