blucontrol 0.3.1.0 → 0.3.2.0

raw patch · 10 files changed

+124/−61 lines, 10 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• CHANGELOG.md +6/−0
• blucontrol.cabal +6/−3
• src/Blucontrol/Control/Count.hs +2/−8
• src/Blucontrol/Control/Wait.hs +1/−1
• src/Blucontrol/Gamma/Const.hs +1/−1
• src/Blucontrol/Gamma/Linear.hs +19/−1
• src/Blucontrol/Main.hs +1/−1
• src/Blucontrol/Main/Control.hs +36/−36
• src/Blucontrol/RGB/Brightness.hs +49/−0
• src/Blucontrol/Recolor/X.hs +3/−10

@@ -1,5 +1,11 @@ # Revision history for blucontrol +## 0.3.2.0 *04 Jun 2021*++* New module `Blucontrol.RGB.Brightness`.+* Introduce strictness to improve performance.+* Allow `runGamma` to directly run in the `IO` monad instead of `g` with `MonadGamma c g`.+ ## 0.3.1.0 *30 May 2021*  * New module `Blucontrol.Gamma.Modifier`.

@@ -1,5 +1,5 @@ name:                blucontrol-version:             0.3.1.0+version:             0.3.2.0 synopsis:            Configurable blue light filter description:         This application is a blue light filter, with the main focus on                      configurability.@@ -41,6 +41,7 @@                        Blucontrol.Recolor.Print                        Blucontrol.Recolor.X                        Blucontrol.RGB+                       Blucontrol.RGB.Brightness                        Blucontrol.RGB.Temperature   other-modules:       Blucontrol.Main.GHC.Internal                        Blucontrol.Recolor.X.Internal@@ -69,7 +70,8 @@   c-sources:           include/XrandrGamma.c                        include/XrandrGamma.h   default-language:    Haskell2010-  default-extensions:  ConstraintKinds+  default-extensions:  BangPatterns+                       ConstraintKinds                        DataKinds                        DeriveGeneric                        FlexibleContexts@@ -106,7 +108,8 @@                      , QuickCheck   >= 2.13.2  && < 2.15                      , time   default-language:    Haskell2010-  default-extensions:  ConstraintKinds+  default-extensions:  BangPatterns+                       ConstraintKinds                        DataKinds                        DeriveGeneric                        FlexibleContexts

@@ -24,17 +24,11 @@ instance MonadTrans ControlCountT where   lift = ControlCountT . lift . lift --- TODO: workaround for ghc-9.0.1-defaultLiftWith2' :: (Monad m)-                  => (Run ControlCountT -> m a)-                  -> ControlCountT m a-defaultLiftWith2' f = ControlCountT $ liftWith $ \run -> liftWith $ \run' -> f $ run' . run . unControlCountT- instance MonadTransControl ControlCountT where   type StT ControlCountT a = StT (ReaderT ConfigCount) (StT (StateT Natural) a)   -- TODO: workaround for ghc-9.0.1   --liftWith = defaultLiftWith2 ControlCountT unControlCountT-  liftWith = defaultLiftWith2'+  liftWith f = ControlCountT $ liftWith $ \run -> liftWith $ \run' -> f $ run' . run . unControlCountT   restoreT = defaultRestoreT2 ControlCountT  instance MonadBaseControl IO m => MonadControl (ControlCountT m) where@@ -49,7 +43,7 @@                         else return ()  runControlCountT :: Monad m => ConfigCount -> ControlCountT m a -> m a-runControlCountT conf tma = runReaderT (evalStateT (unControlCountT tma) 0) conf+runControlCountT !conf tma = runReaderT (evalStateT (unControlCountT tma) 0) conf  newtype ConfigCount = ConfigCount { maxCount :: Natural                                   }

@@ -25,7 +25,7 @@   doInbetween _ = liftBase . threadDelay . interval =<< ControlWaitT ask  runControlWaitT :: ConfigWait -> ControlWaitT m a -> m a-runControlWaitT conf tma = runReaderT (unControlWaitT tma) conf+runControlWaitT !conf tma = runReaderT (unControlWaitT tma) conf  newtype ConfigWait = ConfigWait { interval :: Microseconds                                 }

@@ -25,4 +25,4 @@   gamma = GammaConstT ask  runGammaConstT :: RGB c => c -> GammaConstT c m a -> m a-runGammaConstT rgb tma = runReaderT (unGammaConstT tma) rgb+runGammaConstT !rgb tma = runReaderT (unGammaConstT tma) rgb

