diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /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 --- /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 --- /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 --- /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 + . + . + 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 --- /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 --- /dev/null +++ b/include/XrandrGamma.h @@ -0,0 +1,4 @@ +#include +#include + +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 --- /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 --- /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 --- /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 --- /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 --- /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 --- /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 --- /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 --- /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 --- /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 --- /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 --- /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 --- /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 --- /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 --- /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 --- /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 --- /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 --- /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 --- /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 " XRRGetScreenResourcesCurrent" _XRRGetScreenResourcesCurrent :: Ptr Display -> Window -> IO (Ptr Int) diff --git a/test/Blucontrol.hs b/test/Blucontrol.hs new file mode 100644 --- /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 --- /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 --- /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]