Compare commits

...

2 Commits

4 changed files with 52 additions and 49 deletions

View File

@ -320,7 +320,6 @@ data DBusDependency_ c
= Bus [Fulfillment] BusName = Bus [Fulfillment] BusName
| Endpoint [Fulfillment] BusName ObjectPath InterfaceName DBusMember | Endpoint [Fulfillment] BusName ObjectPath InterfaceName DBusMember
| DBusIO IODependency_ | DBusIO IODependency_
deriving (Generic)
-- | A dependency that only requires IO to evaluate (no payload) -- | A dependency that only requires IO to evaluate (no payload)
data IODependency_ data IODependency_
@ -335,23 +334,23 @@ data SystemDependency
| AccessiblePath FilePath Bool Bool | AccessiblePath FilePath Bool Bool
| Systemd UnitType T.Text | Systemd UnitType T.Text
| Process T.Text | Process T.Text
deriving (Eq, Show, Generic) deriving (Eq, Show)
-- | The type of a systemd service -- | The type of a systemd service
data UnitType = SystemUnit | UserUnit deriving (Eq, Show, Generic) data UnitType = SystemUnit | UserUnit deriving (Eq, Show)
-- | Wrapper type to describe and endpoint -- | Wrapper type to describe and endpoint
data DBusMember data DBusMember
= Method_ MemberName = Method_ MemberName
| Signal_ MemberName | Signal_ MemberName
| Property_ T.Text | Property_ T.Text
deriving (Eq, Show, Generic) deriving (Eq, Show)
-- | A means to fulfill a dependency -- | A means to fulfill a dependency
-- For now this is just the name of an Arch Linux package (AUR or official) -- For now this is just the name of an Arch Linux package (AUR or official)
data Fulfillment = Package ArchPkg T.Text deriving (Eq, Show, Ord) data Fulfillment = Package ArchPkg T.Text deriving (Eq, Show, Ord)
data ArchPkg = Official | AUR | Custom deriving (Eq, Show, Generic, Ord) data ArchPkg = Official | AUR | Custom deriving (Eq, Show, Ord)
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- Tested dependency tree -- Tested dependency tree

View File

@ -46,34 +46,34 @@ backlightDir = "/sys/devices/platform/tuxedo_keyboard"
stateFile :: FilePath stateFile :: FilePath
stateFile = backlightDir </> "state" stateFile = backlightDir </> "state"
stateChange :: Bool -> IO () stateChange :: MonadUnliftIO m => Bool -> m ()
stateChange = writeBool stateFile stateChange = writeBool stateFile
stateOn :: IO () stateOn :: MonadUnliftIO m => m ()
stateOn = stateChange True stateOn = stateChange True
stateOff :: IO () stateOff :: MonadUnliftIO m => m ()
stateOff = stateChange False stateOff = stateChange False
brightnessFile :: FilePath brightnessFile :: FilePath
brightnessFile = backlightDir </> "brightness" brightnessFile = backlightDir </> "brightness"
getBrightness :: RawBounds -> IO Brightness getBrightness :: MonadUnliftIO m => RawBounds -> m Brightness
getBrightness bounds = readPercent bounds brightnessFile getBrightness bounds = readPercent bounds brightnessFile
minBrightness :: RawBounds -> IO Brightness minBrightness :: MonadUnliftIO m => RawBounds -> m Brightness
minBrightness bounds = do minBrightness bounds = do
b <- writePercentMin bounds brightnessFile b <- writePercentMin bounds brightnessFile
stateOff stateOff
return b return b
maxBrightness :: RawBounds -> IO Brightness maxBrightness :: MonadUnliftIO m => RawBounds -> m Brightness
maxBrightness bounds = stateOn >> writePercentMax bounds brightnessFile maxBrightness bounds = stateOn >> writePercentMax bounds brightnessFile
incBrightness :: RawBounds -> IO Brightness incBrightness :: MonadUnliftIO m => RawBounds -> m Brightness
incBrightness bounds = stateOn >> incPercent steps brightnessFile bounds incBrightness bounds = stateOn >> incPercent steps brightnessFile bounds
decBrightness :: RawBounds -> IO Brightness decBrightness :: MonadUnliftIO m => RawBounds -> m Brightness
decBrightness bounds = do decBrightness bounds = do
b <- decPercent steps brightnessFile bounds b <- decPercent steps brightnessFile bounds
when (b == 0) stateOff when (b == 0) stateOff
@ -88,7 +88,7 @@ blPath = objectPath_ "/clevo_keyboard"
interface :: InterfaceName interface :: InterfaceName
interface = interfaceName_ "org.xmonad.Brightness" interface = interfaceName_ "org.xmonad.Brightness"
clevoKeyboardConfig :: BrightnessConfig RawBrightness Brightness clevoKeyboardConfig :: MonadUnliftIO m => BrightnessConfig m RawBrightness Brightness
clevoKeyboardConfig = clevoKeyboardConfig =
BrightnessConfig BrightnessConfig
{ bcMin = minBrightness { bcMin = minBrightness
@ -113,7 +113,9 @@ brightnessFileDep :: IODependency_
brightnessFileDep = pathR brightnessFile [Package AUR "tuxedo-keyboard"] brightnessFileDep = pathR brightnessFile [Package AUR "tuxedo-keyboard"]
clevoKeyboardSignalDep :: DBusDependency_ SesClient clevoKeyboardSignalDep :: DBusDependency_ SesClient
clevoKeyboardSignalDep = signalDep clevoKeyboardConfig clevoKeyboardSignalDep =
-- TODO do I need to get rid of the IO here?
signalDep (clevoKeyboardConfig :: BrightnessConfig IO RawBrightness Brightness)
exportClevoKeyboard exportClevoKeyboard
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m) :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)

