summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorjumper149 <>2020-08-10 13:23:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2020-08-10 13:23:00 (GMT)
commit0582f2af817166df1ab8d1d62a05750708bca834 (patch)
tree4fc09f085be11eacf40961d8726c1e2c58f1068f
version 0.2.0.00.2.0.0
-rwxr-xr-xCHANGELOG.md19
-rw-r--r--LICENSE30
-rw-r--r--Main.hs20
-rw-r--r--blucontrol.cabal120
-rw-r--r--include/XrandrGamma.c19
-rw-r--r--include/XrandrGamma.h4
-rw-r--r--src/Blucontrol.hs53
-rw-r--r--src/Blucontrol/Control.hs25
-rw-r--r--src/Blucontrol/Control/Concat.hs39
-rw-r--r--src/Blucontrol/Control/Count.hs63
-rw-r--r--src/Blucontrol/Control/Print.hs30
-rw-r--r--src/Blucontrol/Control/Wait.hs40
-rw-r--r--src/Blucontrol/Gamma.hs13
-rw-r--r--src/Blucontrol/Gamma/Const.hs28
-rw-r--r--src/Blucontrol/Gamma/Linear.hs112
-rw-r--r--src/Blucontrol/Main.hs18
-rw-r--r--src/Blucontrol/Main/CLI.hs93
-rw-r--r--src/Blucontrol/Main/Control.hs55
-rw-r--r--src/Blucontrol/RGB.hs47
-rw-r--r--src/Blucontrol/RGB/Temperature.hs49
-rw-r--r--src/Blucontrol/Recolor.hs10
-rw-r--r--src/Blucontrol/Recolor/Print.hs29
-rw-r--r--src/Blucontrol/Recolor/X.hs97
-rw-r--r--src/Blucontrol/Recolor/X/Internal.hs29
-rw-r--r--test/Blucontrol.hs11
-rw-r--r--test/Blucontrol/Test/Gamma/Linear.hs65
-rw-r--r--test/Blucontrol/Test/RGB.hs40
27 files changed, 1158 insertions, 0 deletions
diff --git a/CHANGELOG.md b/CHANGELOG.md
new file mode 100755
index 0000000..7efd2a8
--- /dev/null
+++ b/CHANGELOG.md
@@ -0,0 +1,19 @@
+# Revision history for blucontrol
+
+## 0.2.0.0 -- 2020-08-10
+
+* Rename the whole application from bludigon to blucontrol.
+
+## 0.1.1.0 -- 2020-08-10
+
+* `runGamma` runs directly in `IO` now.
+* New module `Bludigon.Control.Concat`.
+* New module `Bludigon.Control.Count`.
+
+## 0.1.0.1 -- 2020-08-02
+
+* Add header file to c-sources.
+
+## 0.1.0.0 -- 2020-08-02
+
+* First version. Released on an unsuspecting world.
diff --git a/LICENSE b/LICENSE
new file mode 100644
index 0000000..cd481b3
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,30 @@
+Copyright (c) 2020, Felix Springer
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+ * Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+ * Redistributions in binary form must reproduce the above
+ copyright notice, this list of conditions and the following
+ disclaimer in the documentation and/or other materials provided
+ with the distribution.
+
+ * Neither the name of Felix Springer nor the names of other
+ contributors may be used to endorse or promote products derived
+ from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
diff --git a/Main.hs b/Main.hs
new file mode 100644
index 0000000..c6bf187
--- /dev/null
+++ b/Main.hs
@@ -0,0 +1,20 @@
+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
+
+main :: IO ()
+main = blucontrol configControl
+ where configControl = ConfigControl { runControl = runControlPrintT !> runControlCountT def !> runControlWaitT def
+ , runGamma = runGammaLinearT rgbMap
+ , runRecolor = runRecolorXTIO def
+ }
+ rgbMap = 00:.00 ==> temperature 4000
+ :| [ 08:.00 ==> temperature 4600
+ , 12:.00 ==> temperature 6600
+ , 18:.00 ==> temperature 6000
+ ]
diff --git a/blucontrol.cabal b/blucontrol.cabal
new file mode 100644
index 0000000..6e51157
--- /dev/null
+++ b/blucontrol.cabal
@@ -0,0 +1,120 @@
+name: blucontrol
+version: 0.2.0.0
+synopsis: Configurable blue light filter
+description: This application is a blue light filter, with the main focus on
+ configurability.
+ .
+ Configuration is done in Haskell in the style of
+ <https://hackage.haskell.org/package/xmonad xmonad>.
+ .
+ Blucontrol makes use of monad transformers and allows monadic calculation of
+ gamma values and recoloring.
+ The user chooses, what will be captured in the monadic state.
+ .
+ To get started with configuring read "Blucontrol".
+license: BSD3
+license-file: LICENSE
+author: Felix Springer
+maintainer: felixspringer149@gmail.com
+homepage: https://github.com/jumper149/blucontrol
+bug-reports: https://github.com/jumper149/blucontrol/issues
+category: System
+build-type: Simple
+extra-source-files: CHANGELOG.md
+cabal-version: >= 1.10
+
+library
+ exposed-modules: Blucontrol
+ Blucontrol.Control
+ Blucontrol.Control.Concat
+ Blucontrol.Control.Count
+ Blucontrol.Control.Print
+ Blucontrol.Control.Wait
+ Blucontrol.Gamma
+ Blucontrol.Gamma.Const
+ Blucontrol.Gamma.Linear
+ Blucontrol.Main
+ Blucontrol.Main.CLI
+ Blucontrol.Main.Control
+ Blucontrol.Recolor
+ Blucontrol.Recolor.Print
+ Blucontrol.Recolor.X
+ Blucontrol.RGB
+ Blucontrol.RGB.Temperature
+ other-modules: Blucontrol.Recolor.X.Internal
+ Paths_blucontrol
+ build-depends: base >= 4.11 && < 5
+ , containers >= 0.6.2.1 && < 0.7
+ , directory >= 1.3.6.0 && < 1.4
+ , data-default >= 0.7.1 && < 0.7.2
+ , deepseq >= 1.4.4.0 && < 1.5
+ , filepath >= 1.4.2.1 && < 1.5
+ , finite-typelits >= 0.1.4.0 && < 0.1.5
+ , lifted-base >= 0.2.3.2 && < 0.2.4
+ , monad-control >= 1.0.2.0 && < 1.1
+ , mtl >= 2.2.2 && < 2.3
+ , process >= 1.6.6.0 && < 1.7
+ , text >= 1.2.0.0 && < 1.3
+ , time >= 1.9.3 && < 1.10
+ , transformers >= 0.5.6.2 && < 0.5.7
+ , transformers-base >= 0.4.5.2 && < 0.5
+ , unix >= 2.7.2.2 && < 2.8
+ , X11 >= 1.9 && < 1.10
+ hs-source-dirs: src
+ includes: XrandrGamma.h
+ extra-libraries: X11, Xrandr
+ include-dirs: include
+ c-sources: include/XrandrGamma.c
+ include/XrandrGamma.h
+ default-language: Haskell2010
+ default-extensions: ConstraintKinds
+ DataKinds
+ DeriveGeneric
+ FlexibleContexts
+ FlexibleInstances
+ FunctionalDependencies
+ GeneralizedNewtypeDeriving
+ MultiParamTypeClasses
+ OverloadedStrings
+ RankNTypes
+ StandaloneDeriving
+ TypeApplications
+ TypeFamilies
+ ghc-options: -Wall
+
+executable blucontrol
+ main-is: Main.hs
+ build-depends: base
+ , blucontrol
+ default-language: Haskell2010
+ ghc-options: -Wall
+
+test-suite test
+ main-is: Blucontrol.hs
+ type: exitcode-stdio-1.0
+ hs-source-dirs: test
+ other-modules: Blucontrol.Test.Gamma.Linear
+ Blucontrol.Test.RGB
+ build-depends: base
+ , blucontrol
+ , data-default
+ , deepseq
+ , hspec >= 2.6.0 && < 2.8
+ , mtl
+ , QuickCheck >= 2.13.2 && < 2.15
+ , time
+ default-language: Haskell2010
+ default-extensions: ConstraintKinds
+ DataKinds
+ DeriveGeneric
+ FlexibleContexts
+ FlexibleInstances
+ FunctionalDependencies
+ GeneralizedNewtypeDeriving
+ MultiParamTypeClasses
+ OverloadedStrings
+ RankNTypes
+ StandaloneDeriving
+ TypeApplications
+ TypeFamilies
+ ghc-options: -Wall
diff --git a/include/XrandrGamma.c b/include/XrandrGamma.c
new file mode 100644
index 0000000..9d8fcfd
--- /dev/null
+++ b/include/XrandrGamma.c
@@ -0,0 +1,19 @@
+#include "XrandrGamma.h"
+
+void setGamma (float red, float green, float blue, XRRScreenResources *res, Display *dpy) {
+ for (int c = 0; c < res->ncrtc; c++) {
+ RRCrtc crtc = res->crtcs[c];
+ int size = XRRGetCrtcGammaSize(dpy, crtc);
+ XRRCrtcGamma *crtcGamma = XRRAllocGamma(size);
+
+ for (int i = 0; i < size; i++) {
+ double g = 65535.0 * i / size;
+ crtcGamma->red[i] = g * red;
+ crtcGamma->green[i] = g * green;
+ crtcGamma->blue[i] = g * blue;
+ }
+
+ XRRSetCrtcGamma(dpy, crtc, crtcGamma);
+ XRRFreeGamma(crtcGamma);
+ }
+}
diff --git a/include/XrandrGamma.h b/include/XrandrGamma.h
new file mode 100644
index 0000000..e9ec047
--- /dev/null
+++ b/include/XrandrGamma.h
@@ -0,0 +1,4 @@
+#include <X11/Xlib.h>
+#include <X11/extensions/Xrandr.h>
+
+void setGamma (float red, float green, float blue, XRRScreenResources *res, Display *dpy);
diff --git a/src/Blucontrol.hs b/src/Blucontrol.hs
new file mode 100644
index 0000000..45117de
--- /dev/null
+++ b/src/Blucontrol.hs
@@ -0,0 +1,53 @@
+module Blucontrol (
+
+-- * main
+{- | For most configurations 'blucontrol' should be called directly from the @main@ function in
+ @$XDG_CONFIG_HOME\/blucontrol\/blucontrol.hs@
+-}
+ blucontrol
+{- | 'ConfigControl' will set the monads in which recoloring and calculation of the gamma values
+ will take place.
+-}
+, ConfigControl (..)
+
+-- * RGB
+-- | RGB values are represented by 'Trichromaticity'.
+, Trichromaticity (..)
+
+{- | An alternative way to declaring 'Trichromaticity' directly is to use 'Temperature' and the
+ conversion function 'temperature'.
+-}
+, Temperature
+, temperature
+
+-- * Control
+-- | Modules with instances of 'MonadControl' can be found under @Blucontrol.Control.*@.
+, MonadControl (..)
+
+{- | To compose instances of 'MonadControl' avoid function composition, as it won't compose
+ 'doInbetween'.
+ Use '!>' instead.
+-}
+, (!>)
+
+-- * Gamma
+-- | Modules with instances of 'MonadGamma' can be found under @Blucontrol.Gamma.*@.
+, MonadGamma (..)
+
+-- * Recolor
+-- | Modules with instances of 'MonadRecolor' can be found under @Blucontrol.Recolor.*@.
+, MonadRecolor (..)
+
+-- * other
+, Default (..)
+) where
+
+import Data.Default
+
+import Blucontrol.Control
+import Blucontrol.Control.Concat
+import Blucontrol.Gamma
+import Blucontrol.Main
+import Blucontrol.Recolor
+import Blucontrol.RGB
+import Blucontrol.RGB.Temperature
diff --git a/src/Blucontrol/Control.hs b/src/Blucontrol/Control.hs
new file mode 100644
index 0000000..8d3bfc9
--- /dev/null
+++ b/src/Blucontrol/Control.hs
@@ -0,0 +1,25 @@
+{-# 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 a = ()
+ doInbetween _ = return ()
diff --git a/src/Blucontrol/Control/Concat.hs b/src/Blucontrol/Control/Concat.hs
new file mode 100644
index 0000000..5ad030d
--- /dev/null
+++ b/src/Blucontrol/Control/Concat.hs
@@ -0,0 +1,39 @@
+{-# LANGUAGE QuantifiedConstraints, UndecidableInstances #-}
+
+module Blucontrol.Control.Concat (
+ ControlConcatT
+, runControlConcatT
+, (!>)
+) where
+
+import Control.Monad.Base
+import Control.Monad.Trans
+import Control.Monad.Trans.Control
+
+import Blucontrol.Control
+
+newtype ControlConcatT (t1 :: (* -> *) -> * -> *) (t2 :: (* -> *) -> * -> *) (m :: * -> *) 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
diff --git a/src/Blucontrol/Control/Count.hs b/src/Blucontrol/Control/Count.hs
new file mode 100644
index 0000000..ef26086
--- /dev/null
+++ b/src/Blucontrol/Control/Count.hs
@@ -0,0 +1,63 @@
+{-# 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 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
diff --git a/src/Blucontrol/Control/Print.hs b/src/Blucontrol/Control/Print.hs
new file mode 100644
index 0000000..050d7d9
--- /dev/null
+++ b/src/Blucontrol/Control/Print.hs
@@ -0,0 +1,30 @@
+{-# 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
diff --git a/src/Blucontrol/Control/Wait.hs b/src/Blucontrol/Control/Wait.hs
new file mode 100644
index 0000000..a17f41f
--- /dev/null
+++ b/src/Blucontrol/Control/Wait.hs
@@ -0,0 +1,40 @@
+{-# 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) a = ()
+ 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
diff --git a/src/Blucontrol/Gamma.hs b/src/Blucontrol/Gamma.hs
new file mode 100644
index 0000000..a43437b
--- /dev/null
+++ b/src/Blucontrol/Gamma.hs
@@ -0,0 +1,13 @@
+module Blucontrol.Gamma (
+ MonadGamma (..)
+) where
+
+import Blucontrol.RGB
+
+class Monad m => MonadGamma m where
+
+ {- | Calculate a 'Trichromaticity'.
+ This is a monadic function, to allow the value to be dependent on side effects like time and
+ location.
+ -}
+ gamma :: m Trichromaticity
diff --git a/src/Blucontrol/Gamma/Const.hs b/src/Blucontrol/Gamma/Const.hs
new file mode 100644
index 0000000..13d1686
--- /dev/null
+++ b/src/Blucontrol/Gamma/Const.hs
@@ -0,0 +1,28 @@
+{-# 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
+import Blucontrol.RGB
+
+newtype GammaConstT m a = GammaConstT { unGammaConstT :: ReaderT Trichromaticity m a }
+ deriving (Applicative, Functor, Monad, MonadBase b, MonadBaseControl b, MonadTrans, MonadTransControl)
+
+instance Monad m => MonadGamma (GammaConstT m) where
+ gamma = GammaConstT ask
+
+instance MonadReader r m => MonadReader r (GammaConstT m) where
+ ask = lift ask
+ local f tma = liftWith $ \ run ->
+ local f $ run tma
+
+runGammaConstT :: Trichromaticity -> GammaConstT m a -> m a
+runGammaConstT rgb tma = runReaderT (unGammaConstT tma) rgb
diff --git a/src/Blucontrol/Gamma/Linear.hs b/src/Blucontrol/Gamma/Linear.hs
new file mode 100644
index 0000000..fc71448
--- /dev/null
+++ b/src/Blucontrol/Gamma/Linear.hs
@@ -0,0 +1,112 @@
+{-# LANGUAGE UndecidableInstances #-}
+
+module Blucontrol.Gamma.Linear (
+ GammaLinearT
+, runGammaLinearT
+, Time (..)
+, Hour
+, Minute
+, (==>)
+, N.NonEmpty (..) -- TODO: keep here?
+, calculateGamma -- 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 GHC.Generics
+
+import Blucontrol.Gamma
+import Blucontrol.RGB
+
+newtype GammaLinearT m a = GammaLinearT { unGammaLinearT :: ReaderT (M.Map TimeOfDay Trichromaticity) m a }
+ deriving (Applicative, Functor, Monad, MonadBase b, MonadBaseControl b, MonadTrans, MonadTransControl)
+
+instance MonadBase IO m => MonadGamma (GammaLinearT m) where
+ gamma = calculateGamma . zonedTimeToLocalTime =<< liftBase getZonedTime
+
+calculateGamma :: Monad m => LocalTime -> GammaLinearT m Trichromaticity
+calculateGamma time = do
+ m <- GammaLinearT ask
+ return . fromJust $ do
+ (nextTime , nextGamma) <- nextTimeGamma m time
+ (prevTime , prevGamma) <- prevTimeGamma m time
+ let diffSeconds t1 t2 = nominalDiffTimeToSeconds $ t1 `diffLocalTime` t2
+ timeFraction = toRational $ (time `diffSeconds` prevTime) / (nextTime `diffSeconds` prevTime)
+ return $ weightedAverage timeFraction prevGamma nextGamma
+
+nextTimeGamma :: M.Map TimeOfDay Trichromaticity -> LocalTime -> Maybe (LocalTime,Trichromaticity)
+nextTimeGamma 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)
+
+prevTimeGamma :: M.Map TimeOfDay Trichromaticity -> LocalTime -> Maybe (LocalTime,Trichromaticity)
+prevTimeGamma 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)
+
+weightedAverage :: Rational -> Trichromaticity -> Trichromaticity -> Trichromaticity
+weightedAverage w tc1 tc2 = Trichromaticity { red = f (red tc1) (red tc2)
+ , green = f (green tc1) (green tc2)
+ , blue = f (blue tc1) (blue tc2)
+ }
+ where f c1 c2 = round $ fromIntegral c1 + w * (fromIntegral c2 - fromIntegral c1)
+
+instance MonadReader r m => MonadReader r (GammaLinearT m) where
+ ask = lift ask
+ local f tma = liftWith $ \ run ->
+ local f $ run tma
+
+runGammaLinearT' :: M.Map TimeOfDay Trichromaticity -> GammaLinearT m a -> m a
+runGammaLinearT' rgbs tma = runReaderT (unGammaLinearT tma) rgbs
+
+runGammaLinearT :: N.NonEmpty (TimeOfDay,Trichromaticity) -> GammaLinearT 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 -> Trichromaticity -> (TimeOfDay,Trichromaticity)
+(==>) (h :. m) c = (time,c)
+ where time = TimeOfDay { todHour = fromIntegral h
+ , todMin = fromIntegral m
+ , todSec = 0
+ }
diff --git a/src/Blucontrol/Main.hs b/src/Blucontrol/Main.hs
new file mode 100644
index 0000000..173ede3
--- /dev/null
+++ b/src/Blucontrol/Main.hs
@@ -0,0 +1,18 @@
+module Blucontrol.Main (
+ blucontrol
+, ConfigControl (..)
+) where
+
+import Control.Monad.Trans.Control
+
+import Blucontrol.Main.Control
+import Blucontrol.Main.CLI
+import Blucontrol.Control
+import Blucontrol.Gamma
+import Blucontrol.Recolor
+
+blucontrol :: (ControlConstraint m (StM g (StM r ())), MonadControl m, MonadBaseControl IO g, MonadBaseControl IO r, MonadGamma g, MonadRecolor r)
+ => ConfigControl m g r
+ -> IO ()
+blucontrol c = do launch
+ runControl c . runControlT $ loopRecolor (runGamma c) (runRecolor c)
diff --git a/src/Blucontrol/Main/CLI.hs b/src/Blucontrol/Main/CLI.hs
new file mode 100644
index 0000000..862ae2f
--- /dev/null
+++ b/src/Blucontrol/Main/CLI.hs
@@ -0,0 +1,93 @@
+module Blucontrol.Main.CLI (
+ launch
+) where
+
+import Control.DeepSeq
+import Data.Version (showVersion)
+import GHC.Generics
+import System.Console.GetOpt
+import System.Directory (XdgDirectory (..), createDirectoryIfMissing, doesFileExist, getXdgDirectory)
+import System.Environment (getArgs, getProgName)
+import System.Exit (ExitCode (..), exitFailure, exitSuccess)
+import System.FilePath ((</>))
+import System.Info (arch, compilerName, compilerVersion, os)
+import System.Posix.Process (executeFile)
+import System.Process (runProcess, waitForProcess)
+
+import Paths_blucontrol (version)
+
+data Flag = Help
+ | Version
+ deriving (Eq, Generic, Ord, Read, Show)
+
+instance NFData Flag
+
+options :: [OptDescr Flag]
+options = [ Option ['h'] ["help"] (NoArg Help) "Explain CLI usage"
+ , Option ['v'] ["version"] (NoArg Version) "Display version"
+ ]
+
+launch :: IO ()
+launch = do
+ args <- getArgs
+ case getOpt Permute options args of
+ (optArgs, [], []) -> controlOptions optArgs
+ _ -> do printUsage
+ exitFailure
+
+controlOptions :: [Flag] -> IO ()
+controlOptions flags
+ | Help `elem` flags = do printUsage
+ exitSuccess
+ | otherwise = case flags of
+ [] -> build
+ [Version] -> do printVersion
+ exitSuccess
+ _ -> do printUsage
+ exitFailure
+
+printUsage :: IO ()
+printUsage = putStr $ usageInfo header options
+ where header = "Usage: blucontrol [OPTIONS]"
+
+printVersion :: IO ()
+printVersion = putStrLn $ "blucontrol-" <> showVersion version <> " compiled with " <> compiler
+ where compiler = compilerName <> "-" <> showVersion compilerVersion
+
+getXdgDir :: XdgDirectory -> IO FilePath
+getXdgDir = flip getXdgDirectory "blucontrol"
+
+build :: IO ()
+build = do
+ configPath <- (</> configLeafname) <$> getXdgDir XdgConfig
+ configExists <- doesFileExist configPath
+ if configExists
+ then do progName <- getProgName
+ if progName == compiledConfigLeafname
+ then return ()
+ else do compile
+ cacheDir <- getXdgDir XdgCache
+ executeFile (cacheDir </> compiledConfigLeafname) False [] Nothing
+ else return ()
+
+compile :: IO ()
+compile = do
+ configDir <- getXdgDir XdgConfig
+ cacheDir <- getXdgDir XdgCache
+ createDirectoryIfMissing False cacheDir
+ status <- waitForProcess =<<
+ runProcess "ghc" [ "--make"
+ , configLeafname
+ , "-main-is", "main"
+ , "-v0"
+ , "-o", cacheDir </> compiledConfigLeafname
+ ] (Just configDir) Nothing Nothing Nothing Nothing
+ case status of
+ ExitSuccess -> return ()
+ ExitFailure _ -> exitFailure
+
+compiledConfigLeafname :: FilePath
+compiledConfigLeafname = "blucontrol-" <> arch <> "-" <> os
+
+configLeafname :: FilePath
+configLeafname = "blucontrol.hs"
diff --git a/src/Blucontrol/Main/Control.hs b/src/Blucontrol/Main/Control.hs
new file mode 100644
index 0000000..3d0bc8f
--- /dev/null
+++ b/src/Blucontrol/Main/Control.hs
@@ -0,0 +1,55 @@
+{-# LANGUAGE UndecidableInstances #-}
+
+module Blucontrol.Main.Control (
+ ControlT
+, runControlT
+, loopRecolor
+, ConfigControl (..)
+) where
+
+import Control.Monad.Base
+import Control.Monad.Trans.Control
+import Control.Monad.Reader
+import Control.Monad.State.Strict
+
+import Blucontrol.Control
+import Blucontrol.Gamma
+import Blucontrol.Recolor
+
+newtype ControlT m a = ControlT { unControlT :: m a }
+ deriving (Applicative, Functor, Monad, MonadBase b, MonadBaseControl b)
+
+instance MonadTrans ControlT where
+ lift = ControlT
+
+instance MonadTransControl ControlT where
+ type StT ControlT a = a
+ liftWith inner = ControlT $ inner unControlT
+ restoreT = ControlT
+
+runControlT :: Monad m
+ => ControlT m a
+ -> m a
+runControlT = unControlT
+
+loopRecolor :: (ControlConstraint m (StM g (StM r ())), MonadBaseControl IO g, MonadBaseControl IO r, MonadControl m, MonadGamma g, MonadRecolor r)
+ => (forall a. g a -> IO (StM g a))
+ -> (forall a. r a -> g (StM r a))
+ -> ControlT m ()
+loopRecolor runG runR = do
+ a <- liftBase doRecolorGamma
+ ControlT $ evalStateT doLoopRecolor a
+ where doRecolorGamma = runG $ do
+ rgb <- gamma
+ runR $ recolor rgb
+ doLoopRecolor = do
+ a' <- get
+ lift $ doInbetween a'
+ a'' <- liftBase doRecolorGamma
+ put a''
+ doLoopRecolor
+
+data ConfigControl m g r = ConfigControl { runControl :: forall a. m a -> IO a
+ , runGamma :: forall a. g a -> IO (StM g a)
+ , runRecolor :: forall a. r a -> g (StM r a)
+ }
diff --git a/src/Blucontrol/RGB.hs b/src/Blucontrol/RGB.hs
new file mode 100644
index 0000000..c182688
--- /dev/null
+++ b/src/Blucontrol/RGB.hs
@@ -0,0 +1,47 @@
+module Blucontrol.RGB (
+ Chromaticity
+, Trichromaticity (..)
+) where
+
+import Control.DeepSeq
+import Data.Default
+import Data.Word
+import GHC.Generics
+
+-- | 8-bit value for color channel intensity
+newtype Chromaticity = Chromaticity Word8
+ deriving (Bounded, Enum, Eq, Generic, Integral, Num, Ord, Read, Real, Show)
+
+instance NFData Chromaticity
+
+instance Default Chromaticity where
+ def = maxBound
+
+-- | combination of 'Chromaticity's for the colors 'red', 'green' and 'blue'
+data Trichromaticity = Trichromaticity { red :: Chromaticity
+ , green :: Chromaticity
+ , blue :: Chromaticity
+ }
+ deriving (Bounded, Eq, Generic, Ord, Read, Show)
+
+instance NFData Trichromaticity
+
+instance Enum Trichromaticity where
+ fromEnum tc = sum [ fromEnum (red tc)
+ , fromEnum (green tc) * range
+ , fromEnum (blue tc) * range * range
+ ]
+ where range = succ . fromEnum $ maxBound @Chromaticity
+ toEnum i = let (b , i') = i `divMod` (range * range)
+ (g , r) = i' `divMod` range
+ in Trichromaticity { red = toEnum r
+ , green = toEnum g
+ , blue = toEnum b
+ }
+ where range = succ . fromEnum $ maxBound @Chromaticity
+
+instance Default Trichromaticity where
+ def = Trichromaticity { red = def
+ , green = def
+ , blue = def
+ }
diff --git a/src/Blucontrol/RGB/Temperature.hs b/src/Blucontrol/RGB/Temperature.hs
new file mode 100644
index 0000000..910dc11
--- /dev/null
+++ b/src/Blucontrol/RGB/Temperature.hs
@@ -0,0 +1,49 @@
+{-# LANGUAGE RecordWildCards #-}
+
+module Blucontrol.RGB.Temperature (
+ Temperature
+, temperature
+) where
+
+import Control.DeepSeq
+import Data.Default
+import GHC.Generics
+
+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
+
+-- TODO: test and implement more accurate, currently based on blugon
+-- | Calculate a 'Trichromaticity' from a 'Temperature'.
+temperature :: Temperature -> Trichromaticity
+temperature (Temperature temp) = Trichromaticity {..}
+ 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
diff --git a/src/Blucontrol/Recolor.hs b/src/Blucontrol/Recolor.hs
new file mode 100644
index 0000000..cee03ca
--- /dev/null
+++ b/src/Blucontrol/Recolor.hs
@@ -0,0 +1,10 @@
+module Blucontrol.Recolor (
+ MonadRecolor (..)
+) where
+
+import Blucontrol.RGB
+
+class Monad m => MonadRecolor m where
+
+ -- | Apply a 'Trichromaticity'.
+ recolor :: Trichromaticity -> m ()
diff --git a/src/Blucontrol/Recolor/Print.hs b/src/Blucontrol/Recolor/Print.hs
new file mode 100644
index 0000000..f73a613
--- /dev/null
+++ b/src/Blucontrol/Recolor/Print.hs
@@ -0,0 +1,29 @@
+{-# 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 m a = RecolorPrintT { unRecolorPrintT :: m a }
+ deriving (Applicative, Functor, Monad, MonadBase b, MonadBaseControl b)
+
+instance MonadTrans RecolorPrintT where
+ lift = RecolorPrintT
+
+instance MonadTransControl RecolorPrintT where
+ type StT RecolorPrintT a = a
+ liftWith inner = RecolorPrintT $ inner unRecolorPrintT
+ restoreT = RecolorPrintT
+
+instance MonadBaseControl IO m => MonadRecolor (RecolorPrintT m) where
+ recolor = liftBase . print
+
+runRecolorPrintT :: RecolorPrintT m a -> m a
+runRecolorPrintT = unRecolorPrintT
diff --git a/src/Blucontrol/Recolor/X.hs b/src/Blucontrol/Recolor/X.hs
new file mode 100644
index 0000000..6930455
--- /dev/null
+++ b/src/Blucontrol/Recolor/X.hs
@@ -0,0 +1,97 @@
+{-# 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)
+ liftWith = defaultLiftWith2 RecolorXT unRecolorXT
+ restoreT = defaultRestoreT2 RecolorXT
+
+instance MonadBaseControl IO m => MonadRecolor (RecolorXT m) where
+ 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 :: Trichromaticity -> XRRGamma
+translateRGB Trichromaticity {..} = XRRGamma {..}
+ where xrr_gamma_red = translateColor red
+ xrr_gamma_green = translateColor green
+ xrr_gamma_blue = translateColor blue
+
+-- | Create a normalized value for a 'Chromaticity'.
+translateColor :: (Fractional a, Num a) => Chromaticity -> a
+translateColor = (/ fromIntegral (maxBound @Chromaticity)) . fromIntegral
diff --git a/src/Blucontrol/Recolor/X/Internal.hs b/src/Blucontrol/Recolor/X/Internal.hs
new file mode 100644
index 0000000..8c3719a
--- /dev/null
+++ b/src/Blucontrol/Recolor/X/Internal.hs
@@ -0,0 +1,29 @@
+{-# 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)
diff --git a/test/Blucontrol.hs b/test/Blucontrol.hs
new file mode 100644
index 0000000..4f03656
--- /dev/null
+++ b/test/Blucontrol.hs
@@ -0,0 +1,11 @@
+module Main where
+
+import Test.Hspec
+
+import qualified Blucontrol.Test.Gamma.Linear
+import qualified Blucontrol.Test.RGB
+
+main :: IO ()
+main = hspec $ do
+ Blucontrol.Test.RGB.test
+ Blucontrol.Test.Gamma.Linear.test
diff --git a/test/Blucontrol/Test/Gamma/Linear.hs b/test/Blucontrol/Test/Gamma/Linear.hs
new file mode 100644
index 0000000..ba037a4
--- /dev/null
+++ b/test/Blucontrol/Test/Gamma/Linear.hs
@@ -0,0 +1,65 @@
+{-# 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 GHC.Generics
+
+import Blucontrol.Gamma.Linear
+import Blucontrol.RGB
+import Blucontrol.Test.RGB (Arbitrary_Trichromaticity (..))
+
+test :: Spec
+test = describe "Blucontrol.Gamma.Linear" $ do
+
+ it "convert Time to TimeOfDay" $
+ property prop_timeToTimeOfDay
+
+ it "calculateGamma between surrounding values" $
+ property prop_calculateGamma
+
+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
+
+prop_calculateGamma :: Arbitrary_Time
+ -> (Arbitrary_Time,Arbitrary_Trichromaticity)
+ -> (Arbitrary_Time,Arbitrary_Trichromaticity)
+ -> Bool
+prop_calculateGamma (Arbitrary_Time time) (Arbitrary_Time xt , Arbitrary_Trichromaticity xtc) (Arbitrary_Time yt , Arbitrary_Trichromaticity ytc) =
+ rgb `prop_TrichromaticityBetween` (xtc , ytc)
+ where rgb = runIdentity . runGammaLinearT rgbMap $ calculateGamma tod
+ rgbMap = xt Blucontrol.Gamma.Linear.==> xtc
+ :| [ yt Blucontrol.Gamma.Linear.==> ytc
+ ]
+ tod = LocalTime (ModifiedJulianDay 0) . fst $ time Blucontrol.Gamma.Linear.==> undefined
+
+prop_TrichromaticityBetween :: Trichromaticity -> (Trichromaticity,Trichromaticity) -> Bool
+prop_TrichromaticityBetween x (a,b) = and
+ [ red x `prop_ChromaticityBetween` (red a , red b)
+ , green x `prop_ChromaticityBetween` (green a , green b)
+ , blue x `prop_ChromaticityBetween` (blue a , blue b)
+ ]
+
+prop_ChromaticityBetween :: Chromaticity -> (Chromaticity,Chromaticity) -> Bool
+prop_ChromaticityBetween x (a,b) = x <= max a b && x >= min a b
diff --git a/test/Blucontrol/Test/RGB.hs b/test/Blucontrol/Test/RGB.hs
new file mode 100644
index 0000000..9b925cb
--- /dev/null
+++ b/test/Blucontrol/Test/RGB.hs
@@ -0,0 +1,40 @@
+{-# LANGUAGE RecordWildCards #-}
+
+module Blucontrol.Test.RGB (
+ test
+, Arbitrary_Chromaticity (..)
+, Arbitrary_Trichromaticity (..)
+) where
+
+import Test.Hspec
+import Test.QuickCheck
+
+import Control.DeepSeq
+import GHC.Generics
+
+import Blucontrol.RGB
+
+test :: Spec
+test = describe "Blucontrol.RGB" $ do
+
+ it "Chromaticity in bounds." $
+ property $ total @Arbitrary_Chromaticity
+
+ it "Trichromaticity in bounds." $
+ property $ total @Arbitrary_Trichromaticity
+
+newtype Arbitrary_Chromaticity = Arbitrary_Chromaticity Chromaticity
+ deriving (Bounded, Enum, Eq, Generic, Ord, Read, Show)
+
+instance NFData Arbitrary_Chromaticity
+
+instance Arbitrary Arbitrary_Chromaticity where
+ arbitrary = elements [minBound .. maxBound]
+
+newtype Arbitrary_Trichromaticity = Arbitrary_Trichromaticity Trichromaticity
+ deriving (Bounded, Enum, Eq, Generic, Ord, Read, Show)
+
+instance NFData Arbitrary_Trichromaticity
+
+instance Arbitrary Arbitrary_Trichromaticity where
+ arbitrary = elements [minBound .. maxBound]