ENH make signal happen when method is called

lib/DBus/IntelBacklight.hs

@@ -13,7 +13,7 @@ module DBus.IntelBacklight
   , matchSignal
   ) where
 
-import Control.Monad (forM_)
+import Control.Monad (void)
 
 import Data.Char
 
@@ -25,6 +25,7 @@ import Data.Text.IO as T (readFile, writeFile)
 
 import DBus
 import DBus.Client
+import DBus.Internal
 
 --------------------------------------------------------------------------------
 -- | Low level sysfs functions
@@ -69,6 +70,7 @@ getRawBrightness = readFileInt curFile
 setRawBrightness :: RawBrightness -> IO ()
 setRawBrightness = T.writeFile curFile . pack . show
 
+-- TODO this has rounding errors that make the steps uneven
 rawToNorm :: RawBrightness -> RawBrightness -> Brightness
 rawToNorm maxRaw curRaw = fromIntegral
   $ (curRaw - 1) * maxNorm `div` (maxRaw - 1)
@@ -105,69 +107,48 @@ setBrightness maxRaw newNorm = do
 -- integer and emit a signal with the same brightness value. Additionally, there
 -- is one method to get the current brightness.
 
-brPath :: ObjectPath
+path :: ObjectPath
-brPath = "/intelbacklight"
+path = "/intelbacklight"
 
-brInterface :: InterfaceName
+interface :: InterfaceName
-brInterface = "org.xmonad.Brightness"
+interface = "org.xmonad.Brightness"
 
-brCurrentBrightness :: MemberName
+memCurrentBrightness :: MemberName
-brCurrentBrightness = "CurrentBrightness"
+memCurrentBrightness = "CurrentBrightness"
 
-brGetBrightness :: MemberName
+memGetBrightness :: MemberName
-brGetBrightness = "GetBrightness"
+memGetBrightness = "GetBrightness"
 
-brMaxBrightness :: MemberName
+memMaxBrightness :: MemberName
-brMaxBrightness = "MaxBrightness"
+memMaxBrightness = "MaxBrightness"
 
-brMinBrightness :: MemberName
+memMinnBrightness :: MemberName
-brMinBrightness = "MinBrightness"
+memMinnBrightness = "MinBrightness"
 
-brIncBrightness :: MemberName
+memIncBrightness :: MemberName
-brIncBrightness = "IncBrightness"
+memIncBrightness = "IncBrightness"
 
-brDecBrightness :: MemberName
+memDecBrightness :: MemberName
-brDecBrightness = "DecBrightness"
+memDecBrightness = "DecBrightness"
 
 brSignal :: Signal
-brSignal = signal brPath brInterface brCurrentBrightness
+brSignal = signal path interface memCurrentBrightness
   -- { signalDestination = Just "org.xmonad" }
 
 brMatcher :: MatchRule
 brMatcher = matchAny