View File

@ -1,4 +1,5 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- DBus module for DBus brightness controls -- DBus module for DBus brightness controls
@ -32,14 +33,14 @@ import XMonad.Internal.DBus.Common
-- integer and emit a signal with the same brightness value. Additionally, there -- integer and emit a signal with the same brightness value. Additionally, there
-- is one method to get the current brightness. -- is one method to get the current brightness.
data BrightnessConfig a b = BrightnessConfig data BrightnessConfig m a b = BrightnessConfig
{ bcMin :: (a, a) -> IO b { bcMin :: (a, a) -> m b
, bcMax :: (a, a) -> IO b , bcMax :: (a, a) -> m b
, bcDec :: (a, a) -> IO b , bcDec :: (a, a) -> m b
, bcInc :: (a, a) -> IO b , bcInc :: (a, a) -> m b
, bcGet :: (a, a) -> IO b , bcGet :: (a, a) -> m b
, bcMinRaw :: a , bcMinRaw :: a
, bcGetMax :: IO a , bcGetMax :: m a
, bcPath :: ObjectPath , bcPath :: ObjectPath
, bcInterface :: InterfaceName , bcInterface :: InterfaceName
, bcName :: T.Text , bcName :: T.Text
@ -55,7 +56,7 @@ data BrightnessControls m = BrightnessControls
brightnessControls brightnessControls
:: MonadUnliftIO m :: MonadUnliftIO m
=> XPQuery => XPQuery
-> BrightnessConfig a b -> BrightnessConfig m a b
-> Maybe SesClient -> Maybe SesClient
-> BrightnessControls m -> BrightnessControls m
brightnessControls q bc cl = brightnessControls q bc cl =
@ -70,20 +71,20 @@ brightnessControls q bc cl =
callGetBrightness callGetBrightness
:: (MonadUnliftIO m, SafeClient c, Num n) :: (MonadUnliftIO m, SafeClient c, Num n)
=> BrightnessConfig a b => BrightnessConfig m a b
-> c -> c
-> m (Maybe n) -> m (Maybe n)
callGetBrightness BrightnessConfig {bcPath = p, bcInterface = i} client = callGetBrightness BrightnessConfig {bcPath = p, bcInterface = i} client =
either (const Nothing) bodyGetBrightness either (const Nothing) bodyGetBrightness
<$> callMethod client xmonadBusName p i memGet <$> callMethod client xmonadBusName p i memGet
signalDep :: BrightnessConfig a b -> DBusDependency_ SesClient signalDep :: BrightnessConfig m a b -> DBusDependency_ SesClient
signalDep BrightnessConfig {bcPath = p, bcInterface = i} = signalDep BrightnessConfig {bcPath = p, bcInterface = i} =
Endpoint [] xmonadBusName p i $ Signal_ memCur Endpoint [] xmonadBusName p i $ Signal_ memCur
matchSignal matchSignal
:: (MonadUnliftIO m, SafeClient c, Num n) :: (MonadUnliftIO m, SafeClient c, Num n)
=> BrightnessConfig a b => BrightnessConfig m a b
-> (Maybe n -> m ()) -> (Maybe n -> m ())
-> c -> c
-> m () -> m ()
@ -106,7 +107,7 @@ brightnessExporter
=> XPQuery => XPQuery
-> [Fulfillment] -> [Fulfillment]
-> [IODependency_] -> [IODependency_]
-> BrightnessConfig a b -> BrightnessConfig m a b
-> Maybe SesClient -> Maybe SesClient
-> Sometimes (m (), m ()) -> Sometimes (m (), m ())
brightnessExporter q ful deps bc@BrightnessConfig {bcName = n} cl = brightnessExporter q ful deps bc@BrightnessConfig {bcName = n} cl =
@ -117,21 +118,19 @@ brightnessExporter q ful deps bc@BrightnessConfig {bcName = n} cl =
exportBrightnessControlsInner exportBrightnessControlsInner
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m, RealFrac b) :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m, RealFrac b)
=> BrightnessConfig a b => BrightnessConfig m a b
-> SesClient -> SesClient
-> (m (), m ()) -> (m (), m ())
exportBrightnessControlsInner bc = cmd exportBrightnessControlsInner bc = cmd
where where
cmd = exportPair (bcPath bc) $ \cl_ -> do cmd = exportPair (bcPath bc) $ \cl_ -> do
-- up = liftIO $ do -- assume the max value will never change
-- let ses = toClient cl bounds <- (bcMinRaw bc,) <$> bcGetMax bc
maxval <- liftIO $ bcGetMax bc -- assume the max value will never change runIO <- askRunInIO
let bounds = (bcMinRaw bc, maxval) let autoMethod' m f = autoMethod m $ runIO $ do
let autoMethod' m f = autoMethod m $ emitBrightness bc cl_ =<< f bc bounds val <- f bc bounds
let funget = bcGet bc emitBrightness bc cl_ val
-- export funget <- toIO $ bcGet bc bounds
-- ses
-- (bcPath bc)
return $ return $
defaultInterface defaultInterface
{ interfaceName = bcInterface bc { interfaceName = bcInterface bc
@ -140,11 +139,10 @@ exportBrightnessControlsInner bc = cmd
, autoMethod' memMin bcMin , autoMethod' memMin bcMin
, autoMethod' memInc bcInc , autoMethod' memInc bcInc
, autoMethod' memDec bcDec , autoMethod' memDec bcDec
, autoMethod memGet (round <$> funget bounds :: IO Int32) , autoMethod memGet (round <$> funget :: IO Int32)
] ]
, interfaceSignals = [sig] , interfaceSignals = [sig]
} }
-- down = liftIO $ unexport (toClient cl) (bcPath bc)
sig = sig =
I.Signal I.Signal
{ I.signalName = memCur { I.signalName = memCur
@ -158,7 +156,7 @@ exportBrightnessControlsInner bc = cmd
emitBrightness emitBrightness
:: (MonadUnliftIO m, RealFrac b) :: (MonadUnliftIO m, RealFrac b)
=> BrightnessConfig a b => BrightnessConfig m a b
-> Client -> Client
-> b -> b
-> m () -> m ()
@ -171,7 +169,7 @@ callBacklight
:: MonadUnliftIO m :: MonadUnliftIO m
=> XPQuery => XPQuery
-> Maybe SesClient -> Maybe SesClient
-> BrightnessConfig a b -> BrightnessConfig m a b
-> T.Text -> T.Text
-> MemberName -> MemberName
-> Sometimes (m ()) -> Sometimes (m ())

View File

@ -45,22 +45,22 @@ maxFile = backlightDir </> "max_brightness"
curFile :: FilePath curFile :: FilePath
curFile = backlightDir </> "brightness" curFile = backlightDir </> "brightness"
getMaxRawBrightness :: IO RawBrightness getMaxRawBrightness :: MonadUnliftIO m => m RawBrightness
getMaxRawBrightness = readInt maxFile getMaxRawBrightness = readInt maxFile
getBrightness :: RawBounds -> IO Brightness getBrightness :: MonadUnliftIO m => RawBounds -> m Brightness
getBrightness bounds = readPercent bounds curFile getBrightness bounds = readPercent bounds curFile
minBrightness :: RawBounds -> IO Brightness minBrightness :: MonadUnliftIO m => RawBounds -> m Brightness
minBrightness bounds = writePercentMin bounds curFile minBrightness bounds = writePercentMin bounds curFile
maxBrightness :: RawBounds -> IO Brightness maxBrightness :: MonadUnliftIO m => RawBounds -> m Brightness
maxBrightness bounds = writePercentMax bounds curFile maxBrightness bounds = writePercentMax bounds curFile
incBrightness :: RawBounds -> IO Brightness incBrightness :: MonadUnliftIO m => RawBounds -> m Brightness
incBrightness = incPercent steps curFile incBrightness = incPercent steps curFile
decBrightness :: RawBounds -> IO Brightness decBrightness :: MonadUnliftIO m => RawBounds -> m Brightness
decBrightness = decPercent steps curFile decBrightness = decPercent steps curFile
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
@ -72,7 +72,9 @@ blPath = objectPath_ "/intelbacklight"
interface :: InterfaceName interface :: InterfaceName
interface = interfaceName_ "org.xmonad.Brightness" interface = interfaceName_ "org.xmonad.Brightness"
intelBacklightConfig :: BrightnessConfig RawBrightness Brightness intelBacklightConfig
:: MonadUnliftIO m
=> BrightnessConfig m RawBrightness Brightness
intelBacklightConfig = intelBacklightConfig =
BrightnessConfig BrightnessConfig
{ bcMin = minBrightness { bcMin = minBrightness
@ -97,7 +99,9 @@ maxFileDep :: IODependency_
maxFileDep = pathR maxFile [] maxFileDep = pathR maxFile []
intelBacklightSignalDep :: DBusDependency_ SesClient intelBacklightSignalDep :: DBusDependency_ SesClient
intelBacklightSignalDep = signalDep intelBacklightConfig intelBacklightSignalDep =
-- TODO do I need to get rid of the IO here?
signalDep (intelBacklightConfig :: BrightnessConfig IO RawBrightness Brightness)
exportIntelBacklight exportIntelBacklight
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m) :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)