blucontrol 0.5.0.0 → 0.5.1.0

raw patch · 16 files changed

+110/−83 lines, 16 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• CHANGELOG.md +5/−0
• blucontrol.cabal +16/−1
• src/Blucontrol/Monad/Control/Count.hs +2/−10
• src/Blucontrol/Monad/Control/Print.hs +2/−8
• src/Blucontrol/Monad/Gamma/Const.hs +0/−5
• src/Blucontrol/Monad/Gamma/Linear.hs +0/−5
• src/Blucontrol/Monad/Recolor/Print.hs +2/−10
• src/Blucontrol/Monad/Recolor/X.hs +20/−19
• src/Blucontrol/Monad/Recolor/X/Internal.hs +2/−2
• src/Blucontrol/Value.hs +1/−1
• src/Blucontrol/Value/Brightness.hs +16/−3
• src/Blucontrol/Value/RGB.hs +0/−12
• src/Blucontrol/Value/RGB/Temperature.hs +2/−2
• src/Control/Monad/Trans/Control/Default.hs +41/−0
• test/Blucontrol/Monad/Gamma/Linear/Test.hs +1/−3
• test/Blucontrol/Value/RGB/Test.hs +0/−2

@@ -1,5 +1,10 @@ # Revision history for blucontrol +## 0.5.1.0 *19 Jun 2021*++* `RecolorXT` now uses `RecolorXValue`, which is just a newtype of the old `RGB Float`.+* Add `applyBrightnessToRGB` conversion function.+ ## 0.5.0.0 *09 Jun 2021*  * Change module structure, now using `Blucontrol.Monad` and `Blucontrol.Value`.

@@ -1,5 +1,5 @@ name:                blucontrol-version:             0.5.0.0+version:             0.5.1.0 synopsis:            Configurable blue light filter description:         This application is a blue light filter, with the main focus on                      configurability.@@ -46,6 +46,7 @@                        Blucontrol.Value.RGB.Temperature   other-modules:       Blucontrol.Main.GHC.Internal                        Blucontrol.Monad.Recolor.X.Internal+                       Control.Monad.Trans.Control.Default                        Paths_blucontrol   build-depends:       base              >= 4.11    && < 5                      , containers        >= 0.6.2.1 && < 0.7@@ -74,12 +75,19 @@   default-extensions:  BangPatterns                        ConstraintKinds                        DataKinds+                       DeriveFoldable+                       DeriveFunctor                        DeriveGeneric+                       DeriveTraversable+                       DerivingStrategies+                       DerivingVia+                       EmptyDataDeriving                        FlexibleContexts                        FlexibleInstances                        FunctionalDependencies                        GeneralizedNewtypeDeriving                        MultiParamTypeClasses+                       NamedFieldPuns                        OverloadedStrings                        RankNTypes                        StandaloneDeriving@@ -112,12 +120,19 @@   default-extensions:  BangPatterns                        ConstraintKinds                        DataKinds+                       DeriveFoldable+                       DeriveFunctor                        DeriveGeneric+                       DeriveTraversable+                       DerivingStrategies+                       DerivingVia+                       EmptyDataDeriving                        FlexibleContexts                        FlexibleInstances                        FunctionalDependencies                        GeneralizedNewtypeDeriving                        MultiParamTypeClasses+                       NamedFieldPuns                        OverloadedStrings                        RankNTypes                        StandaloneDeriving

@@ -10,6 +10,7 @@ import Control.DeepSeq import Control.Monad.Base import Control.Monad.Trans.Control+import Control.Monad.Trans.Control.Default import Control.Monad.Reader import Control.Monad.State.Strict import Data.Default@@ -20,16 +21,7 @@  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 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 f = ControlCountT $ liftWith $ \run -> liftWith $ \run' -> f $ run' . run . unControlCountT-  restoreT = defaultRestoreT2 ControlCountT+  deriving (MonadTrans, MonadTransControl) via Stack2T (StateT Natural) (ReaderT ConfigCount)  instance MonadBaseControl IO m => MonadControl (ControlCountT m) where   type ControlConstraint (ControlCountT m) a = CountableException a

