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

210 lines
6.0 KiB
Haskell

--------------------------------------------------------------------------------
-- DBus module for DBus brightness controls
module XMonad.Internal.DBus.Brightness.Common
( BrightnessConfig (..)
, BrightnessControls (..)
, brightnessControls
, brightnessExporter
, callGetBrightness
, matchSignal
, signalDep
)
where
import DBus
import DBus.Client
import qualified DBus.Introspection as I
import Data.Internal.DBus
import Data.Internal.XIO
import RIO
import qualified RIO.Text as T
import XMonad.Internal.DBus.Common
--------------------------------------------------------------------------------
-- 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 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
, bcMinRaw :: a
, bcGetMax :: m a
, bcPath :: ObjectPath
, bcInterface :: InterfaceName
, bcName :: T.Text
}
data BrightnessControls m = BrightnessControls
{ bctlMax :: Sometimes (m ())
, bctlMin :: Sometimes (m ())
, bctlInc :: Sometimes (m ())
, bctlDec :: Sometimes (m ())
}
brightnessControls
:: (HasClient (DBusEnv env), MonadReader env m, MonadUnliftIO m)
=> XPQuery
-> BrightnessConfig m a b
-> Maybe NamedSesConnection
-> BrightnessControls m
brightnessControls q bc cl =
BrightnessControls
{ bctlMax = cb "max brightness" memMax
, bctlMin = cb "min brightness" memMin
, bctlInc = cb "increase brightness" memInc
, bctlDec = cb "decrease brightness" memDec
}
where
cb = callBacklight q cl bc
callGetBrightness
:: ( HasClient env
, MonadReader (env c) m
, MonadUnliftIO m
, SafeClient c
, Num n
)
=> BrightnessConfig m a b
-> m (Maybe n)
callGetBrightness BrightnessConfig {bcPath = p, bcInterface = i} =
either (const Nothing) bodyGetBrightness
<$> callMethod xmonadSesBusName p i memGet
signalDep :: BrightnessConfig m a b -> DBusDependency_ c
signalDep BrightnessConfig {bcPath = p, bcInterface = i} =
Endpoint [] xmonadSesBusName p i $ Signal_ memCur
matchSignal
:: ( HasClient env
, MonadReader (env c) m
, MonadUnliftIO m
, SafeClient c
, Num n
)
=> BrightnessConfig m a b
-> (Maybe n -> m ())
-> m ()
matchSignal BrightnessConfig {bcPath = p, bcInterface = i} cb =
void $ addMatchCallback brMatcher (cb . bodyGetBrightness)
where
-- TODO add busname to this
brMatcher =
matchAny
{ matchPath = Just p
, matchInterface = Just i
, matchMember = Just memCur
}
--------------------------------------------------------------------------------
-- Internal DBus Crap
brightnessExporter
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m, RealFrac b)
=> XPQuery
-> [Fulfillment]
-> [IODependency_]
-> BrightnessConfig m a b
-> Maybe NamedSesConnection
-> Sometimes (m (), m ())
brightnessExporter q ful deps bc@BrightnessConfig {bcName = n} cl =
Sometimes (T.append n " DBus Interface") q [Subfeature root "exporter"]
where
root = DBusRoot_ (exportBrightnessControlsInner bc) tree cl
tree = listToAnds (Bus ful xmonadSesBusName) $ fmap DBusIO deps
exportBrightnessControlsInner
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m, RealFrac b)
=> BrightnessConfig m a b
-> NamedSesConnection
-> (m (), m ())
exportBrightnessControlsInner bc = cmd
where
cmd = exportPair (bcPath bc) $ \cl_ -> do
-- 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 $
defaultInterface
{ interfaceName = bcInterface bc
, interfaceMethods =
[ autoMethod' memMax bcMax
, autoMethod' memMin bcMin
, autoMethod' memInc bcInc
, autoMethod' memDec bcDec
, autoMethod memGet (round <$> funget :: IO Int32)
]
, interfaceSignals = [sig]
}
sig =
I.Signal
{ I.signalName = memCur
, I.signalArgs =
[ I.SignalArg
{ I.signalArgName = "brightness"
, I.signalArgType = TypeInt32
}
]
}
emitBrightness
:: (MonadUnliftIO m, RealFrac b)
=> BrightnessConfig m a b
-> Client
-> b
-> m ()
emitBrightness BrightnessConfig {bcPath = p, bcInterface = i} client cur =
liftIO $ emit client $ sig {signalBody = [toVariant (round cur :: Int32)]}
where
sig = signal p i memCur
callBacklight
:: (MonadReader env m, HasClient (DBusEnv env), MonadUnliftIO m)
=> XPQuery
-> Maybe NamedSesConnection
-> BrightnessConfig m a b
-> T.Text
-> MemberName
-> Sometimes (m ())
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 [] xmonadSesBusName p i $ Method_ m) cl
cmd c = void $ withDIO c $ callMethod xmonadSesBusName p i m
bodyGetBrightness :: Num a => [Variant] -> Maybe a
bodyGetBrightness [b] = fromIntegral <$> (fromVariant b :: Maybe Int32)
bodyGetBrightness _ = Nothing
--------------------------------------------------------------------------------
-- 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"