ENH add event signals to backlight controls

This commit is contained in:
Nathan Dwarshuis 2020-03-20 15:41:13 -04:00
parent 96cbf72f97
commit 6fa14e10e6
9 changed files with 243 additions and 185 deletions

View File

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

View File

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

View File

@ -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)] }

View File

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

198
lib/DBus/IntelBacklight.hs Normal file
View File

@ -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

View File

@ -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"

View File

@ -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"

View File

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

View File

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