@@ -8,19 +8,13 @@ import Control.Monad.Base import Control.Monad.Trans import Control.Monad.Trans.Control+import Control.Monad.Trans.Control.Default  import Blucontrol.Monad.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+  deriving (MonadTrans, MonadTransControl) via Stack0T  instance MonadBaseControl IO m => MonadControl (ControlPrintT m) where   type ControlConstraint (ControlPrintT m) a = Show a

@@ -15,11 +15,6 @@ newtype GammaConstT c m a = GammaConstT { unGammaConstT :: ReaderT c m a }   deriving (Applicative, Functor, Monad, MonadBase b, MonadBaseControl b, MonadTrans, MonadTransControl) -instance MonadReader r m => MonadReader r (GammaConstT c m) where-  ask = lift ask-  local f tma = liftWith $ \ run ->-    local f $ run tma- instance Monad m => MonadGamma (GammaConstT c m) where   type GammaValue (GammaConstT c m) = c   gamma = GammaConstT ask

@@ -33,11 +33,6 @@ newtype GammaLinearT c m a = GammaLinearT { unGammaLinearT :: ReaderT (M.Map TimeOfDay c) m a }   deriving (Applicative, Functor, Monad, MonadBase b, MonadBaseControl b, MonadTrans, MonadTransControl) -instance MonadReader r m => MonadReader r (GammaLinearT c m) where-  ask = lift ask-  local f tma = liftWith $ \ run ->-    local f $ run tma- instance MonadBase IO m => MonadGamma (GammaLinearT (RGB Word8) m) where   type GammaValue (GammaLinearT (RGB Word8) m) = RGB Word8   gamma = calculateValue weightedAverageRGB . zonedTimeToLocalTime =<< liftBase getZonedTime

