module Blucontrol.Main.Control (
  loopRecolor
, ConfigControl (..)
) where

import Control.Monad.Base
import Control.Monad.Trans.Control
import Control.Monad.Reader
import Control.Monad.State.Strict

import Blucontrol.Control
import Blucontrol.Gamma
import Blucontrol.Recolor
import Blucontrol.RGB

-- | Run the loop, using `gamma`, `recolor` and `doInbetween`.
-- The arguments are the actual monad runners.
loopRecolor :: (ControlConstraint m (StM g (StM r ())), MonadBaseControl IO g, MonadBaseControl IO r, MonadControl m, MonadGamma c g, MonadRecolor r)
            => (forall a. g a -> IO (StM g a))
            -> (forall a. r a -> IO (StM r a))
            -> m ()
loopRecolor :: (forall a. g a -> IO (StM g a))
-> (forall a. r a -> IO (StM r a)) -> m ()
loopRecolor forall a. g a -> IO (StM g a)
runG forall a. r a -> IO (StM r a)
runR = m (StM r (StM g ())) -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m (StM r (StM g ())) -> m ()) -> m (StM r (StM g ())) -> m ()
forall a b. (a -> b) -> a -> b
$
  (RunInBase m IO -> IO (StM r (StM g ()))) -> m (StM r (StM g ()))
forall (b :: * -> *) (m :: * -> *) a.
MonadBaseControl b m =>
(RunInBase m b -> b a) -> m a
liftBaseWith ((RunInBase m IO -> IO (StM r (StM g ()))) -> m (StM r (StM g ())))
-> (RunInBase m IO -> IO (StM r (StM g ())))
-> m (StM r (StM g ()))
forall a b. (a -> b) -> a -> b
$ \ RunInBase m IO
runCIO ->
    r (StM g ()) -> IO (StM r (StM g ()))
forall a. r a -> IO (StM r a)
runR (r (StM g ()) -> IO (StM r (StM g ())))
-> r (StM g ()) -> IO (StM r (StM g ()))
forall a b. (a -> b) -> a -> b
$ ((forall a. r a -> IO (StM r a)) -> IO (StM g ())) -> r (StM g ())
forall (b :: * -> *) (m :: * -> *) a.
MonadBaseControl b m =>
(RunInBase m b -> b a) -> m a
liftBaseWith (((forall a. r a -> IO (StM r a)) -> IO (StM g ()))
 -> r (StM g ()))
-> ((forall a. r a -> IO (StM r a)) -> IO (StM g ()))
-> r (StM g ())
forall a b. (a -> b) -> a -> b
$ \ forall a. r a -> IO (StM r a)
runRIO ->
      g () -> IO (StM g ())
forall a. g a -> IO (StM g a)
runG (g () -> IO (StM g ())) -> g () -> IO (StM g ())
forall a b. (a -> b) -> a -> b
$ ((forall a. g a -> IO (StM g a)) -> IO ()) -> g ()
forall (b :: * -> *) (m :: * -> *) a.
MonadBaseControl b m =>
(RunInBase m b -> b a) -> m a
liftBaseWith (((forall a. g a -> IO (StM g a)) -> IO ()) -> g ())
-> ((forall a. g a -> IO (StM g a)) -> IO ()) -> g ()
forall a b. (a -> b) -> a -> b
$ \ forall a. g a -> IO (StM g a)
runGIO -> do
        StM g (StM r ())
firstResult <- (forall a. g a -> IO (StM g a))
-> (forall a. r a -> IO (StM r a)) -> IO (StM g (StM r ()))
forall (g :: * -> *) (r :: * -> *) c.
(MonadBaseControl IO g, MonadBaseControl IO r, MonadGamma c g,
 MonadRecolor r) =>
(forall a. g a -> IO (StM g a))
-> (forall a. r a -> IO (StM r a)) -> IO (StM g (StM r ()))
doRecolorGamma forall a. g a -> IO (StM g a)
runGIO forall a. r a -> IO (StM r a)
runRIO
        StateT (StM g (StM r ())) IO () -> StM g (StM r ()) -> IO ()
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (RunInBase m IO
-> (forall a. g a -> IO (StM g a))
-> (forall a. r a -> IO (StM r a))
-> StateT (StM g (StM r ())) IO ()
forall (m :: * -> *) (g :: * -> *) (r :: * -> *) c.
(ControlConstraint m (StM g (StM r ())), MonadBaseControl IO g,
 MonadBaseControl IO r, MonadControl m, MonadGamma c g,
 MonadRecolor r) =>
(forall a. m a -> IO (StM m a))
-> (forall a. g a -> IO (StM g a))
-> (forall a. r a -> IO (StM r a))
-> StateT (StM g (StM r ())) IO ()
doLoopRecolor RunInBase m IO
runCIO forall a. g a -> IO (StM g a)
runGIO forall a. r a -> IO (StM r a)
runRIO) StM g (StM r ())
firstResult

-- | Use `gamma` and give the result to `recolor`.
-- The arguments are runners from `liftBaseWith`.
doRecolorGamma :: (MonadBaseControl IO g, MonadBaseControl IO r, MonadGamma c g, MonadRecolor r)
               => (forall a. g a -> IO (StM g a))
               -> (forall a. r a -> IO (StM r a))
               -> IO (StM g (StM r ()))