@@ -26,6 +26,7 @@  import Blucontrol.Gamma import Blucontrol.RGB+import Blucontrol.RGB.Brightness import Blucontrol.RGB.Temperature  newtype GammaLinearT c m a = GammaLinearT { unGammaLinearT :: ReaderT (M.Map TimeOfDay c) m a }@@ -42,6 +43,20 @@ instance MonadBase IO m => MonadGamma Temperature (GammaLinearT Temperature m) where   gamma = calculateRGB weightedAverageTemperature . zonedTimeToLocalTime =<< liftBase getZonedTime +instance (RGB Trichromaticity, MonadBase IO m) => MonadGamma (WithBrightness Trichromaticity) (GammaLinearT (WithBrightness Trichromaticity) m) where+  gamma = calculateRGB weightedAverage . zonedTimeToLocalTime =<< liftBase getZonedTime+    where weightedAverage w WithBrightness { brightness = b1, rgb = tc1 } WithBrightness { brightness = b2, rgb = tc2 } =+            WithBrightness { brightness = weightedAverageBrightness w b1 b2+                           , rgb = weightedAverageTrichromaticity w tc1 tc2+                           }++instance (RGB Temperature, MonadBase IO m) => MonadGamma (WithBrightness Temperature) (GammaLinearT (WithBrightness Temperature) m) where+  gamma = calculateRGB weightedAverage . zonedTimeToLocalTime =<< liftBase getZonedTime+    where weightedAverage w WithBrightness { brightness = b1, rgb = tc1 } WithBrightness { brightness = b2, rgb = tc2 } =+            WithBrightness { brightness = weightedAverageBrightness w b1 b2+                           , rgb = weightedAverageTemperature w tc1 tc2+                           }+ nextTimeRGB :: M.Map TimeOfDay c -> LocalTime -> Maybe (LocalTime,c) nextTimeRGB m time = catchError (toLocalTimeToday <$> M.lookupGT (localTimeOfDay time) m) $                      const (toLocalTimeTomorrow <$> M.lookupMin m)@@ -86,9 +101,12 @@ weightedAverageTemperature :: Rational -> Temperature -> Temperature -> Temperature weightedAverageTemperature w t1 t2 = fromRational $ toRational t1 + w * (toRational t2 - toRational t1) +weightedAverageBrightness :: Rational -> Brightness -> Brightness -> Brightness+weightedAverageBrightness w b1 b2 = fromRational $ toRational b1 + w * (toRational b2 - toRational b1)+ -- TODO: maybe remove RGB constraint runGammaLinearT' :: RGB c => M.Map TimeOfDay c -> GammaLinearT c m a -> m a-runGammaLinearT' rgbs tma = runReaderT (unGammaLinearT tma) rgbs+runGammaLinearT' !rgbs tma = runReaderT (unGammaLinearT tma) rgbs  -- TODO: maybe remove RGB constraint runGammaLinearT :: RGB c => N.NonEmpty (TimeOfDay,c) -> GammaLinearT c m a -> m a

@@ -15,4 +15,4 @@            => ConfigControl m g r            -> IO () blucontrol c = do launch-                  runControl c . runControlT $ loopRecolor (runGamma c) (runRecolor c)+                  runControl c $ loopRecolor (runGamma c) (runRecolor c)