@@ -1,5 +1,3 @@-{-# LANGUAGE UndecidableInstances #-}- module Blucontrol.Monad.Recolor.Print (   RecolorPrintT , runRecolorPrintT@@ -8,19 +6,13 @@ import Control.Monad.Base import Control.Monad.Trans import Control.Monad.Trans.Control+import Control.Monad.Trans.Control.Default  import Blucontrol.Monad.Recolor  newtype RecolorPrintT c m a = RecolorPrintT { unRecolorPrintT :: m a }   deriving (Applicative, Functor, Monad, MonadBase b, MonadBaseControl b)--instance MonadTrans (RecolorPrintT c) where-  lift = RecolorPrintT--instance MonadTransControl (RecolorPrintT c) where-  type StT (RecolorPrintT c) a = a-  liftWith inner = RecolorPrintT $ inner unRecolorPrintT-  restoreT = RecolorPrintT+  deriving (MonadTrans, MonadTransControl) via Stack0T  instance (MonadBaseControl IO m, Show c) => MonadRecolor (RecolorPrintT c m) where   type RecolorValue (RecolorPrintT c m) = c

@@ -1,8 +1,9 @@-{-# LANGUAGE RecordWildCards, UndecidableInstances #-}+{-# LANGUAGE UndecidableInstances #-}  module Blucontrol.Monad.Recolor.X (   RecolorXT , runRecolorXTIO+, RecolorXValue , ConfigX (..) , XError (..) ) where@@ -11,11 +12,13 @@ import Control.Exception.Lifted (SomeException (..), bracket, catch) import Control.Monad.Base import Control.Monad.Trans.Control+import Control.Monad.Trans.Control.Default import Control.Monad.Reader import Control.Monad.Except import Data.Default import Data.Maybe (fromMaybe) import qualified Data.Text as T+import Data.Word import GHC.Generics  import Graphics.X11.Xlib.Display (closeDisplay, defaultScreen, openDisplay, rootWindow)@@ -23,29 +26,21 @@  import Blucontrol.Monad.Recolor import Blucontrol.Monad.Recolor.X.Internal+import Blucontrol.Value import Blucontrol.Value.RGB  newtype RecolorXT m a = RecolorXT { unRecolorXT :: ExceptT XError (ReaderT Display m) a }   deriving (Applicative, Functor, Monad, MonadBase b, MonadBaseControl b, MonadError XError)--instance MonadTrans RecolorXT where-  lift = RecolorXT . lift . lift--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 f = RecolorXT $ liftWith $ \run -> liftWith $ \run' -> f $ run' . run . unRecolorXT-  restoreT = defaultRestoreT2 RecolorXT+  deriving (MonadTrans, MonadTransControl) via Stack2T (ExceptT XError) (ReaderT Display)  instance MonadBaseControl IO m => MonadRecolor (RecolorXT m) where-  type RecolorValue (RecolorXT m) = RGB Float+  type RecolorValue (RecolorXT m) = RecolorXValue   recolor rgb = do     display <- RecolorXT ask     root <- liftXIO XErrorRead $       rootWindow display $ defaultScreen display -    liftXIO XErrorSetGamma $ xrrSetGamma (translateRGB rgb) display root+    liftXIO XErrorSetGamma $ xrrSetGamma (unRecolorXValue rgb) display root  runRecolorXT :: Display -> RecolorXT m a -> m (Either XError a) runRecolorXT display tma = runReaderT (runExceptT (unRecolorXT tma)) display@@ -83,14 +78,20 @@         run display = restoreT $ runRecolorXT display tma  showDisplay :: ConfigX -> String-showDisplay ConfigX {..} = T.unpack . T.concat $+showDisplay ConfigX { hostName, displayServer, screen } = T.unpack . T.concat $   [ fromMaybe "" hostName   , ":" <> T.pack (show displayServer)   , maybe "" (("." <>) . T.pack . show) screen   ] -translateRGB :: RGB Float -> XRRGamma-translateRGB RGB {..} = XRRGamma {..}-  where xrr_gamma_red = red-        xrr_gamma_green = green-        xrr_gamma_blue = blue+newtype RecolorXValue = RecolorXValue { unRecolorXValue :: XRRGamma }+  deriving (Eq, Generic, Ord, Read, Show)++instance NFData RecolorXValue++instance CompatibleValues (RGB Word8) RecolorXValue where+  convertValue RGB { red, green, blue } = RecolorXValue XRRGamma { xrr_gamma_red, xrr_gamma_green, xrr_gamma_blue }+    where xrr_gamma_red = word8ToFloat red+          xrr_gamma_green = word8ToFloat green+          xrr_gamma_blue = word8ToFloat blue+          word8ToFloat = (/ fromIntegral (maxBound @Word8)) . fromIntegral

@@ -1,4 +1,4 @@-{-# LANGUAGE ForeignFunctionInterface, RecordWildCards #-}+{-# LANGUAGE ForeignFunctionInterface #-}  module Blucontrol.Monad.Recolor.X.Internal (   XRRGamma (..)@@ -21,7 +21,7 @@ instance NFData XRRGamma  xrrSetGamma :: XRRGamma -> Display -> Window -> IO ()-xrrSetGamma XRRGamma {..} (Display display) window = do+xrrSetGamma XRRGamma { xrr_gamma_red, xrr_gamma_green, xrr_gamma_blue } (Display display) window = do   res <- _XRRGetScreenResourcesCurrent display window   _setGamma xrr_gamma_red xrr_gamma_green xrr_gamma_blue res display 

@@ -3,7 +3,7 @@ ) where  class CompatibleValues a b where-    convertValue :: a -> b+  convertValue :: a -> b  instance CompatibleValues a a where   convertValue = id

@@ -1,12 +1,16 @@ module Blucontrol.Value.Brightness (   Brightness , WithBrightness (..)+, applyBrightnessToRGB ) where  import Control.DeepSeq import Data.Default import GHC.Generics +import Blucontrol.Value+import Blucontrol.Value.RGB+ -- | Arbitrary precision brightness between 0 and 1 newtype Brightness = Brightness Rational   deriving (Enum, Eq, Fractional, Generic, Num, Ord, Read, Real, RealFrac, Show)@@ -33,6 +37,15 @@                        , color = def                        } --- TODO: Maybe allow applying to RGB?---toRGB WithBrightness {..} = mapRGB applyBrightness $ toRGB rgb---  where applyBrightness = truncate . (toRational brightness *) . toRational+instance CompatibleValues a b => CompatibleValues a (WithBrightness b) where+  convertValue a = WithBrightness { brightness = def+                                  , color = convertValue a+                                  }++applyBrightnessToRGB :: (Integral a, Real a) => WithBrightness (RGB a) -> RGB a+applyBrightnessToRGB x = RGB { red = applyBrightness red'+                             , green = applyBrightness green'+                             , blue = applyBrightness blue'+                             }+  where applyBrightness = truncate . (toRational (brightness x) *) . toRational+        RGB { red = red', green = green', blue = blue' } = color x

@@ -9,8 +9,6 @@ import Data.Word import GHC.Generics -import Blucontrol.Value- -- | Values for the colors 'red', 'green' and 'blue' data RGB a = RGB { red :: a                  , green :: a@@ -40,13 +38,3 @@             , green = maxBound             , blue = maxBound             }--mapRGB :: (a -> b) -> RGB a -> RGB b-mapRGB f rgb = RGB { red = f $ red rgb-                   , green = f $ green rgb-                   , blue = f $ blue rgb-                   }--instance CompatibleValues (RGB Word8) (RGB Float) where-  convertValue = mapRGB word8ToFloat-    where word8ToFloat = (/ fromIntegral (maxBound @Word8)) . fromIntegral

@@ -1,4 +1,4 @@-{-# LANGUAGE RecordWildCards, UndecidableInstances #-}+{-# LANGUAGE UndecidableInstances #-}  module Blucontrol.Value.RGB.Temperature (   Temperature@@ -29,7 +29,7 @@   -- TODO: Test and implement more accurately. Currently based on blugon.   convertValue = convertValue . toRGBWord8     where toRGBWord8 :: Temperature -> RGB Word8-          toRGBWord8 (Temperature temp) = RGB {..}+          toRGBWord8 (Temperature temp) = RGB { red, green, blue }             where red = round . inBounds $                     if t <= 66                        then 255

@@ -0,0 +1,41 @@+{-# LANGUAGE QuantifiedConstraints, UndecidableInstances #-}++module Control.Monad.Trans.Control.Default (+  Stack0T (..)+, Stack2T (..)+) where++import Control.Monad.Base+import Control.Monad.Trans+import Control.Monad.Trans.Control+import Data.Kind++newtype Stack0T+  (m :: Type -> Type)+  (a :: Type)+    = Stack0T { unStack0T :: m a }+  deriving (Applicative, Functor, Monad, MonadBase b, MonadBaseControl b)++instance MonadTrans Stack0T where+  lift = Stack0T++instance MonadTransControl Stack0T where+  type StT Stack0T a = a+  liftWith f = Stack0T $ f unStack0T+  restoreT = Stack0T++newtype Stack2T+  (t1 :: (Type -> Type) -> Type -> Type)+  (t2 :: (Type -> Type) -> Type -> Type)+  (m :: Type -> Type)+  (a :: Type)+    = Stack2T { unStack2T :: t1 (t2 m) a }+  deriving (Applicative, Functor, Monad, MonadBase b, MonadBaseControl b)++instance (forall m. Monad m => Monad (t2 m), MonadTrans t1, MonadTrans t2) => MonadTrans (Stack2T t1 t2) where+  lift = Stack2T . lift . lift++instance (forall m. Monad m => Monad (t2 m), MonadTransControl t1, MonadTransControl t2) => MonadTransControl (Stack2T t1 t2) where+  type StT (Stack2T t1 t2) a = StT t2 (StT t1 a)+  liftWith f = defaultLiftWith2 Stack2T unStack2T $ \x -> f x+  restoreT = defaultRestoreT2 Stack2T

@@ -1,5 +1,3 @@-{-# LANGUAGE RecordWildCards #-}- module Blucontrol.Monad.Gamma.Linear.Test (   test ) where@@ -42,7 +40,7 @@   , 0 == todSec   ]   where h :. m = time-        TimeOfDay {..} = fst $ time Blucontrol.Monad.Gamma.Linear.==> (undefined :: RGB Word8)+        TimeOfDay { todHour, todMin, todSec } = fst $ time Blucontrol.Monad.Gamma.Linear.==> (undefined :: RGB Word8)  prop_calculateRGB :: Arbitrary_Time                   -> (Arbitrary_Time,Arbitrary_RGBWord8)

@@ -1,5 +1,3 @@-{-# LANGUAGE RecordWildCards #-}- module Blucontrol.Value.RGB.Test (   test , Arbitrary_RGBWord8 (..)