doRecolorGamma :: (forall a. g a -> IO (StM g a))
-> (forall a. r a -> IO (StM r a)) -> IO (StM g (StM r ()))
doRecolorGamma forall a. g a -> IO (StM g a)
runGIO forall a. r a -> IO (StM r a)
runRIO = g (StM r ()) -> IO (StM g (StM r ()))
forall a. g a -> IO (StM g a)
runGIO (g (StM r ()) -> IO (StM g (StM r ())))
-> g (StM r ()) -> IO (StM g (StM r ()))
forall a b. (a -> b) -> a -> b
$ do
  Trichromaticity
rgb <- c -> Trichromaticity
forall c. RGB c => c -> Trichromaticity
toRGB (c -> Trichromaticity) -> g c -> g Trichromaticity
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> g c
forall c (m :: * -> *). MonadGamma c m => m c
gamma
  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 ())
forall a. r a -> IO (StM r a)
runRIO (r () -> IO (StM r ())) -> r () -> IO (StM r ())
forall a b. (a -> b) -> a -> b
$ Trichromaticity -> r ()
forall (m :: * -> *). MonadRecolor m => Trichromaticity -> m ()
recolor Trichromaticity
rgb

-- | A single iteration of `loopRecolor`.
-- The arguments are runners from `liftBaseWith`.
doLoopRecolor :: (ControlConstraint m (StM g (StM r ())), MonadBaseControl IO g, MonadBaseControl IO r, MonadControl m, MonadGamma c g, MonadRecolor r)
              => (forall a. m a -> IO (StM m a))
              -> (forall a. g a -> IO (StM g a))
              -> (forall a. r a -> IO (StM r a))
              -> StateT (StM g (StM r ())) IO ()
doLoopRecolor :: (forall a. m a -> IO (StM m a))
-> (forall a. g a -> IO (StM g a))
-> (forall a. r a -> IO (StM r a))
-> StateT (StM g (StM r ())) IO ()
doLoopRecolor forall a. m a -> IO (StM m a)
runCIO forall a. g a -> IO (StM g a)
runGIO forall a. r a -> IO (StM r a)
runRIO = do
  StM g (StM r ())
lastResult <- StateT (StM g (StM r ())) IO (StM g (StM r ()))
forall s (m :: * -> *). MonadState s m => m s
get
  StateT (StM g (StM r ())) IO (StM m ())
-> StateT (StM g (StM r ())) IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (StateT (StM g (StM r ())) IO (StM m ())
 -> StateT (StM g (StM r ())) IO ())
-> StateT (StM g (StM r ())) IO (StM m ())
-> StateT (StM g (StM r ())) IO ()
forall a b. (a -> b) -> a -> b
$ IO (StM m ()) -> StateT (StM g (StM r ())) IO (StM m ())
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO (StM m ()) -> StateT (StM g (StM r ())) IO (StM m ()))
-> IO (StM m ()) -> StateT (StM g (StM r ())) IO (StM m ())
forall a b. (a -> b) -> a -> b
$ m () -> IO (StM m ())
forall a. m a -> IO (StM m a)
runCIO (m () -> IO (StM m ())) -> m () -> IO (StM m ())
forall a b. (a -> b) -> a -> b
$ StM g (StM r ()) -> m ()
forall (m :: * -> *) a.
(MonadControl m, ControlConstraint m a) =>
a -> m ()
doInbetween StM g (StM r ())
lastResult
  StM g (StM r ())
nextResult <- IO (StM g (StM r ()))
-> StateT (StM g (StM r ())) IO (StM g (StM r ()))
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO (StM g (StM r ()))
 -> StateT (StM g (StM r ())) IO (StM g (StM r ())))
-> IO (StM g (StM r ()))
-> StateT (StM g (StM r ())) IO (StM g (StM r ()))
forall a b. (a -> b) -> a -> b
$ (forall a. g a -> IO (StM g a))
-> (forall a. r a -> IO (StM r a)) -> IO (StM g (StM r ()))
forall (g :: * -> *) (r :: * -> *) c.
(MonadBaseControl IO g, MonadBaseControl IO r, MonadGamma c g,
 MonadRecolor r) =>
(forall a. g a -> IO (StM g a))
-> (forall a. r a -> IO (StM r a)) -> IO (StM g (StM r ()))
doRecolorGamma forall a. g a -> IO (StM g a)
runGIO forall a. r a -> IO (StM r a)
runRIO
  StM g (StM r ()) -> StateT (StM g (StM r ())) IO ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put StM g (StM r ())
nextResult
  (forall a. m a -> IO (StM m a))
-> (forall a. g a -> IO (StM g a))
-> (forall a. r a -> IO (StM r a))
-> StateT (StM g (StM r ())) IO ()
forall (m :: * -> *) (g :: * -> *) (r :: * -> *) c.
(ControlConstraint m (StM g (StM r ())), MonadBaseControl IO g,
 MonadBaseControl IO r, MonadControl m, MonadGamma c g,
 MonadRecolor r) =>
(forall a. m a -> IO (StM m a))
-> (forall a. g a -> IO (StM g a))
-> (forall a. r a -> IO (StM r a))
-> StateT (StM g (StM r ())) IO ()
doLoopRecolor forall a. m a -> IO (StM m a)
runCIO forall a. g a -> IO (StM g a)
runGIO forall a. r a -> IO (StM r a)
runRIO

data ConfigControl m g r = ConfigControl { ConfigControl m g r -> forall a. m a -> IO a
runControl :: forall a. m a -> IO a
                                         , ConfigControl m g r -> forall a. g a -> IO (StM g a)
runGamma   :: forall a. g a -> IO (StM g a)
                                         , ConfigControl m g r -> forall a. r a -> IO (StM r a)
runRecolor :: forall a. r a -> IO (StM r a)
                                         }