-  { matchPath = Just brPath
+  { matchPath = Just path
-  , matchInterface = Just brInterface
+  , matchInterface = Just interface
-  , matchMember = Just brCurrentBrightness
+  , matchMember = Just memCurrentBrightness
   }
 
-callBacklight :: Client -> MemberName -> IO (Maybe [Variant])
-callBacklight client method = do
-  -- TODO this will throw a clienterror if it cannot connect at all
-  reply <- call client (methodCall brPath brInterface method)
-    { methodCallDestination = Just "org.xmonad" }
-  return $ case reply of
-    Left _    -> Nothing
-    Right ret -> Just $ methodReturnBody ret
 
-callBacklight' :: MemberName -> IO (Maybe Brightness)
+callBacklight :: MemberName -> IO ()
-callBacklight' method = do
+callBacklight method = void $ callMethod $ methodCall path interface method
-  client <- connectSession
-  body <- callBacklight client method
-  -- TODO this is a bit convoluted...I return the body in the reply of
-  -- the method call and feed that to the signal and then return the
-  -- body (the latter is not really necessary since the only things
-  -- that read the backlight status either use the signal or call
-  -- GetBrightness directly
-  forM_ body $ emitBrightness client
-  return $ body >>= signalBrightness
 
-emitBrightness :: Client -> [Variant] -> IO ()
+bodyGetBrightness :: [Variant] -> Maybe Brightness
-emitBrightness client body =
+bodyGetBrightness [b] = fromVariant b :: Maybe Brightness
-  emit client $ brSignal { signalBody = body }
+bodyGetBrightness _   = Nothing
-
-signalBrightness :: [Variant] -> Maybe Brightness
-signalBrightness [b] = fromVariant b :: Maybe Brightness
-signalBrightness _   = Nothing
 
 -- | Exported haskell API
 
@@ -175,36 +156,39 @@ exportIntelBacklight :: Client -> IO ()
 exportIntelBacklight client = do
   maxval <- getMaxRawBrightness -- assume the max value will never change
   let stepsize = maxBrightness `div` steps
-  export client brPath defaultInterface
+  let emit' = emitBrightness client
-    { interfaceName = brInterface
+  export client path defaultInterface
+    { interfaceName = interface
     , interfaceMethods =
-      [ autoMethod brMaxBrightness (setBrightness maxval maxBrightness)
+      [ autoMethod memMaxBrightness $ emit' =<< setBrightness maxval maxBrightness
-      , autoMethod brMinBrightness (setBrightness maxval 0)
+      , autoMethod memMinnBrightness $ emit' =<< setBrightness maxval 0
-      , autoMethod brIncBrightness (changeBrightness maxval stepsize)
+      , autoMethod memIncBrightness $ emit' =<< changeBrightness maxval stepsize
-      , autoMethod brDecBrightness (changeBrightness maxval (-stepsize))
+      , autoMethod memDecBrightness $ emit' =<< changeBrightness maxval (-stepsize)
-      , autoMethod brGetBrightness (getBrightness maxval)
+      , autoMethod memGetBrightness $ getBrightness maxval
       ]
     }
 
-callMaxBrightness :: IO (Maybe Brightness)
+emitBrightness :: Client -> Brightness -> IO ()
-callMaxBrightness = callBacklight' brMaxBrightness
+emitBrightness client cur = emit client $ brSignal { signalBody = [toVariant cur] }
 
-callMinBrightness :: IO (Maybe Brightness)
+callMaxBrightness :: IO ()
-callMinBrightness = callBacklight' brMinBrightness
+callMaxBrightness = callBacklight memMaxBrightness
 
-callIncBrightness :: IO (Maybe Brightness)
+callMinBrightness :: IO ()
-callIncBrightness = callBacklight' brIncBrightness
+callMinBrightness = callBacklight memMinnBrightness
 
-callDecBrightness :: IO (Maybe Brightness)
+callIncBrightness :: IO ()
-callDecBrightness = callBacklight' brDecBrightness
+callIncBrightness = callBacklight memIncBrightness
+
+callDecBrightness :: IO ()
+callDecBrightness = callBacklight memDecBrightness
 
 callGetBrightness :: IO (Maybe Brightness)
 callGetBrightness = do
-  client <- connectSession
+  reply <- callMethod $ methodCall path interface memGetBrightness
-  body <- callBacklight client brGetBrightness
+  return $ reply >>= bodyGetBrightness
-  return $ body >>= signalBrightness
 
 matchSignal :: (Maybe Brightness -> IO ()) -> IO SignalHandler
 matchSignal cb = do
   client <- connectSession
-  addMatch client brMatcher $ cb . signalBrightness . signalBody
+  addMatch client brMatcher $ cb . bodyGetBrightness . signalBody

lib/DBus/Internal.hs

@@ -2,35 +2,19 @@
 
 module DBus.Internal where
 
-import Control.Monad (forM_)
-
 import DBus
 import DBus.Client
 
-callMethod' :: Client -> MethodCall -> IO (Maybe [Variant])
+-- TODO not all methods warrent that we wait for a reply?
-callMethod' client mc = do
+callMethod :: MethodCall -> IO (Maybe [Variant])
+callMethod mc = do
+  client <- connectSession
   -- TODO handle clienterrors here
   reply <- call client mc { methodCallDestination = Just "org.xmonad" }
   return $ case reply of
     Left _    -> Nothing
     Right ret -> Just $ methodReturnBody ret
 
-callMethod :: MethodCall -> ([Variant] -> Maybe a) -> IO (Maybe a)
-callMethod mc procBody = do
-  client <- connectSession
-  body <- callMethod' client mc
-  return $ body >>= procBody
-
-callMethodEmit :: MethodCall
-  -> ([Variant] -> Maybe a)
-  -> ([Variant] -> Signal)
-  -> IO (Maybe a)
-callMethodEmit mc procBody bodyToSignal = do
-  client <- connectSession
-  body <- callMethod' client mc
-  forM_ body $ emit client . bodyToSignal
-  return $ body >>= procBody
-
 addMatchCallback :: MatchRule -> ([Variant] -> IO ()) -> IO SignalHandler
 addMatchCallback rule cb = do
   client <- connectSession

lib/DBus/Screensaver.hs

@@ -3,7 +3,14 @@
 --------------------------------------------------------------------------------
 -- | DBus module for X11 screensave/DPMS control
 
-module DBus.Screensaver where
+module DBus.Screensaver
+  ( exportScreensaver
+  , callToggle
+  , callQuery
+  , matchSignal
+  ) where
+
+import Control.Monad (void)
 
 import DBus
 import DBus.Client
@@ -46,59 +53,61 @@ query = do
 --------------------------------------------------------------------------------
 -- | DBus Interface
 --
--- Define two methods to enable/disable the screensaver. These methods will
+-- Define a methods to toggle the screensaver. This methods will emit signal
--- emit signals with the state when called. Define another method to get the
+-- with the new state when called. Define another method to get the current
--- current state.
+-- state.
 
-ssPath :: ObjectPath
+path :: ObjectPath
-ssPath = "/screensaver"
+path = "/screensaver"
 
-ssInterface :: InterfaceName
+interface :: InterfaceName
-ssInterface = "org.xmonad.Screensaver"
+interface = "org.xmonad.Screensaver"
 
-ssState :: MemberName
+memState :: MemberName
-ssState = "State"
+memState = "State"
 
-ssToggle :: MemberName
+memToggle :: MemberName
-ssToggle = "Toggle"
+memToggle = "Toggle"
 
-ssQuery :: MemberName
+memQuery :: MemberName
-ssQuery = "Query"
+memQuery = "Query"
 
-ssSignal :: Signal
+sigCurrentState :: Signal
-ssSignal = signal ssPath ssInterface ssState
+sigCurrentState = signal path interface memState
 
-ssMatcher :: MatchRule
+ruleCurrentState :: MatchRule
-ssMatcher = matchAny
+ruleCurrentState = matchAny
-  { matchPath = Just ssPath
+  { matchPath = Just path
-  , matchInterface = Just ssInterface
+  , matchInterface = Just interface
-  , matchMember = Just ssState
+  , matchMember = Just memState
   }
 
+emitState :: Client -> SSState -> IO ()
+emitState client sss = emit client $ sigCurrentState { signalBody = [toVariant sss] }
+
+bodyGetCurrentState :: [Variant] -> Maybe SSState
+bodyGetCurrentState [b] = fromVariant b :: Maybe SSState
+bodyGetCurrentState _   = Nothing
+
+-- | Exported haskell API
+
 exportScreensaver :: Client -> IO ()
 exportScreensaver client =
-  export client ssPath defaultInterface
+  export client path defaultInterface
-    { interfaceName = ssInterface
+    { interfaceName = interface
     , interfaceMethods =
-      [ autoMethod ssToggle toggle
+      [ autoMethod memToggle $ emitState client =<< toggle
-      , autoMethod ssQuery query
+      , autoMethod memQuery query
       ]
     }
 
-callToggle :: IO (Maybe SSState)
+callToggle :: IO ()
-callToggle = callMethodEmit mc bodyState sig
+callToggle = void $ callMethod $ methodCall path interface memToggle
-  where
-    mc = methodCall ssPath ssInterface ssToggle
-    sig b = ssSignal { signalBody = b }
-
-bodyState :: [Variant] -> Maybe SSState
-bodyState [b] = fromVariant b :: Maybe SSState
-bodyState _   = Nothing
 
 callQuery :: IO (Maybe SSState)
-callQuery = callMethod mc bodyState
+callQuery = do
-  where
+  reply <- callMethod $ methodCall path interface memQuery
-    mc = methodCall ssPath ssInterface ssQuery
+  return $ reply >>= bodyGetCurrentState
 
 matchSignal :: (Maybe SSState -> IO ()) -> IO SignalHandler
-matchSignal cb = addMatchCallback ssMatcher $ cb . bodyState
+matchSignal cb = addMatchCallback ruleCurrentState $ cb . bodyGetCurrentState