{-# LANGUAGE UndecidableInstances #-}

module Blucontrol.Main.Control (
  ControlT
, runControlT
, 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

newtype ControlT c m a = ControlT { ControlT c m a -> m a
unControlT :: m a }
  deriving (Functor (ControlT c m)
a -> ControlT c m a
Functor (ControlT c m)
-> (forall a. a -> ControlT c m a)
-> (forall a b.
    ControlT c m (a -> b) -> ControlT c m a -> ControlT c m b)
-> (forall a b c.
    (a -> b -> c)
    -> ControlT c m a -> ControlT c m b -> ControlT c m c)
-> (forall a b. ControlT c m a -> ControlT c m b -> ControlT c m b)
-> (forall a b. ControlT c m a -> ControlT c m b -> ControlT c m a)
-> Applicative (ControlT c m)
ControlT c m a -> ControlT c m b -> ControlT c m b
ControlT c m a -> ControlT c m b -> ControlT c m a
ControlT c m (a -> b) -> ControlT c m a -> ControlT c m b
(a -> b -> c) -> ControlT c m a -> ControlT c m b -> ControlT c m c
forall a. a -> ControlT c m a
forall a b. ControlT c m a -> ControlT c m b -> ControlT c m a
forall a b. ControlT c m a -> ControlT c m b -> ControlT c m b
forall a b.
ControlT c m (a -> b) -> ControlT c m a -> ControlT c m b
forall a b c.
(a -> b -> c) -> ControlT c m a -> ControlT c m b -> ControlT c m c
forall c (m :: * -> *). Applicative m => Functor (ControlT c m)
forall c (m :: * -> *) a. Applicative m => a -> ControlT c m a
forall c (m :: * -> *) a b.
Applicative m =>
ControlT c m a -> ControlT c m b -> ControlT c m a
forall c (m :: * -> *) a b.
Applicative m =>
ControlT c m a -> ControlT c m b -> ControlT c m b
forall c (m :: * -> *) a b.
Applicative m =>
ControlT c m (a -> b) -> ControlT c m a -> ControlT c m b
forall c (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c) -> ControlT c m a -> ControlT c m b -> ControlT c m c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: ControlT c m a -> ControlT c m b -> ControlT c m a
$c<* :: forall c (m :: * -> *) a b.
Applicative m =>
ControlT c m a -> ControlT c m b -> ControlT c m a
*> :: ControlT c m a -> ControlT c m b -> ControlT c m b
$c*> :: forall c (m :: * -> *) a b.
Applicative m =>
ControlT c m a -> ControlT c m b -> ControlT c m b
liftA2 :: (a -> b -> c) -> ControlT c m a -> ControlT c m b -> ControlT c m c
$cliftA2 :: forall c (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c) -> ControlT c m a -> ControlT c m b -> ControlT c m c
<*> :: ControlT c m (a -> b) -> ControlT c m a -> ControlT c m b
$c<*> :: forall c (m :: * -> *) a b.
Applicative m =>
ControlT c m (a -> b) -> ControlT c m a -> ControlT c m b
pure :: a -> ControlT c m a
$cpure :: forall c (m :: * -> *) a. Applicative m => a -> ControlT c m a
$cp1Applicative :: forall c (m :: * -> *). Applicative m => Functor (ControlT c m)
Applicative, a -> ControlT c m b -> ControlT c m a
(a -> b) -> ControlT c m a -> ControlT c m b
(forall a b. (a -> b) -> ControlT c m a -> ControlT c m b)
-> (forall a b. a -> ControlT c m b -> ControlT c m a)
-> Functor (ControlT c m)
forall a b. a -> ControlT c m b -> ControlT c m a
forall a b. (a -> b) -> ControlT c m a -> ControlT c m b
forall c (m :: * -> *) a b.
Functor m =>
a -> ControlT c m b -> ControlT c m a
forall c (m :: * -> *) a b.
Functor m =>
(a -> b) -> ControlT c m a -> ControlT c m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> ControlT c m b -> ControlT c m a
$c<$ :: forall c (m :: * -> *) a b.
Functor m =>
a -> ControlT c m b -> ControlT c m a
fmap :: (a -> b) -> ControlT c m a -> ControlT c m b
$cfmap :: forall c (m :: * -> *) a b.
Functor m =>
(a -> b) -> ControlT c m a -> ControlT c m b
Functor, Applicative (ControlT c m)
a -> ControlT c m a
Applicative (ControlT c m)
-> (forall a b.
    ControlT c m a -> (a -> ControlT c m b) -> ControlT c m b)
-> (forall a b. ControlT c m a -> ControlT c m b -> ControlT c m b)
-> (forall a. a -> ControlT c m a)
-> Monad (ControlT c m)
ControlT c m a -> (a -> ControlT c m b) -> ControlT c m b
ControlT c m a -> ControlT c m b -> ControlT c m b
forall a. a -> ControlT c m a
forall a b. ControlT c m a -> ControlT c m b -> ControlT c m b
forall a b.
ControlT c m a -> (a -> ControlT c m b) -> ControlT c m b
forall c (m :: * -> *). Monad m => Applicative (ControlT c m)
forall c (m :: * -> *) a. Monad m => a -> ControlT c m a
forall c (m :: * -> *) a b.
Monad m =>
ControlT c m a -> ControlT c m b -> ControlT c m b
forall c (m :: * -> *) a b.
Monad m =>
ControlT c m a -> (a -> ControlT c m b) -> ControlT c m b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> ControlT c m a
$creturn :: forall c (m :: * -> *) a. Monad m => a -> ControlT c m a
>> :: ControlT c m a -> ControlT c m b -> ControlT c m b
$c>> :: forall c (m :: * -> *) a b.
Monad m =>
ControlT c m a -> ControlT c m b -> ControlT c m b
>>= :: ControlT c m a -> (a -> ControlT c m b) -> ControlT c m b
$c>>= :: forall c (m :: * -> *) a b.
Monad m =>
ControlT c m a -> (a -> ControlT c m b) -> ControlT c m b
$cp1Monad :: forall c (m :: * -> *). Monad m => Applicative (ControlT c m)
Monad, MonadBase b, MonadBaseControl b)

instance MonadTrans (ControlT c) where
  lift :: m a -> ControlT c m a
lift = m a -> ControlT c m a
forall c (m :: * -> *) a. m a -> ControlT c m a
ControlT

instance MonadTransControl (ControlT c) where
  type StT (ControlT c) a = a
  liftWith :: (Run (ControlT c) -> m a) -> ControlT c m a
liftWith Run (ControlT c) -> m a
inner = m a -> ControlT c m a
forall c (m :: * -> *) a. m a -> ControlT c m a
ControlT (m a -> ControlT c m a) -> m a -> ControlT c m a
forall a b. (a -> b) -> a -> b
$ Run (ControlT c) -> m a
inner forall c (m :: * -> *) a. ControlT c m a -> m a
Run (ControlT c)
unControlT
  restoreT :: m (StT (ControlT c) a) -> ControlT c m a
restoreT = m (StT (ControlT c) a) -> ControlT c m a
forall c (m :: * -> *) a. m a -> ControlT c m a
ControlT

runControlT :: Monad m
            => ControlT c m a
            -> m a
runControlT :: ControlT c m a -> m a
runControlT = ControlT c m a -> m a
forall c (m :: * -> *) a. ControlT c m a -> m a
unControlT

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 -> g (StM r a))
            -> ControlT c m ()
loopRecolor :: (forall a. g a -> IO (StM g a))
-> (forall a. r a -> g (StM r a)) -> ControlT c m ()
loopRecolor forall a. g a -> IO (StM g a)
runG forall a. r a -> g (StM r a)
runR = do
  StM g (StM r ())
a <- IO (StM g (StM r ())) -> ControlT c m (StM g (StM r ()))
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase IO (StM g (StM r ()))
doRecolorGamma
  m () -> ControlT c m ()
forall c (m :: * -> *) a. m a -> ControlT c m a
ControlT (m () -> ControlT c m ()) -> m () -> ControlT c m ()
forall a b. (a -> b) -> a -> b
$ StateT (StM g (StM r ())) m () -> StM g (StM r ()) -> m ()
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT StateT (StM g (StM r ())) m ()
doLoopRecolor StM g (StM r ())
a
  where doRecolorGamma :: IO (StM g (StM r ()))
doRecolorGamma = g (StM r ()) -> IO (StM g (StM r ()))
forall a. g a -> IO (StM g a)
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
          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
          r () -> g (StM r ())
forall a. r a -> g (StM r a)
runR (r () -> g (StM r ())) -> r () -> g (StM r ())
forall a b. (a -> b) -> a -> b
$ Trichromaticity -> r ()
forall (m :: * -> *). MonadRecolor m => Trichromaticity -> m ()
recolor Trichromaticity
rgb
        doLoopRecolor :: StateT (StM g (StM r ())) m ()
doLoopRecolor = do
          StM g (StM r ())
a' <- StateT (StM g (StM r ())) m (StM g (StM r ()))
forall s (m :: * -> *). MonadState s m => m s
get
          m () -> StateT (StM g (StM r ())) m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> StateT (StM g (StM r ())) m ())
-> m () -> StateT (StM g (StM r ())) 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 ())
a'
          StM g (StM r ())
a'' <- IO (StM g (StM r ()))
-> StateT (StM g (StM r ())) m (StM g (StM r ()))
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase IO (StM g (StM r ()))
doRecolorGamma
          StM g (StM r ()) -> StateT (StM g (StM r ())) m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put StM g (StM r ())
a''
          StateT (StM g (StM r ())) m ()
doLoopRecolor

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 -> g (StM r a)
runRecolor :: forall a. r a -> g (StM r a)
                                         }