xmonad-config/lib/XMonad/Internal/DBus/Brightness/Common.hs

203 lines
5.5 KiB
Haskell
Raw Normal View History

{-# LANGUAGE OverloadedStrings #-}
--------------------------------------------------------------------------------
2022-12-30 14:58:23 -05:00
-- DBus module for DBus brightness controls
module XMonad.Internal.DBus.Brightness.Common
2022-12-30 14:58:23 -05:00
( BrightnessConfig (..)
, BrightnessControls (..)
, brightnessControls
, brightnessExporter
, callGetBrightness
, matchSignal
, signalDep
2022-12-30 14:58:23 -05:00
)
where
import Control.Monad (void)
import DBus
import DBus.Client
import qualified DBus.Introspection as I
import Data.Int (Int32)
import Data.Internal.DBus
import Data.Internal.Dependency
import qualified RIO.Text as T
import XMonad.Core (io)
import XMonad.Internal.DBus.Common
--------------------------------------------------------------------------------
2022-12-30 14:58:23 -05:00
-- External API
--
-- Define four methods to increase, decrease, maximize, or minimize the
-- brightness. These methods will all return the current brightness as a 32-bit
-- integer and emit a signal with the same brightness value. Additionally, there
-- is one method to get the current brightness.
data BrightnessConfig a b = BrightnessConfig
2022-12-30 14:58:23 -05:00
{ bcMin :: (a, a) -> IO b
, bcMax :: (a, a) -> IO b
, bcDec :: (a, a) -> IO b
, bcInc :: (a, a) -> IO b
, bcGet :: (a, a) -> IO b
, bcMinRaw :: a
, bcGetMax :: IO a
, bcPath :: ObjectPath
, bcInterface :: InterfaceName
2022-12-30 14:58:23 -05:00
, bcName :: T.Text
}
data BrightnessControls = BrightnessControls
{ bctlMax :: SometimesX
, bctlMin :: SometimesX
, bctlInc :: SometimesX
, bctlDec :: SometimesX
}
2022-12-30 14:58:23 -05:00
brightnessControls
:: XPQuery
-> BrightnessConfig a b
-> Maybe SesClient
-> BrightnessControls
2022-07-09 17:08:10 -04:00
brightnessControls q bc cl =
BrightnessControls
2022-12-30 14:58:23 -05:00
{ bctlMax = cb "max brightness" memMax
, bctlMin = cb "min brightness" memMin
, bctlInc = cb "increase brightness" memInc
, bctlDec = cb "decrease brightness" memDec
}
2021-11-11 00:11:15 -05:00
where
2022-07-09 17:08:10 -04:00
cb = callBacklight q cl bc
2022-12-30 14:58:23 -05:00
callGetBrightness
:: (SafeClient c, Num n)
=> BrightnessConfig a b
-> c
2022-07-09 17:44:14 -04:00
-> IO (Maybe n)
2022-12-30 14:58:23 -05:00
callGetBrightness BrightnessConfig {bcPath = p, bcInterface = i} client =
2021-11-27 13:24:13 -05:00
either (const Nothing) bodyGetBrightness
2022-12-30 14:58:23 -05:00
<$> callMethod client xmonadBusName p i memGet
2022-07-09 17:08:10 -04:00
signalDep :: BrightnessConfig a b -> DBusDependency_ SesClient
2022-12-30 14:58:23 -05:00
signalDep BrightnessConfig {bcPath = p, bcInterface = i} =
Endpoint [] xmonadBusName p i $ Signal_ memCur
2022-12-30 14:58:23 -05:00
matchSignal
:: (SafeClient c, Num n)
=> BrightnessConfig a b
-> (Maybe n -> IO ())
-> c
-> IO ()
matchSignal BrightnessConfig {bcPath = p, bcInterface = i} cb =
void . addMatchCallback brMatcher (cb . bodyGetBrightness)
where
2021-11-27 13:24:13 -05:00
-- TODO add busname to this
2022-12-30 14:58:23 -05:00
brMatcher =
matchAny
{ matchPath = Just p
, matchInterface = Just i
, matchMember = Just memCur
}
--------------------------------------------------------------------------------
2022-12-30 14:58:23 -05:00
-- Internal DBus Crap
brightnessExporter
:: RealFrac b
=> XPQuery
-> [Fulfillment]
-> [IODependency_]
-> BrightnessConfig a b
-> Maybe SesClient
-> SometimesIO
brightnessExporter q ful deps bc@BrightnessConfig {bcName = n} cl =
Sometimes (T.append n " DBus Interface") q [Subfeature root "exporter"]
where
root = DBusRoot_ (exportBrightnessControls' bc) tree cl
tree = listToAnds (Bus ful xmonadBusName) $ fmap DBusIO deps
2021-11-11 00:11:15 -05:00
exportBrightnessControls' :: RealFrac b => BrightnessConfig a b -> SesClient -> FIO ()
exportBrightnessControls' bc cl = io $ do
2022-07-09 17:08:10 -04:00
let ses = toClient cl
maxval <- bcGetMax bc -- assume the max value will never change
2021-11-21 00:42:40 -05:00
let bounds = (bcMinRaw bc, maxval)
2022-07-09 17:08:10 -04:00
let autoMethod' m f = autoMethod m $ emitBrightness bc ses =<< f bc bounds
let funget = bcGet bc
2022-12-30 14:58:23 -05:00
export
ses
(bcPath bc)
defaultInterface
{ interfaceName = bcInterface bc
, interfaceMethods =
[ autoMethod' memMax bcMax
, autoMethod' memMin bcMin
, autoMethod' memInc bcInc
, autoMethod' memDec bcDec
, autoMethod memGet (round <$> funget bounds :: IO Int32)
]
, interfaceSignals = [sig]
}
2022-12-30 14:58:23 -05:00
where
sig =
I.Signal
{ I.signalName = memCur
, I.signalArgs =
[ I.SignalArg
{ I.signalArgName = "brightness"
, I.signalArgType = TypeInt32
}
]
}
emitBrightness :: RealFrac b => BrightnessConfig a b -> Client -> b -> IO ()
2022-12-30 14:58:23 -05:00
emitBrightness BrightnessConfig {bcPath = p, bcInterface = i} client cur =
emit client $ sig {signalBody = [toVariant (round cur :: Int32)]}
where
sig = signal p i memCur
2022-12-30 14:58:23 -05:00
callBacklight
:: XPQuery
-> Maybe SesClient
-> BrightnessConfig a b
-> T.Text
-> MemberName
-> SometimesX
callBacklight
q
cl
BrightnessConfig
{ bcPath = p
, bcInterface = i
, bcName = n
}
controlName
m =
Sometimes (T.unwords [n, controlName]) q [Subfeature root "method call"]
where
root = DBusRoot_ cmd (Only_ $ Endpoint [] xmonadBusName p i $ Method_ m) cl
cmd c = io $ void $ callMethod c xmonadBusName p i m
bodyGetBrightness :: Num a => [Variant] -> Maybe a
bodyGetBrightness [b] = fromIntegral <$> (fromVariant b :: Maybe Int32)
2022-12-30 14:58:23 -05:00
bodyGetBrightness _ = Nothing
--------------------------------------------------------------------------------
2022-12-30 14:58:23 -05:00
-- DBus Members
memCur :: MemberName
memCur = memberName_ "CurrentBrightness"
memGet :: MemberName
memGet = memberName_ "GetBrightness"
memMax :: MemberName
memMax = memberName_ "MaxBrightness"
memMin :: MemberName
memMin = memberName_ "MinBrightness"
memInc :: MemberName
memInc = memberName_ "IncBrightness"
memDec :: MemberName
memDec = memberName_ "DecBrightness"