blucontrol 0.4.1.0 → 0.5.0.0

raw patch · 45 files changed

+878/−872 lines, 45 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG.md +6/−0
• Main.hs +6/−6
• blucontrol.cabal +20/−20
• src/Blucontrol.hs +4/−4
• src/Blucontrol/CompatibleValues.hs +0/−9
• src/Blucontrol/Control.hs +0/−25
• src/Blucontrol/Control/Concat.hs +0/−40
• src/Blucontrol/Control/Count.hs +0/−70
• src/Blucontrol/Control/Print.hs +0/−30
• src/Blucontrol/Control/Wait.hs +0/−40
• src/Blucontrol/Gamma.hs +0/−13
• src/Blucontrol/Gamma/Const.hs +0/−28
• src/Blucontrol/Gamma/Linear.hs +0/−142
• src/Blucontrol/Gamma/Modifier.hs +0/−29
• src/Blucontrol/Main.hs +4/−4
• src/Blucontrol/Main/Control.hs +3/−3
• src/Blucontrol/Monad/Control.hs +25/−0
• src/Blucontrol/Monad/Control/Concat.hs +40/−0
• src/Blucontrol/Monad/Control/Count.hs +70/−0
• src/Blucontrol/Monad/Control/Print.hs +30/−0
• src/Blucontrol/Monad/Control/Wait.hs +40/−0
• src/Blucontrol/Monad/Gamma.hs +13/−0
• src/Blucontrol/Monad/Gamma/Const.hs +28/−0
• src/Blucontrol/Monad/Gamma/Linear.hs +142/−0
• src/Blucontrol/Monad/Gamma/Modifier.hs +29/−0
• src/Blucontrol/Monad/Recolor.hs +13/−0
• src/Blucontrol/Monad/Recolor/Print.hs +30/−0
• src/Blucontrol/Monad/Recolor/X.hs +96/−0
• src/Blucontrol/Monad/Recolor/X/Internal.hs +29/−0
• src/Blucontrol/RGB.hs +0/−52
• src/Blucontrol/RGB/Brightness.hs +0/−38
• src/Blucontrol/RGB/Temperature.hs +0/−51
• src/Blucontrol/Recolor.hs +0/−13
• src/Blucontrol/Recolor/Print.hs +0/−30
• src/Blucontrol/Recolor/X.hs +0/−96
• src/Blucontrol/Recolor/X/Internal.hs +0/−29
• src/Blucontrol/Value.hs +9/−0
• src/Blucontrol/Value/Brightness.hs +38/−0
• src/Blucontrol/Value/RGB.hs +52/−0
• src/Blucontrol/Value/RGB/Temperature.hs +51/−0
• test/Blucontrol.hs +4/−4
• test/Blucontrol/Monad/Gamma/Linear/Test.hs +67/−0
• test/Blucontrol/Test/Gamma/Linear.hs +0/−67
• test/Blucontrol/Test/RGB.hs +0/−29
• test/Blucontrol/Value/RGB/Test.hs +29/−0

@@ -1,5 +1,11 @@ # Revision history for blucontrol +## 0.5.0.0 *09 Jun 2021*++* Change module structure, now using `Blucontrol.Monad` and `Blucontrol.Value`.+* Move module `Blucontrol.Value.RGB.Brightness` to `Blucontrol.Value.Brightness`.+* Rename module `Blucontrol.CompatibleValues` to `Blucontrol.Value`.+ ## 0.4.1.0 *08 Jun 2021*  * Remove field `coerceValue` from `ConfigControl`.

@@ -3,12 +3,12 @@ module Main where  import Blucontrol-import Blucontrol.Control.Count-import Blucontrol.Control.Print-import Blucontrol.Control.Wait-import Blucontrol.Gamma.Linear-import Blucontrol.Recolor.X-import Blucontrol.RGB.Temperature+import Blucontrol.Monad.Control.Count+import Blucontrol.Monad.Control.Print+import Blucontrol.Monad.Control.Wait+import Blucontrol.Monad.Gamma.Linear+import Blucontrol.Monad.Recolor.X+import Blucontrol.Value.RGB.Temperature  main :: IO () main = blucontrol configControl

@@ -1,5 +1,5 @@ name:                blucontrol-version:             0.4.1.0+version:             0.5.0.0 synopsis:            Configurable blue light filter description:         This application is a blue light filter, with the main focus on                      configurability.@@ -25,27 +25,27 @@  library   exposed-modules:     Blucontrol-                       Blucontrol.CompatibleValues-                       Blucontrol.Control-                       Blucontrol.Control.Concat-                       Blucontrol.Control.Count-                       Blucontrol.Control.Print-                       Blucontrol.Control.Wait-                       Blucontrol.Gamma-                       Blucontrol.Gamma.Const-                       Blucontrol.Gamma.Linear-                       Blucontrol.Gamma.Modifier                        Blucontrol.Main                        Blucontrol.Main.CLI                        Blucontrol.Main.Control-                       Blucontrol.Recolor-                       Blucontrol.Recolor.Print-                       Blucontrol.Recolor.X-                       Blucontrol.RGB-                       Blucontrol.RGB.Brightness-                       Blucontrol.RGB.Temperature+                       Blucontrol.Monad.Control+                       Blucontrol.Monad.Control.Concat+                       Blucontrol.Monad.Control.Count+                       Blucontrol.Monad.Control.Print+                       Blucontrol.Monad.Control.Wait+                       Blucontrol.Monad.Gamma+                       Blucontrol.Monad.Gamma.Const+                       Blucontrol.Monad.Gamma.Linear+                       Blucontrol.Monad.Gamma.Modifier+                       Blucontrol.Monad.Recolor+                       Blucontrol.Monad.Recolor.Print+                       Blucontrol.Monad.Recolor.X+                       Blucontrol.Value+                       Blucontrol.Value.Brightness+                       Blucontrol.Value.RGB+                       Blucontrol.Value.RGB.Temperature   other-modules:       Blucontrol.Main.GHC.Internal-                       Blucontrol.Recolor.X.Internal+                       Blucontrol.Monad.Recolor.X.Internal                        Paths_blucontrol   build-depends:       base              >= 4.11    && < 5                      , containers        >= 0.6.2.1 && < 0.7@@ -98,8 +98,8 @@   main-is:             Blucontrol.hs   type:                exitcode-stdio-1.0   hs-source-dirs:      test-  other-modules:       Blucontrol.Test.Gamma.Linear-                       Blucontrol.Test.RGB+  other-modules:       Blucontrol.Monad.Gamma.Linear.Test+                       Blucontrol.Value.RGB.Test   build-depends:       base                      , blucontrol                      , data-default

@@ -35,8 +35,8 @@  import Data.Default -import Blucontrol.Control-import Blucontrol.Control.Concat-import Blucontrol.Gamma import Blucontrol.Main-import Blucontrol.Recolor+import Blucontrol.Monad.Control+import Blucontrol.Monad.Control.Concat+import Blucontrol.Monad.Gamma+import Blucontrol.Monad.Recolor

@@ -1,9 +0,0 @@-module Blucontrol.CompatibleValues (-  CompatibleValues (..)-) where--class CompatibleValues a b where-    convertValue :: a -> b--instance CompatibleValues a a where-  convertValue = id

