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

--------------------------------------------------------------------------------
-- 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 SesClient
  -> 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 xmonadBusName p i memGet

signalDep :: BrightnessConfig m a b -> DBusDependency_ SesClient
signalDep BrightnessConfig {bcPath = p, bcInterface = i} =
  Endpoint [] xmonadBusName 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 SesClient
  -> 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 xmonadBusName) $ fmap DBusIO deps

exportBrightnessControlsInner
  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m, RealFrac b)
  => BrightnessConfig m a b
  -> SesClient
  -> (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 SesClient
  -> 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 [] 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)
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"