blucontrol 0.6.0.0 → 0.7.0.0

raw patch · 28 files changed

+519/−514 lines, 28 filesdep ~QuickCheckdep ~hspecPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: QuickCheck, hspec

API changes (from Hackage documentation)

Files

• CHANGELOG.md +7/−0
• Main.hs +9/−9
• blucontrol.cabal +13/−13
• src/Blucontrol.hs +11/−11
• src/Blucontrol/Main.hs +21/−21
• src/Blucontrol/Main/Control.hs +20/−20
• src/Blucontrol/Monad/ApplyValue.hs +13/−0
• src/Blucontrol/Monad/ApplyValue/Print.hs +22/−0
• src/Blucontrol/Monad/ApplyValue/X.hs +97/−0
• src/Blucontrol/Monad/ApplyValue/X/Internal.hs +29/−0
• src/Blucontrol/Monad/Control.hs +2/−2
• src/Blucontrol/Monad/Control/Count.hs +2/−3
• src/Blucontrol/Monad/Gamma.hs +0/−13
• src/Blucontrol/Monad/Gamma/Const.hs +0/−23
• src/Blucontrol/Monad/Gamma/Linear.hs +0/−137
• src/Blucontrol/Monad/Gamma/Modifier.hs +0/−29
• src/Blucontrol/Monad/PrepareValue.hs +13/−0
• src/Blucontrol/Monad/PrepareValue/Const.hs +23/−0
• src/Blucontrol/Monad/PrepareValue/Linear.hs +137/−0
• src/Blucontrol/Monad/PrepareValue/Modifier.hs +30/−0
• src/Blucontrol/Monad/Recolor.hs +0/−13
• src/Blucontrol/Monad/Recolor/Print.hs +0/−22
• src/Blucontrol/Monad/Recolor/X.hs +0/−97
• src/Blucontrol/Monad/Recolor/X/Internal.hs +0/−29
• test/Blucontrol.hs +2/−2
• test/Blucontrol/Monad/Gamma/Linear/Test.hs +0/−65
• test/Blucontrol/Monad/PrepareValue/Linear/Test.hs +63/−0
• test/Blucontrol/Value/RGB/Test.hs +5/−5

@@ -1,5 +1,12 @@ # Revision history for blucontrol +## 0.7.0.0 *19 Jul 2021*++* `MonadGamma` has been renamed to `MonadPrepareValue`.+* `MonadRecolor` has been renamed to `MonadApplyValue`.+* Move modules from `Blucontrol.Monad.Gamma` to `Blucontrol.Monad.PrepareValue`.+* Move modules from `Blucontrol.Monad.Recolor` to `Blucontrol.Monad.ApplyValue`.+ ## 0.6.0.0 *24 Jun 2021*  * `runControl` is now a regular monad runner, that also returns the monadic state.

@@ -3,21 +3,21 @@ module Main where  import Blucontrol+import Blucontrol.Monad.ApplyValue.X 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.Monad.PrepareValue.Linear import Blucontrol.Value.RGB.Temperature  main :: IO () main = print =<< blucontrol configControl   where configControl = ConfigControl { runControl = runControlPrintT !> runControlCountT def !> runControlWaitT def-                                      , runGamma = runGammaLinearT @Temperature rgbMap-                                      , runRecolor = runRecolorXTIO def+                                      , runPrepareValue = runPrepareValueLinearT @Temperature temperatureMap+                                      , runApplyValue = runApplyValueXTIO def                                       }-        rgbMap = 00:.00 ==> 4000-            :| [ 08:.00 ==> 4600-               , 12:.00 ==> 6600-               , 18:.00 ==> 6000-               ]+        temperatureMap = 00:.00 ==> 4000+                    :| [ 08:.00 ==> 4600+                       , 12:.00 ==> 6600+                       , 18:.00 ==> 6000+                       ]