@@ -1,25 +0,0 @@-{-# LANGUAGE UndecidableInstances #-}--module Blucontrol.Control (-  MonadControl (..)-) where--import Control.Monad.Trans.Control-import Data.Kind--class MonadBaseControl IO m => MonadControl m where--  {- | Give a constraint to allow 'doInbetween' to handle a polymorphic argument.-    This is usfeul to allow arguments wrapped in monadic state 'StM' from running-    'Blucontrol.Gamma.MonadGamma' and 'Blucontrol.Recolor.MonadRecolor'.-  -}-  type ControlConstraint m a :: Constraint--  -- | This function will be called after recoloring the screen.-  doInbetween :: ControlConstraint m a-              => a -- ^ the returned value from the last call of 'Blucontrol.Recolor.recolor' including monadic state-              -> m () -- ^ the side effect to be run inbetween recoloring--instance MonadControl IO where-  type ControlConstraint IO _ = ()-  doInbetween _ = return ()

@@ -1,40 +0,0 @@-{-# LANGUAGE QuantifiedConstraints, UndecidableInstances #-}--module Blucontrol.Control.Concat (-  ControlConcatT-, runControlConcatT-, (!>)-) where--import Control.Monad.Base-import Control.Monad.Trans-import Control.Monad.Trans.Control-import Data.Kind--import Blucontrol.Control--newtype ControlConcatT (t1 :: (Type -> Type) -> Type -> Type) (t2 :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a = ControlConcatT { unControlConcatT :: t2 (t1 m) a }-  deriving (Applicative, Functor, Monad, MonadBase b, MonadBaseControl b)--instance (forall m. Monad m => Monad (t1 m), MonadTrans t1, MonadTrans t2) => MonadTrans (ControlConcatT t1 t2) where-  lift = ControlConcatT . lift . lift--instance (forall m. Monad m => Monad (t1 m), MonadTransControl t1, MonadTransControl t2) => MonadTransControl (ControlConcatT t1 t2) where-  type StT (ControlConcatT t1 t2) a = StT t1 (StT t2 a)-  liftWith inner = ControlConcatT $-    liftWith $ \ runT2 ->-      liftWith $ \ runT1 ->-        inner $ runT1 . runT2 . unControlConcatT-  restoreT = ControlConcatT . restoreT . restoreT--instance (MonadControl (t1 m), MonadControl (t2 (t1 m)), MonadTrans t2) => MonadControl (ControlConcatT t1 t2 m) where-  type ControlConstraint (ControlConcatT t1 t2 m) a = (ControlConstraint (t1 m) a, ControlConstraint (t2 (t1 m)) a)-  doInbetween a = do ControlConcatT . lift $ doInbetween a-                     ControlConcatT $ doInbetween a--runControlConcatT :: (t1 m a -> m a) -> (t2 (t1 m) a -> t1 m a) -> ControlConcatT t1 t2 m a -> m a-runControlConcatT runT1 runT2 = runT1 . runT2 . unControlConcatT--infixr 5 !>-(!>) :: (t1 m a -> m a) -> (t2 (t1 m) a -> t1 m a) -> (ControlConcatT t1 t2 m a -> m a)-(!>) = runControlConcatT

@@ -1,70 +0,0 @@-{-# LANGUAGE UndecidableInstances #-}--module Blucontrol.Control.Count (-  ControlCountT-, runControlCountT-, ConfigCount (..)-, CountableException (..)-) where--import Control.DeepSeq-import Control.Monad.Base-import Control.Monad.Trans.Control-import Control.Monad.Reader-import Control.Monad.State.Strict-import Data.Default-import GHC.Generics-import Numeric.Natural--import Blucontrol.Control--newtype ControlCountT m a = ControlCountT { unControlCountT :: StateT Natural (ReaderT ConfigCount m) a }-  deriving (Applicative, Functor, Monad, MonadBase b, MonadBaseControl b)--instance MonadTrans ControlCountT where-  lift = ControlCountT . lift . lift--instance MonadTransControl ControlCountT where-  type StT ControlCountT a = StT (ReaderT ConfigCount) (StT (StateT Natural) a)-  -- TODO: workaround for ghc-9.0.1-  --liftWith = defaultLiftWith2 ControlCountT unControlCountT-  liftWith f = ControlCountT $ liftWith $ \run -> liftWith $ \run' -> f $ run' . run . unControlCountT-  restoreT = defaultRestoreT2 ControlCountT--instance MonadBaseControl IO m => MonadControl (ControlCountT m) where-  type ControlConstraint (ControlCountT m) a = CountableException a-  doInbetween a = do if isException a-                        then ControlCountT $ modify succ-                        else ControlCountT $ put 0-                     current <- ControlCountT get-                     limit <- ControlCountT . lift $ reader maxCount-                     if current >= limit-                        then error $ "failed after " <> show limit <> " consecutive tries"-                        else return ()--runControlCountT :: Monad m => ConfigCount -> ControlCountT m a -> m a-runControlCountT !conf tma = runReaderT (evalStateT (unControlCountT tma) 0) conf--newtype ConfigCount = ConfigCount { maxCount :: Natural-                                  }-  deriving (Eq, Generic, Ord, Read, Show)--instance NFData ConfigCount--instance Default ConfigCount where-  def = ConfigCount { maxCount = 5-                    }--class CountableException a where-  isException :: a -> Bool--instance CountableException () where-  isException () = False--instance CountableException a => CountableException (Maybe a) where-  isException Nothing = True-  isException (Just a) = isException a--instance CountableException a => CountableException (Either b a) where-  isException (Left _) = True-  isException (Right a) = isException a

@@ -1,30 +0,0 @@-{-# LANGUAGE UndecidableInstances #-}--module Blucontrol.Control.Print (-  ControlPrintT-, runControlPrintT-) where--import Control.Monad.Base-import Control.Monad.Trans-import Control.Monad.Trans.Control--import Blucontrol.Control--newtype ControlPrintT m a = ControlPrintT { unControlPrintT :: m a }-  deriving (Applicative, Functor, Monad, MonadBase b, MonadBaseControl b)--instance MonadTrans ControlPrintT where-  lift = ControlPrintT--instance MonadTransControl ControlPrintT where-  type StT ControlPrintT a = a-  liftWith inner = ControlPrintT $ inner unControlPrintT-  restoreT = ControlPrintT--instance MonadBaseControl IO m => MonadControl (ControlPrintT m) where-  type ControlConstraint (ControlPrintT m) a = Show a-  doInbetween a = liftBase $ print a--runControlPrintT :: ControlPrintT m a -> m a-runControlPrintT = unControlPrintT

@@ -1,40 +0,0 @@-{-# LANGUAGE UndecidableInstances #-}--module Blucontrol.Control.Wait (-  ControlWaitT-, runControlWaitT-, ConfigWait (..)-, Microseconds-) where--import Control.Concurrent (threadDelay)-import Control.DeepSeq-import Control.Monad.Base-import Control.Monad.Trans.Control-import Control.Monad.Reader-import Data.Default-import GHC.Generics--import Blucontrol.Control--newtype ControlWaitT m a = ControlWaitT { unControlWaitT :: ReaderT ConfigWait m a }-  deriving (Applicative, Functor, Monad, MonadBase b, MonadBaseControl b, MonadTrans, MonadTransControl)--instance MonadBaseControl IO m => MonadControl (ControlWaitT m) where-  type ControlConstraint (ControlWaitT m) _ = ()-  doInbetween _ = liftBase . threadDelay . interval =<< ControlWaitT ask--runControlWaitT :: ConfigWait -> ControlWaitT m a -> m a-runControlWaitT !conf tma = runReaderT (unControlWaitT tma) conf--newtype ConfigWait = ConfigWait { interval :: Microseconds-                                }-  deriving (Eq, Generic, Ord, Read, Show)--instance NFData ConfigWait--instance Default ConfigWait where-  def = ConfigWait { interval = 1000000-                   }--type Microseconds = Int

@@ -1,13 +0,0 @@-module Blucontrol.Gamma (-  MonadGamma (..)-) where--class Monad m => MonadGamma m where--  type GammaValue m--  {- | Calculate a gamma value.-     This is a monadic function, to allow the value to be dependent on side effects like time and-     location.-  -}-  gamma :: m (GammaValue m)

@@ -1,28 +0,0 @@-{-# LANGUAGE UndecidableInstances #-}--module Blucontrol.Gamma.Const (-  GammaConstT-, runGammaConstT-) where--import Control.Monad.Base-import Control.Monad.Trans-import Control.Monad.Trans.Control-import Control.Monad.Reader--import Blucontrol.Gamma--newtype GammaConstT c m a = GammaConstT { unGammaConstT :: ReaderT c m a }-  deriving (Applicative, Functor, Monad, MonadBase b, MonadBaseControl b, MonadTrans, MonadTransControl)--instance MonadReader r m => MonadReader r (GammaConstT c m) where-  ask = lift ask-  local f tma = liftWith $ \ run ->-    local f $ run tma--instance Monad m => MonadGamma (GammaConstT c m) where-  type GammaValue (GammaConstT c m) = c-  gamma = GammaConstT ask--runGammaConstT :: c -> GammaConstT c m a -> m a-runGammaConstT !rgb tma = runReaderT (unGammaConstT tma) rgb

@@ -1,142 +0,0 @@-{-# LANGUAGE UndecidableInstances #-}--module Blucontrol.Gamma.Linear (-  GammaLinearT-, runGammaLinearT-, Time (..)-, Hour-, Minute-, (==>)-, N.NonEmpty (..) -- TODO: keep here?-, calculateValue -- TODO: export for testing-, weightedAverageRGB -- TODO: export for testing-) where--import Control.DeepSeq-import Control.Monad.Base-import Control.Monad.Except-import Control.Monad.Reader-import Control.Monad.Trans.Control-import qualified Data.Finite as F-import qualified Data.List.NonEmpty as N-import qualified Data.Map as M-import Data.Maybe (fromJust)-import Data.Time-import Data.Word-import GHC.Generics--import Blucontrol.Gamma-import Blucontrol.RGB-import Blucontrol.RGB.Brightness-import Blucontrol.RGB.Temperature--newtype GammaLinearT c m a = GammaLinearT { unGammaLinearT :: ReaderT (M.Map TimeOfDay c) m a }-  deriving (Applicative, Functor, Monad, MonadBase b, MonadBaseControl b, MonadTrans, MonadTransControl)--instance MonadReader r m => MonadReader r (GammaLinearT c m) where-  ask = lift ask-  local f tma = liftWith $ \ run ->-    local f $ run tma--instance MonadBase IO m => MonadGamma (GammaLinearT (RGB Word8) m) where-  type GammaValue (GammaLinearT (RGB Word8) m) = RGB Word8-  gamma = calculateValue weightedAverageRGB . zonedTimeToLocalTime =<< liftBase getZonedTime--instance MonadBase IO m => MonadGamma (GammaLinearT Temperature m) where-  type GammaValue (GammaLinearT Temperature m) = Temperature-  gamma = calculateValue weightedAverageTemperature . zonedTimeToLocalTime =<< liftBase getZonedTime--instance (MonadBase IO m, MonadGamma (GammaLinearT c m)) => MonadGamma (GammaLinearT (WithBrightness c) m) where-  type GammaValue (GammaLinearT (WithBrightness c) m) = WithBrightness (GammaValue (GammaLinearT c m))-  -- TODO: It would be nice to use the same exact time for `color'` and `brightness'`.-  gamma = do-    color' <- withGammaLinearT color gamma-    brightness' <- withGammaLinearT brightness $ calculateValue weightedAverageBrightness . zonedTimeToLocalTime =<< liftBase getZonedTime-    return WithBrightness { brightness = brightness'-                          , color = color'-                          }--withGammaLinearT :: (c' -> c) -> GammaLinearT c m a -> GammaLinearT c' m a-withGammaLinearT f m = GammaLinearT $ withReaderT (fmap f) $ unGammaLinearT m--nextTimeValue :: M.Map TimeOfDay c -> LocalTime -> Maybe (LocalTime,c)-nextTimeValue m time = catchError (toLocalTimeToday <$> M.lookupGT (localTimeOfDay time) m) $-                     const (toLocalTimeTomorrow <$> M.lookupMin m)-  where toLocalTimeToday (tod,tc) = let t = LocalTime { localDay = localDay time-                                                      , localTimeOfDay = tod-                                                      }-                                     in (t,tc)-        toLocalTimeTomorrow x = let (t,tc) = toLocalTimeToday x-                                    t' = t { localDay = succ $ localDay t }-                                 in (t',tc)--prevTimeValue :: M.Map TimeOfDay c -> LocalTime -> Maybe (LocalTime,c)-prevTimeValue m time = catchError (toLocalTimeToday <$> M.lookupLE (localTimeOfDay time) m) $-                     const (toLocalTimeYesterday <$> M.lookupMax m)-  where toLocalTimeToday (tod,tc) = let t = LocalTime { localDay = localDay time-                                                      , localTimeOfDay = tod-                                                      }-                                     in (t,tc)-        toLocalTimeYesterday x = let (t,tc) = toLocalTimeToday x-                                     t' = t { localDay = pred $ localDay t }-                                  in (t',tc)--calculateValue :: Monad m-               => (Rational -> c -> c -> c)-               -> LocalTime -> GammaLinearT c m c-calculateValue weightedAverage time = do-  m <- GammaLinearT ask-  return . fromJust $ do-    (nextTime , nextValue) <- nextTimeValue m time-    (prevTime , prevValue) <- prevTimeValue m time-    let diffSeconds t1 t2 = nominalDiffTimeToSeconds $ t1 `diffLocalTime` t2-        timeFraction = toRational $ (time `diffSeconds` prevTime) / (nextTime `diffSeconds` prevTime)-    return $ weightedAverage timeFraction prevValue nextValue--weightedAverageRGB :: Rational -> RGB Word8 -> RGB Word8 -> RGB Word8-weightedAverageRGB w rgb1 rgb2 = RGB { red = f (red rgb1) (red rgb2)-                                     , green = f (green rgb1) (green rgb2)-                                     , blue = f (blue rgb1) (blue rgb2)-                                     }-  where f c1 c2 = round $ fromIntegral c1 + w * (fromIntegral c2 - fromIntegral c1)--weightedAverageTemperature :: Rational -> Temperature -> Temperature -> Temperature-weightedAverageTemperature w t1 t2 = fromRational $ toRational t1 + w * (toRational t2 - toRational t1)--weightedAverageBrightness :: Rational -> Brightness -> Brightness -> Brightness-weightedAverageBrightness w b1 b2 = fromRational $ toRational b1 + w * (toRational b2 - toRational b1)--runGammaLinearT' :: M.Map TimeOfDay c -> GammaLinearT c m a -> m a-runGammaLinearT' !rgbs tma = runReaderT (unGammaLinearT tma) rgbs--runGammaLinearT :: N.NonEmpty (TimeOfDay,c) -> GammaLinearT c m a -> m a-runGammaLinearT rgbs = runGammaLinearT' $ M.fromList . N.toList $ rgbs--newtype Hour = Hour { unHour :: F.Finite 24 }-  deriving (Bounded, Enum, Eq, Generic, Integral, Num, Ord, Read, Real, Show)--instance NFData Hour--newtype Minute = Minute { unMinute :: F.Finite 60 }-  deriving (Bounded, Enum, Eq, Generic, Integral, Num, Ord, Read, Real, Show)--instance NFData Minute--infix 7 :.-data Time = Hour :. Minute-  deriving (Bounded, Eq, Generic, Ord, Read, Show)--instance NFData Time--instance Enum Time where-  fromEnum (h :. m) = fromEnum h * succ (fromEnum $ maxBound @Minute) + fromEnum m-  toEnum i = let (h , m) = i `divMod` succ (fromEnum $ maxBound @Minute)-              in toEnum h :. toEnum m--infix 6 ==>-(==>) :: Time -> c -> (TimeOfDay,c)-(==>) (h :. m) c = (time,c)-  where time = TimeOfDay { todHour = fromIntegral h-                         , todMin = fromIntegral m-                         , todSec = 0-                         }

@@ -1,29 +0,0 @@-{-# LANGUAGE UndecidableInstances #-}--module Blucontrol.Gamma.Modifier (-  GammaModifierT-, runGammaModifierT-) where--import Control.Monad.Base-import Control.Monad.Except-import Control.Monad.Reader-import Control.Monad.Trans.Control--import Blucontrol.Gamma--newtype GammaModifierT m a = GammaModifierT { unGammaModifierT :: ReaderT (GammaValue m -> IO (GammaValue m)) m a }-  deriving (Applicative, Functor, Monad, MonadBase b, MonadBaseControl b)--- TODO: A `MonadTransControl` instance seems to be impossible--instance MonadTrans GammaModifierT where-  lift = GammaModifierT . lift--instance (MonadBase IO m, MonadGamma m) => MonadGamma (GammaModifierT m) where-  type GammaValue (GammaModifierT m) = GammaValue m-  gamma = do oldGamma <- lift gamma-             modifyGamma <- GammaModifierT ask-             liftBase $ modifyGamma oldGamma--runGammaModifierT :: (GammaValue m -> IO (GammaValue m)) -> GammaModifierT m a -> m a-runGammaModifierT modify tma = runReaderT (unGammaModifierT tma) modify

@@ -6,12 +6,12 @@  import Control.Monad.Trans.Control -import Blucontrol.CompatibleValues import Blucontrol.Main.Control import Blucontrol.Main.CLI-import Blucontrol.Control-import Blucontrol.Gamma-import Blucontrol.Recolor+import Blucontrol.Monad.Control+import Blucontrol.Monad.Gamma+import Blucontrol.Monad.Recolor+import Blucontrol.Value  type BlucontrolConstraints m g r =   ( ControlConstraint m (StM g (StM r ()))

@@ -7,9 +7,9 @@ import Control.Monad.Reader import Control.Monad.State.Strict -import Blucontrol.Control-import Blucontrol.Gamma-import Blucontrol.Recolor+import Blucontrol.Monad.Control+import Blucontrol.Monad.Gamma+import Blucontrol.Monad.Recolor  -- | Run the loop, using `gamma`, `recolor` and `doInbetween`. -- The arguments are the actual monad runners.

@@ -0,0 +1,25 @@+{-# LANGUAGE UndecidableInstances #-}++module Blucontrol.Monad.Control (+  MonadControl (..)+) where++import Control.Monad.Trans.Control+import Data.Kind++class MonadBaseControl IO m => MonadControl m where++  {- | Give a constraint to allow 'doInbetween' to handle a polymorphic argument.+    This is usfeul to allow arguments wrapped in monadic state 'StM' from running+    'Blucontrol.Gamma.MonadGamma' and 'Blucontrol.Recolor.MonadRecolor'.+  -}+  type ControlConstraint m a :: Constraint++  -- | This function will be called after recoloring the screen.+  doInbetween :: ControlConstraint m a+              => a -- ^ the returned value from the last call of 'Blucontrol.Recolor.recolor' including monadic state+              -> m () -- ^ the side effect to be run inbetween recoloring++instance MonadControl IO where+  type ControlConstraint IO _ = ()+  doInbetween _ = return ()

@@ -0,0 +1,40 @@+{-# LANGUAGE QuantifiedConstraints, UndecidableInstances #-}++module Blucontrol.Monad.Control.Concat (+  ControlConcatT+, runControlConcatT+, (!>)+) where++import Control.Monad.Base+import Control.Monad.Trans+import Control.Monad.Trans.Control+import Data.Kind++import Blucontrol.Monad.Control++newtype ControlConcatT (t1 :: (Type -> Type) -> Type -> Type) (t2 :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a = ControlConcatT { unControlConcatT :: t2 (t1 m) a }+  deriving (Applicative, Functor, Monad, MonadBase b, MonadBaseControl b)++instance (forall m. Monad m => Monad (t1 m), MonadTrans t1, MonadTrans t2) => MonadTrans (ControlConcatT t1 t2) where+  lift = ControlConcatT . lift . lift++instance (forall m. Monad m => Monad (t1 m), MonadTransControl t1, MonadTransControl t2) => MonadTransControl (ControlConcatT t1 t2) where+  type StT (ControlConcatT t1 t2) a = StT t1 (StT t2 a)+  liftWith inner = ControlConcatT $+    liftWith $ \ runT2 ->+      liftWith $ \ runT1 ->+        inner $ runT1 . runT2 . unControlConcatT+  restoreT = ControlConcatT . restoreT . restoreT++instance (MonadControl (t1 m), MonadControl (t2 (t1 m)), MonadTrans t2) => MonadControl (ControlConcatT t1 t2 m) where+  type ControlConstraint (ControlConcatT t1 t2 m) a = (ControlConstraint (t1 m) a, ControlConstraint (t2 (t1 m)) a)+  doInbetween a = do ControlConcatT . lift $ doInbetween a+                     ControlConcatT $ doInbetween a++runControlConcatT :: (t1 m a -> m a) -> (t2 (t1 m) a -> t1 m a) -> ControlConcatT t1 t2 m a -> m a+runControlConcatT runT1 runT2 = runT1 . runT2 . unControlConcatT++infixr 5 !>+(!>) :: (t1 m a -> m a) -> (t2 (t1 m) a -> t1 m a) -> (ControlConcatT t1 t2 m a -> m a)+(!>) = runControlConcatT

@@ -0,0 +1,70 @@+{-# LANGUAGE UndecidableInstances #-}++module Blucontrol.Monad.Control.Count (+  ControlCountT+, runControlCountT+, ConfigCount (..)+, CountableException (..)+) where++import Control.DeepSeq+import Control.Monad.Base+import Control.Monad.Trans.Control+import Control.Monad.Reader+import Control.Monad.State.Strict+import Data.Default+import GHC.Generics+import Numeric.Natural++import Blucontrol.Monad.Control++newtype ControlCountT m a = ControlCountT { unControlCountT :: StateT Natural (ReaderT ConfigCount m) a }+  deriving (Applicative, Functor, Monad, MonadBase b, MonadBaseControl b)++instance MonadTrans ControlCountT where+  lift = ControlCountT . lift . lift++instance MonadTransControl ControlCountT where+  type StT ControlCountT a = StT (ReaderT ConfigCount) (StT (StateT Natural) a)+  -- TODO: workaround for ghc-9.0.1+  --liftWith = defaultLiftWith2 ControlCountT unControlCountT+  liftWith f = ControlCountT $ liftWith $ \run -> liftWith $ \run' -> f $ run' . run . unControlCountT+  restoreT = defaultRestoreT2 ControlCountT++instance MonadBaseControl IO m => MonadControl (ControlCountT m) where+  type ControlConstraint (ControlCountT m) a = CountableException a+  doInbetween a = do if isException a+                        then ControlCountT $ modify succ+                        else ControlCountT $ put 0+                     current <- ControlCountT get+                     limit <- ControlCountT . lift $ reader maxCount+                     if current >= limit+                        then error $ "failed after " <> show limit <> " consecutive tries"+                        else return ()++runControlCountT :: Monad m => ConfigCount -> ControlCountT m a -> m a+runControlCountT !conf tma = runReaderT (evalStateT (unControlCountT tma) 0) conf++newtype ConfigCount = ConfigCount { maxCount :: Natural+                                  }+  deriving (Eq, Generic, Ord, Read, Show)++instance NFData ConfigCount++instance Default ConfigCount where+  def = ConfigCount { maxCount = 5+                    }++class CountableException a where+  isException :: a -> Bool++instance CountableException () where+  isException () = False++instance CountableException a => CountableException (Maybe a) where+  isException Nothing = True+  isException (Just a) = isException a++instance CountableException a => CountableException (Either b a) where+  isException (Left _) = True+  isException (Right a) = isException a

@@ -0,0 +1,30 @@+{-# LANGUAGE UndecidableInstances #-}++module Blucontrol.Monad.Control.Print (+  ControlPrintT+, runControlPrintT+) where++import Control.Monad.Base+import Control.Monad.Trans+import Control.Monad.Trans.Control++import Blucontrol.Monad.Control++newtype ControlPrintT m a = ControlPrintT { unControlPrintT :: m a }+  deriving (Applicative, Functor, Monad, MonadBase b, MonadBaseControl b)++instance MonadTrans ControlPrintT where+  lift = ControlPrintT++instance MonadTransControl ControlPrintT where+  type StT ControlPrintT a = a+  liftWith inner = ControlPrintT $ inner unControlPrintT+  restoreT = ControlPrintT++instance MonadBaseControl IO m => MonadControl (ControlPrintT m) where+  type ControlConstraint (ControlPrintT m) a = Show a+  doInbetween a = liftBase $ print a++runControlPrintT :: ControlPrintT m a -> m a+runControlPrintT = unControlPrintT

@@ -0,0 +1,40 @@+{-# LANGUAGE UndecidableInstances #-}++module Blucontrol.Monad.Control.Wait (+  ControlWaitT+, runControlWaitT+, ConfigWait (..)+, Microseconds+) where++import Control.Concurrent (threadDelay)+import Control.DeepSeq+import Control.Monad.Base+import Control.Monad.Trans.Control+import Control.Monad.Reader+import Data.Default+import GHC.Generics++import Blucontrol.Monad.Control++newtype ControlWaitT m a = ControlWaitT { unControlWaitT :: ReaderT ConfigWait m a }+  deriving (Applicative, Functor, Monad, MonadBase b, MonadBaseControl b, MonadTrans, MonadTransControl)++instance MonadBaseControl IO m => MonadControl (ControlWaitT m) where+  type ControlConstraint (ControlWaitT m) _ = ()+  doInbetween _ = liftBase . threadDelay . interval =<< ControlWaitT ask++runControlWaitT :: ConfigWait -> ControlWaitT m a -> m a+runControlWaitT !conf tma = runReaderT (unControlWaitT tma) conf++newtype ConfigWait = ConfigWait { interval :: Microseconds+                                }+  deriving (Eq, Generic, Ord, Read, Show)++instance NFData ConfigWait++instance Default ConfigWait where+  def = ConfigWait { interval = 1000000+                   }++type Microseconds = Int

@@ -0,0 +1,13 @@+module Blucontrol.Monad.Gamma (+  MonadGamma (..)+) where++class Monad m => MonadGamma m where++  type GammaValue m++  {- | Calculate a gamma value.+     This is a monadic function, to allow the value to be dependent on side effects like time and+     location.+  -}+  gamma :: m (GammaValue m)

@@ -0,0 +1,28 @@+{-# LANGUAGE UndecidableInstances #-}++module Blucontrol.Monad.Gamma.Const (+  GammaConstT+, runGammaConstT+) where++import Control.Monad.Base+import Control.Monad.Trans+import Control.Monad.Trans.Control+import Control.Monad.Reader++import Blucontrol.Monad.Gamma++newtype GammaConstT c m a = GammaConstT { unGammaConstT :: ReaderT c m a }+  deriving (Applicative, Functor, Monad, MonadBase b, MonadBaseControl b, MonadTrans, MonadTransControl)++instance MonadReader r m => MonadReader r (GammaConstT c m) where+  ask = lift ask+  local f tma = liftWith $ \ run ->+    local f $ run tma++instance Monad m => MonadGamma (GammaConstT c m) where+  type GammaValue (GammaConstT c m) = c+  gamma = GammaConstT ask++runGammaConstT :: c -> GammaConstT c m a -> m a+runGammaConstT !rgb tma = runReaderT (unGammaConstT tma) rgb

@@ -0,0 +1,142 @@+{-# LANGUAGE UndecidableInstances #-}++module Blucontrol.Monad.Gamma.Linear (+  GammaLinearT+, runGammaLinearT+, Time (..)+, Hour+, Minute+, (==>)+, N.NonEmpty (..) -- TODO: keep here?+, calculateValue -- TODO: export for testing+, weightedAverageRGB -- TODO: export for testing+) where++import Control.DeepSeq+import Control.Monad.Base+import Control.Monad.Except+import Control.Monad.Reader+import Control.Monad.Trans.Control+import qualified Data.Finite as F+import qualified Data.List.NonEmpty as N+import qualified Data.Map as M+import Data.Maybe (fromJust)+import Data.Time+import Data.Word+import GHC.Generics++import Blucontrol.Monad.Gamma+import Blucontrol.Value.Brightness+import Blucontrol.Value.RGB+import Blucontrol.Value.RGB.Temperature++newtype GammaLinearT c m a = GammaLinearT { unGammaLinearT :: ReaderT (M.Map TimeOfDay c) m a }+  deriving (Applicative, Functor, Monad, MonadBase b, MonadBaseControl b, MonadTrans, MonadTransControl)++instance MonadReader r m => MonadReader r (GammaLinearT c m) where+  ask = lift ask+  local f tma = liftWith $ \ run ->+    local f $ run tma++instance MonadBase IO m => MonadGamma (GammaLinearT (RGB Word8) m) where+  type GammaValue (GammaLinearT (RGB Word8) m) = RGB Word8+  gamma = calculateValue weightedAverageRGB . zonedTimeToLocalTime =<< liftBase getZonedTime++instance MonadBase IO m => MonadGamma (GammaLinearT Temperature m) where+  type GammaValue (GammaLinearT Temperature m) = Temperature+  gamma = calculateValue weightedAverageTemperature . zonedTimeToLocalTime =<< liftBase getZonedTime++instance (MonadBase IO m, MonadGamma (GammaLinearT c m)) => MonadGamma (GammaLinearT (WithBrightness c) m) where+  type GammaValue (GammaLinearT (WithBrightness c) m) = WithBrightness (GammaValue (GammaLinearT c m))+  -- TODO: It would be nice to use the same exact time for `color'` and `brightness'`.+  gamma = do+    color' <- withGammaLinearT color gamma+    brightness' <- withGammaLinearT brightness $ calculateValue weightedAverageBrightness . zonedTimeToLocalTime =<< liftBase getZonedTime+    return WithBrightness { brightness = brightness'+                          , color = color'+                          }++withGammaLinearT :: (c' -> c) -> GammaLinearT c m a -> GammaLinearT c' m a+withGammaLinearT f m = GammaLinearT $ withReaderT (fmap f) $ unGammaLinearT m++nextTimeValue :: M.Map TimeOfDay c -> LocalTime -> Maybe (LocalTime,c)+nextTimeValue m time = catchError (toLocalTimeToday <$> M.lookupGT (localTimeOfDay time) m) $+                     const (toLocalTimeTomorrow <$> M.lookupMin m)+  where toLocalTimeToday (tod,tc) = let t = LocalTime { localDay = localDay time+                                                      , localTimeOfDay = tod+                                                      }+                                     in (t,tc)+        toLocalTimeTomorrow x = let (t,tc) = toLocalTimeToday x+                                    t' = t { localDay = succ $ localDay t }+                                 in (t',tc)++prevTimeValue :: M.Map TimeOfDay c -> LocalTime -> Maybe (LocalTime,c)+prevTimeValue m time = catchError (toLocalTimeToday <$> M.lookupLE (localTimeOfDay time) m) $+                     const (toLocalTimeYesterday <$> M.lookupMax m)+  where toLocalTimeToday (tod,tc) = let t = LocalTime { localDay = localDay time+                                                      , localTimeOfDay = tod+                                                      }+                                     in (t,tc)+        toLocalTimeYesterday x = let (t,tc) = toLocalTimeToday x+                                     t' = t { localDay = pred $ localDay t }+                                  in (t',tc)++calculateValue :: Monad m+               => (Rational -> c -> c -> c)+               -> LocalTime -> GammaLinearT c m c+calculateValue weightedAverage time = do+  m <- GammaLinearT ask+  return . fromJust $ do+    (nextTime , nextValue) <- nextTimeValue m time+    (prevTime , prevValue) <- prevTimeValue m time+    let diffSeconds t1 t2 = nominalDiffTimeToSeconds $ t1 `diffLocalTime` t2+        timeFraction = toRational $ (time `diffSeconds` prevTime) / (nextTime `diffSeconds` prevTime)+    return $ weightedAverage timeFraction prevValue nextValue++weightedAverageRGB :: Rational -> RGB Word8 -> RGB Word8 -> RGB Word8+weightedAverageRGB w rgb1 rgb2 = RGB { red = f (red rgb1) (red rgb2)+                                     , green = f (green rgb1) (green rgb2)+                                     , blue = f (blue rgb1) (blue rgb2)+                                     }+  where f c1 c2 = round $ fromIntegral c1 + w * (fromIntegral c2 - fromIntegral c1)++weightedAverageTemperature :: Rational -> Temperature -> Temperature -> Temperature+weightedAverageTemperature w t1 t2 = fromRational $ toRational t1 + w * (toRational t2 - toRational t1)++weightedAverageBrightness :: Rational -> Brightness -> Brightness -> Brightness+weightedAverageBrightness w b1 b2 = fromRational $ toRational b1 + w * (toRational b2 - toRational b1)++runGammaLinearT' :: M.Map TimeOfDay c -> GammaLinearT c m a -> m a+runGammaLinearT' !rgbs tma = runReaderT (unGammaLinearT tma) rgbs++runGammaLinearT :: N.NonEmpty (TimeOfDay,c) -> GammaLinearT c m a -> m a+runGammaLinearT rgbs = runGammaLinearT' $ M.fromList . N.toList $ rgbs++newtype Hour = Hour { unHour :: F.Finite 24 }+  deriving (Bounded, Enum, Eq, Generic, Integral, Num, Ord, Read, Real, Show)++instance NFData Hour++newtype Minute = Minute { unMinute :: F.Finite 60 }+  deriving (Bounded, Enum, Eq, Generic, Integral, Num, Ord, Read, Real, Show)++instance NFData Minute++infix 7 :.+data Time = Hour :. Minute+  deriving (Bounded, Eq, Generic, Ord, Read, Show)++instance NFData Time++instance Enum Time where+  fromEnum (h :. m) = fromEnum h * succ (fromEnum $ maxBound @Minute) + fromEnum m+  toEnum i = let (h , m) = i `divMod` succ (fromEnum $ maxBound @Minute)+              in toEnum h :. toEnum m++infix 6 ==>+(==>) :: Time -> c -> (TimeOfDay,c)+(==>) (h :. m) c = (time,c)+  where time = TimeOfDay { todHour = fromIntegral h+                         , todMin = fromIntegral m+                         , todSec = 0+                         }

@@ -0,0 +1,29 @@+{-# LANGUAGE UndecidableInstances #-}++module Blucontrol.Monad.Gamma.Modifier (+  GammaModifierT+, runGammaModifierT+) where++import Control.Monad.Base+import Control.Monad.Except+import Control.Monad.Reader+import Control.Monad.Trans.Control++import Blucontrol.Monad.Gamma++newtype GammaModifierT m a = GammaModifierT { unGammaModifierT :: ReaderT (GammaValue m -> IO (GammaValue m)) m a }+  deriving (Applicative, Functor, Monad, MonadBase b, MonadBaseControl b)+-- TODO: A `MonadTransControl` instance seems to be impossible++instance MonadTrans GammaModifierT where+  lift = GammaModifierT . lift++instance (MonadBase IO m, MonadGamma m) => MonadGamma (GammaModifierT m) where+  type GammaValue (GammaModifierT m) = GammaValue m+  gamma = do oldGamma <- lift gamma+             modifyGamma <- GammaModifierT ask+             liftBase $ modifyGamma oldGamma++runGammaModifierT :: (GammaValue m -> IO (GammaValue m)) -> GammaModifierT m a -> m a+runGammaModifierT modify tma = runReaderT (unGammaModifierT tma) modify

@@ -0,0 +1,13 @@+module Blucontrol.Monad.Recolor (+  MonadRecolor (..)+) where++class Monad m => MonadRecolor m where++  type RecolorValue m++  {- | Apply a gamma value.+     This is a monadic function, to allow application to external programs like an X display+     server.+  -}+  recolor :: RecolorValue m -> m ()

@@ -0,0 +1,30 @@+{-# LANGUAGE UndecidableInstances #-}++module Blucontrol.Monad.Recolor.Print (+  RecolorPrintT+, runRecolorPrintT+) where++import Control.Monad.Base+import Control.Monad.Trans+import Control.Monad.Trans.Control++import Blucontrol.Monad.Recolor++newtype RecolorPrintT c m a = RecolorPrintT { unRecolorPrintT :: m a }+  deriving (Applicative, Functor, Monad, MonadBase b, MonadBaseControl b)++instance MonadTrans (RecolorPrintT c) where+  lift = RecolorPrintT++instance MonadTransControl (RecolorPrintT c) where+  type StT (RecolorPrintT c) a = a+  liftWith inner = RecolorPrintT $ inner unRecolorPrintT+  restoreT = RecolorPrintT++instance (MonadBaseControl IO m, Show c) => MonadRecolor (RecolorPrintT c m) where+  type RecolorValue (RecolorPrintT c m) = c+  recolor = liftBase . print++runRecolorPrintT :: RecolorPrintT c m a -> m a+runRecolorPrintT = unRecolorPrintT

@@ -0,0 +1,96 @@+{-# LANGUAGE RecordWildCards, UndecidableInstances #-}++module Blucontrol.Monad.Recolor.X (+  RecolorXT+, runRecolorXTIO+, ConfigX (..)+, XError (..)+) where++import Control.DeepSeq+import Control.Exception.Lifted (SomeException (..), bracket, catch)+import Control.Monad.Base+import Control.Monad.Trans.Control+import Control.Monad.Reader+import Control.Monad.Except+import Data.Default+import Data.Maybe (fromMaybe)+import qualified Data.Text as T+import GHC.Generics++import Graphics.X11.Xlib.Display (closeDisplay, defaultScreen, openDisplay, rootWindow)+import Graphics.X11.Xlib.Types (Display)++import Blucontrol.Monad.Recolor+import Blucontrol.Monad.Recolor.X.Internal+import Blucontrol.Value.RGB++newtype RecolorXT m a = RecolorXT { unRecolorXT :: ExceptT XError (ReaderT Display m) a }+  deriving (Applicative, Functor, Monad, MonadBase b, MonadBaseControl b, MonadError XError)++instance MonadTrans RecolorXT where+  lift = RecolorXT . lift . lift++instance MonadTransControl RecolorXT where+  type StT RecolorXT a = StT (ReaderT Display) (StT (ExceptT XError) a)+  -- TODO: broken by ghc-9.0.1+  -- liftWith = defaultLiftWith2 RecolorXT unRecolorXT+  liftWith f = RecolorXT $ liftWith $ \run -> liftWith $ \run' -> f $ run' . run . unRecolorXT+  restoreT = defaultRestoreT2 RecolorXT++instance MonadBaseControl IO m => MonadRecolor (RecolorXT m) where+  type RecolorValue (RecolorXT m) = RGB Float+  recolor rgb = do+    display <- RecolorXT ask+    root <- liftXIO XErrorRead $+      rootWindow display $ defaultScreen display++    liftXIO XErrorSetGamma $ xrrSetGamma (translateRGB rgb) display root++runRecolorXT :: Display -> RecolorXT m a -> m (Either XError a)+runRecolorXT display tma = runReaderT (runExceptT (unRecolorXT tma)) display++data ConfigX = ConfigX { hostName :: Maybe T.Text+                       , displayServer :: Int+                       , screen :: Maybe Int+                       }+  deriving (Eq, Generic, Ord, Read, Show)++instance NFData ConfigX++instance Default ConfigX where+  def = ConfigX { hostName = Nothing+                , displayServer = 0+                , screen = Nothing+                }++data XError = XErrorCloseDisplay+            | XErrorOpenDisplay+            | XErrorRead+            | XErrorSetGamma+  deriving (Bounded, Enum, Eq, Generic, Ord, Read, Show)++instance NFData XError++liftXIO :: (MonadBaseControl IO m, MonadError XError m) => XError -> IO a -> m a+liftXIO xError = flip catch throwXError . liftBase+  where throwXError (SomeException _) = throwError xError++runRecolorXTIO :: MonadBaseControl IO m => ConfigX -> RecolorXT m a -> m (Either XError a)+runRecolorXTIO !conf tma = runExceptT $ bracket open close run+  where open = liftXIO XErrorOpenDisplay $ openDisplay $ showDisplay conf+        close display = liftXIO XErrorCloseDisplay $ closeDisplay display+        run display = restoreT $ runRecolorXT display tma++showDisplay :: ConfigX -> String+showDisplay ConfigX {..} = T.unpack . T.concat $+  [ fromMaybe "" hostName+  , ":" <> T.pack (show displayServer)+  , maybe "" (("." <>) . T.pack . show) screen+  ]++translateRGB :: RGB Float -> XRRGamma+translateRGB RGB {..} = XRRGamma {..}+  where xrr_gamma_red = red+        xrr_gamma_green = green+        xrr_gamma_blue = blue

@@ -0,0 +1,29 @@+{-# LANGUAGE ForeignFunctionInterface, RecordWildCards #-}++module Blucontrol.Monad.Recolor.X.Internal (+  XRRGamma (..)+, xrrSetGamma+) where++import Control.DeepSeq+import Foreign.Ptr+import GHC.Generics++import Graphics.X11.Types+import Graphics.X11.Xlib.Types++data XRRGamma = XRRGamma { xrr_gamma_red :: Float+                         , xrr_gamma_green :: Float+                         , xrr_gamma_blue :: Float+                         }+  deriving (Eq, Generic, Ord, Read, Show)++instance NFData XRRGamma++xrrSetGamma :: XRRGamma -> Display -> Window -> IO ()+xrrSetGamma XRRGamma {..} (Display display) window = do+  res <- _XRRGetScreenResourcesCurrent display window+  _setGamma xrr_gamma_red xrr_gamma_green xrr_gamma_blue res display++foreign import ccall "XrandrGamma.h setGamma" _setGamma :: Float -> Float -> Float -> Ptr Int -> Ptr Display -> IO ()+foreign import ccall "<X11/extensions/Xrandr.h> XRRGetScreenResourcesCurrent" _XRRGetScreenResourcesCurrent :: Ptr Display -> Window -> IO (Ptr Int)

@@ -1,52 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}--module Blucontrol.RGB (-  RGB (..)-) where--import Control.DeepSeq-import Data.Default-import Data.Word-import GHC.Generics--import Blucontrol.CompatibleValues---- | Values for the colors 'red', 'green' and 'blue'-data RGB a = RGB { red :: a-                 , green :: a-                 , blue :: a-                 }-  deriving (Bounded, Eq, Generic, Ord, Read, Show)--instance NFData a => NFData (RGB a)---- TODO: Is this instance really necessary?-instance (Bounded a, Enum a) => Enum (RGB a) where-  fromEnum rgb = sum [ fromEnum (red rgb)-                     , fromEnum (green rgb) * range-                     , fromEnum (blue rgb) * range * range-                     ]-    where range = succ . fromEnum $ maxBound @a-  toEnum i = let (b , i') = i `divMod` (range * range)-                 (g , r) = i' `divMod` range-              in RGB { red = toEnum r-                     , green = toEnum g-                     , blue = toEnum b-                     }-    where range = succ . fromEnum $ maxBound @a--instance Default (RGB Word8) where-  def = RGB { red = maxBound-            , green = maxBound-            , blue = maxBound-            }--mapRGB :: (a -> b) -> RGB a -> RGB b-mapRGB f rgb = RGB { red = f $ red rgb-                   , green = f $ green rgb-                   , blue = f $ blue rgb-                   }--instance CompatibleValues (RGB Word8) (RGB Float) where-  convertValue = mapRGB word8ToFloat-    where word8ToFloat = (/ fromIntegral (maxBound @Word8)) . fromIntegral

@@ -1,38 +0,0 @@-module Blucontrol.RGB.Brightness (-  Brightness-, WithBrightness (..)-) where--import Control.DeepSeq-import Data.Default-import GHC.Generics---- | Arbitrary precision brightness between 0 and 1-newtype Brightness = Brightness Rational-  deriving (Enum, Eq, Fractional, Generic, Num, Ord, Read, Real, RealFrac, Show)--instance NFData Brightness--instance Bounded Brightness where-  minBound = 0-  maxBound = 1--instance Default Brightness where-  def = 1---- | Combination of a color value and a 'Brightness'-data WithBrightness a = WithBrightness { brightness :: Brightness-                                       , color :: a-                                       }-  deriving (Eq, Generic, Ord, Read, Show)--instance NFData a => NFData (WithBrightness a)--instance Default a => Default (WithBrightness a) where-  def = WithBrightness { brightness = def-                       , color = def-                       }---- TODO: Maybe allow applying to RGB?---toRGB WithBrightness {..} = mapRGB applyBrightness $ toRGB rgb---  where applyBrightness = truncate . (toRational brightness *) . toRational

@@ -1,51 +0,0 @@-{-# LANGUAGE RecordWildCards, UndecidableInstances #-}--module Blucontrol.RGB.Temperature (-  Temperature-) where--import Control.DeepSeq-import Data.Default-import Data.Word-import GHC.Generics--import Blucontrol.CompatibleValues-import Blucontrol.RGB---- | Arbitrary precision temperature in Kelvin-newtype Temperature = Temperature Rational-  deriving (Enum, Eq, Fractional, Generic, Num, Ord, Read, Real, RealFrac, Show)--instance NFData Temperature--instance Bounded Temperature where-  minBound = 0-  maxBound = 20000--instance Default Temperature where-  def = 6600--instance CompatibleValues (RGB Word8) a => CompatibleValues Temperature a where-  -- TODO: Test and implement more accurately. Currently based on blugon.-  convertValue = convertValue . toRGBWord8-    where toRGBWord8 :: Temperature -> RGB Word8-          toRGBWord8 (Temperature temp) = RGB {..}-            where red = round . inBounds $-                    if t <= 66-                       then 255-                       else 329.698727446 * ((t - 60) ** (-0.1332047592))-                  green = round . inBounds $-                    if t <= 66-                       then 99.4708025861 * log t - 161.1195681661-                       else 288.1221695283 * ((t - 60) ** (-0.0755148492))-                  blue = round . inBounds $-                    if t <= 0-                       then 0-                       else if t >= 66-                               then 255-                               else 138.5177312231 * log (t - 10) - 305.0447927307-                  t = fromRational $ temp / 100 :: Double-                  inBounds x-                    | x < 0 = 0-                    | x > 255 = 255-                    | otherwise = x

@@ -1,13 +0,0 @@-module Blucontrol.Recolor (-  MonadRecolor (..)-) where--class Monad m => MonadRecolor m where--  type RecolorValue m--  {- | Apply a gamma value.-     This is a monadic function, to allow application to external programs like an X display-     server.-  -}-  recolor :: RecolorValue m -> m ()

@@ -1,30 +0,0 @@-{-# LANGUAGE UndecidableInstances #-}--module Blucontrol.Recolor.Print (-  RecolorPrintT-, runRecolorPrintT-) where--import Control.Monad.Base-import Control.Monad.Trans-import Control.Monad.Trans.Control--import Blucontrol.Recolor--newtype RecolorPrintT c m a = RecolorPrintT { unRecolorPrintT :: m a }-  deriving (Applicative, Functor, Monad, MonadBase b, MonadBaseControl b)--instance MonadTrans (RecolorPrintT c) where-  lift = RecolorPrintT--instance MonadTransControl (RecolorPrintT c) where-  type StT (RecolorPrintT c) a = a-  liftWith inner = RecolorPrintT $ inner unRecolorPrintT-  restoreT = RecolorPrintT--instance (MonadBaseControl IO m, Show c) => MonadRecolor (RecolorPrintT c m) where-  type RecolorValue (RecolorPrintT c m) = c-  recolor = liftBase . print--runRecolorPrintT :: RecolorPrintT c m a -> m a-runRecolorPrintT = unRecolorPrintT

@@ -1,96 +0,0 @@-{-# LANGUAGE RecordWildCards, UndecidableInstances #-}--module Blucontrol.Recolor.X (-  RecolorXT-, runRecolorXTIO-, ConfigX (..)-, XError (..)-) where--import Control.DeepSeq-import Control.Exception.Lifted (SomeException (..), bracket, catch)-import Control.Monad.Base-import Control.Monad.Trans.Control-import Control.Monad.Reader-import Control.Monad.Except-import Data.Default-import Data.Maybe (fromMaybe)-import qualified Data.Text as T-import GHC.Generics--import Graphics.X11.Xlib.Display (closeDisplay, defaultScreen, openDisplay, rootWindow)-import Graphics.X11.Xlib.Types (Display)--import Blucontrol.RGB-import Blucontrol.Recolor-import Blucontrol.Recolor.X.Internal--newtype RecolorXT m a = RecolorXT { unRecolorXT :: ExceptT XError (ReaderT Display m) a }-  deriving (Applicative, Functor, Monad, MonadBase b, MonadBaseControl b, MonadError XError)--instance MonadTrans RecolorXT where-  lift = RecolorXT . lift . lift--instance MonadTransControl RecolorXT where-  type StT RecolorXT a = StT (ReaderT Display) (StT (ExceptT XError) a)-  -- TODO: broken by ghc-9.0.1-  -- liftWith = defaultLiftWith2 RecolorXT unRecolorXT-  liftWith f = RecolorXT $ liftWith $ \run -> liftWith $ \run' -> f $ run' . run . unRecolorXT-  restoreT = defaultRestoreT2 RecolorXT--instance MonadBaseControl IO m => MonadRecolor (RecolorXT m) where-  type RecolorValue (RecolorXT m) = RGB Float-  recolor rgb = do-    display <- RecolorXT ask-    root <- liftXIO XErrorRead $-      rootWindow display $ defaultScreen display--    liftXIO XErrorSetGamma $ xrrSetGamma (translateRGB rgb) display root--runRecolorXT :: Display -> RecolorXT m a -> m (Either XError a)-runRecolorXT display tma = runReaderT (runExceptT (unRecolorXT tma)) display--data ConfigX = ConfigX { hostName :: Maybe T.Text-                       , displayServer :: Int-                       , screen :: Maybe Int-                       }-  deriving (Eq, Generic, Ord, Read, Show)--instance NFData ConfigX--instance Default ConfigX where-  def = ConfigX { hostName = Nothing-                , displayServer = 0-                , screen = Nothing-                }--data XError = XErrorCloseDisplay-            | XErrorOpenDisplay-            | XErrorRead-            | XErrorSetGamma-  deriving (Bounded, Enum, Eq, Generic, Ord, Read, Show)--instance NFData XError--liftXIO :: (MonadBaseControl IO m, MonadError XError m) => XError -> IO a -> m a-liftXIO xError = flip catch throwXError . liftBase-  where throwXError (SomeException _) = throwError xError--runRecolorXTIO :: MonadBaseControl IO m => ConfigX -> RecolorXT m a -> m (Either XError a)-runRecolorXTIO !conf tma = runExceptT $ bracket open close run-  where open = liftXIO XErrorOpenDisplay $ openDisplay $ showDisplay conf-        close display = liftXIO XErrorCloseDisplay $ closeDisplay display-        run display = restoreT $ runRecolorXT display tma--showDisplay :: ConfigX -> String-showDisplay ConfigX {..} = T.unpack . T.concat $-  [ fromMaybe "" hostName-  , ":" <> T.pack (show displayServer)-  , maybe "" (("." <>) . T.pack . show) screen-  ]--translateRGB :: RGB Float -> XRRGamma-translateRGB RGB {..} = XRRGamma {..}-  where xrr_gamma_red = red-        xrr_gamma_green = green-        xrr_gamma_blue = blue

@@ -1,29 +0,0 @@-{-# LANGUAGE ForeignFunctionInterface, RecordWildCards #-}--module Blucontrol.Recolor.X.Internal (-  XRRGamma (..)-, xrrSetGamma-) where--import Control.DeepSeq-import Foreign.Ptr-import GHC.Generics--import Graphics.X11.Types-import Graphics.X11.Xlib.Types--data XRRGamma = XRRGamma { xrr_gamma_red :: Float-                         , xrr_gamma_green :: Float-                         , xrr_gamma_blue :: Float-                         }-  deriving (Eq, Generic, Ord, Read, Show)--instance NFData XRRGamma--xrrSetGamma :: XRRGamma -> Display -> Window -> IO ()-xrrSetGamma XRRGamma {..} (Display display) window = do-  res <- _XRRGetScreenResourcesCurrent display window-  _setGamma xrr_gamma_red xrr_gamma_green xrr_gamma_blue res display--foreign import ccall "XrandrGamma.h setGamma" _setGamma :: Float -> Float -> Float -> Ptr Int -> Ptr Display -> IO ()-foreign import ccall "<X11/extensions/Xrandr.h> XRRGetScreenResourcesCurrent" _XRRGetScreenResourcesCurrent :: Ptr Display -> Window -> IO (Ptr Int)

@@ -0,0 +1,9 @@+module Blucontrol.Value (+  CompatibleValues (..)+) where++class CompatibleValues a b where+    convertValue :: a -> b++instance CompatibleValues a a where+  convertValue = id

@@ -0,0 +1,38 @@+module Blucontrol.Value.Brightness (+  Brightness+, WithBrightness (..)+) where++import Control.DeepSeq+import Data.Default+import GHC.Generics++-- | Arbitrary precision brightness between 0 and 1+newtype Brightness = Brightness Rational+  deriving (Enum, Eq, Fractional, Generic, Num, Ord, Read, Real, RealFrac, Show)++instance NFData Brightness++instance Bounded Brightness where+  minBound = 0+  maxBound = 1++instance Default Brightness where+  def = 1++-- | Combination of a color value and a 'Brightness'+data WithBrightness a = WithBrightness { brightness :: Brightness+                                       , color :: a+                                       }+  deriving (Eq, Generic, Ord, Read, Show)++instance NFData a => NFData (WithBrightness a)++instance Default a => Default (WithBrightness a) where+  def = WithBrightness { brightness = def+                       , color = def+                       }++-- TODO: Maybe allow applying to RGB?+--toRGB WithBrightness {..} = mapRGB applyBrightness $ toRGB rgb+--  where applyBrightness = truncate . (toRational brightness *) . toRational

@@ -0,0 +1,52 @@+{-# LANGUAGE ScopedTypeVariables #-}++module Blucontrol.Value.RGB (+  RGB (..)+) where++import Control.DeepSeq+import Data.Default+import Data.Word+import GHC.Generics++import Blucontrol.Value++-- | Values for the colors 'red', 'green' and 'blue'+data RGB a = RGB { red :: a+                 , green :: a+                 , blue :: a+                 }+  deriving (Bounded, Eq, Generic, Ord, Read, Show)++instance NFData a => NFData (RGB a)++-- TODO: Is this instance really necessary?+instance (Bounded a, Enum a) => Enum (RGB a) where+  fromEnum rgb = sum [ fromEnum (red rgb)+                     , fromEnum (green rgb) * range+                     , fromEnum (blue rgb) * range * range+                     ]+    where range = succ . fromEnum $ maxBound @a+  toEnum i = let (b , i') = i `divMod` (range * range)+                 (g , r) = i' `divMod` range+              in RGB { red = toEnum r+                     , green = toEnum g+                     , blue = toEnum b+                     }+    where range = succ . fromEnum $ maxBound @a++instance Default (RGB Word8) where+  def = RGB { red = maxBound+            , green = maxBound+            , blue = maxBound+            }++mapRGB :: (a -> b) -> RGB a -> RGB b+mapRGB f rgb = RGB { red = f $ red rgb+                   , green = f $ green rgb+                   , blue = f $ blue rgb+                   }++instance CompatibleValues (RGB Word8) (RGB Float) where+  convertValue = mapRGB word8ToFloat+    where word8ToFloat = (/ fromIntegral (maxBound @Word8)) . fromIntegral

@@ -0,0 +1,51 @@+{-# LANGUAGE RecordWildCards, UndecidableInstances #-}++module Blucontrol.Value.RGB.Temperature (+  Temperature+) where++import Control.DeepSeq+import Data.Default+import Data.Word+import GHC.Generics++import Blucontrol.Value+import Blucontrol.Value.RGB++-- | Arbitrary precision temperature in Kelvin+newtype Temperature = Temperature Rational+  deriving (Enum, Eq, Fractional, Generic, Num, Ord, Read, Real, RealFrac, Show)++instance NFData Temperature++instance Bounded Temperature where+  minBound = 0+  maxBound = 20000++instance Default Temperature where+  def = 6600++instance CompatibleValues (RGB Word8) a => CompatibleValues Temperature a where+  -- TODO: Test and implement more accurately. Currently based on blugon.+  convertValue = convertValue . toRGBWord8+    where toRGBWord8 :: Temperature -> RGB Word8+          toRGBWord8 (Temperature temp) = RGB {..}+            where red = round . inBounds $+                    if t <= 66+                       then 255+                       else 329.698727446 * ((t - 60) ** (-0.1332047592))+                  green = round . inBounds $+                    if t <= 66+                       then 99.4708025861 * log t - 161.1195681661+                       else 288.1221695283 * ((t - 60) ** (-0.0755148492))+                  blue = round . inBounds $+                    if t <= 0+                       then 0+                       else if t >= 66+                               then 255+                               else 138.5177312231 * log (t - 10) - 305.0447927307+                  t = fromRational $ temp / 100 :: Double+                  inBounds x+                    | x < 0 = 0+                    | x > 255 = 255+                    | otherwise = x

@@ -2,10 +2,10 @@  import Test.Hspec -import qualified Blucontrol.Test.Gamma.Linear-import qualified Blucontrol.Test.RGB+import qualified Blucontrol.Monad.Gamma.Linear.Test+import qualified Blucontrol.Value.RGB.Test  main :: IO () main = hspec $ do-  Blucontrol.Test.RGB.test-  Blucontrol.Test.Gamma.Linear.test+  Blucontrol.Value.RGB.Test.test+  Blucontrol.Monad.Gamma.Linear.Test.test

@@ -0,0 +1,67 @@+{-# LANGUAGE RecordWildCards #-}++module Blucontrol.Monad.Gamma.Linear.Test (+  test+) where++import Test.Hspec+import Test.QuickCheck++import Control.DeepSeq+import Control.Monad.Identity+import Data.Time+import Data.Word+import GHC.Generics++import Blucontrol.Monad.Gamma.Linear+import Blucontrol.Value.RGB+import Blucontrol.Value.RGB.Test (Arbitrary_RGBWord8 (..))++test :: Spec+test = describe "Blucontrol.Gamma.Linear" $ do++  it "convert Time to TimeOfDay" $+    property prop_timeToTimeOfDay++  -- TODO: this tests `calculateValue weightedAverageRGB`+  it "calculateRGB between surrounding values" $+    property prop_calculateRGB++newtype Arbitrary_Time = Arbitrary_Time Time+  deriving (Bounded, Enum, Eq, Generic, Ord, Read, Show)++instance NFData Arbitrary_Time++instance Arbitrary Arbitrary_Time where+  arbitrary = elements [minBound .. maxBound]++prop_timeToTimeOfDay :: Arbitrary_Time -> Bool+prop_timeToTimeOfDay (Arbitrary_Time time) = and+  [ fromIntegral h == todHour+  , fromIntegral m == todMin+  , 0 == todSec+  ]+  where h :. m = time+        TimeOfDay {..} = fst $ time Blucontrol.Monad.Gamma.Linear.==> (undefined :: RGB Word8)++prop_calculateRGB :: Arbitrary_Time+                  -> (Arbitrary_Time,Arbitrary_RGBWord8)+                  -> (Arbitrary_Time,Arbitrary_RGBWord8)+                  -> Bool+prop_calculateRGB (Arbitrary_Time time) (Arbitrary_Time xt , Arbitrary_RGBWord8 xtc) (Arbitrary_Time yt , Arbitrary_RGBWord8 ytc) =+  rgb `prop_RGBBetween` (xtc , ytc)+  where rgb = runIdentity . runGammaLinearT rgbMap $ calculateValue weightedAverageRGB tod+        rgbMap = xt Blucontrol.Monad.Gamma.Linear.==> xtc+            :| [ yt Blucontrol.Monad.Gamma.Linear.==> ytc+               ]+        tod = LocalTime (ModifiedJulianDay 0) . fst $ time Blucontrol.Monad.Gamma.Linear.==> (undefined :: RGB Word8)++prop_RGBBetween :: RGB Word8 -> (RGB Word8,RGB Word8) -> Bool+prop_RGBBetween x (a,b) = and+  [ red x `prop_between` (red a , red b)+  , green x `prop_between` (green a , green b)+  , blue x `prop_between` (blue a , blue b)+  ]++prop_between :: Ord a => a -> (a,a) -> Bool+prop_between x (a,b) = x <= max a b && x >= min a b

@@ -1,67 +0,0 @@-{-# LANGUAGE RecordWildCards #-}--module Blucontrol.Test.Gamma.Linear (-  test-) where--import Test.Hspec-import Test.QuickCheck--import Control.DeepSeq-import Control.Monad.Identity-import Data.Time-import Data.Word-import GHC.Generics--import Blucontrol.Gamma.Linear-import Blucontrol.RGB-import Blucontrol.Test.RGB (Arbitrary_RGBWord8 (..))--test :: Spec-test = describe "Blucontrol.Gamma.Linear" $ do--  it "convert Time to TimeOfDay" $-    property prop_timeToTimeOfDay--  -- TODO: this tests `calculateValue weightedAverageRGB`-  it "calculateRGB between surrounding values" $-    property prop_calculateRGB--newtype Arbitrary_Time = Arbitrary_Time Time-  deriving (Bounded, Enum, Eq, Generic, Ord, Read, Show)--instance NFData Arbitrary_Time--instance Arbitrary Arbitrary_Time where-  arbitrary = elements [minBound .. maxBound]--prop_timeToTimeOfDay :: Arbitrary_Time -> Bool-prop_timeToTimeOfDay (Arbitrary_Time time) = and-  [ fromIntegral h == todHour-  , fromIntegral m == todMin-  , 0 == todSec-  ]-  where h :. m = time-        TimeOfDay {..} = fst $ time Blucontrol.Gamma.Linear.==> (undefined :: RGB Word8)--prop_calculateRGB :: Arbitrary_Time-                  -> (Arbitrary_Time,Arbitrary_RGBWord8)-                  -> (Arbitrary_Time,Arbitrary_RGBWord8)-                  -> Bool-prop_calculateRGB (Arbitrary_Time time) (Arbitrary_Time xt , Arbitrary_RGBWord8 xtc) (Arbitrary_Time yt , Arbitrary_RGBWord8 ytc) =-  rgb `prop_RGBBetween` (xtc , ytc)-  where rgb = runIdentity . runGammaLinearT rgbMap $ calculateValue weightedAverageRGB tod-        rgbMap = xt Blucontrol.Gamma.Linear.==> xtc-            :| [ yt Blucontrol.Gamma.Linear.==> ytc-               ]-        tod = LocalTime (ModifiedJulianDay 0) . fst $ time Blucontrol.Gamma.Linear.==> (undefined :: RGB Word8)--prop_RGBBetween :: RGB Word8 -> (RGB Word8,RGB Word8) -> Bool-prop_RGBBetween x (a,b) = and-  [ red x `prop_between` (red a , red b)-  , green x `prop_between` (green a , green b)-  , blue x `prop_between` (blue a , blue b)-  ]--prop_between :: Ord a => a -> (a,a) -> Bool-prop_between x (a,b) = x <= max a b && x >= min a b

@@ -1,29 +0,0 @@-{-# LANGUAGE RecordWildCards #-}--module Blucontrol.Test.RGB (-  test-, Arbitrary_RGBWord8 (..)-) where--import Test.Hspec-import Test.QuickCheck--import Control.DeepSeq-import Data.Word-import GHC.Generics--import Blucontrol.RGB--test :: Spec-test = describe "Blucontrol.RGB" $ do--  it "(RGB Word8) in bounds." $-    property $ total @Arbitrary_RGBWord8--newtype Arbitrary_RGBWord8 = Arbitrary_RGBWord8 (RGB Word8)-  deriving (Bounded, Enum, Eq, Generic, Ord, Read, Show)--instance NFData Arbitrary_RGBWord8--instance Arbitrary Arbitrary_RGBWord8 where-  arbitrary = elements [minBound .. maxBound]

@@ -0,0 +1,29 @@+{-# LANGUAGE RecordWildCards #-}++module Blucontrol.Value.RGB.Test (+  test+, Arbitrary_RGBWord8 (..)+) where++import Test.Hspec+import Test.QuickCheck++import Control.DeepSeq+import Data.Word+import GHC.Generics++import Blucontrol.Value.RGB++test :: Spec+test = describe "Blucontrol.RGB" $ do++  it "(RGB Word8) in bounds." $+    property $ total @Arbitrary_RGBWord8++newtype Arbitrary_RGBWord8 = Arbitrary_RGBWord8 (RGB Word8)+  deriving (Bounded, Enum, Eq, Generic, Ord, Read, Show)++instance NFData Arbitrary_RGBWord8++instance Arbitrary Arbitrary_RGBWord8 where+  arbitrary = elements [minBound .. maxBound]