packages feed

blucontrol (empty) → 0.2.0.0

raw patch · 27 files changed

+1158/−0 lines, 27 filesdep +QuickCheckdep +X11dep +base

Dependencies added: QuickCheck, X11, base, blucontrol, containers, data-default, deepseq, directory, filepath, finite-typelits, hspec, lifted-base, monad-control, mtl, process, text, time, transformers, transformers-base, unix

Files

+ CHANGELOG.md view
@@ -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.
+ LICENSE view
@@ -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.
+ Main.hs view
@@ -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+               ]
+ blucontrol.cabal view
@@ -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
+ include/XrandrGamma.c view
@@ -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);+    }+}
+ include/XrandrGamma.h view
@@ -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);
+ src/Blucontrol.hs view
@@ -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
+ src/Blucontrol/Control.hs view
@@ -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 ()
+ src/Blucontrol/Control/Concat.hs view
@@ -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
+ src/Blucontrol/Control/Count.hs view
@@ -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
+ src/Blucontrol/Control/Print.hs view
@@ -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
+ src/Blucontrol/Control/Wait.hs view
@@ -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
+ src/Blucontrol/Gamma.hs view
@@ -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
+ src/Blucontrol/Gamma/Const.hs view
@@ -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
+ src/Blucontrol/Gamma/Linear.hs view
@@ -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+                         }
+ src/Blucontrol/Main.hs view
@@ -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)
+ src/Blucontrol/Main/CLI.hs view
@@ -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"
+ src/Blucontrol/Main/Control.hs view
@@ -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)+                                         }
+ src/Blucontrol/RGB.hs view
@@ -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+                        }
+ src/Blucontrol/RGB/Temperature.hs view
@@ -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
+ src/Blucontrol/Recolor.hs view
@@ -0,0 +1,10 @@+module Blucontrol.Recolor (+  MonadRecolor (..)+) where++import Blucontrol.RGB++class Monad m => MonadRecolor m where++  -- | Apply a 'Trichromaticity'.+  recolor :: Trichromaticity -> m ()
+ src/Blucontrol/Recolor/Print.hs view
@@ -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
+ src/Blucontrol/Recolor/X.hs view
@@ -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
+ src/Blucontrol/Recolor/X/Internal.hs view
@@ -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)
+ test/Blucontrol.hs view
@@ -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
+ test/Blucontrol/Test/Gamma/Linear.hs view
@@ -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
+ test/Blucontrol/Test/RGB.hs view
@@ -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]