ENH add event signals to backlight controls

bin/xmobar.hs

@@ -1,5 +1,5 @@
--- import Xmobar.Backlight
-import           Xmobar.Screensaver
+import Xmobar.Plugins.IntelBacklight
+import Xmobar.Plugins.Screensaver
 
 import qualified Theme as T
 
@@ -25,8 +25,7 @@ myTemplate = formatTemplate left right
     right = [ "%wlp0s20f3wi%"
             , "%alsa:default:Master%"
             , "%battery%"
-            , "%bright%"
-            -- , "%betterbacklight%"
+            , "%intelbacklight%"
             , "%screensaver%"
             , "%locks%"
             , "%date%"
@@ -100,12 +99,7 @@ config confDir = defaultConfig
                     , "-i" , "<fn=1>\xf1e6</fn>"
                     ] 50
 
-      , Run $ Brightness ["-t", "<fn=1>\xf185</fn><percent>%"
-                       , "--"
-                       , "-D", "intel_backlight"
-                       ] 10
-
-      -- , Run $ Backlight ("", "")
+      , Run $ IntelBacklight "<fn=1>\xf185</fn>"
 
       , Run $ Wireless "wlp0s20f3"
         [ "-t", "<qualityipat><essid>"

bin/xmonad.hs

@@ -9,8 +9,8 @@ import Notify
 import SendXMsg
 import Shell
 
-import DBus.Backlight
 import DBus.Common
+import DBus.IntelBacklight
 
 import qualified Theme as T
 
@@ -521,18 +521,17 @@ runToggleBluetooth = spawn
   #!>> fmtCmd "bluetoothctl" ["power", "$a", ">", "/dev/null"]
   #!&& fmtNotifyCmd defNoteInfo { body = Just $ Text "bluetooth powered $a"  }
 
--- TODO write these in haskell
 runIncBacklight :: X ()
-runIncBacklight = spawnCmd "adj_backlight" ["up"]
+runIncBacklight = io $ void callIncBrightness
 
 runDecBacklight :: X ()
-runDecBacklight = spawnCmd "adj_backlight" ["down"]
+runDecBacklight = io $ void callDecBrightness
 
 runMinBacklight :: X ()
-runMinBacklight = io callMinBrightness
+runMinBacklight = io $ void callMinBrightness
 
 runMaxBacklight :: X ()
-runMaxBacklight = io callMaxBrightness
+runMaxBacklight = io $ void callMaxBrightness
 
 showWorkspace :: WorkspaceId -> X ()
 showWorkspace tag = windows $ W.view tag

lib/DBus/Backlight.hs

@@ -1,111 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-
-module DBus.Backlight where
-
--- import Control.Monad
-
-import Data.Char
-
-import Data.Int (Int32)
-
--- use strict IO here, the data in these files is literally 1-10 bytes
-import Data.Text (pack, unpack)
-import Data.Text.IO as T (readFile, writeFile)
-
-import DBus
-import DBus.Client
-
-brightnessDir :: FilePath
-brightnessDir = "/sys/class/backlight/intel_backlight/"
-
-maxFile :: String
-maxFile = brightnessDir ++ "max_brightness"
-
-curFile :: String
-curFile = brightnessDir ++ "brightness"
-
-steps :: Int
-steps = 15
-
-readFileInt :: FilePath -> IO Int
-readFileInt file = do
-  contents <- T.readFile file
-  return $ read $ takeWhile isDigit $ unpack contents
-
-getMaxValue :: IO Int
-getMaxValue = readFileInt maxFile
-
-getCurValue :: IO Int
-getCurValue = readFileInt curFile
-
-getStepSize :: IO Int
-getStepSize = getMaxValue >>= (\x -> return $ x `div` steps)
-
-setCurValue :: Int -> IO ()
-setCurValue = T.writeFile curFile . pack . show
-
-truncateValue :: Int -> Int -> Int
-truncateValue maxval = min maxval . max 1
-
-changeBrightness :: Int -> Int -> IO ()
-changeBrightness maxval delta = getCurValue
-  >>= setCurValue . truncateValue maxval . (+ delta)
-
-setBrightness :: Int -> IO ()
-setBrightness = setCurValue
-
-exportBrightness :: Client -> IO ()
-exportBrightness client = do
-  maxval <- getMaxValue
-  stepsize <- getStepSize
-  export client "/brightness" defaultInterface
-    { interfaceName = "org.xmonad.Brightness"
-    , interfaceMethods =
-      [ autoMethod "MaxBrightness" (setBrightness maxval)
-      , autoMethod "MinBrightness" (setBrightness 1)
-      , autoMethod "IncBrightness" (changeBrightness maxval stepsize)
-      , autoMethod "DecBrightness" (changeBrightness maxval (-stepsize))
-      ]
-    }
-
-brPath :: ObjectPath
-brPath = "/brightness"
-
-brInterface :: InterfaceName
-brInterface = "org.xmonad.Brightness"
-
-brSignal :: Signal
-brSignal = (signal brPath brInterface "CurrentBrightness")
-  -- { signalDestination = Just "org.xmonad" }
-
-brMatcher :: MatchRule
-brMatcher = matchAny
-  {
-    -- matchSender = Just "org.xmonad"
-  -- , matchDestination = Just "org.xmonad"
-   -- matchPath = Just brPath
-  -- , matchInterface = Just brInterface
-   matchMember = Just "CurrentBrightness"
-  }
-
-callMaxBrightness :: IO ()
-callMaxBrightness = do
-  client <- connectSession
-  _ <- call client (methodCall "/brightness" "org.xmonad.Brightness" "MaxBrightness")
-    { methodCallDestination = Just "org.xmonad" }
-  emit client =<< wrapSig <$> getCurValue
-  -- print reply
-  where
-    wrapSig i = brSignal
-      { signalBody = [toVariant (fromIntegral i :: Int32)] }
-
-callMinBrightness :: IO ()
-callMinBrightness = do
-  client <- connectSession
-  _ <- call client (methodCall "/brightness" "org.xmonad.Brightness" "MinBrightness")
-    { methodCallDestination = Just "org.xmonad" }
-  emit client =<< wrapSig <$> getCurValue
-  -- print reply
-  where
-    wrapSig i = brSignal
-      { signalBody = [toVariant (fromIntegral i :: Int32)] }

lib/DBus/Common.hs

@@ -2,17 +2,10 @@
 
 module DBus.Common where
 
--- import Control.Concurrent
--- import Control.Monad
+import DBus.IntelBacklight
 
-import DBus.Backlight
-
--- import DBus
 import DBus.Client
 
-onFoo :: IO String
-onFoo = return "testicle"
-
 startXMonadService :: IO Client
 startXMonadService = do
   client <- connectSession
@@ -23,11 +16,7 @@ startXMonadService = do
     putStrLn "Another service owns \"org.xmonad\""
   else do
     putStrLn "Started xmonad dbus client"
-    exportBrightness client
-    export client "/test" defaultInterface
-      { interfaceName = "test.iface"
-      , interfaceMethods = [ autoMethod "foo" onFoo ]
-      }
+    exportIntelBacklight client
   return client
 
 stopXMonadService :: Client -> IO ()

lib/DBus/IntelBacklight.hs

@@ -0,0 +1,198 @@
+{-# LANGUAGE LambdaCase        #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+{- |
+  DBus module for backlight control
+-}
+
+module DBus.IntelBacklight
+  ( callDecBrightness
+  , callGetBrightness
+  , callIncBrightness
+  , callMaxBrightness
+  , callMinBrightness
+  , exportIntelBacklight
+  , matchSignal
+  ) where
+
+import Control.Monad (forM_)
+
+import Data.Char
+
+import Data.Int (Int16, Int32)
+
+-- use strict IO here, the data in these files is literally 1-10 bytes
+import Data.Text    (pack, unpack)
+import Data.Text.IO as T (readFile, writeFile)
+
+import DBus
+import DBus.Client
+
+backlightDir :: FilePath
+backlightDir = "/sys/class/backlight/intel_backlight/"
+
+maxFile :: String
+maxFile = backlightDir ++ "max_brightness"
+
+curFile :: String
+curFile = backlightDir ++ "brightness"
+
+steps :: Brightness
+steps = 16
+
+-- TODO this is hacky but not sure if there is a cleaner way to
+-- enforce type checking between these without making two new types
+-- and adding Integral instances to both of them
+type Brightness = Int16
+type RawBrightness = Int32
+
+maxBrightness :: Brightness
+maxBrightness = 10000
+
+readFileInt :: FilePath -> IO RawBrightness
+readFileInt file = do
+  contents <- T.readFile file
+  return $ read $ takeWhile isDigit $ unpack contents
+
+getMaxRawBrightness :: IO RawBrightness
+getMaxRawBrightness = readFileInt maxFile
+
+getRawBrightness :: IO RawBrightness
+getRawBrightness = readFileInt curFile
+
+setRawBrightness :: RawBrightness -> IO ()
+setRawBrightness = T.writeFile curFile . pack . show
+
+rawToNorm :: RawBrightness -> RawBrightness -> Brightness
+rawToNorm maxRaw curRaw = fromIntegral
+  $ (curRaw - 1) * maxNorm `div` (maxRaw - 1)
+  where
+    maxNorm = fromIntegral maxBrightness :: Int32
+
+normToRaw :: RawBrightness -> Brightness -> RawBrightness
+normToRaw maxRaw = normalize . fromIntegral
+  where
+    normalize c = c * (maxRaw - 1) `div` maxNorm + 1
+    maxNorm = fromIntegral maxBrightness :: Int32
+
+truncateNorm :: Brightness -> Brightness
+truncateNorm = min maxBrightness . max 0
+
+getBrightness :: RawBrightness -> IO Brightness
+getBrightness maxRaw = rawToNorm maxRaw <$> getRawBrightness
+
+changeBrightness :: RawBrightness -> Brightness -> IO Brightness
+changeBrightness maxRaw delta = setBrightness maxRaw
+  =<< (+ delta) <$> getBrightness maxRaw
+
+setBrightness :: RawBrightness -> Brightness -> IO Brightness
+setBrightness maxRaw newNorm = do
+  let newNorm' = truncateNorm newNorm
+  setRawBrightness $ normToRaw maxRaw newNorm'
+  return newNorm'
+
+exportIntelBacklight :: Client -> IO ()
+exportIntelBacklight client = do
+  maxval <- getMaxRawBrightness -- assume the max value will never change
+  let stepsize = maxBrightness `div` steps
+  export client brPath defaultInterface
+    { interfaceName = brInterface
+    , interfaceMethods =
+      [ autoMethod brMaxBrightness (setBrightness maxval maxBrightness)
+      , autoMethod brMinBrightness (setBrightness maxval 0)
+      , autoMethod brIncBrightness (changeBrightness maxval stepsize)
+      , autoMethod brDecBrightness (changeBrightness maxval (-stepsize))
+      , autoMethod brGetBrightness (getBrightness maxval)
+      ]
+    }
+
+brPath :: ObjectPath
+brPath = "/intelbacklight"
+
+brInterface :: InterfaceName
+brInterface = "org.xmonad.Brightness"
+
+brCurrentBrightness :: MemberName
+brCurrentBrightness = "CurrentBrightness"
+
+brGetBrightness :: MemberName
+brGetBrightness = "GetBrightness"
+
+brMaxBrightness :: MemberName
+brMaxBrightness = "MaxBrightness"
+
+brMinBrightness :: MemberName
+brMinBrightness = "MinBrightness"
+
+brIncBrightness :: MemberName
+brIncBrightness = "IncBrightness"
+
+brDecBrightness :: MemberName
+brDecBrightness = "DecBrightness"
+
+brSignal :: Signal
+brSignal = signal brPath brInterface brCurrentBrightness
+  -- { signalDestination = Just "org.xmonad" }
+
+brMatcher :: MatchRule
+brMatcher = matchAny
+  { matchPath = Just brPath
+  , matchInterface = Just brInterface
+  , matchMember = Just brCurrentBrightness
+  }
+
+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' method = do
+  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 ()
+emitBrightness client body =
+  emit client $ brSignal { signalBody = body }
+
+signalBrightness :: [Variant] -> Maybe Brightness
+signalBrightness [b] = fromVariant b :: Maybe Brightness
+signalBrightness _   = Nothing
+
+callMaxBrightness :: IO (Maybe Brightness)
+callMaxBrightness = callBacklight' brMaxBrightness
+
+callMinBrightness :: IO (Maybe Brightness)
+callMinBrightness = callBacklight' brMinBrightness
+
+callIncBrightness :: IO (Maybe Brightness)
+callIncBrightness = callBacklight' brIncBrightness
+
+callDecBrightness :: IO (Maybe Brightness)
+callDecBrightness = callBacklight' brDecBrightness
+
+callGetBrightness :: IO (Maybe Brightness)
+callGetBrightness = do
+  client <- connectSession
+  body <- callBacklight client brGetBrightness
+  return $ body >>= signalBrightness
+
+matchSignal :: (Maybe Brightness -> IO ()) -> IO SignalHandler
+matchSignal cb = do
+  client <- connectSession
+  addMatch client brMatcher $ cb . pullBrightness . signalBody
+  where
+    pullBrightness = \case
+      [b] -> fromVariant b :: Maybe Brightness
+      _   -> Nothing

lib/Xmobar/Backlight.hs

@@ -1,34 +0,0 @@
-module Xmobar.Backlight where
-
-import Control.Monad
-import Control.Concurrent
-
-import Data.Int (Int32)
-
-import DBus
-import DBus.Client
-
-import DBus.Backlight
-
-import Xmobar
-
-data Backlight = Backlight (String, String)
-  deriving (Read, Show)
-
-instance Exec Backlight where
-    alias (Backlight _) = "betterbacklight"
-    start (Backlight _) cb = do
-      -- print "connecting"
-      client <- connectSession
-      _ <- addMatch client brMatcher $ \sig -> do
-        cb $ formatSignal sig
-        -- print sig
-      forever (threadDelay 5000)
-
-formatSignal :: Signal -> String
-formatSignal sig = -- show $ (map fromVariant $ signalBody sig :: [Maybe Int32])
-  case signalBody sig of
-    [] -> "N/A"
-    (x:_) -> case (fromVariant x :: Maybe Int32) of
-      Just i -> show i
-      Nothing -> "n/a"

lib/Xmobar/Plugins/IntelBacklight.hs

@@ -0,0 +1,23 @@
+{-# LANGUAGE LambdaCase #-}
+
+module Xmobar.Plugins.IntelBacklight where
+
+import Control.Concurrent
+import Control.Monad
+
+import DBus.IntelBacklight
+
+import Xmobar
+
+newtype IntelBacklight = IntelBacklight String deriving (Read, Show)
+
+instance Exec IntelBacklight where
+  alias (IntelBacklight _) = "intelbacklight"
+  start (IntelBacklight icon) cb = do
+    _ <- matchSignal $ cb . formatBrightness
+    cb . formatBrightness =<< callGetBrightness
+    forever (threadDelay 5000)
+    where
+      formatBrightness = \case
+        Just b  -> icon ++ show (b `div` 100) ++ "%"
+        Nothing -> "N/A"

lib/Xmobar/Plugins/Screensaver.hs

@@ -1,4 +1,4 @@
-module Xmobar.Screensaver where
+module Xmobar.Plugins.Screensaver where
 
 import Graphics.X11.Xlib.Display
 import Graphics.X11.XScreenSaver

my-xmonad.cabal

@@ -11,9 +11,9 @@ library
                    , Notify
                    , Shell
                    , DBus.Common
-                   , DBus.Backlight
-                   , Xmobar.Screensaver
-                   , Xmobar.Backlight
+                   , DBus.IntelBacklight
+                   , Xmobar.Plugins.Screensaver
+                   , Xmobar.Plugins.IntelBacklight
     build-depends: base
                  , X11 >= 1.9.1
                  , colour >= 2.3.5