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

210 lines
5.9 KiB
Haskell
Raw Normal View History

--------------------------------------------------------------------------------
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 DBus
import DBus.Client
import qualified DBus.Introspection as I
import Data.Internal.DBus
2023-01-01 18:33:02 -05:00
import Data.Internal.XIO
2022-12-30 17:11:15 -05:00
import RIO
2022-12-30 14:58:23 -05:00
import qualified RIO.Text as T
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.
2023-01-02 19:15:25 -05:00
data BrightnessConfig m a b = BrightnessConfig
{ bcMin :: (a, a) -> m b
, bcMax :: (a, a) -> m b
, bcDec :: (a, a) -> m b
, bcInc :: (a, a) -> m b
, bcGet :: (a, a) -> m b
2022-12-30 14:58:23 -05:00
, bcMinRaw :: a
2023-01-02 19:15:25 -05:00
, bcGetMax :: m a
2022-12-30 14:58:23 -05:00
, bcPath :: ObjectPath
, bcInterface :: InterfaceName
2022-12-30 14:58:23 -05:00
, bcName :: T.Text
}
2023-01-02 18:30:17 -05:00
data BrightnessControls m = BrightnessControls
{ bctlMax :: Sometimes (m ())
, bctlMin :: Sometimes (m ())
, bctlInc :: Sometimes (m ())
, bctlDec :: Sometimes (m ())
}
2022-12-30 14:58:23 -05:00
brightnessControls
2023-01-03 22:18:55 -05:00
:: (HasClient (DBusEnv env), MonadReader env m, MonadUnliftIO m)
2023-01-02 18:30:17 -05:00
=> XPQuery
2023-01-02 19:15:25 -05:00
-> BrightnessConfig m a b
2022-12-30 14:58:23 -05:00
-> Maybe SesClient
2023-01-02 18:30:17 -05:00
-> BrightnessControls m
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
2023-01-03 22:18:55 -05:00
:: ( HasClient env
, MonadReader (env c) m
, MonadUnliftIO m
, SafeClient c
, Num n
)
2023-01-02 19:15:25 -05:00
=> BrightnessConfig m a b
2022-12-30 17:11:15 -05:00
-> m (Maybe n)
2023-01-03 22:18:55 -05:00
callGetBrightness BrightnessConfig {bcPath = p, bcInterface = i} =
2021-11-27 13:24:13 -05:00
either (const Nothing) bodyGetBrightness
2023-01-03 22:18:55 -05:00
<$> callMethod xmonadBusName p i memGet
2023-01-02 19:15:25 -05:00
signalDep :: BrightnessConfig m 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
2023-01-03 22:18:55 -05:00
:: ( HasClient env
, MonadReader (env c) m
, MonadUnliftIO m
, SafeClient c
, Num n
)
2023-01-02 19:15:25 -05:00
=> BrightnessConfig m a b
2022-12-30 17:11:15 -05:00
-> (Maybe n -> m ())
-> m ()
2022-12-30 14:58:23 -05:00
matchSignal BrightnessConfig {bcPath = p, bcInterface = i} cb =
2023-01-03 22:18:55 -05:00
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
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m, RealFrac b)
2022-12-30 14:58:23 -05:00
=> XPQuery
-> [Fulfillment]
-> [IODependency_]
2023-01-02 19:15:25 -05:00
-> BrightnessConfig m a b
2022-12-30 14:58:23 -05:00
-> Maybe SesClient
2023-01-01 12:43:54 -05:00
-> Sometimes (m (), m ())
2022-12-30 14:58:23 -05:00
brightnessExporter q ful deps bc@BrightnessConfig {bcName = n} cl =
Sometimes (T.append n " DBus Interface") q [Subfeature root "exporter"]
where
2023-01-01 12:43:54 -05:00
root = DBusRoot_ (exportBrightnessControlsInner bc) tree cl
tree = listToAnds (Bus ful xmonadBusName) $ fmap DBusIO deps
2021-11-11 00:11:15 -05:00
2023-01-01 12:43:54 -05:00
exportBrightnessControlsInner
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m, RealFrac b)
2023-01-02 19:15:25 -05:00
=> BrightnessConfig m a b
2022-12-30 17:15:50 -05:00
-> SesClient
2023-01-01 12:43:54 -05:00
-> (m (), m ())
exportBrightnessControlsInner bc = cmd
2022-12-30 14:58:23 -05:00
where
cmd = exportPair (bcPath bc) $ \cl_ -> do
2023-01-02 19:15:25 -05:00
-- assume the max value will never change
bounds <- (bcMinRaw bc,) <$> bcGetMax bc
runIO <- askRunInIO
let autoMethod' m f = autoMethod m $ runIO $ do
val <- f bc bounds
emitBrightness bc cl_ val
funget <- toIO $ bcGet bc bounds
return $
2023-01-01 12:43:54 -05:00
defaultInterface
{ interfaceName = bcInterface bc
, interfaceMethods =
[ autoMethod' memMax bcMax
, autoMethod' memMin bcMin
, autoMethod' memInc bcInc
, autoMethod' memDec bcDec
2023-01-02 19:15:25 -05:00
, autoMethod memGet (round <$> funget :: IO Int32)
2023-01-01 12:43:54 -05:00
]
, interfaceSignals = [sig]
}
2022-12-30 14:58:23 -05:00
sig =
I.Signal
{ I.signalName = memCur
, I.signalArgs =
[ I.SignalArg
{ I.signalArgName = "brightness"
, I.signalArgType = TypeInt32
}
]
}
2022-12-30 17:11:15 -05:00
emitBrightness
:: (MonadUnliftIO m, RealFrac b)
2023-01-02 19:15:25 -05:00
=> BrightnessConfig m a b
2022-12-30 17:11:15 -05:00
-> Client
-> b
-> m ()
2022-12-30 14:58:23 -05:00
emitBrightness BrightnessConfig {bcPath = p, bcInterface = i} client cur =
2022-12-30 17:11:15 -05:00
liftIO $ emit client $ sig {signalBody = [toVariant (round cur :: Int32)]}
where
sig = signal p i memCur
2022-12-30 14:58:23 -05:00
callBacklight
2023-01-03 22:18:55 -05:00
:: (MonadReader env m, HasClient (DBusEnv env), MonadUnliftIO m)
2023-01-02 18:30:17 -05:00
=> XPQuery
2022-12-30 14:58:23 -05:00
-> Maybe SesClient
2023-01-02 19:15:25 -05:00
-> BrightnessConfig m a b
2022-12-30 14:58:23 -05:00
-> T.Text
-> MemberName
2023-01-02 18:30:17 -05:00
-> Sometimes (m ())
2023-01-03 22:18:55 -05:00
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 = void $ withDIO c $ callMethod 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"