@@ -1,5 +1,5 @@ name:                blucontrol-version:             0.6.0.0+version:             0.7.0.0 synopsis:            Configurable blue light filter description:         This application is a blue light filter, with the main focus on                      configurability.@@ -8,7 +8,7 @@                      <https://hackage.haskell.org/package/xmonad xmonad>.                      .                      Blucontrol makes use of monad transformers and allows monadic calculation of-                     gamma values and recoloring.+                     values and applying those values.                      The user chooses, what will be captured in the monadic state.                      .                      To get started with configuring read "Blucontrol".@@ -28,24 +28,24 @@                        Blucontrol.Main                        Blucontrol.Main.CLI                        Blucontrol.Main.Control+                       Blucontrol.Monad.ApplyValue+                       Blucontrol.Monad.ApplyValue.Print+                       Blucontrol.Monad.ApplyValue.X                        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.Monad.PrepareValue+                       Blucontrol.Monad.PrepareValue.Const+                       Blucontrol.Monad.PrepareValue.Linear+                       Blucontrol.Monad.PrepareValue.Modifier                        Blucontrol.Value                        Blucontrol.Value.Brightness                        Blucontrol.Value.RGB                        Blucontrol.Value.RGB.Temperature   other-modules:       Blucontrol.Main.GHC.Internal-                       Blucontrol.Monad.Recolor.X.Internal+                       Blucontrol.Monad.ApplyValue.X.Internal                        Control.Monad.Trans.Control.Default                        Paths_blucontrol   build-depends:       base              >= 4.11    && < 5@@ -106,15 +106,15 @@   main-is:             Blucontrol.hs   type:                exitcode-stdio-1.0   hs-source-dirs:      test-  other-modules:       Blucontrol.Monad.Gamma.Linear.Test+  other-modules:       Blucontrol.Monad.PrepareValue.Linear.Test                        Blucontrol.Value.RGB.Test   build-depends:       base                      , blucontrol                      , data-default                      , deepseq-                     , hspec        >= 2.6.0   && < 2.8+                     , hspec        >= 2.6.0   && < 3.0                      , mtl-                     , QuickCheck   >= 2.13.2  && < 2.15+                     , QuickCheck   >= 2.13.2  && < 3.0                      , time   default-language:    Haskell2010   default-extensions:  BangPatterns