@@ -1,9 +1,5 @@-{-# LANGUAGE UndecidableInstances #-}- module Blucontrol.Main.Control (-  ControlT-, runControlT-, loopRecolor+  loopRecolor , ConfigControl (..) ) where @@ -17,40 +13,44 @@ import Blucontrol.Recolor import Blucontrol.RGB -newtype ControlT c m a = ControlT { unControlT :: m a }-  deriving (Applicative, Functor, Monad, MonadBase b, MonadBaseControl b)--instance MonadTrans (ControlT c) where-  lift = ControlT--instance MonadTransControl (ControlT c) where-  type StT (ControlT c) a = a-  liftWith inner = ControlT $ inner unControlT-  restoreT = ControlT--runControlT :: Monad m-            => ControlT c m a-            -> m a-runControlT = unControlT-+-- | Run the loop, using `gamma`, `recolor` and `doInbetween`.+-- The arguments are the actual monad runners. loopRecolor :: (ControlConstraint m (StM g (StM r ())), MonadBaseControl IO g, MonadBaseControl IO r, MonadControl m, MonadGamma c g, MonadRecolor r)             => (forall a. g a -> IO (StM g a))-            -> (forall a. r a -> g (StM r a))-            -> ControlT c m ()-loopRecolor runG runR = do-  a <- liftBase doRecolorGamma-  ControlT $ evalStateT doLoopRecolor a-  where doRecolorGamma = runG $ do-          rgb <- toRGB <$> gamma-          runR $ recolor rgb-        doLoopRecolor = do-          a' <- get-          lift $ doInbetween a'-          a'' <- liftBase doRecolorGamma-          put a''-          doLoopRecolor+            -> (forall a. r a -> IO (StM r a))+            -> m ()+loopRecolor runG runR = void $+  liftBaseWith $ \ runCIO ->+    runR $ liftBaseWith $ \ runRIO ->+      runG $ liftBaseWith $ \ runGIO -> do+        firstResult <- doRecolorGamma runGIO runRIO+        evalStateT (doLoopRecolor runCIO runGIO runRIO) firstResult +-- | Use `gamma` and give the result to `recolor`.+-- The arguments are runners from `liftBaseWith`.+doRecolorGamma :: (MonadBaseControl IO g, MonadBaseControl IO r, MonadGamma c g, MonadRecolor r)+               => (forall a. g a -> IO (StM g a))+               -> (forall a. r a -> IO (StM r a))+               -> IO (StM g (StM r ()))+doRecolorGamma runGIO runRIO = runGIO $ do+  rgb <- toRGB <$> gamma+  liftBase $ runRIO $ recolor rgb++-- | A single iteration of `loopRecolor`.+-- The arguments are runners from `liftBaseWith`.+doLoopRecolor :: (ControlConstraint m (StM g (StM r ())), MonadBaseControl IO g, MonadBaseControl IO r, MonadControl m, MonadGamma c g, MonadRecolor r)+              => (forall a. m a -> IO (StM m a))+              -> (forall a. g a -> IO (StM g a))+              -> (forall a. r a -> IO (StM r a))+              -> StateT (StM g (StM r ())) IO ()+doLoopRecolor runCIO runGIO runRIO = do+  lastResult <- get+  void $ liftBase $ runCIO $ doInbetween lastResult+  nextResult <- liftBase $ doRecolorGamma runGIO runRIO+  put nextResult+  doLoopRecolor runCIO runGIO runRIO+ 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)+                                         , runRecolor :: forall a. r a -> IO (StM r a)                                          }

@@ -0,0 +1,49 @@+{-# LANGUAGE RecordWildCards #-}++module Blucontrol.RGB.Brightness (+  Brightness+, WithBrightness (..)+) where++import Control.DeepSeq+import Data.Default+import GHC.Generics++import Blucontrol.RGB++-- | Arbitrary precision brightness between 0 and 1+newtype Brightness = Brightness Rational+  deriving (Enum, Eq, Fractional, Generic, Num, Ord, Read, Real, RealFrac, Show)++instance NFData Brightness++instance Bounded Brightness where+  minBound = 0+  maxBound = 1++instance Default Brightness where+  def = 1++-- | Parametric RGB value with an associated brightness+data WithBrightness a = WithBrightness { brightness :: Brightness+                                       , rgb :: a+                                       }+  deriving (Eq, Generic, Ord, Read, Show)++instance NFData a => NFData (WithBrightness a)++instance Default a => Default (WithBrightness a) where+  def = WithBrightness { brightness = def+                       , rgb = def+                       }++-- TODO: maybe create separate instances for Trichromaticity and Temperature+instance RGB a => RGB (WithBrightness a) where+  toRGB WithBrightness {..} = mapChromaticity applyBrightness $ toRGB rgb+      where applyBrightness = truncate . (toRational brightness *) . toRational++mapChromaticity :: (Chromaticity -> Chromaticity) -> Trichromaticity -> Trichromaticity+mapChromaticity f rgb = Trichromaticity { red = f $ red rgb+                                        , green = f $ green rgb+                                        , blue = f $ blue rgb+                                        }

@@ -31,18 +31,11 @@ instance MonadTrans RecolorXT where   lift = RecolorXT . lift . lift --- TODO: ghc-9.0.1 can't unify 'Run RecolorXT' and 'RunDefault2 RecolorXT n n'', when using 'defaultLiftWith2'--- current solution is the exact same on the value level, but uses 'Run RecolorXT' on the type level-defaultLiftWith2' :: Monad n-                  => (Run RecolorXT -> n a)-                  -> RecolorXT n a-defaultLiftWith2' f = RecolorXT $ liftWith $ \run -> liftWith $ \run' -> f $ run' . run . unRecolorXT- instance MonadTransControl RecolorXT where   type StT RecolorXT a = StT (ReaderT Display) (StT (ExceptT XError) a)   -- TODO: broken by ghc-9.0.1-  -- liftWith = defaultLiftWith2' RecolorXT unRecolorXT-  liftWith = defaultLiftWith2'+  -- liftWith = defaultLiftWith2 RecolorXT unRecolorXT+  liftWith f = RecolorXT $ liftWith $ \run -> liftWith $ \run' -> f $ run' . run . unRecolorXT   restoreT = defaultRestoreT2 RecolorXT  instance MonadBaseControl IO m => MonadRecolor (RecolorXT m) where@@ -83,7 +76,7 @@   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+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