{-# 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

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

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

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

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

loopRecolor :: (ControlConstraint m (StM g (StM r ())), MonadBaseControl IO g, MonadBaseControl IO r, MonadControl m, MonadGamma g, MonadRecolor r)
            => (forall a. g a -> IO (StM g a))
            -> (forall a. r a -> g (StM r a))
            -> ControlT m ()
loopRecolor :: (forall a. g a -> IO (StM g a))
-> (forall a. r a -> g (StM r a)) -> ControlT 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 m (StM g (StM r ()))
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase IO (StM g (StM r ()))
doRecolorGamma
  m () -> ControlT m ()
forall (m :: * -> *) a. m a -> ControlT m a
ControlT (m () -> ControlT m ()) -> m () -> ControlT 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 <- g Trichromaticity
forall (m :: * -> *). MonadGamma m => m Trichromaticity
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)
                                         }