@@ -6,13 +6,13 @@ -}   blucontrol , BlucontrolConstraints-{- | 'ConfigControl' will set the monads in which recoloring and calculation of the gamma values-  will take place.+{- | 'ConfigControl' will set the monads in which calculation and application of values will take+   place. -} , ConfigControl (..)  -- * Control--- | Modules with instances of 'MonadControl' can be found under @Blucontrol.Control.*@.+-- | Modules with instances of 'MonadControl' can be found under @Blucontrol.Monad.Control.*@. , MonadControl (..)  {- | To compose instances of 'MonadControl' avoid function composition, as it won't compose@@ -21,13 +21,13 @@ -} , (!>) --- * Gamma--- | Modules with instances of 'MonadGamma' can be found under @Blucontrol.Gamma.*@.-, MonadGamma (..)+-- * Prepare value+-- | Modules with instances of 'MonadPrepareValue' can be found under @Blucontrol.Monad.PrepareValue.*@.+, MonadPrepareValue (..) --- * Recolor--- | Modules with instances of 'MonadRecolor' can be found under @Blucontrol.Recolor.*@.-, MonadRecolor (..)+-- * ApplyValue+-- | Modules with instances of 'MonadApplyValue' can be found under @Blucontrol.Monad.ApplyValue.*@.+, MonadApplyValue (..)  -- * other , Default (..)@@ -36,7 +36,7 @@ import Data.Default  import Blucontrol.Main+import Blucontrol.Monad.ApplyValue import Blucontrol.Monad.Control import Blucontrol.Monad.Control.Concat-import Blucontrol.Monad.Gamma-import Blucontrol.Monad.Recolor+import Blucontrol.Monad.PrepareValue

@@ -8,32 +8,32 @@  import Blucontrol.Main.Control import Blucontrol.Main.CLI+import Blucontrol.Monad.ApplyValue import Blucontrol.Monad.Control-import Blucontrol.Monad.Gamma-import Blucontrol.Monad.Recolor+import Blucontrol.Monad.PrepareValue import Blucontrol.Value -type BlucontrolConstraints m g r =-  ( ControlConstraint m (StM g (StM r ()))-  , MonadControl m-  , MonadBaseControl IO g-  , MonadBaseControl IO r-  , MonadGamma g-  , MonadRecolor r-  , CompatibleValues (GammaValue g) (RecolorValue r)+type BlucontrolConstraints mc mp ma =+  ( CompatibleValues (PreparedValue mp) (ApplicableValue ma)+  , ControlConstraint mc (StM mp (StM ma ()))+  , MonadBaseControl IO mp+  , MonadBaseControl IO ma+  , MonadApplyValue ma+  , MonadControl mc+  , MonadPrepareValue mp   ) -blucontrol :: BlucontrolConstraints m g r-           => ConfigControl m g r-           -> IO (StM m (StM g (StM r ())))-blucontrol ConfigControl { runControl, runGamma, runRecolor } = do+blucontrol :: BlucontrolConstraints mc mp ma+           => ConfigControl mc mp ma+           -> IO (StM mc (StM mp (StM ma ())))+blucontrol ConfigControl { runControl, runPrepareValue, runApplyValue } = do   launch   runControl $ liftBaseWith $ \ runC ->-    runGamma $ liftBaseWith $ \ runG ->-      runRecolor $ liftBaseWith $ \ runR ->-        loopRecolor runC runG runR convertValue+    runPrepareValue $ liftBaseWith $ \ runP ->+      runApplyValue $ liftBaseWith $ \ runA ->+        loopRecolor runC runP runA convertValue -data ConfigControl m g r = ConfigControl { runControl :: forall a. m a -> IO (StM m a)-                                         , runGamma   :: forall a. g a -> IO (StM g a)-                                         , runRecolor :: forall a. r a -> IO (StM r a)-                                         }+data ConfigControl mc mp ma = ConfigControl { runControl :: forall a. mc a -> IO (StM mc a)+                                            , runPrepareValue :: forall a. mp a -> IO (StM mp a)+                                            , runApplyValue :: forall a. ma a -> IO (StM ma a)+                                            }

@@ -7,48 +7,48 @@ import Control.Monad.Trans.Control import Unsafe.Coerce +import Blucontrol.Monad.ApplyValue import Blucontrol.Monad.Control-import Blucontrol.Monad.Gamma-import Blucontrol.Monad.Recolor+import Blucontrol.Monad.PrepareValue --- | 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)+-- | Run the loop, using `prepareValue`, `applyValue` and `doInbetween`.+loopRecolor :: (ControlConstraint mc (StM mp (StM ma ())), MonadBaseControl IO mc, MonadBaseControl IO mp, MonadBaseControl IO ma, MonadApplyValue ma, MonadControl mc, MonadPrepareValue mp)+            => RunInBase mc IO+            -> RunInBase mp IO+            -> RunInBase ma IO+            -> (PreparedValue mp -> ApplicableValue ma)             -> IO ()-loopRecolor runC runG runR coerceValue = do+loopRecolor runC runP runA 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.+      -- Use `preparedValue` and give the result to `applyValue`.+      -- Then use the result of `applyValue` and give it to `doInbetween` including the monadic state.       -- The argument is an initial monadic state.-  let doRecolorGamma x =+  let doRecolor x =         runC $ do           x1 <- restoreM x           x4 <- liftBase $ do-            runG $ do+            runP $ do               x2 <- restoreM x1-              value <- coerceValue <$> gamma-              liftBase $ runR $ do+              value <- coerceValue <$> preparedValue+              liftBase $ runA $ do                 x3 <- restoreM x2-                recolor value+                applyValue value                 pure x3           let currentRecolorValue =-                runG $ do+                runP $ do                   -- TODO: `unsafeCoerce` is necessary because of GHC limitations with type families.                   -- `unsafeCoerce` will act like `id`.                   x5 <- restoreM $ unsafeCoerce x4-                  liftBase $ runR $ void $ restoreM x5+                  liftBase $ runA $ void $ restoreM x5           currentRecolorValue' <- liftBase currentRecolorValue           doInbetween currentRecolorValue'           pure x4        -- Run `doLoopRecolor` in a recursive loop while passing the monadic state explicitly.-      doLoopRecolor x = doLoopRecolor =<< liftBase (doRecolorGamma x)+      doLoopRecolor x = doLoopRecolor =<< liftBase (doRecolor x)    -- Initialize the monadic state.-  initStM <- runC $ liftBase $ runG $ liftBase $ runR $ pure undefined+  initStM <- runC $ liftBase $ runP $ liftBase $ runA $ pure undefined    -- Start an infinite loop.   -- TODO: `unsafeCoerce` is necessary because of GHC limitations with type families.

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

@@ -0,0 +1,22 @@+module Blucontrol.Monad.ApplyValue.Print (+  ApplyValuePrintT+, runApplyValuePrintT+) where++import Control.Monad.Base+import Control.Monad.Trans+import Control.Monad.Trans.Control+import Control.Monad.Trans.Control.Default++import Blucontrol.Monad.ApplyValue++newtype ApplyValuePrintT c m a = ApplyValuePrintT { unApplyValuePrintT :: m a }+  deriving (Applicative, Functor, Monad, MonadBase b, MonadBaseControl b)+  deriving (MonadTrans, MonadTransControl) via Stack0T++instance (MonadBaseControl IO m, Show c) => MonadApplyValue (ApplyValuePrintT c m) where+  type ApplicableValue (ApplyValuePrintT c m) = c+  applyValue = liftBase . print++runApplyValuePrintT :: ApplyValuePrintT c m a -> m a+runApplyValuePrintT = unApplyValuePrintT

@@ -0,0 +1,97 @@+{-# LANGUAGE UndecidableInstances #-}++module Blucontrol.Monad.ApplyValue.X (+  ApplyValueXT+, runApplyValueXTIO+, ApplicableValueX+, 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.Trans.Control.Default+import Control.Monad.Reader+import Control.Monad.Except+import Data.Default+import Data.Maybe (fromMaybe)+import qualified Data.Text as T+import Data.Word+import GHC.Generics++import Graphics.X11.Xlib.Display (closeDisplay, defaultScreen, openDisplay, rootWindow)+import Graphics.X11.Xlib.Types (Display)++import Blucontrol.Monad.ApplyValue+import Blucontrol.Monad.ApplyValue.X.Internal+import Blucontrol.Value+import Blucontrol.Value.RGB++newtype ApplyValueXT m a = ApplyValueXT { unApplyValueXT :: ExceptT XError (ReaderT Display m) a }+  deriving (Applicative, Functor, Monad, MonadBase b, MonadBaseControl b, MonadError XError)+  deriving (MonadTrans, MonadTransControl) via Stack2T (ExceptT XError) (ReaderT Display)++instance MonadBaseControl IO m => MonadApplyValue (ApplyValueXT m) where+  type ApplicableValue (ApplyValueXT m) = ApplicableValueX+  applyValue rgb = do+    display <- ApplyValueXT ask+    root <- liftXIO XErrorRead $+      rootWindow display $ defaultScreen display++    liftXIO XErrorSetGamma $ xrrSetGamma (unApplicableValueX rgb) display root++runApplyValueXT :: Display -> ApplyValueXT m a -> m (Either XError a)+runApplyValueXT display tma = runReaderT (runExceptT (unApplyValueXT 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++runApplyValueXTIO :: MonadBaseControl IO m => ConfigX -> ApplyValueXT m a -> m (Either XError a)+runApplyValueXTIO !conf tma = runExceptT $ bracket open close run+  where open = liftXIO XErrorOpenDisplay $ openDisplay $ showDisplay conf+        close display = liftXIO XErrorCloseDisplay $ closeDisplay display+        run display = restoreT $ runApplyValueXT display tma++showDisplay :: ConfigX -> String+showDisplay ConfigX { hostName, displayServer, screen } = T.unpack . T.concat $+  [ fromMaybe "" hostName+  , ":" <> T.pack (show displayServer)+  , maybe "" (("." <>) . T.pack . show) screen+  ]++newtype ApplicableValueX = ApplicableValueX { unApplicableValueX :: XRRGamma }+  deriving (Eq, Generic, Ord, Read, Show)++instance NFData ApplicableValueX++instance CompatibleValues (RGB Word8) ApplicableValueX where+  convertValue RGB { red, green, blue } = ApplicableValueX XRRGamma { xrr_gamma_red, xrr_gamma_green, xrr_gamma_blue }+    where xrr_gamma_red = word8ToFloat red+          xrr_gamma_green = word8ToFloat green+          xrr_gamma_blue = word8ToFloat blue+          word8ToFloat = (/ fromIntegral (maxBound @Word8)) . fromIntegral

@@ -0,0 +1,29 @@+{-# LANGUAGE ForeignFunctionInterface #-}++module Blucontrol.Monad.ApplyValue.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 { xrr_gamma_red, xrr_gamma_green, xrr_gamma_blue } (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)

@@ -11,13 +11,13 @@    {- | 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'.+    'Blucontrol.Monad.PrepareValue' and 'Blucontrol.Monad.ApplyValue'.   -}   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+              => a -- ^ the returned value from the last call of 'Blucontrol.Monad.ApplyValue.applyValue' including monadic state               -> m () -- ^ the side effect to be run inbetween recoloring  instance MonadControl IO where

@@ -30,9 +30,8 @@                         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 ()+                     unless (current < limit) $+                        error $ "failed after " <> show limit <> " consecutive tries"  runControlCountT :: Monad m => ConfigCount -> ControlCountT m a -> m (a, Natural) runControlCountT !conf tma = runReaderT (runStateT (unControlCountT tma) 0) conf

@@ -1,13 +0,0 @@-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)

@@ -1,23 +0,0 @@-{-# 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 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,137 +0,0 @@-{-# 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 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.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.PrepareValue (+  MonadPrepareValue (..)+) where++class Monad m => MonadPrepareValue m where++  type PreparedValue m++  {- | Calculate a value.+     This is a monadic function, to allow the value to be dependent on side effects like time and+     location.+  -}+  preparedValue :: m (PreparedValue m)

@@ -0,0 +1,23 @@+{-# LANGUAGE UndecidableInstances #-}++module Blucontrol.Monad.PrepareValue.Const (+  PrepareValueConstT+, runPrepareValueConstT+) where++import Control.Monad.Base+import Control.Monad.Trans+import Control.Monad.Trans.Control+import Control.Monad.Reader++import Blucontrol.Monad.PrepareValue++newtype PrepareValueConstT c m a = PrepareValueConstT { unPrepareValueConstT :: ReaderT c m a }+  deriving (Applicative, Functor, Monad, MonadBase b, MonadBaseControl b, MonadTrans, MonadTransControl)++instance Monad m => MonadPrepareValue (PrepareValueConstT c m) where+  type PreparedValue (PrepareValueConstT c m) = c+  preparedValue = PrepareValueConstT ask++runPrepareValueConstT :: c -> PrepareValueConstT c m a -> m a+runPrepareValueConstT !rgb tma = runReaderT (unPrepareValueConstT tma) rgb

@@ -0,0 +1,137 @@+{-# LANGUAGE UndecidableInstances #-}++module Blucontrol.Monad.PrepareValue.Linear (+  PrepareValueLinearT+, runPrepareValueLinearT+, 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.PrepareValue+import Blucontrol.Value.Brightness+import Blucontrol.Value.RGB+import Blucontrol.Value.RGB.Temperature++newtype PrepareValueLinearT c m a = PrepareValueLinearT { unPrepareValueLinearT :: ReaderT (M.Map TimeOfDay c) m a }+  deriving (Applicative, Functor, Monad, MonadBase b, MonadBaseControl b, MonadTrans, MonadTransControl)++instance MonadBase IO m => MonadPrepareValue (PrepareValueLinearT (RGB Word8) m) where+  type PreparedValue (PrepareValueLinearT (RGB Word8) m) = RGB Word8+  preparedValue = calculateValue weightedAverageRGB . zonedTimeToLocalTime =<< liftBase getZonedTime++instance MonadBase IO m => MonadPrepareValue (PrepareValueLinearT Temperature m) where+  type PreparedValue (PrepareValueLinearT Temperature m) = Temperature+  preparedValue = calculateValue weightedAverageTemperature . zonedTimeToLocalTime =<< liftBase getZonedTime++instance (MonadBase IO m, MonadPrepareValue (PrepareValueLinearT c m)) => MonadPrepareValue (PrepareValueLinearT (WithBrightness c) m) where+  type PreparedValue (PrepareValueLinearT (WithBrightness c) m) = WithBrightness (PreparedValue (PrepareValueLinearT c m))+  -- TODO: It would be nice to use the same exact time for `color'` and `brightness'`.+  preparedValue = do+    color' <- withPrepareValueLinearT color preparedValue+    brightness' <- withPrepareValueLinearT brightness $ calculateValue weightedAverageBrightness . zonedTimeToLocalTime =<< liftBase getZonedTime+    return WithBrightness { brightness = brightness'+                          , color = color'+                          }++withPrepareValueLinearT :: (c' -> c) -> PrepareValueLinearT c m a -> PrepareValueLinearT c' m a+withPrepareValueLinearT f m = PrepareValueLinearT $ withReaderT (fmap f) $ unPrepareValueLinearT 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 -> PrepareValueLinearT c m c+calculateValue weightedAverage time = do+  m <- PrepareValueLinearT 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)++runPrepareValueLinearT' :: M.Map TimeOfDay c -> PrepareValueLinearT c m a -> m a+runPrepareValueLinearT' !rgbs tma = runReaderT (unPrepareValueLinearT tma) rgbs++runPrepareValueLinearT :: N.NonEmpty (TimeOfDay,c) -> PrepareValueLinearT c m a -> m a+runPrepareValueLinearT rgbs = runPrepareValueLinearT' $ 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,30 @@+{-# LANGUAGE UndecidableInstances #-}++module Blucontrol.Monad.PrepareValue.Modifier (+  PrepareValueModifierT+, runPrepareValueModifierT+) where++import Control.Monad.Base+import Control.Monad.Except+import Control.Monad.Reader+import Control.Monad.Trans.Control++import Blucontrol.Monad.PrepareValue++newtype PrepareValueModifierT m a = PrepareValueModifierT { unPrepareValueModifierT :: ReaderT (PreparedValue m -> IO (PreparedValue m)) m a }+  deriving (Applicative, Functor, Monad, MonadBase b, MonadBaseControl b)+-- TODO: A `MonadTransControl` instance seems to be impossible++instance MonadTrans PrepareValueModifierT where+  lift = PrepareValueModifierT . lift++instance (MonadBase IO m, MonadPrepareValue m) => MonadPrepareValue (PrepareValueModifierT m) where+  type PreparedValue (PrepareValueModifierT m) = PreparedValue m+  preparedValue = do+    oldValue <- lift preparedValue+    modifyValue <- PrepareValueModifierT ask+    liftBase $ modifyValue oldValue++runPrepareValueModifierT :: (PreparedValue m -> IO (PreparedValue m)) -> PrepareValueModifierT m a -> m a+runPrepareValueModifierT modify tma = runReaderT (unPrepareValueModifierT tma) modify

@@ -1,13 +0,0 @@-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 ()

@@ -1,22 +0,0 @@-module Blucontrol.Monad.Recolor.Print (-  RecolorPrintT-, runRecolorPrintT-) where--import Control.Monad.Base-import Control.Monad.Trans-import Control.Monad.Trans.Control-import Control.Monad.Trans.Control.Default--import Blucontrol.Monad.Recolor--newtype RecolorPrintT c m a = RecolorPrintT { unRecolorPrintT :: m a }-  deriving (Applicative, Functor, Monad, MonadBase b, MonadBaseControl b)-  deriving (MonadTrans, MonadTransControl) via Stack0T--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,97 +0,0 @@-{-# LANGUAGE UndecidableInstances #-}--module Blucontrol.Monad.Recolor.X (-  RecolorXT-, runRecolorXTIO-, RecolorXValue-, 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.Trans.Control.Default-import Control.Monad.Reader-import Control.Monad.Except-import Data.Default-import Data.Maybe (fromMaybe)-import qualified Data.Text as T-import Data.Word-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-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)-  deriving (MonadTrans, MonadTransControl) via Stack2T (ExceptT XError) (ReaderT Display)--instance MonadBaseControl IO m => MonadRecolor (RecolorXT m) where-  type RecolorValue (RecolorXT m) = RecolorXValue-  recolor rgb = do-    display <- RecolorXT ask-    root <- liftXIO XErrorRead $-      rootWindow display $ defaultScreen display--    liftXIO XErrorSetGamma $ xrrSetGamma (unRecolorXValue 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 { hostName, displayServer, screen } = T.unpack . T.concat $-  [ fromMaybe "" hostName-  , ":" <> T.pack (show displayServer)-  , maybe "" (("." <>) . T.pack . show) screen-  ]--newtype RecolorXValue = RecolorXValue { unRecolorXValue :: XRRGamma }-  deriving (Eq, Generic, Ord, Read, Show)--instance NFData RecolorXValue--instance CompatibleValues (RGB Word8) RecolorXValue where-  convertValue RGB { red, green, blue } = RecolorXValue XRRGamma { xrr_gamma_red, xrr_gamma_green, xrr_gamma_blue }-    where xrr_gamma_red = word8ToFloat red-          xrr_gamma_green = word8ToFloat green-          xrr_gamma_blue = word8ToFloat blue-          word8ToFloat = (/ fromIntegral (maxBound @Word8)) . fromIntegral

@@ -1,29 +0,0 @@-{-# LANGUAGE ForeignFunctionInterface #-}--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 { xrr_gamma_red, xrr_gamma_green, xrr_gamma_blue } (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)

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

@@ -1,65 +0,0 @@-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 { todHour, todMin, todSec } = 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

@@ -0,0 +1,63 @@+module Blucontrol.Monad.PrepareValue.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.PrepareValue.Linear+import Blucontrol.Value.RGB+import Blucontrol.Value.RGB.Test (RGBWord8Arbitrary (..))++test :: Spec+test = describe "Blucontrol.PrepareValue.Linear" $ do++  it "convert Time to TimeOfDay" $+    property prop_timeToTimeOfDay++  -- TODO: this tests `calculateValue weightedAverageRGB`+  it "calculateRGB between surrounding values" $+    property prop_calculateRGB++newtype TimeArbitrary = TimeArbitrary Time+  deriving (Bounded, Enum, Eq, Generic, Ord, Read, Show)++instance NFData TimeArbitrary++instance Arbitrary TimeArbitrary where+  arbitrary = elements [minBound .. maxBound]++prop_timeToTimeOfDay :: TimeArbitrary -> Bool+prop_timeToTimeOfDay (TimeArbitrary time) =+     (fromIntegral h == todHour)+  && (fromIntegral m == todMin)+  && (0 == todSec)+  where h :. m = time+        TimeOfDay { todHour, todMin, todSec } = fst $ time Blucontrol.Monad.PrepareValue.Linear.==> (undefined :: RGB Word8)++prop_calculateRGB :: TimeArbitrary+                  -> (TimeArbitrary, RGBWord8Arbitrary)+                  -> (TimeArbitrary, RGBWord8Arbitrary)+                  -> Bool+prop_calculateRGB (TimeArbitrary time) (TimeArbitrary xt , RGBWord8Arbitrary xtc) (TimeArbitrary yt , RGBWord8Arbitrary ytc) =+  rgb `prop_RGBBetween` (xtc , ytc)+  where rgb = runIdentity . runPrepareValueLinearT rgbMap $ calculateValue weightedAverageRGB tod+        rgbMap = xt Blucontrol.Monad.PrepareValue.Linear.==> xtc+            :| [ yt Blucontrol.Monad.PrepareValue.Linear.==> ytc+               ]+        tod = LocalTime (ModifiedJulianDay 0) . fst $ time Blucontrol.Monad.PrepareValue.Linear.==> (undefined :: RGB Word8)++prop_RGBBetween :: RGB Word8 -> (RGB Word8,RGB Word8) -> Bool+prop_RGBBetween x (a,b) =+     (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,6 +1,6 @@ module Blucontrol.Value.RGB.Test (   test-, Arbitrary_RGBWord8 (..)+, RGBWord8Arbitrary (..) ) where  import Test.Hspec@@ -16,12 +16,12 @@ test = describe "Blucontrol.RGB" $ do    it "(RGB Word8) in bounds." $-    property $ total @Arbitrary_RGBWord8+    property $ total @RGBWord8Arbitrary -newtype Arbitrary_RGBWord8 = Arbitrary_RGBWord8 (RGB Word8)+newtype RGBWord8Arbitrary = RGBWord8Arbitrary (RGB Word8)   deriving (Bounded, Enum, Eq, Generic, Ord, Read, Show) -instance NFData Arbitrary_RGBWord8+instance NFData RGBWord8Arbitrary -instance Arbitrary Arbitrary_RGBWord8 where+instance Arbitrary RGBWord8Arbitrary where   arbitrary = elements [minBound .. maxBound]