REF reformat everything with fourmolu
This commit is contained in:
parent
b2b0f72178
commit
adf0257533
|
@ -1,7 +1,6 @@
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
{-# LANGUAGE ScopedTypeVariables #-}
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
|
||||||
-- | Start a VirtualBox instance with a sentinel wrapper process.
|
-- | Start a VirtualBox instance with a sentinel wrapper process.
|
||||||
--
|
--
|
||||||
-- The only reason why this is needed is because I want to manage virtualboxes
|
-- The only reason why this is needed is because I want to manage virtualboxes
|
||||||
|
@ -15,21 +14,16 @@
|
||||||
-- until its PID exits. By monitoring this wrapper, the dynamic workspace only
|
-- until its PID exits. By monitoring this wrapper, the dynamic workspace only
|
||||||
-- has one process to track and will maintain the workspace throughout the
|
-- has one process to track and will maintain the workspace throughout the
|
||||||
-- lifetime of the VM.
|
-- lifetime of the VM.
|
||||||
|
|
||||||
module Main (main) where
|
module Main (main) where
|
||||||
|
|
||||||
import qualified Data.ByteString.Lazy.UTF8 as BU
|
import qualified Data.ByteString.Lazy.UTF8 as BU
|
||||||
|
import RIO
|
||||||
import RIO
|
import RIO.Process
|
||||||
import RIO.Process
|
import qualified RIO.Text as T
|
||||||
import qualified RIO.Text as T
|
import System.Environment
|
||||||
|
import Text.XML.Light
|
||||||
import Text.XML.Light
|
import XMonad.Internal.Concurrent.VirtualBox
|
||||||
|
import XMonad.Internal.IO
|
||||||
import System.Environment
|
|
||||||
|
|
||||||
import XMonad.Internal.Concurrent.VirtualBox
|
|
||||||
import XMonad.Internal.IO
|
|
||||||
|
|
||||||
main :: IO ()
|
main :: IO ()
|
||||||
main = do
|
main = do
|
||||||
|
@ -48,7 +42,6 @@ runAndWait [n] = do
|
||||||
p <- vmPID i
|
p <- vmPID i
|
||||||
liftIO $ mapM_ waitUntilExit p
|
liftIO $ mapM_ waitUntilExit p
|
||||||
err = logError "Could not get machine ID"
|
err = logError "Could not get machine ID"
|
||||||
|
|
||||||
runAndWait _ = liftIO $ putStrLn "Usage: vbox-start VBOXNAME"
|
runAndWait _ = liftIO $ putStrLn "Usage: vbox-start VBOXNAME"
|
||||||
|
|
||||||
vmLaunch :: T.Text -> RIO SimpleApp ()
|
vmLaunch :: T.Text -> RIO SimpleApp ()
|
||||||
|
@ -56,25 +49,28 @@ vmLaunch i = do
|
||||||
rc <- proc "VBoxManage" ["startvm", T.unpack i] runProcess
|
rc <- proc "VBoxManage" ["startvm", T.unpack i] runProcess
|
||||||
case rc of
|
case rc of
|
||||||
ExitSuccess -> return ()
|
ExitSuccess -> return ()
|
||||||
_ -> logError $ "Failed to start VM: "
|
_ ->
|
||||||
<> displayBytesUtf8 (encodeUtf8 i)
|
logError $
|
||||||
|
"Failed to start VM: "
|
||||||
|
<> displayBytesUtf8 (encodeUtf8 i)
|
||||||
|
|
||||||
vmPID :: T.Text -> RIO SimpleApp (Maybe Int)
|
vmPID :: T.Text -> RIO SimpleApp (Maybe Int)
|
||||||
vmPID vid = do
|
vmPID vid = do
|
||||||
(rc, out) <- proc "pgrep" ["-f", "VirtualBoxVM.*" ++ T.unpack vid] readProcessStdout
|
(rc, out) <- proc "pgrep" ["-f", "VirtualBoxVM.*" ++ T.unpack vid] readProcessStdout
|
||||||
return $ case rc of
|
return $ case rc of
|
||||||
ExitSuccess -> readMaybe $ BU.toString out
|
ExitSuccess -> readMaybe $ BU.toString out
|
||||||
_ -> Nothing
|
_ -> Nothing
|
||||||
|
|
||||||
vmMachineID :: FilePath -> RIO SimpleApp (Maybe T.Text)
|
vmMachineID :: FilePath -> RIO SimpleApp (Maybe T.Text)
|
||||||
vmMachineID iPath = do
|
vmMachineID iPath = do
|
||||||
res <- tryAny $ readFileUtf8 iPath
|
res <- tryAny $ readFileUtf8 iPath
|
||||||
case res of
|
case res of
|
||||||
Right contents -> return $ findMachineID contents
|
Right contents -> return $ findMachineID contents
|
||||||
Left e -> logError (displayShow e) >> return Nothing
|
Left e -> logError (displayShow e) >> return Nothing
|
||||||
where
|
where
|
||||||
findMachineID c = T.stripSuffix "}"
|
findMachineID c =
|
||||||
=<< T.stripPrefix "{"
|
T.stripSuffix "}"
|
||||||
=<< (fmap T.pack . findAttr (blank_name { qName = "uuid" }))
|
=<< T.stripPrefix "{"
|
||||||
=<< (\e -> findChild (qual e "Machine") e)
|
=<< (fmap T.pack . findAttr (blank_name {qName = "uuid"}))
|
||||||
=<< parseXMLDoc c
|
=<< (\e -> findChild (qual e "Machine") e)
|
||||||
|
=<< parseXMLDoc c
|
||||||
|
|
562
bin/xmobar.hs
562
bin/xmobar.hs
|
@ -1,8 +1,5 @@
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
module Main (main) where
|
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
|
||||||
-- | Xmobar binary
|
-- | Xmobar binary
|
||||||
--
|
--
|
||||||
-- Features:
|
-- Features:
|
||||||
|
@ -12,52 +9,47 @@ module Main (main) where
|
||||||
-- * Some custom plugins (imported below)
|
-- * Some custom plugins (imported below)
|
||||||
-- * Theme integration with xmonad (shared module imported below)
|
-- * Theme integration with xmonad (shared module imported below)
|
||||||
-- * A custom Locks plugin from my own forked repo
|
-- * A custom Locks plugin from my own forked repo
|
||||||
|
module Main (main) where
|
||||||
|
|
||||||
import Control.Monad
|
import Control.Monad
|
||||||
|
import Data.Internal.DBus
|
||||||
import Data.Internal.DBus
|
import Data.Internal.Dependency
|
||||||
import Data.Internal.Dependency
|
import Data.List
|
||||||
import Data.List
|
import Data.Maybe
|
||||||
import Data.Maybe
|
import RIO hiding (hFlush)
|
||||||
|
import qualified RIO.ByteString.Lazy as BL
|
||||||
import RIO hiding (hFlush)
|
import RIO.Process
|
||||||
import qualified RIO.ByteString.Lazy as BL
|
import qualified RIO.Text as T
|
||||||
import RIO.Process
|
import System.Environment
|
||||||
import qualified RIO.Text as T
|
import System.IO
|
||||||
|
import XMonad.Core hiding (config)
|
||||||
import System.Environment
|
import XMonad.Internal.Command.Desktop
|
||||||
import System.IO
|
import XMonad.Internal.Command.Power
|
||||||
|
import XMonad.Internal.DBus.Brightness.ClevoKeyboard
|
||||||
import Xmobar.Plugins.Bluetooth
|
import XMonad.Internal.DBus.Brightness.IntelBacklight
|
||||||
import Xmobar.Plugins.ClevoKeyboard
|
import XMonad.Internal.DBus.Control
|
||||||
import Xmobar.Plugins.Device
|
import XMonad.Internal.DBus.Screensaver (ssSignalDep)
|
||||||
import Xmobar.Plugins.IntelBacklight
|
import qualified XMonad.Internal.Theme as XT
|
||||||
import Xmobar.Plugins.Screensaver
|
import Xmobar hiding
|
||||||
import Xmobar.Plugins.VPN
|
( iconOffset
|
||||||
|
, run
|
||||||
import XMonad.Core hiding (config)
|
)
|
||||||
import XMonad.Internal.Command.Desktop
|
import Xmobar.Plugins.Bluetooth
|
||||||
import XMonad.Internal.Command.Power
|
import Xmobar.Plugins.ClevoKeyboard
|
||||||
import XMonad.Internal.DBus.Brightness.ClevoKeyboard
|
import Xmobar.Plugins.Common
|
||||||
import XMonad.Internal.DBus.Brightness.IntelBacklight
|
import Xmobar.Plugins.Device
|
||||||
import XMonad.Internal.DBus.Control
|
import Xmobar.Plugins.IntelBacklight
|
||||||
import XMonad.Internal.DBus.Screensaver (ssSignalDep)
|
import Xmobar.Plugins.Screensaver
|
||||||
import qualified XMonad.Internal.Theme as XT
|
import Xmobar.Plugins.VPN
|
||||||
import Xmobar hiding
|
|
||||||
( iconOffset
|
|
||||||
, run
|
|
||||||
)
|
|
||||||
import Xmobar.Plugins.Common
|
|
||||||
|
|
||||||
|
|
||||||
main :: IO ()
|
main :: IO ()
|
||||||
main = getArgs >>= parse
|
main = getArgs >>= parse
|
||||||
|
|
||||||
parse :: [String] -> IO ()
|
parse :: [String] -> IO ()
|
||||||
parse [] = run
|
parse [] = run
|
||||||
parse ["--deps"] = withCache printDeps
|
parse ["--deps"] = withCache printDeps
|
||||||
parse ["--test"] = void $ withCache . evalConfig =<< connectDBus
|
parse ["--test"] = void $ withCache . evalConfig =<< connectDBus
|
||||||
parse _ = usage
|
parse _ = usage
|
||||||
|
|
||||||
run :: IO ()
|
run :: IO ()
|
||||||
run = do
|
run = do
|
||||||
|
@ -84,13 +76,16 @@ printDeps = do
|
||||||
io $ disconnectDBus db
|
io $ disconnectDBus db
|
||||||
|
|
||||||
usage :: IO ()
|
usage :: IO ()
|
||||||
usage = putStrLn $ intercalate "\n"
|
usage =
|
||||||
[ "xmobar: run greatest taskbar"
|
putStrLn $
|
||||||
, "xmobar --deps: print dependencies"
|
intercalate
|
||||||
]
|
"\n"
|
||||||
|
[ "xmobar: run greatest taskbar"
|
||||||
|
, "xmobar --deps: print dependencies"
|
||||||
|
]
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | toplevel configuration
|
-- toplevel configuration
|
||||||
|
|
||||||
-- | The text font family
|
-- | The text font family
|
||||||
textFont :: Always XT.FontBuilder
|
textFont :: Always XT.FontBuilder
|
||||||
|
@ -102,88 +97,93 @@ textFontOffset = 16
|
||||||
|
|
||||||
-- | Attributes for the bar font (size, weight, etc)
|
-- | Attributes for the bar font (size, weight, etc)
|
||||||
textFontData :: XT.FontData
|
textFontData :: XT.FontData
|
||||||
textFontData = XT.defFontData { XT.weight = Just XT.Bold, XT.size = Just 11 }
|
textFontData = XT.defFontData {XT.weight = Just XT.Bold, XT.size = Just 11}
|
||||||
|
|
||||||
-- | The icon font family
|
-- | The icon font family
|
||||||
iconFont :: Sometimes XT.FontBuilder
|
iconFont :: Sometimes XT.FontBuilder
|
||||||
iconFont = fontSometimes "XMobar Icon Font" "Symbols Nerd Font"
|
iconFont =
|
||||||
[Package Official "ttf-nerd-fonts-symbols-2048-em"]
|
fontSometimes
|
||||||
|
"XMobar Icon Font"
|
||||||
|
"Symbols Nerd Font"
|
||||||
|
[Package Official "ttf-nerd-fonts-symbols-2048-em"]
|
||||||
|
|
||||||
-- | Offsets for the icons in the bar (relative to the text offset)
|
-- | Offsets for the icons in the bar (relative to the text offset)
|
||||||
iconOffset :: BarFont -> Int
|
iconOffset :: BarFont -> Int
|
||||||
iconOffset IconSmall = 0
|
iconOffset IconSmall = 0
|
||||||
iconOffset IconMedium = 1
|
iconOffset IconMedium = 1
|
||||||
iconOffset IconLarge = 1
|
iconOffset IconLarge = 1
|
||||||
iconOffset IconXLarge = 2
|
iconOffset IconXLarge = 2
|
||||||
|
|
||||||
-- | Sizes (in pixels) for the icon fonts
|
-- | Sizes (in pixels) for the icon fonts
|
||||||
iconSize :: BarFont -> Int
|
iconSize :: BarFont -> Int
|
||||||
iconSize IconSmall = 13
|
iconSize IconSmall = 13
|
||||||
iconSize IconMedium = 15
|
iconSize IconMedium = 15
|
||||||
iconSize IconLarge = 18
|
iconSize IconLarge = 18
|
||||||
iconSize IconXLarge = 20
|
iconSize IconXLarge = 20
|
||||||
|
|
||||||
-- | Attributes for icon fonts
|
-- | Attributes for icon fonts
|
||||||
iconFontData :: Int -> XT.FontData
|
iconFontData :: Int -> XT.FontData
|
||||||
iconFontData s = XT.defFontData { XT.pixelsize = Just s, XT.size = Nothing }
|
iconFontData s = XT.defFontData {XT.pixelsize = Just s, XT.size = Nothing}
|
||||||
|
|
||||||
-- | Global configuration
|
-- | Global configuration
|
||||||
-- Note that the 'font' and 'textOffset' are assumed to pertain to one (and
|
-- Note that the 'font' and 'textOffset' are assumed to pertain to one (and
|
||||||
-- only one) text font, and all other fonts are icon fonts. If this assumption
|
-- only one) text font, and all other fonts are icon fonts. If this assumption
|
||||||
-- changes the code will need to change significantly
|
-- changes the code will need to change significantly
|
||||||
config :: T.Text -> [T.Text] -> [Int] -> BarRegions -> FilePath -> Config
|
config :: T.Text -> [T.Text] -> [Int] -> BarRegions -> FilePath -> Config
|
||||||
config bf ifs ios br confDir = defaultConfig
|
config bf ifs ios br confDir =
|
||||||
{ font = T.unpack bf
|
defaultConfig
|
||||||
, additionalFonts = fmap T.unpack ifs
|
{ font = T.unpack bf
|
||||||
, textOffset = textFontOffset
|
, additionalFonts = fmap T.unpack ifs
|
||||||
, textOffsets = ios
|
, textOffset = textFontOffset
|
||||||
, bgColor = T.unpack XT.bgColor
|
, textOffsets = ios
|
||||||
, fgColor = T.unpack XT.fgColor
|
, bgColor = T.unpack XT.bgColor
|
||||||
, position = BottomSize C 100 24
|
, fgColor = T.unpack XT.fgColor
|
||||||
, border = NoBorder
|
, position = BottomSize C 100 24
|
||||||
, borderColor = T.unpack XT.bordersColor
|
, border = NoBorder
|
||||||
|
, borderColor = T.unpack XT.bordersColor
|
||||||
, sepChar = T.unpack pSep
|
, sepChar = T.unpack pSep
|
||||||
, alignSep = [lSep, rSep]
|
, alignSep = [lSep, rSep]
|
||||||
, template = T.unpack $ fmtRegions br
|
, template = T.unpack $ fmtRegions br
|
||||||
|
, lowerOnStart = False
|
||||||
, lowerOnStart = False
|
, hideOnStart = False
|
||||||
, hideOnStart = False
|
, allDesktops = True
|
||||||
, allDesktops = True
|
, overrideRedirect = True
|
||||||
, overrideRedirect = True
|
, pickBroadest = False
|
||||||
, pickBroadest = False
|
, persistent = True
|
||||||
, persistent = True
|
, -- store the icons with the xmonad/xmobar stack project
|
||||||
-- store the icons with the xmonad/xmobar stack project
|
iconRoot = confDir ++ "/icons"
|
||||||
, iconRoot = confDir ++ "/icons"
|
, commands = csRunnable <$> concatRegions br
|
||||||
|
}
|
||||||
, commands = csRunnable <$> concatRegions br
|
|
||||||
}
|
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | plugin features
|
-- plugin features
|
||||||
--
|
--
|
||||||
-- some commands depend on the presence of interfaces that can only be
|
-- some commands depend on the presence of interfaces that can only be
|
||||||
-- determined at runtime; define these checks here
|
-- determined at runtime; define these checks here
|
||||||
|
|
||||||
getAllCommands :: [Maybe CmdSpec] -> BarRegions
|
getAllCommands :: [Maybe CmdSpec] -> BarRegions
|
||||||
getAllCommands right = BarRegions
|
getAllCommands right =
|
||||||
{ brLeft = [ CmdSpec
|
BarRegions
|
||||||
{ csAlias = "UnsafeStdinReader"
|
{ brLeft =
|
||||||
, csRunnable = Run UnsafeStdinReader
|
[ CmdSpec
|
||||||
}
|
{ csAlias = "UnsafeStdinReader"
|
||||||
]
|
, csRunnable = Run UnsafeStdinReader
|
||||||
, brCenter = []
|
}
|
||||||
, brRight = catMaybes right
|
]
|
||||||
}
|
, brCenter = []
|
||||||
|
, brRight = catMaybes right
|
||||||
|
}
|
||||||
|
|
||||||
rightPlugins :: DBusState -> FIO [Maybe CmdSpec]
|
rightPlugins :: DBusState -> FIO [Maybe CmdSpec]
|
||||||
rightPlugins db = mapM evalFeature $ allFeatures db
|
rightPlugins db =
|
||||||
++ [always' "date indicator" dateCmd]
|
mapM evalFeature $
|
||||||
|
allFeatures db
|
||||||
|
++ [always' "date indicator" dateCmd]
|
||||||
where
|
where
|
||||||
always' n = Right . Always n . Always_ . FallbackAlone
|
always' n = Right . Always n . Always_ . FallbackAlone
|
||||||
|
|
||||||
allFeatures :: DBusState -> [Feature CmdSpec]
|
allFeatures :: DBusState -> [Feature CmdSpec]
|
||||||
allFeatures DBusState { dbSesClient = ses, dbSysClient = sys } =
|
allFeatures DBusState {dbSesClient = ses, dbSysClient = sys} =
|
||||||
[ Left getWireless
|
[ Left getWireless
|
||||||
, Left $ getEthernet sys
|
, Left $ getEthernet sys
|
||||||
, Left $ getVPN sys
|
, Left $ getVPN sys
|
||||||
|
@ -200,8 +200,11 @@ type BarFeature = Sometimes CmdSpec
|
||||||
|
|
||||||
-- TODO what if I don't have a wireless card?
|
-- TODO what if I don't have a wireless card?
|
||||||
getWireless :: BarFeature
|
getWireless :: BarFeature
|
||||||
getWireless = Sometimes "wireless status indicator" xpfWireless
|
getWireless =
|
||||||
[Subfeature (IORoot wirelessCmd $ Only readWireless) "sysfs path"]
|
Sometimes
|
||||||
|
"wireless status indicator"
|
||||||
|
xpfWireless
|
||||||
|
[Subfeature (IORoot wirelessCmd $ Only readWireless) "sysfs path"]
|
||||||
|
|
||||||
getEthernet :: Maybe SysClient -> BarFeature
|
getEthernet :: Maybe SysClient -> BarFeature
|
||||||
getEthernet cl = iconDBus "ethernet status indicator" xpfEthernet root tree
|
getEthernet cl = iconDBus "ethernet status indicator" xpfEthernet root tree
|
||||||
|
@ -213,32 +216,49 @@ getBattery :: BarFeature
|
||||||
getBattery = iconIO_ "battery level indicator" xpfBattery root tree
|
getBattery = iconIO_ "battery level indicator" xpfBattery root tree
|
||||||
where
|
where
|
||||||
root useIcon = IORoot_ (batteryCmd useIcon)
|
root useIcon = IORoot_ (batteryCmd useIcon)
|
||||||
tree = Only_ $ IOTest_ "Test if battery is present" []
|
tree =
|
||||||
$ io $ fmap (Msg LevelError) <$> hasBattery
|
Only_ $
|
||||||
|
IOTest_ "Test if battery is present" [] $
|
||||||
|
io $
|
||||||
|
fmap (Msg LevelError) <$> hasBattery
|
||||||
|
|
||||||
getVPN :: Maybe SysClient -> BarFeature
|
getVPN :: Maybe SysClient -> BarFeature
|
||||||
getVPN cl = iconDBus_ "VPN status indicator" xpfVPN root $ toAnd_ vpnDep test
|
getVPN cl = iconDBus_ "VPN status indicator" xpfVPN root $ toAnd_ vpnDep test
|
||||||
where
|
where
|
||||||
root useIcon tree = DBusRoot_ (const $ vpnCmd useIcon) tree cl
|
root useIcon tree = DBusRoot_ (const $ vpnCmd useIcon) tree cl
|
||||||
test = DBusIO $ IOTest_ "Use nmcli to test if VPN is present"
|
test =
|
||||||
networkManagerPkgs vpnPresent
|
DBusIO $
|
||||||
|
IOTest_
|
||||||
|
"Use nmcli to test if VPN is present"
|
||||||
|
networkManagerPkgs
|
||||||
|
vpnPresent
|
||||||
|
|
||||||
getBt :: Maybe SysClient -> BarFeature
|
getBt :: Maybe SysClient -> BarFeature
|
||||||
getBt = xmobarDBus "bluetooth status indicator" xpfBluetooth btDep btCmd
|
getBt = xmobarDBus "bluetooth status indicator" xpfBluetooth btDep btCmd
|
||||||
|
|
||||||
getAlsa :: BarFeature
|
getAlsa :: BarFeature
|
||||||
getAlsa = iconIO_ "volume level indicator" (const True) root
|
getAlsa =
|
||||||
$ Only_ $ sysExe [Package Official "alsa-utils"] "alsactl"
|
iconIO_ "volume level indicator" (const True) root $
|
||||||
|
Only_ $
|
||||||
|
sysExe [Package Official "alsa-utils"] "alsactl"
|
||||||
where
|
where
|
||||||
root useIcon = IORoot_ (alsaCmd useIcon)
|
root useIcon = IORoot_ (alsaCmd useIcon)
|
||||||
|
|
||||||
getBl :: Maybe SesClient -> BarFeature
|
getBl :: Maybe SesClient -> BarFeature
|
||||||
getBl = xmobarDBus "Intel backlight indicator" xpfIntelBacklight
|
getBl =
|
||||||
intelBacklightSignalDep blCmd
|
xmobarDBus
|
||||||
|
"Intel backlight indicator"
|
||||||
|
xpfIntelBacklight
|
||||||
|
intelBacklightSignalDep
|
||||||
|
blCmd
|
||||||
|
|
||||||
getCk :: Maybe SesClient -> BarFeature
|
getCk :: Maybe SesClient -> BarFeature
|
||||||
getCk = xmobarDBus "Clevo keyboard indicator" xpfClevoBacklight
|
getCk =
|
||||||
clevoKeyboardSignalDep ckCmd
|
xmobarDBus
|
||||||
|
"Clevo keyboard indicator"
|
||||||
|
xpfClevoBacklight
|
||||||
|
clevoKeyboardSignalDep
|
||||||
|
ckCmd
|
||||||
|
|
||||||
getSs :: Maybe SesClient -> BarFeature
|
getSs :: Maybe SesClient -> BarFeature
|
||||||
getSs = xmobarDBus "screensaver indicator" (const True) ssSignalDep ssCmd
|
getSs = xmobarDBus "screensaver indicator" (const True) ssSignalDep ssCmd
|
||||||
|
@ -249,158 +269,232 @@ getLock = always1 "lock indicator" "icon indicator" root $ lockCmd fontifyAlt
|
||||||
root = IORoot_ (lockCmd fontifyIcon) $ Only_ iconDependency
|
root = IORoot_ (lockCmd fontifyIcon) $ Only_ iconDependency
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | bar feature constructors
|
-- bar feature constructors
|
||||||
|
|
||||||
xmobarDBus :: SafeClient c => T.Text -> XPQuery -> DBusDependency_ c
|
xmobarDBus
|
||||||
-> (Fontifier -> CmdSpec) -> Maybe c -> BarFeature
|
:: SafeClient c
|
||||||
|
=> T.Text
|
||||||
|
-> XPQuery
|
||||||
|
-> DBusDependency_ c
|
||||||
|
-> (Fontifier -> CmdSpec)
|
||||||
|
-> Maybe c
|
||||||
|
-> BarFeature
|
||||||
xmobarDBus n q dep cmd cl = iconDBus_ n q root (Only_ dep)
|
xmobarDBus n q dep cmd cl = iconDBus_ n q root (Only_ dep)
|
||||||
where
|
where
|
||||||
root useIcon tree = DBusRoot_ (const $ cmd useIcon) tree cl
|
root useIcon tree = DBusRoot_ (const $ cmd useIcon) tree cl
|
||||||
|
|
||||||
iconIO_ :: T.Text -> XPQuery -> (Fontifier -> IOTree_ -> Root CmdSpec)
|
iconIO_
|
||||||
-> IOTree_ -> BarFeature
|
:: T.Text
|
||||||
|
-> XPQuery
|
||||||
|
-> (Fontifier -> IOTree_ -> Root CmdSpec)
|
||||||
|
-> IOTree_
|
||||||
|
-> BarFeature
|
||||||
iconIO_ = iconSometimes' And_ Only_
|
iconIO_ = iconSometimes' And_ Only_
|
||||||
|
|
||||||
iconDBus :: SafeClient c => T.Text -> XPQuery
|
iconDBus
|
||||||
-> (Fontifier -> DBusTree c p -> Root CmdSpec) -> DBusTree c p -> BarFeature
|
:: SafeClient c
|
||||||
|
=> T.Text
|
||||||
|
-> XPQuery
|
||||||
|
-> (Fontifier -> DBusTree c p -> Root CmdSpec)
|
||||||
|
-> DBusTree c p
|
||||||
|
-> BarFeature
|
||||||
iconDBus = iconSometimes' And1 $ Only_ . DBusIO
|
iconDBus = iconSometimes' And1 $ Only_ . DBusIO
|
||||||
|
|
||||||
iconDBus_ :: SafeClient c => T.Text -> XPQuery
|
iconDBus_
|
||||||
-> (Fontifier -> DBusTree_ c -> Root CmdSpec) -> DBusTree_ c -> BarFeature
|
:: SafeClient c
|
||||||
|
=> T.Text
|
||||||
|
-> XPQuery
|
||||||
|
-> (Fontifier -> DBusTree_ c -> Root CmdSpec)
|
||||||
|
-> DBusTree_ c
|
||||||
|
-> BarFeature
|
||||||
iconDBus_ = iconSometimes' And_ $ Only_ . DBusIO
|
iconDBus_ = iconSometimes' And_ $ Only_ . DBusIO
|
||||||
|
|
||||||
iconSometimes' :: (t -> t_ -> t) -> (IODependency_ -> t_) -> T.Text -> XPQuery
|
iconSometimes'
|
||||||
-> (Fontifier -> t -> Root CmdSpec) -> t -> BarFeature
|
:: (t -> t_ -> t)
|
||||||
iconSometimes' c d n q r t = Sometimes n q
|
-> (IODependency_ -> t_)
|
||||||
[ Subfeature icon "icon indicator"
|
-> T.Text
|
||||||
, Subfeature text "text indicator"
|
-> XPQuery
|
||||||
]
|
-> (Fontifier -> t -> Root CmdSpec)
|
||||||
|
-> t
|
||||||
|
-> BarFeature
|
||||||
|
iconSometimes' c d n q r t =
|
||||||
|
Sometimes
|
||||||
|
n
|
||||||
|
q
|
||||||
|
[ Subfeature icon "icon indicator"
|
||||||
|
, Subfeature text "text indicator"
|
||||||
|
]
|
||||||
where
|
where
|
||||||
icon = r fontifyIcon $ c t $ d iconDependency
|
icon = r fontifyIcon $ c t $ d iconDependency
|
||||||
text = r fontifyAlt t
|
text = r fontifyAlt t
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | command specifications
|
-- command specifications
|
||||||
|
|
||||||
data BarRegions = BarRegions
|
data BarRegions = BarRegions
|
||||||
{ brLeft :: [CmdSpec]
|
{ brLeft :: [CmdSpec]
|
||||||
, brCenter :: [CmdSpec]
|
, brCenter :: [CmdSpec]
|
||||||
, brRight :: [CmdSpec]
|
, brRight :: [CmdSpec]
|
||||||
} deriving Show
|
}
|
||||||
|
deriving (Show)
|
||||||
|
|
||||||
data CmdSpec = CmdSpec
|
data CmdSpec = CmdSpec
|
||||||
{ csAlias :: T.Text
|
{ csAlias :: T.Text
|
||||||
, csRunnable :: Runnable
|
, csRunnable :: Runnable
|
||||||
} deriving Show
|
}
|
||||||
|
deriving (Show)
|
||||||
|
|
||||||
concatRegions :: BarRegions -> [CmdSpec]
|
concatRegions :: BarRegions -> [CmdSpec]
|
||||||
concatRegions (BarRegions l c r) = l ++ c ++ r
|
concatRegions (BarRegions l c r) = l ++ c ++ r
|
||||||
|
|
||||||
wirelessCmd :: T.Text -> CmdSpec
|
wirelessCmd :: T.Text -> CmdSpec
|
||||||
wirelessCmd iface = CmdSpec
|
wirelessCmd iface =
|
||||||
{ csAlias = T.append iface "wi"
|
CmdSpec
|
||||||
, csRunnable = Run $ Wireless (T.unpack iface) args 5
|
{ csAlias = T.append iface "wi"
|
||||||
}
|
, csRunnable = Run $ Wireless (T.unpack iface) args 5
|
||||||
|
}
|
||||||
where
|
where
|
||||||
args = fmap T.unpack
|
args =
|
||||||
[ "-t", "<qualityipat><essid>"
|
fmap
|
||||||
, "--"
|
T.unpack
|
||||||
, "--quality-icon-pattern", "<icon=wifi_%%.xpm/>"
|
[ "-t"
|
||||||
]
|
, "<qualityipat><essid>"
|
||||||
|
, "--"
|
||||||
|
, "--quality-icon-pattern"
|
||||||
|
, "<icon=wifi_%%.xpm/>"
|
||||||
|
]
|
||||||
|
|
||||||
ethernetCmd :: Fontifier -> T.Text -> CmdSpec
|
ethernetCmd :: Fontifier -> T.Text -> CmdSpec
|
||||||
ethernetCmd fontify iface = CmdSpec
|
ethernetCmd fontify iface =
|
||||||
{ csAlias = iface
|
CmdSpec
|
||||||
, csRunnable = Run
|
{ csAlias = iface
|
||||||
$ Device (iface, fontify IconMedium "\xf0e8" "ETH", colors)
|
, csRunnable =
|
||||||
}
|
Run $
|
||||||
|
Device (iface, fontify IconMedium "\xf0e8" "ETH", colors)
|
||||||
|
}
|
||||||
|
|
||||||
batteryCmd :: Fontifier -> CmdSpec
|
batteryCmd :: Fontifier -> CmdSpec
|
||||||
batteryCmd fontify = CmdSpec
|
batteryCmd fontify =
|
||||||
{ csAlias = "battery"
|
CmdSpec
|
||||||
, csRunnable = Run $ Battery args 50
|
{ csAlias = "battery"
|
||||||
}
|
, csRunnable = Run $ Battery args 50
|
||||||
|
}
|
||||||
where
|
where
|
||||||
fontify' = fontify IconSmall
|
fontify' = fontify IconSmall
|
||||||
args = fmap T.unpack
|
args =
|
||||||
[ "--template", "<acstatus><left>"
|
fmap
|
||||||
, "--Low", "10"
|
T.unpack
|
||||||
, "--High", "80"
|
[ "--template"
|
||||||
, "--low", "red"
|
, "<acstatus><left>"
|
||||||
, "--normal", XT.fgColor
|
, "--Low"
|
||||||
, "--high", XT.fgColor
|
, "10"
|
||||||
, "--"
|
, "--High"
|
||||||
, "-P"
|
, "80"
|
||||||
, "-o" , fontify' "\xf0e7" "BAT"
|
, "--low"
|
||||||
, "-O" , fontify' "\xf1e6" "AC"
|
, "red"
|
||||||
, "-i" , fontify' "\xf1e6" "AC"
|
, "--normal"
|
||||||
]
|
, XT.fgColor
|
||||||
|
, "--high"
|
||||||
|
, XT.fgColor
|
||||||
|
, "--"
|
||||||
|
, "-P"
|
||||||
|
, "-o"
|
||||||
|
, fontify' "\xf0e7" "BAT"
|
||||||
|
, "-O"
|
||||||
|
, fontify' "\xf1e6" "AC"
|
||||||
|
, "-i"
|
||||||
|
, fontify' "\xf1e6" "AC"
|
||||||
|
]
|
||||||
|
|
||||||
vpnCmd :: Fontifier -> CmdSpec
|
vpnCmd :: Fontifier -> CmdSpec
|
||||||
vpnCmd fontify = CmdSpec
|
vpnCmd fontify =
|
||||||
{ csAlias = vpnAlias
|
CmdSpec
|
||||||
, csRunnable = Run $ VPN (fontify IconMedium "\xf023" "VPN", colors)
|
{ csAlias = vpnAlias
|
||||||
}
|
, csRunnable = Run $ VPN (fontify IconMedium "\xf023" "VPN", colors)
|
||||||
|
}
|
||||||
|
|
||||||
btCmd :: Fontifier -> CmdSpec
|
btCmd :: Fontifier -> CmdSpec
|
||||||
btCmd fontify = CmdSpec
|
btCmd fontify =
|
||||||
{ csAlias = btAlias
|
CmdSpec
|
||||||
, csRunnable = Run
|
{ csAlias = btAlias
|
||||||
$ Bluetooth (fontify' "\xf5b0" "+", fontify' "\xf5ae" "-") colors
|
, csRunnable =
|
||||||
}
|
Run $
|
||||||
|
Bluetooth (fontify' "\xf5b0" "+", fontify' "\xf5ae" "-") colors
|
||||||
|
}
|
||||||
where
|
where
|
||||||
fontify' i = fontify IconLarge i . T.append "BT"
|
fontify' i = fontify IconLarge i . T.append "BT"
|
||||||
|
|
||||||
alsaCmd :: Fontifier -> CmdSpec
|
alsaCmd :: Fontifier -> CmdSpec
|
||||||
alsaCmd fontify = CmdSpec
|
alsaCmd fontify =
|
||||||
{ csAlias = "alsa:default:Master"
|
CmdSpec
|
||||||
, csRunnable = Run
|
{ csAlias = "alsa:default:Master"
|
||||||
$ Alsa "default" "Master"
|
, csRunnable =
|
||||||
$ fmap T.unpack
|
Run $
|
||||||
[ "-t", "<status><volume>%"
|
Alsa "default" "Master" $
|
||||||
, "--"
|
fmap
|
||||||
, "-O", fontify' "\xf028" "+"
|
T.unpack
|
||||||
, "-o", T.append (fontify' "\xf026" "-") " "
|
[ "-t"
|
||||||
, "-c", XT.fgColor
|
, "<status><volume>%"
|
||||||
, "-C", XT.fgColor
|
, "--"
|
||||||
]
|
, "-O"
|
||||||
}
|
, fontify' "\xf028" "+"
|
||||||
|
, "-o"
|
||||||
|
, T.append (fontify' "\xf026" "-") " "
|
||||||
|
, "-c"
|
||||||
|
, XT.fgColor
|
||||||
|
, "-C"
|
||||||
|
, XT.fgColor
|
||||||
|
]
|
||||||
|
}
|
||||||
where
|
where
|
||||||
fontify' i = fontify IconSmall i . T.append "VOL"
|
fontify' i = fontify IconSmall i . T.append "VOL"
|
||||||
|
|
||||||
blCmd :: Fontifier -> CmdSpec
|
blCmd :: Fontifier -> CmdSpec
|
||||||
blCmd fontify = CmdSpec
|
blCmd fontify =
|
||||||
{ csAlias = blAlias
|
CmdSpec
|
||||||
, csRunnable = Run $ IntelBacklight $ fontify IconSmall "\xf185" "BL: "
|
{ csAlias = blAlias
|
||||||
}
|
, csRunnable = Run $ IntelBacklight $ fontify IconSmall "\xf185" "BL: "
|
||||||
|
}
|
||||||
|
|
||||||
ckCmd :: Fontifier -> CmdSpec
|
ckCmd :: Fontifier -> CmdSpec
|
||||||
ckCmd fontify = CmdSpec
|
ckCmd fontify =
|
||||||
{ csAlias = ckAlias
|
CmdSpec
|
||||||
, csRunnable = Run $ ClevoKeyboard $ fontify IconSmall "\xf40b" "KB: "
|
{ csAlias = ckAlias
|
||||||
}
|
, csRunnable = Run $ ClevoKeyboard $ fontify IconSmall "\xf40b" "KB: "
|
||||||
|
}
|
||||||
|
|
||||||
ssCmd :: Fontifier -> CmdSpec
|
ssCmd :: Fontifier -> CmdSpec
|
||||||
ssCmd fontify = CmdSpec
|
ssCmd fontify =
|
||||||
{ csAlias = ssAlias
|
CmdSpec
|
||||||
, csRunnable = Run $ Screensaver (fontify IconSmall "\xf254" "SS", colors)
|
{ csAlias = ssAlias
|
||||||
}
|
, csRunnable = Run $ Screensaver (fontify IconSmall "\xf254" "SS", colors)
|
||||||
|
}
|
||||||
|
|
||||||
lockCmd :: Fontifier -> CmdSpec
|
lockCmd :: Fontifier -> CmdSpec
|
||||||
lockCmd fontify = CmdSpec
|
lockCmd fontify =
|
||||||
{ csAlias = "locks"
|
CmdSpec
|
||||||
, csRunnable = Run
|
{ csAlias = "locks"
|
||||||
$ Locks
|
, csRunnable =
|
||||||
$ fmap T.unpack
|
Run $
|
||||||
[ "-N", numIcon
|
Locks $
|
||||||
, "-n", disabledColor numIcon
|
fmap
|
||||||
, "-C", capIcon
|
T.unpack
|
||||||
, "-c", disabledColor capIcon
|
[ "-N"
|
||||||
, "-s", ""
|
, numIcon
|
||||||
, "-S", ""
|
, "-n"
|
||||||
, "-d", " "
|
, disabledColor numIcon
|
||||||
]
|
, "-C"
|
||||||
}
|
, capIcon
|
||||||
|
, "-c"
|
||||||
|
, disabledColor capIcon
|
||||||
|
, "-s"
|
||||||
|
, ""
|
||||||
|
, "-S"
|
||||||
|
, ""
|
||||||
|
, "-d"
|
||||||
|
, " "
|
||||||
|
]
|
||||||
|
}
|
||||||
where
|
where
|
||||||
numIcon = fontify' "\xf8a5" "N"
|
numIcon = fontify' "\xf8a5" "N"
|
||||||
capIcon = fontify' "\xf657" "C"
|
capIcon = fontify' "\xf657" "C"
|
||||||
|
@ -408,33 +502,37 @@ lockCmd fontify = CmdSpec
|
||||||
disabledColor = xmobarFGColor XT.backdropFgColor
|
disabledColor = xmobarFGColor XT.backdropFgColor
|
||||||
|
|
||||||
dateCmd :: CmdSpec
|
dateCmd :: CmdSpec
|
||||||
dateCmd = CmdSpec
|
dateCmd =
|
||||||
{ csAlias = "date"
|
CmdSpec
|
||||||
, csRunnable = Run $ Date "%Y-%m-%d %H:%M:%S " "date" 10
|
{ csAlias = "date"
|
||||||
}
|
, csRunnable = Run $ Date "%Y-%m-%d %H:%M:%S " "date" 10
|
||||||
|
}
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | low-level testing functions
|
-- low-level testing functions
|
||||||
|
|
||||||
vpnPresent :: FIO (Maybe Msg)
|
vpnPresent :: FIO (Maybe Msg)
|
||||||
vpnPresent = do
|
vpnPresent = do
|
||||||
res <- proc "nmcli" args readProcess
|
res <- proc "nmcli" args readProcess
|
||||||
return $ case res of
|
return $ case res of
|
||||||
(ExitSuccess, out, _) | "vpn" `elem` BL.split 10 out -> Nothing
|
(ExitSuccess, out, _)
|
||||||
| otherwise -> Just $ Msg LevelError "vpn not found"
|
| "vpn" `elem` BL.split 10 out -> Nothing
|
||||||
(ExitFailure c, _, err) -> Just $ Msg LevelError
|
| otherwise -> Just $ Msg LevelError "vpn not found"
|
||||||
$ T.concat
|
(ExitFailure c, _, err) ->
|
||||||
["vpn search exited with code "
|
Just $
|
||||||
, T.pack $ show c
|
Msg LevelError $
|
||||||
, ": "
|
T.concat
|
||||||
, T.decodeUtf8With T.lenientDecode
|
[ "vpn search exited with code "
|
||||||
$ BL.toStrict err
|
, T.pack $ show c
|
||||||
]
|
, ": "
|
||||||
|
, T.decodeUtf8With T.lenientDecode $
|
||||||
|
BL.toStrict err
|
||||||
|
]
|
||||||
where
|
where
|
||||||
args = ["-c", "no", "-t", "-f", "TYPE", "c", "show"]
|
args = ["-c", "no", "-t", "-f", "TYPE", "c", "show"]
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | text font
|
-- text font
|
||||||
--
|
--
|
||||||
-- ASSUME there is only one text font for this entire configuration. This
|
-- ASSUME there is only one text font for this entire configuration. This
|
||||||
-- will correspond to the first font/offset parameters in the config record.
|
-- will correspond to the first font/offset parameters in the config record.
|
||||||
|
@ -445,17 +543,20 @@ getTextFont = do
|
||||||
return $ fb textFontData
|
return $ fb textFontData
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | icon fonts
|
-- icon fonts
|
||||||
|
|
||||||
getIconFonts :: FIO ([T.Text], [Int])
|
getIconFonts :: FIO ([T.Text], [Int])
|
||||||
getIconFonts = do
|
getIconFonts = do
|
||||||
fb <- evalSometimes iconFont
|
fb <- evalSometimes iconFont
|
||||||
return $ maybe ([], []) apply fb
|
return $ maybe ([], []) apply fb
|
||||||
where
|
where
|
||||||
apply fb = unzip $ (\i -> (iconString fb i, iconOffset i + textFontOffset))
|
apply fb =
|
||||||
<$> iconFonts
|
unzip $
|
||||||
|
(\i -> (iconString fb i, iconOffset i + textFontOffset))
|
||||||
|
<$> iconFonts
|
||||||
|
|
||||||
data BarFont = IconSmall
|
data BarFont
|
||||||
|
= IconSmall
|
||||||
| IconMedium
|
| IconMedium
|
||||||
| IconLarge
|
| IconLarge
|
||||||
| IconXLarge
|
| IconXLarge
|
||||||
|
@ -483,10 +584,10 @@ fontifyIcon :: Fontifier
|
||||||
fontifyIcon f i _ = fontifyText f i
|
fontifyIcon f i _ = fontifyText f i
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | various formatting things
|
-- various formatting things
|
||||||
|
|
||||||
colors :: Colors
|
colors :: Colors
|
||||||
colors = Colors { colorsOn = XT.fgColor, colorsOff = XT.backdropFgColor }
|
colors = Colors {colorsOn = XT.fgColor, colorsOff = XT.backdropFgColor}
|
||||||
|
|
||||||
sep :: T.Text
|
sep :: T.Text
|
||||||
sep = xmobarFGColor XT.backdropFgColor " : "
|
sep = xmobarFGColor XT.backdropFgColor " : "
|
||||||
|
@ -503,8 +604,9 @@ pSep = "%"
|
||||||
fmtSpecs :: [CmdSpec] -> T.Text
|
fmtSpecs :: [CmdSpec] -> T.Text
|
||||||
fmtSpecs = T.intercalate sep . fmap go
|
fmtSpecs = T.intercalate sep . fmap go
|
||||||
where
|
where
|
||||||
go CmdSpec { csAlias = a } = T.concat [pSep, a, pSep]
|
go CmdSpec {csAlias = a} = T.concat [pSep, a, pSep]
|
||||||
|
|
||||||
fmtRegions :: BarRegions -> T.Text
|
fmtRegions :: BarRegions -> T.Text
|
||||||
fmtRegions BarRegions { brLeft = l, brCenter = c, brRight = r } = T.concat
|
fmtRegions BarRegions {brLeft = l, brCenter = c, brRight = r} =
|
||||||
[fmtSpecs l, T.singleton lSep, fmtSpecs c, T.singleton rSep, fmtSpecs r]
|
T.concat
|
||||||
|
[fmtSpecs l, T.singleton lSep, fmtSpecs c, T.singleton rSep, fmtSpecs r]
|
||||||
|
|
887
bin/xmonad.hs
887
bin/xmonad.hs
File diff suppressed because it is too large
Load Diff
|
@ -1,7 +1,7 @@
|
||||||
indentation: 2
|
indentation: 2
|
||||||
function-arrows: trailing
|
function-arrows: leading
|
||||||
comma-style: leading
|
comma-style: leading
|
||||||
import-export-style: trailing
|
import-export-style: leading
|
||||||
indent-wheres: true
|
indent-wheres: true
|
||||||
record-brace-space: true
|
record-brace-space: true
|
||||||
newlines-between-decls: 1
|
newlines-between-decls: 1
|
||||||
|
|
|
@ -1,15 +1,15 @@
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Common internal DBus functions
|
-- Common internal DBus functions
|
||||||
|
|
||||||
module Data.Internal.DBus
|
module Data.Internal.DBus
|
||||||
( SafeClient(..)
|
( SafeClient (..)
|
||||||
, SysClient(..)
|
, SysClient (..)
|
||||||
, SesClient(..)
|
, SesClient (..)
|
||||||
, addMatchCallback
|
, addMatchCallback
|
||||||
, matchProperty
|
, matchProperty
|
||||||
, matchPropertyFull
|
, matchPropertyFull
|
||||||
, matchPropertyChanged
|
, matchPropertyChanged
|
||||||
, SignalMatch(..)
|
, SignalMatch (..)
|
||||||
, SignalCallback
|
, SignalCallback
|
||||||
, MethodBody
|
, MethodBody
|
||||||
, withSignalMatch
|
, withSignalMatch
|
||||||
|
@ -25,22 +25,20 @@ module Data.Internal.DBus
|
||||||
, addInterfaceRemovedListener
|
, addInterfaceRemovedListener
|
||||||
, fromSingletonVariant
|
, fromSingletonVariant
|
||||||
, bodyToMaybe
|
, bodyToMaybe
|
||||||
) where
|
)
|
||||||
|
where
|
||||||
|
|
||||||
import Control.Exception
|
import Control.Exception
|
||||||
import Control.Monad
|
import Control.Monad
|
||||||
|
import DBus
|
||||||
import Data.Bifunctor
|
import DBus.Client
|
||||||
import qualified Data.Map.Strict as M
|
import Data.Bifunctor
|
||||||
import Data.Maybe
|
import qualified Data.Map.Strict as M
|
||||||
|
import Data.Maybe
|
||||||
import qualified RIO.Text as T
|
import qualified RIO.Text as T
|
||||||
|
|
||||||
import DBus
|
|
||||||
import DBus.Client
|
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Type-safe client
|
-- Type-safe client
|
||||||
|
|
||||||
class SafeClient c where
|
class SafeClient c where
|
||||||
toClient :: c -> Client
|
toClient :: c -> Client
|
||||||
|
@ -82,28 +80,37 @@ getDBusClient' :: Bool -> IO (Maybe Client)
|
||||||
getDBusClient' sys = do
|
getDBusClient' sys = do
|
||||||
res <- try $ if sys then connectSystem else connectSession
|
res <- try $ if sys then connectSystem else connectSession
|
||||||
case res of
|
case res of
|
||||||
Left e -> putStrLn (clientErrorMessage e) >> return Nothing
|
Left e -> putStrLn (clientErrorMessage e) >> return Nothing
|
||||||
Right c -> return $ Just c
|
Right c -> return $ Just c
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Methods
|
-- Methods
|
||||||
|
|
||||||
type MethodBody = Either T.Text [Variant]
|
type MethodBody = Either T.Text [Variant]
|
||||||
|
|
||||||
callMethod' :: SafeClient c => c -> MethodCall -> IO MethodBody
|
callMethod' :: SafeClient c => c -> MethodCall -> IO MethodBody
|
||||||
callMethod' cl = fmap (bimap (T.pack . methodErrorMessage) methodReturnBody)
|
callMethod' cl =
|
||||||
. call (toClient cl)
|
fmap (bimap (T.pack . methodErrorMessage) methodReturnBody)
|
||||||
|
. call (toClient cl)
|
||||||
|
|
||||||
callMethod :: SafeClient c => c -> BusName -> ObjectPath -> InterfaceName
|
callMethod
|
||||||
-> MemberName -> IO MethodBody
|
:: SafeClient c
|
||||||
|
=> c
|
||||||
|
-> BusName
|
||||||
|
-> ObjectPath
|
||||||
|
-> InterfaceName
|
||||||
|
-> MemberName
|
||||||
|
-> IO MethodBody
|
||||||
callMethod client bus path iface = callMethod' client . methodCallBus bus path iface
|
callMethod client bus path iface = callMethod' client . methodCallBus bus path iface
|
||||||
|
|
||||||
methodCallBus :: BusName -> ObjectPath -> InterfaceName -> MemberName -> MethodCall
|
methodCallBus :: BusName -> ObjectPath -> InterfaceName -> MemberName -> MethodCall
|
||||||
methodCallBus b p i m = (methodCall p i m)
|
methodCallBus b p i m =
|
||||||
{ methodCallDestination = Just b }
|
(methodCall p i m)
|
||||||
|
{ methodCallDestination = Just b
|
||||||
|
}
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Bus names
|
-- Bus names
|
||||||
|
|
||||||
dbusInterface :: InterfaceName
|
dbusInterface :: InterfaceName
|
||||||
dbusInterface = interfaceName_ "org.freedesktop.DBus"
|
dbusInterface = interfaceName_ "org.freedesktop.DBus"
|
||||||
|
@ -111,12 +118,14 @@ dbusInterface = interfaceName_ "org.freedesktop.DBus"
|
||||||
callGetNameOwner :: SafeClient c => c -> BusName -> IO (Maybe BusName)
|
callGetNameOwner :: SafeClient c => c -> BusName -> IO (Maybe BusName)
|
||||||
callGetNameOwner cl name = bodyToMaybe <$> callMethod' cl mc
|
callGetNameOwner cl name = bodyToMaybe <$> callMethod' cl mc
|
||||||
where
|
where
|
||||||
mc = (methodCallBus dbusName dbusPath dbusInterface mem)
|
mc =
|
||||||
{ methodCallBody = [toVariant name] }
|
(methodCallBus dbusName dbusPath dbusInterface mem)
|
||||||
|
{ methodCallBody = [toVariant name]
|
||||||
|
}
|
||||||
mem = memberName_ "GetNameOwner"
|
mem = memberName_ "GetNameOwner"
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Variant parsing
|
-- Variant parsing
|
||||||
|
|
||||||
fromSingletonVariant :: IsVariant a => [Variant] -> Maybe a
|
fromSingletonVariant :: IsVariant a => [Variant] -> Maybe a
|
||||||
fromSingletonVariant = fromVariant <=< listToMaybe
|
fromSingletonVariant = fromVariant <=< listToMaybe
|
||||||
|
@ -125,30 +134,45 @@ bodyToMaybe :: IsVariant a => MethodBody -> Maybe a
|
||||||
bodyToMaybe = either (const Nothing) fromSingletonVariant
|
bodyToMaybe = either (const Nothing) fromSingletonVariant
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Signals
|
-- Signals
|
||||||
|
|
||||||
type SignalCallback = [Variant] -> IO ()
|
type SignalCallback = [Variant] -> IO ()
|
||||||
|
|
||||||
addMatchCallback :: SafeClient c => MatchRule -> SignalCallback -> c
|
addMatchCallback
|
||||||
|
:: SafeClient c
|
||||||
|
=> MatchRule
|
||||||
|
-> SignalCallback
|
||||||
|
-> c
|
||||||
-> IO SignalHandler
|
-> IO SignalHandler
|
||||||
addMatchCallback rule cb cl = addMatch (toClient cl) rule $ cb . signalBody
|
addMatchCallback rule cb cl = addMatch (toClient cl) rule $ cb . signalBody
|
||||||
|
|
||||||
matchSignal :: Maybe BusName -> Maybe ObjectPath -> Maybe InterfaceName
|
matchSignal
|
||||||
-> Maybe MemberName -> MatchRule
|
:: Maybe BusName
|
||||||
matchSignal b p i m = matchAny
|
-> Maybe ObjectPath
|
||||||
{ matchPath = p
|
-> Maybe InterfaceName
|
||||||
, matchSender = b
|
-> Maybe MemberName
|
||||||
, matchInterface = i
|
-> MatchRule
|
||||||
, matchMember = m
|
matchSignal b p i m =
|
||||||
}
|
matchAny
|
||||||
|
{ matchPath = p
|
||||||
|
, matchSender = b
|
||||||
|
, matchInterface = i
|
||||||
|
, matchMember = m
|
||||||
|
}
|
||||||
|
|
||||||
matchSignalFull :: SafeClient c => c -> BusName -> Maybe ObjectPath
|
matchSignalFull
|
||||||
-> Maybe InterfaceName -> Maybe MemberName -> IO (Maybe MatchRule)
|
:: SafeClient c
|
||||||
|
=> c
|
||||||
|
-> BusName
|
||||||
|
-> Maybe ObjectPath
|
||||||
|
-> Maybe InterfaceName
|
||||||
|
-> Maybe MemberName
|
||||||
|
-> IO (Maybe MatchRule)
|
||||||
matchSignalFull client b p i m =
|
matchSignalFull client b p i m =
|
||||||
fmap (\o -> matchSignal (Just o) p i m) <$> callGetNameOwner client b
|
fmap (\o -> matchSignal (Just o) p i m) <$> callGetNameOwner client b
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Properties
|
-- Properties
|
||||||
|
|
||||||
propertyInterface :: InterfaceName
|
propertyInterface :: InterfaceName
|
||||||
propertyInterface = interfaceName_ "org.freedesktop.DBus.Properties"
|
propertyInterface = interfaceName_ "org.freedesktop.DBus.Properties"
|
||||||
|
@ -156,16 +180,28 @@ propertyInterface = interfaceName_ "org.freedesktop.DBus.Properties"
|
||||||
propertySignal :: MemberName
|
propertySignal :: MemberName
|
||||||
propertySignal = memberName_ "PropertiesChanged"
|
propertySignal = memberName_ "PropertiesChanged"
|
||||||
|
|
||||||
callPropertyGet :: SafeClient c => BusName -> ObjectPath -> InterfaceName
|
callPropertyGet
|
||||||
-> MemberName -> c -> IO [Variant]
|
:: SafeClient c
|
||||||
callPropertyGet bus path iface property cl = fmap (either (const []) (:[]))
|
=> BusName
|
||||||
$ getProperty (toClient cl) $ methodCallBus bus path iface property
|
-> ObjectPath
|
||||||
|
-> InterfaceName
|
||||||
|
-> MemberName
|
||||||
|
-> c
|
||||||
|
-> IO [Variant]
|
||||||
|
callPropertyGet bus path iface property cl =
|
||||||
|
fmap (either (const []) (: [])) $
|
||||||
|
getProperty (toClient cl) $
|
||||||
|
methodCallBus bus path iface property
|
||||||
|
|
||||||
matchProperty :: Maybe BusName -> Maybe ObjectPath -> MatchRule
|
matchProperty :: Maybe BusName -> Maybe ObjectPath -> MatchRule
|
||||||
matchProperty b p =
|
matchProperty b p =
|
||||||
matchSignal b p (Just propertyInterface) (Just propertySignal)
|
matchSignal b p (Just propertyInterface) (Just propertySignal)
|
||||||
|
|
||||||
matchPropertyFull :: SafeClient c => c -> BusName -> Maybe ObjectPath
|
matchPropertyFull
|
||||||
|
:: SafeClient c
|
||||||
|
=> c
|
||||||
|
-> BusName
|
||||||
|
-> Maybe ObjectPath
|
||||||
-> IO (Maybe MatchRule)
|
-> IO (Maybe MatchRule)
|
||||||
matchPropertyFull cl b p =
|
matchPropertyFull cl b p =
|
||||||
matchSignalFull cl b p (Just propertyInterface) (Just propertySignal)
|
matchSignalFull cl b p (Just propertyInterface) (Just propertySignal)
|
||||||
|
@ -174,25 +210,30 @@ data SignalMatch a = Match a | NoMatch | Failure deriving (Eq, Show)
|
||||||
|
|
||||||
withSignalMatch :: (Maybe a -> IO ()) -> SignalMatch a -> IO ()
|
withSignalMatch :: (Maybe a -> IO ()) -> SignalMatch a -> IO ()
|
||||||
withSignalMatch f (Match x) = f (Just x)
|
withSignalMatch f (Match x) = f (Just x)
|
||||||
withSignalMatch f Failure = f Nothing
|
withSignalMatch f Failure = f Nothing
|
||||||
withSignalMatch _ NoMatch = return ()
|
withSignalMatch _ NoMatch = return ()
|
||||||
|
|
||||||
matchPropertyChanged :: IsVariant a => InterfaceName -> T.Text -> [Variant]
|
matchPropertyChanged
|
||||||
|
:: IsVariant a
|
||||||
|
=> InterfaceName
|
||||||
|
-> T.Text
|
||||||
|
-> [Variant]
|
||||||
-> SignalMatch a
|
-> SignalMatch a
|
||||||
matchPropertyChanged iface property [i, body, _] =
|
matchPropertyChanged iface property [i, body, _] =
|
||||||
let i' = (fromVariant i :: Maybe T.Text)
|
let i' = (fromVariant i :: Maybe T.Text)
|
||||||
b = toMap body in
|
b = toMap body
|
||||||
case (i', b) of
|
in case (i', b) of
|
||||||
(Just i'', Just b') -> if i'' == T.pack (formatInterfaceName iface) then
|
(Just i'', Just b') ->
|
||||||
maybe NoMatch Match $ fromVariant =<< M.lookup property b'
|
if i'' == T.pack (formatInterfaceName iface)
|
||||||
else NoMatch
|
then maybe NoMatch Match $ fromVariant =<< M.lookup property b'
|
||||||
_ -> Failure
|
else NoMatch
|
||||||
|
_ -> Failure
|
||||||
where
|
where
|
||||||
toMap v = fromVariant v :: Maybe (M.Map T.Text Variant)
|
toMap v = fromVariant v :: Maybe (M.Map T.Text Variant)
|
||||||
matchPropertyChanged _ _ _ = Failure
|
matchPropertyChanged _ _ _ = Failure
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Object Manager
|
-- Object Manager
|
||||||
|
|
||||||
type ObjectTree = M.Map ObjectPath (M.Map T.Text (M.Map T.Text Variant))
|
type ObjectTree = M.Map ObjectPath (M.Map T.Text (M.Map T.Text Variant))
|
||||||
|
|
||||||
|
@ -208,24 +249,44 @@ omInterfacesAdded = memberName_ "InterfacesAdded"
|
||||||
omInterfacesRemoved :: MemberName
|
omInterfacesRemoved :: MemberName
|
||||||
omInterfacesRemoved = memberName_ "InterfacesRemoved"
|
omInterfacesRemoved = memberName_ "InterfacesRemoved"
|
||||||
|
|
||||||
callGetManagedObjects :: SafeClient c => c -> BusName -> ObjectPath
|
callGetManagedObjects
|
||||||
|
:: SafeClient c
|
||||||
|
=> c
|
||||||
|
-> BusName
|
||||||
|
-> ObjectPath
|
||||||
-> IO ObjectTree
|
-> IO ObjectTree
|
||||||
callGetManagedObjects cl bus path =
|
callGetManagedObjects cl bus path =
|
||||||
either (const M.empty) (fromMaybe M.empty . fromSingletonVariant)
|
either (const M.empty) (fromMaybe M.empty . fromSingletonVariant)
|
||||||
<$> callMethod cl bus path omInterface getManagedObjects
|
<$> callMethod cl bus path omInterface getManagedObjects
|
||||||
|
|
||||||
addInterfaceChangedListener :: SafeClient c => BusName -> MemberName
|
addInterfaceChangedListener
|
||||||
-> ObjectPath -> SignalCallback -> c -> IO (Maybe SignalHandler)
|
:: SafeClient c
|
||||||
|
=> BusName
|
||||||
|
-> MemberName
|
||||||
|
-> ObjectPath
|
||||||
|
-> SignalCallback
|
||||||
|
-> c
|
||||||
|
-> IO (Maybe SignalHandler)
|
||||||
addInterfaceChangedListener bus prop path sc cl = do
|
addInterfaceChangedListener bus prop path sc cl = do
|
||||||
rule <- matchSignalFull cl bus (Just path) (Just omInterface) (Just prop)
|
rule <- matchSignalFull cl bus (Just path) (Just omInterface) (Just prop)
|
||||||
forM rule $ \r -> addMatchCallback r sc cl
|
forM rule $ \r -> addMatchCallback r sc cl
|
||||||
|
|
||||||
addInterfaceAddedListener :: SafeClient c => BusName -> ObjectPath
|
addInterfaceAddedListener
|
||||||
-> SignalCallback -> c -> IO (Maybe SignalHandler)
|
:: SafeClient c
|
||||||
|
=> BusName
|
||||||
|
-> ObjectPath
|
||||||
|
-> SignalCallback
|
||||||
|
-> c
|
||||||
|
-> IO (Maybe SignalHandler)
|
||||||
addInterfaceAddedListener bus =
|
addInterfaceAddedListener bus =
|
||||||
addInterfaceChangedListener bus omInterfacesAdded
|
addInterfaceChangedListener bus omInterfacesAdded
|
||||||
|
|
||||||
addInterfaceRemovedListener :: SafeClient c => BusName -> ObjectPath
|
addInterfaceRemovedListener
|
||||||
-> SignalCallback -> c -> IO (Maybe SignalHandler)
|
:: SafeClient c
|
||||||
|
=> BusName
|
||||||
|
-> ObjectPath
|
||||||
|
-> SignalCallback
|
||||||
|
-> c
|
||||||
|
-> IO (Maybe SignalHandler)
|
||||||
addInterfaceRemovedListener bus =
|
addInterfaceRemovedListener bus =
|
||||||
addInterfaceChangedListener bus omInterfacesRemoved
|
addInterfaceChangedListener bus omInterfacesRemoved
|
||||||
|
|
File diff suppressed because it is too large
Load Diff
|
@ -1,7 +1,7 @@
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Dmenu (Rofi) Commands
|
-- Dmenu (Rofi) Commands
|
||||||
|
|
||||||
module XMonad.Internal.Command.DMenu
|
module XMonad.Internal.Command.DMenu
|
||||||
( runCmdMenu
|
( runCmdMenu
|
||||||
|
@ -15,32 +15,28 @@ module XMonad.Internal.Command.DMenu
|
||||||
, runBTMenu
|
, runBTMenu
|
||||||
, runShowKeys
|
, runShowKeys
|
||||||
, runAutorandrMenu
|
, runAutorandrMenu
|
||||||
) where
|
)
|
||||||
|
where
|
||||||
|
|
||||||
import Data.Internal.DBus
|
import DBus
|
||||||
import Data.Internal.Dependency
|
import Data.Internal.DBus
|
||||||
|
import Data.Internal.Dependency
|
||||||
import DBus
|
import Graphics.X11.Types
|
||||||
|
import qualified RIO.Text as T
|
||||||
import Graphics.X11.Types
|
import System.Directory
|
||||||
|
( XdgDirectory (..)
|
||||||
import qualified RIO.Text as T
|
, getXdgDirectory
|
||||||
|
)
|
||||||
import System.Directory
|
import System.IO
|
||||||
( XdgDirectory (..)
|
import XMonad.Core hiding (spawn)
|
||||||
, getXdgDirectory
|
import XMonad.Internal.Command.Desktop
|
||||||
)
|
import XMonad.Internal.DBus.Common
|
||||||
import System.IO
|
import XMonad.Internal.Notify
|
||||||
|
import XMonad.Internal.Shell
|
||||||
import XMonad.Core hiding (spawn)
|
import XMonad.Util.NamedActions
|
||||||
import XMonad.Internal.Command.Desktop
|
|
||||||
import XMonad.Internal.DBus.Common
|
|
||||||
import XMonad.Internal.Notify
|
|
||||||
import XMonad.Internal.Shell
|
|
||||||
import XMonad.Util.NamedActions
|
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | DMenu executables
|
-- DMenu executables
|
||||||
|
|
||||||
myDmenuCmd :: FilePath
|
myDmenuCmd :: FilePath
|
||||||
myDmenuCmd = "rofi"
|
myDmenuCmd = "rofi"
|
||||||
|
@ -67,7 +63,7 @@ myClipboardManager :: FilePath
|
||||||
myClipboardManager = "greenclip"
|
myClipboardManager = "greenclip"
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Packages
|
-- Packages
|
||||||
|
|
||||||
dmenuPkgs :: [Fulfillment]
|
dmenuPkgs :: [Fulfillment]
|
||||||
dmenuPkgs = [Package Official "rofi"]
|
dmenuPkgs = [Package Official "rofi"]
|
||||||
|
@ -76,7 +72,7 @@ clipboardPkgs :: [Fulfillment]
|
||||||
clipboardPkgs = [Package AUR "rofi-greenclip"]
|
clipboardPkgs = [Package AUR "rofi-greenclip"]
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Other internal functions
|
-- Other internal functions
|
||||||
|
|
||||||
spawnDmenuCmd :: T.Text -> [T.Text] -> SometimesX
|
spawnDmenuCmd :: T.Text -> [T.Text] -> SometimesX
|
||||||
spawnDmenuCmd n =
|
spawnDmenuCmd n =
|
||||||
|
@ -98,7 +94,7 @@ dmenuDep :: IODependency_
|
||||||
dmenuDep = sysExe dmenuPkgs myDmenuCmd
|
dmenuDep = sysExe dmenuPkgs myDmenuCmd
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Exported Commands
|
-- Exported Commands
|
||||||
|
|
||||||
-- TODO test that veracrypt and friends are installed
|
-- TODO test that veracrypt and friends are installed
|
||||||
runDevMenu :: SometimesX
|
runDevMenu :: SometimesX
|
||||||
|
@ -107,28 +103,38 @@ runDevMenu = sometimesIO_ "device manager" "rofi devices" t x
|
||||||
t = dmenuTree $ Only_ (localExe [] myDmenuDevices)
|
t = dmenuTree $ Only_ (localExe [] myDmenuDevices)
|
||||||
x = do
|
x = do
|
||||||
c <- io $ getXdgDirectory XdgConfig "rofi/devices.dhall"
|
c <- io $ getXdgDirectory XdgConfig "rofi/devices.dhall"
|
||||||
spawnCmd myDmenuDevices
|
spawnCmd myDmenuDevices $
|
||||||
$ ["-c", T.pack c]
|
["-c", T.pack c]
|
||||||
++ "--" : themeArgs "#999933"
|
++ "--"
|
||||||
++ myDmenuMatchingArgs
|
: themeArgs "#999933"
|
||||||
|
++ myDmenuMatchingArgs
|
||||||
|
|
||||||
-- TODO test that bluetooth interface exists
|
-- TODO test that bluetooth interface exists
|
||||||
runBTMenu :: SometimesX
|
runBTMenu :: SometimesX
|
||||||
runBTMenu = Sometimes "bluetooth selector" xpfBluetooth
|
runBTMenu =
|
||||||
[Subfeature (IORoot_ cmd tree) "rofi bluetooth"]
|
Sometimes
|
||||||
|
"bluetooth selector"
|
||||||
|
xpfBluetooth
|
||||||
|
[Subfeature (IORoot_ cmd tree) "rofi bluetooth"]
|
||||||
where
|
where
|
||||||
cmd = spawnCmd myDmenuBluetooth $ "-c":themeArgs "#0044bb"
|
cmd = spawnCmd myDmenuBluetooth $ "-c" : themeArgs "#0044bb"
|
||||||
tree = dmenuTree $ Only_ $ sysExe [] myDmenuBluetooth
|
tree = dmenuTree $ Only_ $ sysExe [] myDmenuBluetooth
|
||||||
|
|
||||||
runVPNMenu :: SometimesX
|
runVPNMenu :: SometimesX
|
||||||
runVPNMenu = Sometimes "VPN selector" xpfVPN
|
runVPNMenu =
|
||||||
[Subfeature (IORoot_ cmd tree) "rofi VPN"]
|
Sometimes
|
||||||
|
"VPN selector"
|
||||||
|
xpfVPN
|
||||||
|
[Subfeature (IORoot_ cmd tree) "rofi VPN"]
|
||||||
where
|
where
|
||||||
cmd = spawnCmd myDmenuVPN
|
cmd =
|
||||||
$ ["-c"] ++ themeArgs "#007766" ++ myDmenuMatchingArgs
|
spawnCmd myDmenuVPN $
|
||||||
tree = dmenuTree $ toAnd_ (localExe [] myDmenuVPN)
|
["-c"] ++ themeArgs "#007766" ++ myDmenuMatchingArgs
|
||||||
$ socketExists "expressVPN" []
|
tree =
|
||||||
$ return "/var/lib/expressvpn/expressvpnd.socket"
|
dmenuTree $
|
||||||
|
toAnd_ (localExe [] myDmenuVPN) $
|
||||||
|
socketExists "expressVPN" [] $
|
||||||
|
return "/var/lib/expressvpn/expressvpnd.socket"
|
||||||
|
|
||||||
runCmdMenu :: SometimesX
|
runCmdMenu :: SometimesX
|
||||||
runCmdMenu = spawnDmenuCmd "command menu" ["-show", "run"]
|
runCmdMenu = spawnDmenuCmd "command menu" ["-show", "run"]
|
||||||
|
@ -140,15 +146,20 @@ runWinMenu :: SometimesX
|
||||||
runWinMenu = spawnDmenuCmd "window switcher" ["-show", "window"]
|
runWinMenu = spawnDmenuCmd "window switcher" ["-show", "window"]
|
||||||
|
|
||||||
runNetMenu :: Maybe SysClient -> SometimesX
|
runNetMenu :: Maybe SysClient -> SometimesX
|
||||||
runNetMenu cl = Sometimes "network control menu" enabled
|
runNetMenu cl =
|
||||||
[Subfeature root "network control menu"]
|
Sometimes
|
||||||
|
"network control menu"
|
||||||
|
enabled
|
||||||
|
[Subfeature root "network control menu"]
|
||||||
where
|
where
|
||||||
enabled f = xpfEthernet f || xpfWireless f || xpfVPN f
|
enabled f = xpfEthernet f || xpfWireless f || xpfVPN f
|
||||||
root = DBusRoot_ cmd tree cl
|
root = DBusRoot_ cmd tree cl
|
||||||
cmd _ = spawnCmd myDmenuNetworks $ themeArgs "#ff3333"
|
cmd _ = spawnCmd myDmenuNetworks $ themeArgs "#ff3333"
|
||||||
tree = And_ (Only_ $ Bus networkManagerPkgs networkManagerBus)
|
tree =
|
||||||
$ toAnd_ (DBusIO dmenuDep) $ DBusIO
|
And_ (Only_ $ Bus networkManagerPkgs networkManagerBus) $
|
||||||
$ sysExe [Package AUR "networkmanager-dmenu-git"] myDmenuNetworks
|
toAnd_ (DBusIO dmenuDep) $
|
||||||
|
DBusIO $
|
||||||
|
sysExe [Package AUR "networkmanager-dmenu-git"] myDmenuNetworks
|
||||||
|
|
||||||
runAutorandrMenu :: SometimesX
|
runAutorandrMenu :: SometimesX
|
||||||
runAutorandrMenu = sometimesIO_ "autorandr menu" "rofi autorandr" tree cmd
|
runAutorandrMenu = sometimesIO_ "autorandr menu" "rofi autorandr" tree cmd
|
||||||
|
@ -157,47 +168,63 @@ runAutorandrMenu = sometimesIO_ "autorandr menu" "rofi autorandr" tree cmd
|
||||||
tree = dmenuTree $ Only_ $ localExe [] myDmenuMonitors
|
tree = dmenuTree $ Only_ $ localExe [] myDmenuMonitors
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Password manager
|
-- Password manager
|
||||||
|
|
||||||
runBwMenu :: Maybe SesClient -> SometimesX
|
runBwMenu :: Maybe SesClient -> SometimesX
|
||||||
runBwMenu cl = sometimesDBus cl "password manager" "rofi bitwarden" tree cmd
|
runBwMenu cl = sometimesDBus cl "password manager" "rofi bitwarden" tree cmd
|
||||||
where
|
where
|
||||||
cmd _ = spawnCmd myDmenuPasswords
|
cmd _ =
|
||||||
$ ["-c"] ++ themeArgs "#bb6600" ++ myDmenuMatchingArgs
|
spawnCmd myDmenuPasswords $
|
||||||
tree = And_ (Only_ $ Bus [] $ busName_ "org.rofi.bitwarden")
|
["-c"] ++ themeArgs "#bb6600" ++ myDmenuMatchingArgs
|
||||||
$ toAnd_ (DBusIO dmenuDep) (DBusIO $ localExe [] myDmenuPasswords)
|
tree =
|
||||||
|
And_ (Only_ $ Bus [] $ busName_ "org.rofi.bitwarden") $
|
||||||
|
toAnd_ (DBusIO dmenuDep) (DBusIO $ localExe [] myDmenuPasswords)
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Clipboard
|
-- Clipboard
|
||||||
|
|
||||||
runClipMenu :: SometimesX
|
runClipMenu :: SometimesX
|
||||||
runClipMenu = sometimesIO_ "clipboard manager" "rofi greenclip" tree act
|
runClipMenu = sometimesIO_ "clipboard manager" "rofi greenclip" tree act
|
||||||
where
|
where
|
||||||
act = spawnCmd myDmenuCmd args
|
act = spawnCmd myDmenuCmd args
|
||||||
tree = listToAnds dmenuDep [ sysExe clipboardPkgs myClipboardManager
|
tree =
|
||||||
, process [] $ T.pack myClipboardManager
|
listToAnds
|
||||||
]
|
dmenuDep
|
||||||
args = [ "-modi", "\"clipboard:greenclip print\""
|
[ sysExe clipboardPkgs myClipboardManager
|
||||||
, "-show", "clipboard"
|
, process [] $ T.pack myClipboardManager
|
||||||
, "-run-command", "'{cmd}'"
|
]
|
||||||
] ++ themeArgs "#00c44e"
|
args =
|
||||||
|
[ "-modi"
|
||||||
|
, "\"clipboard:greenclip print\""
|
||||||
|
, "-show"
|
||||||
|
, "clipboard"
|
||||||
|
, "-run-command"
|
||||||
|
, "'{cmd}'"
|
||||||
|
]
|
||||||
|
++ themeArgs "#00c44e"
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Shortcut menu
|
-- Shortcut menu
|
||||||
|
|
||||||
runShowKeys :: Always ([((KeyMask, KeySym), NamedAction)] -> X ())
|
runShowKeys :: Always ([((KeyMask, KeySym), NamedAction)] -> X ())
|
||||||
runShowKeys = Always "keyboard menu" $ Option showKeysDMenu $ Always_
|
runShowKeys =
|
||||||
$ FallbackAlone fallback
|
Always "keyboard menu" $
|
||||||
|
Option showKeysDMenu $
|
||||||
|
Always_ $
|
||||||
|
FallbackAlone fallback
|
||||||
where
|
where
|
||||||
-- TODO this should technically depend on dunst
|
-- TODO this should technically depend on dunst
|
||||||
fallback = const $ spawnNotify
|
fallback =
|
||||||
$ defNoteError { body = Just $ Text "could not display keymap" }
|
const $
|
||||||
|
spawnNotify $
|
||||||
|
defNoteError {body = Just $ Text "could not display keymap"}
|
||||||
|
|
||||||
showKeysDMenu :: SubfeatureRoot ([((KeyMask, KeySym), NamedAction)] -> X ())
|
showKeysDMenu :: SubfeatureRoot ([((KeyMask, KeySym), NamedAction)] -> X ())
|
||||||
showKeysDMenu = Subfeature
|
showKeysDMenu =
|
||||||
{ sfName = "keyboard shortcut menu"
|
Subfeature
|
||||||
, sfData = IORoot_ showKeys $ Only_ dmenuDep
|
{ sfName = "keyboard shortcut menu"
|
||||||
}
|
, sfData = IORoot_ showKeys $ Only_ dmenuDep
|
||||||
|
}
|
||||||
|
|
||||||
showKeys :: [((KeyMask, KeySym), NamedAction)] -> X ()
|
showKeys :: [((KeyMask, KeySym), NamedAction)] -> X ()
|
||||||
showKeys kbs = do
|
showKeys kbs = do
|
||||||
|
@ -205,5 +232,8 @@ showKeys kbs = do
|
||||||
io $ hPutStr h $ unlines $ showKm kbs
|
io $ hPutStr h $ unlines $ showKm kbs
|
||||||
io $ hClose h
|
io $ hClose h
|
||||||
where
|
where
|
||||||
cmd = fmtCmd myDmenuCmd $ ["-dmenu", "-p", "commands"]
|
cmd =
|
||||||
++ themeArgs "#7f66ff" ++ myDmenuMatchingArgs
|
fmtCmd myDmenuCmd $
|
||||||
|
["-dmenu", "-p", "commands"]
|
||||||
|
++ themeArgs "#7f66ff"
|
||||||
|
++ myDmenuMatchingArgs
|
||||||
|
|
|
@ -1,12 +1,11 @@
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | General commands
|
-- General commands
|
||||||
|
|
||||||
module XMonad.Internal.Command.Desktop
|
module XMonad.Internal.Command.Desktop
|
||||||
( myTerm
|
( myTerm
|
||||||
, playSound
|
, playSound
|
||||||
|
|
||||||
-- commands
|
-- commands
|
||||||
, runTerm
|
, runTerm
|
||||||
, runTMux
|
, runTMux
|
||||||
|
@ -33,37 +32,32 @@ module XMonad.Internal.Command.Desktop
|
||||||
, runNotificationCloseAll
|
, runNotificationCloseAll
|
||||||
, runNotificationHistory
|
, runNotificationHistory
|
||||||
, runNotificationContext
|
, runNotificationContext
|
||||||
|
|
||||||
-- daemons
|
-- daemons
|
||||||
, runNetAppDaemon
|
, runNetAppDaemon
|
||||||
|
|
||||||
-- packages
|
-- packages
|
||||||
, networkManagerPkgs
|
, networkManagerPkgs
|
||||||
) where
|
)
|
||||||
|
where
|
||||||
|
|
||||||
import Data.Internal.DBus
|
import DBus
|
||||||
import Data.Internal.Dependency
|
import Data.Internal.DBus
|
||||||
|
import Data.Internal.Dependency
|
||||||
import DBus
|
import RIO
|
||||||
|
import RIO.FilePath
|
||||||
import RIO
|
import qualified RIO.Process as P
|
||||||
import RIO.FilePath
|
import qualified RIO.Text as T
|
||||||
import qualified RIO.Process as P
|
import System.Directory
|
||||||
import qualified RIO.Text as T
|
import System.Environment
|
||||||
|
import System.Posix.User
|
||||||
import System.Directory
|
import XMonad.Actions.Volume
|
||||||
import System.Environment
|
import XMonad.Core hiding (spawn)
|
||||||
import System.Posix.User
|
import XMonad.Internal.DBus.Common
|
||||||
|
import XMonad.Internal.Notify
|
||||||
import XMonad.Actions.Volume
|
import XMonad.Internal.Shell as S
|
||||||
import XMonad.Core hiding (spawn)
|
import XMonad.Operations
|
||||||
import XMonad.Internal.DBus.Common
|
|
||||||
import XMonad.Internal.Notify
|
|
||||||
import XMonad.Internal.Shell as S
|
|
||||||
import XMonad.Operations
|
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | My Executables
|
-- My Executables
|
||||||
|
|
||||||
myTerm :: FilePath
|
myTerm :: FilePath
|
||||||
myTerm = "urxvt"
|
myTerm = "urxvt"
|
||||||
|
@ -96,12 +90,13 @@ myNotificationCtrl :: FilePath
|
||||||
myNotificationCtrl = "dunstctl"
|
myNotificationCtrl = "dunstctl"
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Packages
|
-- Packages
|
||||||
|
|
||||||
myTermPkgs :: [Fulfillment]
|
myTermPkgs :: [Fulfillment]
|
||||||
myTermPkgs = [ Package Official "rxvt-unicode"
|
myTermPkgs =
|
||||||
, Package Official "urxvt-perls"
|
[ Package Official "rxvt-unicode"
|
||||||
]
|
, Package Official "urxvt-perls"
|
||||||
|
]
|
||||||
|
|
||||||
myEditorPkgs :: [Fulfillment]
|
myEditorPkgs :: [Fulfillment]
|
||||||
myEditorPkgs = [Package Official "emacs-nativecomp"]
|
myEditorPkgs = [Package Official "emacs-nativecomp"]
|
||||||
|
@ -116,13 +111,13 @@ networkManagerPkgs :: [Fulfillment]
|
||||||
networkManagerPkgs = [Package Official "networkmanager"]
|
networkManagerPkgs = [Package Official "networkmanager"]
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Misc constants
|
-- Misc constants
|
||||||
|
|
||||||
volumeChangeSound :: FilePath
|
volumeChangeSound :: FilePath
|
||||||
volumeChangeSound = "smb_fireball.wav"
|
volumeChangeSound = "smb_fireball.wav"
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Some nice apps
|
-- Some nice apps
|
||||||
|
|
||||||
runTerm :: SometimesX
|
runTerm :: SometimesX
|
||||||
runTerm = sometimesExe "terminal" "urxvt" myTermPkgs True myTerm
|
runTerm = sometimesExe "terminal" "urxvt" myTermPkgs True myTerm
|
||||||
|
@ -130,12 +125,14 @@ runTerm = sometimesExe "terminal" "urxvt" myTermPkgs True myTerm
|
||||||
runTMux :: SometimesX
|
runTMux :: SometimesX
|
||||||
runTMux = sometimesIO_ "terminal multiplexer" "tmux" deps act
|
runTMux = sometimesIO_ "terminal multiplexer" "tmux" deps act
|
||||||
where
|
where
|
||||||
deps = listToAnds (socketExists "tmux" [] socketName)
|
deps =
|
||||||
$ fmap (sysExe myTermPkgs) [myTerm, "tmux", "bash"]
|
listToAnds (socketExists "tmux" [] socketName) $
|
||||||
act = S.spawn
|
fmap (sysExe myTermPkgs) [myTerm, "tmux", "bash"]
|
||||||
$ fmtCmd "tmux" ["has-session"]
|
act =
|
||||||
#!&& fmtCmd myTerm ["-e", "bash", "-c", singleQuote c]
|
S.spawn $
|
||||||
#!|| fmtNotifyCmd defNoteError { body = Just $ Text msg }
|
fmtCmd "tmux" ["has-session"]
|
||||||
|
#!&& fmtCmd myTerm ["-e", "bash", "-c", singleQuote c]
|
||||||
|
#!|| fmtNotifyCmd defNoteError {body = Just $ Text msg}
|
||||||
c = "exec tmux attach-session -d"
|
c = "exec tmux attach-session -d"
|
||||||
msg = "could not connect to tmux session"
|
msg = "could not connect to tmux session"
|
||||||
socketName = do
|
socketName = do
|
||||||
|
@ -150,28 +147,46 @@ runCalc = sometimesIO_ "calculator" "bc" deps act
|
||||||
act = spawnCmd myTerm ["-e", T.pack myCalc, "-l"]
|
act = spawnCmd myTerm ["-e", T.pack myCalc, "-l"]
|
||||||
|
|
||||||
runBrowser :: SometimesX
|
runBrowser :: SometimesX
|
||||||
runBrowser = sometimesExe "web browser" "brave" [Package AUR "brave-bin"]
|
runBrowser =
|
||||||
False myBrowser
|
sometimesExe
|
||||||
|
"web browser"
|
||||||
|
"brave"
|
||||||
|
[Package AUR "brave-bin"]
|
||||||
|
False
|
||||||
|
myBrowser
|
||||||
|
|
||||||
runEditor :: SometimesX
|
runEditor :: SometimesX
|
||||||
runEditor = sometimesIO_ "text editor" "emacs" tree cmd
|
runEditor = sometimesIO_ "text editor" "emacs" tree cmd
|
||||||
where
|
where
|
||||||
cmd = spawnCmd myEditor
|
cmd =
|
||||||
["-c", "-e", doubleQuote "(select-frame-set-input-focus (selected-frame))"]
|
spawnCmd
|
||||||
|
myEditor
|
||||||
|
["-c", "-e", doubleQuote "(select-frame-set-input-focus (selected-frame))"]
|
||||||
-- NOTE 1: we could test if the emacs socket exists, but it won't come up
|
-- NOTE 1: we could test if the emacs socket exists, but it won't come up
|
||||||
-- before xmonad starts, so just check to see if the process has started
|
-- before xmonad starts, so just check to see if the process has started
|
||||||
tree = toAnd_ (sysExe myEditorPkgs myEditor) $ process [] $ T.pack myEditorServer
|
tree = toAnd_ (sysExe myEditorPkgs myEditor) $ process [] $ T.pack myEditorServer
|
||||||
|
|
||||||
runFileManager :: SometimesX
|
runFileManager :: SometimesX
|
||||||
runFileManager = sometimesExe "file browser" "pcmanfm" [Package Official "pcmanfm"]
|
runFileManager =
|
||||||
True "pcmanfm"
|
sometimesExe
|
||||||
|
"file browser"
|
||||||
|
"pcmanfm"
|
||||||
|
[Package Official "pcmanfm"]
|
||||||
|
True
|
||||||
|
"pcmanfm"
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Multimedia Commands
|
-- Multimedia Commands
|
||||||
|
|
||||||
runMultimediaIfInstalled :: T.Text -> T.Text -> SometimesX
|
runMultimediaIfInstalled :: T.Text -> T.Text -> SometimesX
|
||||||
runMultimediaIfInstalled n cmd = sometimesExeArgs (T.append n " multimedia control")
|
runMultimediaIfInstalled n cmd =
|
||||||
"playerctl" [Package Official "playerctl"] True myMultimediaCtl [cmd]
|
sometimesExeArgs
|
||||||
|
(T.append n " multimedia control")
|
||||||
|
"playerctl"
|
||||||
|
[Package Official "playerctl"]
|
||||||
|
True
|
||||||
|
myMultimediaCtl
|
||||||
|
[cmd]
|
||||||
|
|
||||||
runTogglePlay :: SometimesX
|
runTogglePlay :: SometimesX
|
||||||
runTogglePlay = runMultimediaIfInstalled "play/pause" "play-pause"
|
runTogglePlay = runMultimediaIfInstalled "play/pause" "play-pause"
|
||||||
|
@ -186,7 +201,7 @@ runStopPlay :: SometimesX
|
||||||
runStopPlay = runMultimediaIfInstalled "stop playback" "stop"
|
runStopPlay = runMultimediaIfInstalled "stop playback" "stop"
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Volume Commands
|
-- Volume Commands
|
||||||
|
|
||||||
soundDir :: FilePath
|
soundDir :: FilePath
|
||||||
soundDir = "sound"
|
soundDir = "sound"
|
||||||
|
@ -200,8 +215,8 @@ playSound file = do
|
||||||
|
|
||||||
featureSound :: T.Text -> FilePath -> X () -> X () -> SometimesX
|
featureSound :: T.Text -> FilePath -> X () -> X () -> SometimesX
|
||||||
featureSound n file pre post =
|
featureSound n file pre post =
|
||||||
sometimesIO_ (T.unwords ["volume", n, " control"]) "paplay" tree
|
sometimesIO_ (T.unwords ["volume", n, " control"]) "paplay" tree $
|
||||||
$ pre >> playSound file >> post
|
pre >> playSound file >> post
|
||||||
where
|
where
|
||||||
-- ASSUME pulseaudio pulls in libpulse as a dep; pulseaudio itself is needed
|
-- ASSUME pulseaudio pulls in libpulse as a dep; pulseaudio itself is needed
|
||||||
-- to play sound (duh) but libpulse is the package with the paplay binary
|
-- to play sound (duh) but libpulse is the package with the paplay binary
|
||||||
|
@ -217,16 +232,18 @@ runVolumeMute :: SometimesX
|
||||||
runVolumeMute = featureSound "mute" volumeChangeSound (void toggleMute) $ return ()
|
runVolumeMute = featureSound "mute" volumeChangeSound (void toggleMute) $ return ()
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Notification control
|
-- Notification control
|
||||||
|
|
||||||
runNotificationCmd :: T.Text -> T.Text -> Maybe SesClient -> SometimesX
|
runNotificationCmd :: T.Text -> T.Text -> Maybe SesClient -> SometimesX
|
||||||
runNotificationCmd n arg cl =
|
runNotificationCmd n arg cl =
|
||||||
sometimesDBus cl (T.unwords [n, "control"]) "dunstctl" tree cmd
|
sometimesDBus cl (T.unwords [n, "control"]) "dunstctl" tree cmd
|
||||||
where
|
where
|
||||||
cmd _ = spawnCmd myNotificationCtrl [arg]
|
cmd _ = spawnCmd myNotificationCtrl [arg]
|
||||||
tree = toAnd_ (DBusIO $ sysExe notifyPkgs myNotificationCtrl)
|
tree =
|
||||||
$ Endpoint [] notifyBus notifyPath (interfaceName_ "org.dunstproject.cmd0")
|
toAnd_ (DBusIO $ sysExe notifyPkgs myNotificationCtrl) $
|
||||||
$ Method_ $ memberName_ "NotificationAction"
|
Endpoint [] notifyBus notifyPath (interfaceName_ "org.dunstproject.cmd0") $
|
||||||
|
Method_ $
|
||||||
|
memberName_ "NotificationAction"
|
||||||
|
|
||||||
runNotificationClose :: Maybe SesClient -> SometimesX
|
runNotificationClose :: Maybe SesClient -> SometimesX
|
||||||
runNotificationClose = runNotificationCmd "close notification" "close"
|
runNotificationClose = runNotificationCmd "close notification" "close"
|
||||||
|
@ -244,47 +261,61 @@ runNotificationContext =
|
||||||
runNotificationCmd "open notification context" "context"
|
runNotificationCmd "open notification context" "context"
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | System commands
|
-- System commands
|
||||||
|
|
||||||
-- this is required for some vpn's to work properly with network-manager
|
-- this is required for some vpn's to work properly with network-manager
|
||||||
runNetAppDaemon :: Maybe SysClient -> Sometimes (FIO (P.Process () () ()))
|
runNetAppDaemon :: Maybe SysClient -> Sometimes (FIO (P.Process () () ()))
|
||||||
runNetAppDaemon cl = Sometimes "network applet" xpfVPN
|
runNetAppDaemon cl =
|
||||||
[Subfeature (DBusRoot_ cmd tree cl) "NM-applet"]
|
Sometimes
|
||||||
|
"network applet"
|
||||||
|
xpfVPN
|
||||||
|
[Subfeature (DBusRoot_ cmd tree cl) "NM-applet"]
|
||||||
where
|
where
|
||||||
tree = toAnd_ app $ Bus networkManagerPkgs networkManagerBus
|
tree = toAnd_ app $ Bus networkManagerPkgs networkManagerBus
|
||||||
app = DBusIO $ sysExe [Package Official "network-manager-applet"] "nm-applet"
|
app = DBusIO $ sysExe [Package Official "network-manager-applet"] "nm-applet"
|
||||||
cmd _ = P.proc "nm-applet" [] (P.startProcess . P.setCreateGroup True)
|
cmd _ = P.proc "nm-applet" [] (P.startProcess . P.setCreateGroup True)
|
||||||
|
|
||||||
runToggleBluetooth :: Maybe SysClient -> SometimesX
|
runToggleBluetooth :: Maybe SysClient -> SometimesX
|
||||||
runToggleBluetooth cl = Sometimes "bluetooth toggle" xpfBluetooth
|
runToggleBluetooth cl =
|
||||||
[Subfeature (DBusRoot_ cmd tree cl) "bluetoothctl"]
|
Sometimes
|
||||||
|
"bluetooth toggle"
|
||||||
|
xpfBluetooth
|
||||||
|
[Subfeature (DBusRoot_ cmd tree cl) "bluetoothctl"]
|
||||||
where
|
where
|
||||||
tree = And_ (Only_ $ DBusIO $ sysExe bluetoothPkgs myBluetooth) (Only_ $ Bus [] btBus)
|
tree = And_ (Only_ $ DBusIO $ sysExe bluetoothPkgs myBluetooth) (Only_ $ Bus [] btBus)
|
||||||
cmd _ = S.spawn
|
cmd _ =
|
||||||
$ fmtCmd myBluetooth ["show"]
|
S.spawn $
|
||||||
#!| "grep -q \"Powered: no\""
|
fmtCmd myBluetooth ["show"]
|
||||||
#!&& "a=on"
|
#!| "grep -q \"Powered: no\""
|
||||||
#!|| "a=off"
|
#!&& "a=on"
|
||||||
#!>> fmtCmd myBluetooth ["power", "$a", ">", "/dev/null"]
|
#!|| "a=off"
|
||||||
#!&& fmtNotifyCmd defNoteInfo { body = Just $ Text "bluetooth powered $a" }
|
#!>> fmtCmd myBluetooth ["power", "$a", ">", "/dev/null"]
|
||||||
|
#!&& fmtNotifyCmd defNoteInfo {body = Just $ Text "bluetooth powered $a"}
|
||||||
|
|
||||||
runToggleEthernet :: SometimesX
|
runToggleEthernet :: SometimesX
|
||||||
runToggleEthernet = Sometimes "ethernet toggle" xpfEthernet
|
runToggleEthernet =
|
||||||
[Subfeature root "nmcli"]
|
Sometimes
|
||||||
|
"ethernet toggle"
|
||||||
|
xpfEthernet
|
||||||
|
[Subfeature root "nmcli"]
|
||||||
where
|
where
|
||||||
root = IORoot cmd $ And1 (Only readEthernet) $ Only_
|
root =
|
||||||
$ sysExe networkManagerPkgs "nmcli"
|
IORoot cmd $
|
||||||
|
And1 (Only readEthernet) $
|
||||||
|
Only_ $
|
||||||
|
sysExe networkManagerPkgs "nmcli"
|
||||||
-- TODO make this less noisy
|
-- TODO make this less noisy
|
||||||
cmd iface = S.spawn
|
cmd iface =
|
||||||
$ fmtCmd "nmcli" ["-g", "GENERAL.STATE", "device", "show", iface]
|
S.spawn $
|
||||||
#!| "grep -q disconnected"
|
fmtCmd "nmcli" ["-g", "GENERAL.STATE", "device", "show", iface]
|
||||||
#!&& "a=connect"
|
#!| "grep -q disconnected"
|
||||||
#!|| "a=disconnect"
|
#!&& "a=connect"
|
||||||
#!>> fmtCmd "nmcli" ["device", "$a", iface]
|
#!|| "a=disconnect"
|
||||||
#!&& fmtNotifyCmd defNoteInfo { body = Just $ Text "ethernet \"$a\"ed" }
|
#!>> fmtCmd "nmcli" ["device", "$a", iface]
|
||||||
|
#!&& fmtNotifyCmd defNoteInfo {body = Just $ Text "ethernet \"$a\"ed"}
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Configuration commands
|
-- Configuration commands
|
||||||
|
|
||||||
runRestart :: X ()
|
runRestart :: X ()
|
||||||
runRestart = restart "xmonad" True
|
runRestart = restart "xmonad" True
|
||||||
|
@ -294,14 +325,14 @@ runRecompile :: X ()
|
||||||
runRecompile = do
|
runRecompile = do
|
||||||
-- assume that the conf directory contains a valid stack project
|
-- assume that the conf directory contains a valid stack project
|
||||||
confDir <- asks (cfgDir . directories)
|
confDir <- asks (cfgDir . directories)
|
||||||
spawn
|
spawn $
|
||||||
$ fmtCmd "cd" [T.pack confDir]
|
fmtCmd "cd" [T.pack confDir]
|
||||||
#!&& fmtCmd "stack" ["install"]
|
#!&& fmtCmd "stack" ["install"]
|
||||||
#!&& fmtNotifyCmd defNoteInfo { body = Just $ Text "compilation succeeded" }
|
#!&& fmtNotifyCmd defNoteInfo {body = Just $ Text "compilation succeeded"}
|
||||||
#!|| fmtNotifyCmd defNoteError { body = Just $ Text "compilation failed" }
|
#!|| fmtNotifyCmd defNoteError {body = Just $ Text "compilation failed"}
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Screen capture commands
|
-- Screen capture commands
|
||||||
|
|
||||||
getCaptureDir :: IO FilePath
|
getCaptureDir :: IO FilePath
|
||||||
getCaptureDir = do
|
getCaptureDir = do
|
||||||
|
@ -321,8 +352,10 @@ runFlameshot :: T.Text -> T.Text -> Maybe SesClient -> SometimesX
|
||||||
runFlameshot n mode cl = sometimesDBus cl n (T.pack myCapture) tree cmd
|
runFlameshot n mode cl = sometimesDBus cl n (T.pack myCapture) tree cmd
|
||||||
where
|
where
|
||||||
cmd _ = spawnCmd myCapture [mode]
|
cmd _ = spawnCmd myCapture [mode]
|
||||||
tree = toAnd_ (DBusIO $ sysExe [Package Official "flameshot"] myCapture)
|
tree =
|
||||||
$ Bus [] $ busName_ "org.flameshot.Flameshot"
|
toAnd_ (DBusIO $ sysExe [Package Official "flameshot"] myCapture) $
|
||||||
|
Bus [] $
|
||||||
|
busName_ "org.flameshot.Flameshot"
|
||||||
|
|
||||||
-- TODO this will steal focus from the current window (and puts it
|
-- TODO this will steal focus from the current window (and puts it
|
||||||
-- in the root window?) ...need to fix
|
-- in the root window?) ...need to fix
|
||||||
|
@ -338,7 +371,10 @@ runScreenCapture :: Maybe SesClient -> SometimesX
|
||||||
runScreenCapture = runFlameshot "screen capture" "screen"
|
runScreenCapture = runFlameshot "screen capture" "screen"
|
||||||
|
|
||||||
runCaptureBrowser :: SometimesX
|
runCaptureBrowser :: SometimesX
|
||||||
runCaptureBrowser = sometimesIO_ "screen capture browser" "feh"
|
runCaptureBrowser = sometimesIO_
|
||||||
(Only_ $ sysExe [Package Official "feh"] myImageBrowser) $ do
|
"screen capture browser"
|
||||||
dir <- io getCaptureDir
|
"feh"
|
||||||
spawnCmd myImageBrowser [T.pack dir]
|
(Only_ $ sysExe [Package Official "feh"] myImageBrowser)
|
||||||
|
$ do
|
||||||
|
dir <- io getCaptureDir
|
||||||
|
spawnCmd myImageBrowser [T.pack dir]
|
||||||
|
|
|
@ -1,10 +1,10 @@
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Commands for controlling power
|
-- Commands for controlling power
|
||||||
|
|
||||||
module XMonad.Internal.Command.Power
|
module XMonad.Internal.Command.Power
|
||||||
-- commands
|
-- commands
|
||||||
( runHibernate
|
( runHibernate
|
||||||
, runOptimusPrompt
|
, runOptimusPrompt
|
||||||
, runPowerOff
|
, runPowerOff
|
||||||
|
@ -14,10 +14,8 @@ module XMonad.Internal.Command.Power
|
||||||
, runSuspend
|
, runSuspend
|
||||||
, runSuspendPrompt
|
, runSuspendPrompt
|
||||||
, runQuitPrompt
|
, runQuitPrompt
|
||||||
|
|
||||||
-- daemons
|
-- daemons
|
||||||
, runAutolock
|
, runAutolock
|
||||||
|
|
||||||
-- functions
|
-- functions
|
||||||
, hasBattery
|
, hasBattery
|
||||||
, suspendPrompt
|
, suspendPrompt
|
||||||
|
@ -25,32 +23,27 @@ module XMonad.Internal.Command.Power
|
||||||
, powerPrompt
|
, powerPrompt
|
||||||
, defFontPkgs
|
, defFontPkgs
|
||||||
, promptFontDep
|
, promptFontDep
|
||||||
) where
|
)
|
||||||
|
where
|
||||||
|
|
||||||
import Data.Internal.Dependency
|
import Data.Either
|
||||||
|
import Data.Internal.Dependency
|
||||||
import Data.Either
|
import qualified Data.Map as M
|
||||||
import qualified Data.Map as M
|
import Graphics.X11.Types
|
||||||
|
import RIO
|
||||||
import Graphics.X11.Types
|
import RIO.FilePath
|
||||||
|
import qualified RIO.Process as P
|
||||||
import RIO
|
import qualified RIO.Text as T
|
||||||
import RIO.FilePath
|
import System.Directory
|
||||||
import qualified RIO.Process as P
|
import System.IO.Error
|
||||||
import qualified RIO.Text as T
|
import XMonad.Core hiding (spawn)
|
||||||
|
import XMonad.Internal.Shell
|
||||||
import System.Directory
|
import qualified XMonad.Internal.Theme as XT
|
||||||
import System.IO.Error
|
import XMonad.Prompt
|
||||||
|
import XMonad.Prompt.ConfirmPrompt
|
||||||
import XMonad.Core hiding (spawn)
|
|
||||||
import XMonad.Internal.Shell
|
|
||||||
import qualified XMonad.Internal.Theme as XT
|
|
||||||
import XMonad.Prompt
|
|
||||||
import XMonad.Prompt.ConfirmPrompt
|
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Executables
|
-- Executables
|
||||||
|
|
||||||
myScreenlock :: FilePath
|
myScreenlock :: FilePath
|
||||||
myScreenlock = "screenlock"
|
myScreenlock = "screenlock"
|
||||||
|
|
||||||
|
@ -61,17 +54,22 @@ myPrimeOffload :: FilePath
|
||||||
myPrimeOffload = "prime-offload"
|
myPrimeOffload = "prime-offload"
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Packages
|
-- Packages
|
||||||
|
|
||||||
optimusPackages :: [Fulfillment]
|
optimusPackages :: [Fulfillment]
|
||||||
optimusPackages = [Package AUR "optimus-manager"]
|
optimusPackages = [Package AUR "optimus-manager"]
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Core commands
|
-- Core commands
|
||||||
|
|
||||||
runScreenLock :: SometimesX
|
runScreenLock :: SometimesX
|
||||||
runScreenLock = sometimesExe "screen locker" "i3lock script"
|
runScreenLock =
|
||||||
[Package AUR "i3lock-color"] False myScreenlock
|
sometimesExe
|
||||||
|
"screen locker"
|
||||||
|
"i3lock script"
|
||||||
|
[Package AUR "i3lock-color"]
|
||||||
|
False
|
||||||
|
myScreenlock
|
||||||
|
|
||||||
runPowerOff :: X ()
|
runPowerOff :: X ()
|
||||||
runPowerOff = spawn "systemctl poweroff"
|
runPowerOff = spawn "systemctl poweroff"
|
||||||
|
@ -86,17 +84,19 @@ runReboot :: X ()
|
||||||
runReboot = spawn "systemctl reboot"
|
runReboot = spawn "systemctl reboot"
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Autolock
|
-- Autolock
|
||||||
|
|
||||||
runAutolock :: Sometimes (FIO (P.Process () () ()))
|
runAutolock :: Sometimes (FIO (P.Process () () ()))
|
||||||
runAutolock = sometimesIO_ "automatic screen lock" "xss-lock" tree cmd
|
runAutolock = sometimesIO_ "automatic screen lock" "xss-lock" tree cmd
|
||||||
where
|
where
|
||||||
tree = And_ (Only_ $ sysExe [Package Official "xss-lock"] "xss-lock")
|
tree =
|
||||||
$ Only_ $ IOSometimes_ runScreenLock
|
And_ (Only_ $ sysExe [Package Official "xss-lock"] "xss-lock") $
|
||||||
|
Only_ $
|
||||||
|
IOSometimes_ runScreenLock
|
||||||
cmd = P.proc "xss-lock" ["--ignore-sleep", "screenlock"] (P.startProcess . P.setCreateGroup True)
|
cmd = P.proc "xss-lock" ["--ignore-sleep", "screenlock"] (P.startProcess . P.setCreateGroup True)
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Confirmation prompts
|
-- Confirmation prompts
|
||||||
|
|
||||||
promptFontDep :: IOTree XT.FontBuilder
|
promptFontDep :: IOTree XT.FontBuilder
|
||||||
promptFontDep = fontTreeAlt XT.defFontFamily defFontPkgs
|
promptFontDep = fontTreeAlt XT.defFontFamily defFontPkgs
|
||||||
|
@ -124,7 +124,7 @@ runQuitPrompt :: SometimesX
|
||||||
runQuitPrompt = sometimesPrompt "quit prompt" quitPrompt
|
runQuitPrompt = sometimesPrompt "quit prompt" quitPrompt
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Nvidia Optimus
|
-- Nvidia Optimus
|
||||||
|
|
||||||
-- TODO for some reason the screen never wakes up after suspend when
|
-- TODO for some reason the screen never wakes up after suspend when
|
||||||
-- the nvidia card is up, so block suspend if nvidia card is running
|
-- the nvidia card is up, so block suspend if nvidia card is running
|
||||||
|
@ -148,30 +148,36 @@ runOptimusPrompt' fb = do
|
||||||
where
|
where
|
||||||
switch mode = confirmPrompt' (prompt mode) (cmd mode) fb
|
switch mode = confirmPrompt' (prompt mode) (cmd mode) fb
|
||||||
prompt mode = T.concat ["gpu switch to ", mode, "?"]
|
prompt mode = T.concat ["gpu switch to ", mode, "?"]
|
||||||
cmd mode = spawn
|
cmd mode =
|
||||||
$ T.pack myPrimeOffload
|
spawn $
|
||||||
#!&& T.unwords [T.pack myOptimusManager, "--switch", mode, "--no-confirm"]
|
T.pack myPrimeOffload
|
||||||
#!&& "killall xmonad"
|
#!&& T.unwords [T.pack myOptimusManager, "--switch", mode, "--no-confirm"]
|
||||||
|
#!&& "killall xmonad"
|
||||||
|
|
||||||
runOptimusPrompt :: SometimesX
|
runOptimusPrompt :: SometimesX
|
||||||
runOptimusPrompt = Sometimes "graphics switcher"
|
runOptimusPrompt =
|
||||||
(\x -> xpfOptimus x && xpfBattery x) [s]
|
Sometimes
|
||||||
|
"graphics switcher"
|
||||||
|
(\x -> xpfOptimus x && xpfBattery x)
|
||||||
|
[s]
|
||||||
where
|
where
|
||||||
s = Subfeature { sfData = r, sfName = "optimus manager" }
|
s = Subfeature {sfData = r, sfName = "optimus manager"}
|
||||||
r = IORoot runOptimusPrompt' t
|
r = IORoot runOptimusPrompt' t
|
||||||
t = And1 promptFontDep
|
t =
|
||||||
$ listToAnds (socketExists "optimus-manager" [] socketName)
|
And1 promptFontDep $
|
||||||
$ sysExe optimusPackages <$> [myOptimusManager, myPrimeOffload]
|
listToAnds (socketExists "optimus-manager" [] socketName) $
|
||||||
|
sysExe optimusPackages <$> [myOptimusManager, myPrimeOffload]
|
||||||
socketName = (</> "optimus-manager") <$> getTemporaryDirectory
|
socketName = (</> "optimus-manager") <$> getTemporaryDirectory
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Universal power prompt
|
-- Universal power prompt
|
||||||
|
|
||||||
data PowerMaybeAction = Poweroff
|
data PowerMaybeAction
|
||||||
| Shutdown
|
= Poweroff
|
||||||
| Hibernate
|
| Shutdown
|
||||||
| Reboot
|
| Hibernate
|
||||||
deriving (Eq)
|
| Reboot
|
||||||
|
deriving (Eq)
|
||||||
|
|
||||||
instance Enum PowerMaybeAction where
|
instance Enum PowerMaybeAction where
|
||||||
toEnum 0 = Poweroff
|
toEnum 0 = Poweroff
|
||||||
|
@ -180,15 +186,15 @@ instance Enum PowerMaybeAction where
|
||||||
toEnum 3 = Reboot
|
toEnum 3 = Reboot
|
||||||
toEnum _ = errorWithoutStackTrace "Main.Enum.PowerMaybeAction.toEnum: bad argument"
|
toEnum _ = errorWithoutStackTrace "Main.Enum.PowerMaybeAction.toEnum: bad argument"
|
||||||
|
|
||||||
fromEnum Poweroff = 0
|
fromEnum Poweroff = 0
|
||||||
fromEnum Shutdown = 1
|
fromEnum Shutdown = 1
|
||||||
fromEnum Hibernate = 2
|
fromEnum Hibernate = 2
|
||||||
fromEnum Reboot = 3
|
fromEnum Reboot = 3
|
||||||
|
|
||||||
data PowerPrompt = PowerPrompt
|
data PowerPrompt = PowerPrompt
|
||||||
|
|
||||||
instance XPrompt PowerPrompt where
|
instance XPrompt PowerPrompt where
|
||||||
showXPrompt PowerPrompt = "(P)oweroff (S)uspend (H)ibernate (R)eboot:"
|
showXPrompt PowerPrompt = "(P)oweroff (S)uspend (H)ibernate (R)eboot:"
|
||||||
|
|
||||||
runPowerPrompt :: SometimesX
|
runPowerPrompt :: SometimesX
|
||||||
runPowerPrompt = Sometimes "power prompt" (const True) [sf]
|
runPowerPrompt = Sometimes "power prompt" (const True) [sf]
|
||||||
|
@ -202,20 +208,22 @@ powerPrompt :: X () -> XT.FontBuilder -> X ()
|
||||||
powerPrompt lock fb = mkXPrompt PowerPrompt theme comp executeMaybeAction
|
powerPrompt lock fb = mkXPrompt PowerPrompt theme comp executeMaybeAction
|
||||||
where
|
where
|
||||||
comp = mkComplFunFromList theme []
|
comp = mkComplFunFromList theme []
|
||||||
theme = (XT.promptTheme fb) { promptKeymap = keymap }
|
theme = (XT.promptTheme fb) {promptKeymap = keymap}
|
||||||
keymap = M.fromList
|
keymap =
|
||||||
$ ((controlMask, xK_g), quit) :
|
M.fromList $
|
||||||
map (first $ (,) 0)
|
((controlMask, xK_g), quit)
|
||||||
[ (xK_p, sendMaybeAction Poweroff)
|
: map
|
||||||
, (xK_s, sendMaybeAction Shutdown)
|
(first $ (,) 0)
|
||||||
, (xK_h, sendMaybeAction Hibernate)
|
[ (xK_p, sendMaybeAction Poweroff)
|
||||||
, (xK_r, sendMaybeAction Reboot)
|
, (xK_s, sendMaybeAction Shutdown)
|
||||||
, (xK_Return, quit)
|
, (xK_h, sendMaybeAction Hibernate)
|
||||||
, (xK_Escape, quit)
|
, (xK_r, sendMaybeAction Reboot)
|
||||||
]
|
, (xK_Return, quit)
|
||||||
|
, (xK_Escape, quit)
|
||||||
|
]
|
||||||
sendMaybeAction a = setInput (show $ fromEnum a) >> setSuccess True >> setDone True
|
sendMaybeAction a = setInput (show $ fromEnum a) >> setSuccess True >> setDone True
|
||||||
executeMaybeAction a = case toEnum $ read a of
|
executeMaybeAction a = case toEnum $ read a of
|
||||||
Poweroff -> runPowerOff
|
Poweroff -> runPowerOff
|
||||||
Shutdown -> lock >> runSuspend
|
Shutdown -> lock >> runSuspend
|
||||||
Hibernate -> lock >> runHibernate
|
Hibernate -> lock >> runHibernate
|
||||||
Reboot -> runReboot
|
Reboot -> runReboot
|
||||||
|
|
|
@ -1,38 +1,37 @@
|
||||||
{-# LANGUAGE LambdaCase #-}
|
{-# LANGUAGE LambdaCase #-}
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Concurrent module to handle events from acpid
|
-- Concurrent module to handle events from acpid
|
||||||
|
|
||||||
module XMonad.Internal.Concurrent.ACPIEvent
|
module XMonad.Internal.Concurrent.ACPIEvent
|
||||||
( runPowermon
|
( runPowermon
|
||||||
, runHandleACPI
|
, runHandleACPI
|
||||||
) where
|
)
|
||||||
|
where
|
||||||
|
|
||||||
import Data.Internal.Dependency
|
import Data.Internal.Dependency
|
||||||
|
import Network.Socket
|
||||||
import Network.Socket
|
import Network.Socket.ByteString
|
||||||
import Network.Socket.ByteString
|
import RIO
|
||||||
|
import qualified RIO.ByteString as B
|
||||||
import RIO
|
import XMonad.Core
|
||||||
import qualified RIO.ByteString as B
|
import XMonad.Internal.Command.Power
|
||||||
|
import XMonad.Internal.Concurrent.ClientMessage
|
||||||
import XMonad.Core
|
import XMonad.Internal.Shell
|
||||||
import XMonad.Internal.Command.Power
|
import XMonad.Internal.Theme (FontBuilder)
|
||||||
import XMonad.Internal.Concurrent.ClientMessage
|
|
||||||
import XMonad.Internal.Shell
|
|
||||||
import XMonad.Internal.Theme (FontBuilder)
|
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Data structure to hold the ACPI events I care about
|
-- Data structure to hold the ACPI events I care about
|
||||||
--
|
--
|
||||||
-- Enumerate so these can be converted to strings and back when sent in a
|
-- Enumerate so these can be converted to strings and back when sent in a
|
||||||
-- ClientMessage event to X
|
-- ClientMessage event to X
|
||||||
|
|
||||||
data ACPIEvent = Power
|
data ACPIEvent
|
||||||
| Sleep
|
= Power
|
||||||
| LidClose
|
| Sleep
|
||||||
deriving (Eq)
|
| LidClose
|
||||||
|
deriving (Eq)
|
||||||
|
|
||||||
instance Enum ACPIEvent where
|
instance Enum ACPIEvent where
|
||||||
toEnum 0 = Power
|
toEnum 0 = Power
|
||||||
|
@ -40,24 +39,24 @@ instance Enum ACPIEvent where
|
||||||
toEnum 2 = LidClose
|
toEnum 2 = LidClose
|
||||||
toEnum _ = errorWithoutStackTrace "ACPI.Enum.ACPIEvent.toEnum: bad argument"
|
toEnum _ = errorWithoutStackTrace "ACPI.Enum.ACPIEvent.toEnum: bad argument"
|
||||||
|
|
||||||
fromEnum Power = 0
|
fromEnum Power = 0
|
||||||
fromEnum Sleep = 1
|
fromEnum Sleep = 1
|
||||||
fromEnum LidClose = 2
|
fromEnum LidClose = 2
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Internal functions
|
-- Internal functions
|
||||||
|
|
||||||
-- | Convert a string to an ACPI event (this string is assumed to come from
|
-- | Convert a string to an ACPI event (this string is assumed to come from
|
||||||
-- the acpid socket)
|
-- the acpid socket)
|
||||||
parseLine :: ByteString -> Maybe ACPIEvent
|
parseLine :: ByteString -> Maybe ACPIEvent
|
||||||
parseLine line =
|
parseLine line =
|
||||||
case splitLine line of
|
case splitLine line of
|
||||||
(_:"PBTN":_) -> Just Power
|
(_ : "PBTN" : _) -> Just Power
|
||||||
(_:"PWRF":_) -> Just Power
|
(_ : "PWRF" : _) -> Just Power
|
||||||
(_:"SLPB":_) -> Just Sleep
|
(_ : "SLPB" : _) -> Just Sleep
|
||||||
(_:"SBTN":_) -> Just Sleep
|
(_ : "SBTN" : _) -> Just Sleep
|
||||||
(_:"LID":"close":_) -> Just LidClose
|
(_ : "LID" : "close" : _) -> Just LidClose
|
||||||
_ -> Nothing
|
_ -> Nothing
|
||||||
where
|
where
|
||||||
splitLine = B.split space . B.reverse . B.dropWhile (== newline) . B.reverse
|
splitLine = B.split space . B.reverse . B.dropWhile (== newline) . B.reverse
|
||||||
newline = 10
|
newline = 10
|
||||||
|
@ -71,7 +70,7 @@ isDischarging :: IO (Maybe Bool)
|
||||||
isDischarging = do
|
isDischarging = do
|
||||||
status <- tryIO $ B.readFile "/sys/class/power_supply/BAT0/status"
|
status <- tryIO $ B.readFile "/sys/class/power_supply/BAT0/status"
|
||||||
case status of
|
case status of
|
||||||
Left _ -> return Nothing
|
Left _ -> return Nothing
|
||||||
Right s -> return $ Just (s == "Discharging")
|
Right s -> return $ Just (s == "Discharging")
|
||||||
|
|
||||||
listenACPI :: IO ()
|
listenACPI :: IO ()
|
||||||
|
@ -103,7 +102,7 @@ handleACPI fb lock tag = do
|
||||||
lock
|
lock
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Exported API
|
-- Exported API
|
||||||
|
|
||||||
-- | Spawn a new thread that will listen for ACPI events on the acpid socket
|
-- | Spawn a new thread that will listen for ACPI events on the acpid socket
|
||||||
-- and send ClientMessage events when it receives them
|
-- and send ClientMessage events when it receives them
|
||||||
|
@ -114,7 +113,9 @@ runHandleACPI :: Always (String -> X ())
|
||||||
runHandleACPI = Always "ACPI event handler" $ Option sf fallback
|
runHandleACPI = Always "ACPI event handler" $ Option sf fallback
|
||||||
where
|
where
|
||||||
sf = Subfeature withLock "acpid prompt"
|
sf = Subfeature withLock "acpid prompt"
|
||||||
withLock = IORoot (uncurry handleACPI)
|
withLock =
|
||||||
$ And12 (,) promptFontDep $ Only
|
IORoot (uncurry handleACPI) $
|
||||||
$ IOSometimes runScreenLock id
|
And12 (,) promptFontDep $
|
||||||
|
Only $
|
||||||
|
IOSometimes runScreenLock id
|
||||||
fallback = Always_ $ FallbackAlone $ const skip
|
fallback = Always_ $ FallbackAlone $ const skip
|
||||||
|
|
|
@ -1,5 +1,5 @@
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Core ClientMessage module to 'achieve' concurrency in XMonad
|
-- Core ClientMessage module to 'achieve' concurrency in XMonad
|
||||||
--
|
--
|
||||||
-- Since XMonad is single threaded, the only way to have multiple threads that
|
-- Since XMonad is single threaded, the only way to have multiple threads that
|
||||||
-- listen/react to non-X events is to spawn other threads the run outside of
|
-- listen/react to non-X events is to spawn other threads the run outside of
|
||||||
|
@ -16,50 +16,50 @@
|
||||||
-- much like something from X even though it isn't
|
-- much like something from X even though it isn't
|
||||||
|
|
||||||
module XMonad.Internal.Concurrent.ClientMessage
|
module XMonad.Internal.Concurrent.ClientMessage
|
||||||
( XMsgType(..)
|
( XMsgType (..)
|
||||||
, sendXMsg
|
, sendXMsg
|
||||||
, splitXMsg
|
, splitXMsg
|
||||||
) where
|
)
|
||||||
|
where
|
||||||
|
|
||||||
import Data.Char
|
import Data.Char
|
||||||
|
import Graphics.X11.Types
|
||||||
import Graphics.X11.Types
|
import Graphics.X11.Xlib.Atom
|
||||||
import Graphics.X11.Xlib.Atom
|
import Graphics.X11.Xlib.Display
|
||||||
import Graphics.X11.Xlib.Display
|
import Graphics.X11.Xlib.Event
|
||||||
import Graphics.X11.Xlib.Event
|
import Graphics.X11.Xlib.Extras
|
||||||
import Graphics.X11.Xlib.Extras
|
import Graphics.X11.Xlib.Types
|
||||||
import Graphics.X11.Xlib.Types
|
import RIO hiding (Display)
|
||||||
|
|
||||||
import RIO hiding (Display)
|
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Data structure for the ClientMessage
|
-- Data structure for the ClientMessage
|
||||||
--
|
--
|
||||||
-- These are the "types" of client messages to send; add more here as needed
|
-- These are the "types" of client messages to send; add more here as needed
|
||||||
|
|
||||||
-- TODO is there a way to do this in the libraries that import this one?
|
-- TODO is there a way to do this in the libraries that import this one?
|
||||||
data XMsgType = ACPI
|
data XMsgType
|
||||||
| Workspace
|
= ACPI
|
||||||
| Unknown
|
| Workspace
|
||||||
deriving (Eq, Show)
|
| Unknown
|
||||||
|
deriving (Eq, Show)
|
||||||
|
|
||||||
instance Enum XMsgType where
|
instance Enum XMsgType where
|
||||||
toEnum 0 = ACPI
|
toEnum 0 = ACPI
|
||||||
toEnum 1 = Workspace
|
toEnum 1 = Workspace
|
||||||
toEnum _ = errorWithoutStackTrace "ACPI.Enum.ACPIEvent.toEnum: bad argument"
|
toEnum _ = errorWithoutStackTrace "ACPI.Enum.ACPIEvent.toEnum: bad argument"
|
||||||
|
|
||||||
fromEnum ACPI = 0
|
fromEnum ACPI = 0
|
||||||
fromEnum Workspace = 1
|
fromEnum Workspace = 1
|
||||||
fromEnum Unknown = 2
|
fromEnum Unknown = 2
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Exported API
|
-- Exported API
|
||||||
|
|
||||||
-- | Given a string from the data field in a ClientMessage event, return the
|
-- | Given a string from the data field in a ClientMessage event, return the
|
||||||
-- type and payload
|
-- type and payload
|
||||||
splitXMsg :: (Integral a) => [a] -> (XMsgType, String)
|
splitXMsg :: (Integral a) => [a] -> (XMsgType, String)
|
||||||
splitXMsg [] = (Unknown, "")
|
splitXMsg [] = (Unknown, "")
|
||||||
splitXMsg (x:xs) = (xtype, tag)
|
splitXMsg (x : xs) = (xtype, tag)
|
||||||
where
|
where
|
||||||
xtype = toEnum $ fromIntegral x
|
xtype = toEnum $ fromIntegral x
|
||||||
tag = chr . fromIntegral <$> takeWhile (/= 0) xs
|
tag = chr . fromIntegral <$> takeWhile (/= 0) xs
|
||||||
|
@ -91,7 +91,7 @@ sendXMsg xtype tag = withOpenDisplay $ \dpy -> do
|
||||||
-- longer will be clipped to 19, and anything less than 19 will be padded
|
-- longer will be clipped to 19, and anything less than 19 will be padded
|
||||||
-- with 0 (note this used to be random garbage before). See this function
|
-- with 0 (note this used to be random garbage before). See this function
|
||||||
-- for more details.
|
-- for more details.
|
||||||
setClientMessageEvent' e root bITMAP 8 (x:t)
|
setClientMessageEvent' e root bITMAP 8 (x : t)
|
||||||
sendEvent dpy root False substructureNotifyMask e
|
sendEvent dpy root False substructureNotifyMask e
|
||||||
where
|
where
|
||||||
x = fromIntegral $ fromEnum xtype
|
x = fromIntegral $ fromEnum xtype
|
||||||
|
|
|
@ -1,5 +1,5 @@
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Automatically Manage Dynamic Workspaces
|
-- Automatically Manage Dynamic Workspaces
|
||||||
-- This is a somewhat convoluted wrapper for the Dymamic Workspaces module
|
-- This is a somewhat convoluted wrapper for the Dymamic Workspaces module
|
||||||
-- in the contrib library. The general behavior this allows:
|
-- in the contrib library. The general behavior this allows:
|
||||||
-- 1) launch app
|
-- 1) launch app
|
||||||
|
@ -24,72 +24,66 @@
|
||||||
-- 3) Virtualbox (should always be by itself anyways)
|
-- 3) Virtualbox (should always be by itself anyways)
|
||||||
|
|
||||||
module XMonad.Internal.Concurrent.DynamicWorkspaces
|
module XMonad.Internal.Concurrent.DynamicWorkspaces
|
||||||
( DynWorkspace(..)
|
( DynWorkspace (..)
|
||||||
, appendShift
|
, appendShift
|
||||||
, appendViewShift
|
, appendViewShift
|
||||||
, removeDynamicWorkspace
|
, removeDynamicWorkspace
|
||||||
, runWorkspaceMon
|
, runWorkspaceMon
|
||||||
, spawnOrSwitch
|
, spawnOrSwitch
|
||||||
, doSink
|
, doSink
|
||||||
) where
|
)
|
||||||
|
where
|
||||||
import Data.List (deleteBy, find)
|
|
||||||
import qualified Data.Map as M
|
|
||||||
import Data.Maybe
|
|
||||||
|
|
||||||
-- import Control.Concurrent
|
-- import Control.Concurrent
|
||||||
import Control.Monad
|
import Control.Monad
|
||||||
import Control.Monad.Reader
|
import Control.Monad.Reader
|
||||||
|
import Data.List (deleteBy, find)
|
||||||
|
import qualified Data.Map as M
|
||||||
import Graphics.X11.Types
|
import Data.Maybe
|
||||||
|
import Graphics.X11.Types
|
||||||
import Graphics.X11.Xlib.Atom
|
import Graphics.X11.Xlib.Atom
|
||||||
import Graphics.X11.Xlib.Display
|
import Graphics.X11.Xlib.Display
|
||||||
import Graphics.X11.Xlib.Event
|
import Graphics.X11.Xlib.Event
|
||||||
import Graphics.X11.Xlib.Extras
|
import Graphics.X11.Xlib.Extras
|
||||||
import Graphics.X11.Xlib.Misc
|
import Graphics.X11.Xlib.Misc
|
||||||
import Graphics.X11.Xlib.Types
|
import Graphics.X11.Xlib.Types
|
||||||
|
import RIO hiding
|
||||||
import RIO hiding
|
( Display
|
||||||
( Display
|
, display
|
||||||
, display
|
)
|
||||||
)
|
import qualified RIO.Set as S
|
||||||
import qualified RIO.Set as S
|
import System.Process
|
||||||
|
import XMonad.Actions.DynamicWorkspaces
|
||||||
import System.Process
|
import XMonad.Core
|
||||||
|
( ManageHook
|
||||||
import XMonad.Actions.DynamicWorkspaces
|
, WorkspaceId
|
||||||
import XMonad.Core
|
, X
|
||||||
( ManageHook
|
, io
|
||||||
, WorkspaceId
|
, withWindowSet
|
||||||
, X
|
)
|
||||||
, io
|
import XMonad.Hooks.ManageHelpers (MaybeManageHook)
|
||||||
, withWindowSet
|
import XMonad.Internal.Concurrent.ClientMessage
|
||||||
)
|
import XMonad.Internal.IO
|
||||||
import XMonad.Hooks.ManageHelpers (MaybeManageHook)
|
import XMonad.ManageHook
|
||||||
import XMonad.Internal.Concurrent.ClientMessage
|
import XMonad.Operations
|
||||||
import XMonad.Internal.IO
|
import qualified XMonad.StackSet as W
|
||||||
import XMonad.ManageHook
|
|
||||||
import XMonad.Operations
|
|
||||||
import qualified XMonad.StackSet as W
|
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Dynamic Workspace datatype
|
-- Dynamic Workspace datatype
|
||||||
-- This hold all the data needed to tie an app to a particular dynamic workspace
|
-- This holds all the data needed to tie an app to a particular dynamic workspace
|
||||||
|
|
||||||
data DynWorkspace = DynWorkspace
|
data DynWorkspace = DynWorkspace
|
||||||
{ dwName :: String
|
{ dwName :: String
|
||||||
, dwTag :: WorkspaceId
|
, dwTag :: WorkspaceId
|
||||||
, dwClass :: String
|
, dwClass :: String
|
||||||
, dwHook :: [MaybeManageHook]
|
, dwHook :: [MaybeManageHook]
|
||||||
, dwKey :: Char
|
, dwKey :: Char
|
||||||
, dwCmd :: Maybe (X ())
|
, dwCmd :: Maybe (X ())
|
||||||
-- TODO this should also have the layout for this workspace
|
-- TODO this should also have the layout for this workspace
|
||||||
}
|
}
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Manager thread
|
-- Manager thread
|
||||||
-- The main thread that watches for new windows. When a match is found, this
|
-- The main thread that watches for new windows. When a match is found, this
|
||||||
-- thread spawns a new thread the waits for the PID of the window to exit. When
|
-- thread spawns a new thread the waits for the PID of the window to exit. When
|
||||||
-- the PID exits, it sends a ClientMessage event to X
|
-- the PID exits, it sends a ClientMessage event to X
|
||||||
|
@ -99,10 +93,10 @@ data DynWorkspace = DynWorkspace
|
||||||
-- type MatchTags = M.Map String String
|
-- type MatchTags = M.Map String String
|
||||||
|
|
||||||
data WConf = WConf
|
data WConf = WConf
|
||||||
{ display :: Display
|
{ display :: Display
|
||||||
, dynWorkspaces :: [DynWorkspace]
|
, dynWorkspaces :: [DynWorkspace]
|
||||||
, curPIDs :: MVar (S.Set Pid)
|
, curPIDs :: MVar (S.Set Pid)
|
||||||
}
|
}
|
||||||
|
|
||||||
type W a = RIO WConf ()
|
type W a = RIO WConf ()
|
||||||
|
|
||||||
|
@ -120,51 +114,56 @@ runWorkspaceMon dws = withOpenDisplay $ \dpy -> do
|
||||||
where
|
where
|
||||||
withEvents dpy e = do
|
withEvents dpy e = do
|
||||||
ps <- newMVar S.empty
|
ps <- newMVar S.empty
|
||||||
let c = WConf { display = dpy, dynWorkspaces = dws, curPIDs = ps }
|
let c = WConf {display = dpy, dynWorkspaces = dws, curPIDs = ps}
|
||||||
runRIO c
|
runRIO c $
|
||||||
$ forever
|
forever $
|
||||||
$ handleEvent =<< io (nextEvent dpy e >> getEvent e)
|
handleEvent =<< io (nextEvent dpy e >> getEvent e)
|
||||||
|
|
||||||
handleEvent :: Event -> W ()
|
handleEvent :: Event -> W ()
|
||||||
|
|
||||||
-- | assume this fires at least once when a new window is created (also could
|
-- | assume this fires at least once when a new window is created (also could
|
||||||
-- use CreateNotify but that is really noisy)
|
-- use CreateNotify but that is really noisy)
|
||||||
handleEvent MapNotifyEvent { ev_window = w } = do
|
handleEvent MapNotifyEvent {ev_window = w} = do
|
||||||
dpy <- asks display
|
dpy <- asks display
|
||||||
hint <- io $ getClassHint dpy w
|
hint <- io $ getClassHint dpy w
|
||||||
dws <- asks dynWorkspaces
|
dws <- asks dynWorkspaces
|
||||||
let tag = M.lookup (resClass hint)
|
let tag =
|
||||||
$ M.fromList
|
M.lookup (resClass hint) $
|
||||||
$ fmap (\DynWorkspace { dwTag = t, dwClass = c } -> (c, t)) dws
|
M.fromList $
|
||||||
|
fmap (\DynWorkspace {dwTag = t, dwClass = c} -> (c, t)) dws
|
||||||
forM_ tag $ \t -> do
|
forM_ tag $ \t -> do
|
||||||
a <- io $ internAtom dpy "_NET_WM_PID" False
|
a <- io $ internAtom dpy "_NET_WM_PID" False
|
||||||
pid <- io $ getWindowProperty32 dpy a w
|
pid <- io $ getWindowProperty32 dpy a w
|
||||||
case pid of
|
case pid of
|
||||||
-- ASSUMPTION windows will only have one PID at one time
|
-- ASSUMPTION windows will only have one PID at one time
|
||||||
Just [p] -> let p' = fromIntegral p in void $ async $ withUniquePid p' t
|
Just [p] -> let p' = fromIntegral p in void $ async $ withUniquePid p' t
|
||||||
_ -> return ()
|
_ -> return ()
|
||||||
|
|
||||||
handleEvent _ = return ()
|
handleEvent _ = return ()
|
||||||
|
|
||||||
withUniquePid :: Pid -> String -> W ()
|
withUniquePid :: Pid -> String -> W ()
|
||||||
withUniquePid pid tag = do
|
withUniquePid pid tag = do
|
||||||
ps <- asks curPIDs
|
ps <- asks curPIDs
|
||||||
pids <- readMVar ps
|
pids <- readMVar ps
|
||||||
io $ unless (pid `elem` pids) $ bracket_
|
io
|
||||||
(modifyMVar_ ps (return . S.insert pid))
|
$ unless (pid `elem` pids)
|
||||||
(modifyMVar_ ps (return . S.delete pid))
|
$ bracket_
|
||||||
|
(modifyMVar_ ps (return . S.insert pid))
|
||||||
|
(modifyMVar_ ps (return . S.delete pid))
|
||||||
$ waitUntilExit pid >> sendXMsg Workspace tag
|
$ waitUntilExit pid >> sendXMsg Workspace tag
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Launching apps
|
-- Launching apps
|
||||||
-- When launching apps on dymamic workspaces, first check if they are running
|
-- When launching apps on dymamic workspaces, first check if they are running
|
||||||
-- and launch if not, then switch to their workspace
|
-- and launch if not, then switch to their workspace
|
||||||
|
|
||||||
wsOccupied :: Eq a1 => a1 -> W.StackSet a1 l a2 sid sd -> Bool
|
wsOccupied :: Eq a1 => a1 -> W.StackSet a1 l a2 sid sd -> Bool
|
||||||
wsOccupied tag ws = elem tag $ map W.tag $ filter (isJust . W.stack)
|
wsOccupied tag ws =
|
||||||
-- list of all workspaces with windows on them
|
elem tag $
|
||||||
-- TODO is there not a better way to do this?
|
map W.tag $
|
||||||
$ W.workspace (W.current ws) : W.hidden ws ++ map W.workspace (W.visible ws)
|
filter (isJust . W.stack)
|
||||||
|
-- list of all workspaces with windows on them
|
||||||
|
-- TODO is there not a better way to do this?
|
||||||
|
$
|
||||||
|
W.workspace (W.current ws) : W.hidden ws ++ map W.workspace (W.visible ws)
|
||||||
|
|
||||||
spawnOrSwitch :: WorkspaceId -> X () -> X ()
|
spawnOrSwitch :: WorkspaceId -> X () -> X ()
|
||||||
spawnOrSwitch tag cmd = do
|
spawnOrSwitch tag cmd = do
|
||||||
|
@ -172,7 +171,7 @@ spawnOrSwitch tag cmd = do
|
||||||
if occupied then windows $ W.view tag else cmd
|
if occupied then windows $ W.view tag else cmd
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Managehook
|
-- Managehook
|
||||||
-- Move windows to new workspace if they are part of a dynamic workspace
|
-- Move windows to new workspace if they are part of a dynamic workspace
|
||||||
|
|
||||||
-- shamelessly ripped off from appendWorkspace (this analogue doesn't exist)
|
-- shamelessly ripped off from appendWorkspace (this analogue doesn't exist)
|
||||||
|
@ -193,29 +192,31 @@ appendViewShift tag = liftX (appendWorkspace tag) >> viewShift tag
|
||||||
-- TODO surprisingly this doesn't exist? We shouldn't need to TBH
|
-- TODO surprisingly this doesn't exist? We shouldn't need to TBH
|
||||||
doSink :: ManageHook
|
doSink :: ManageHook
|
||||||
doSink = doF $ \s -> case W.stack $ W.workspace $ W.current s of
|
doSink = doF $ \s -> case W.stack $ W.workspace $ W.current s of
|
||||||
Just s' -> W.sink (W.focus s') s
|
Just s' -> W.sink (W.focus s') s
|
||||||
Nothing -> s
|
Nothing -> s
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Eventhook
|
-- Eventhook
|
||||||
|
|
||||||
-- When an app is closed, this will respond the event that is sent in the main
|
-- When an app is closed, this will respond the event that is sent in the main
|
||||||
-- XMonad thread
|
-- XMonad thread
|
||||||
|
|
||||||
removeDynamicWorkspace :: WorkspaceId -> X ()
|
removeDynamicWorkspace :: WorkspaceId -> X ()
|
||||||
removeDynamicWorkspace target = windows removeIfEmpty
|
removeDynamicWorkspace target = windows removeIfEmpty
|
||||||
where
|
where
|
||||||
-- remove workspace if it is empty and if there are hidden workspaces
|
-- remove workspace if it is empty and if there are hidden workspaces
|
||||||
removeIfEmpty s@W.StackSet { W.visible = vis, W.hidden = hall@(h:hs) }
|
removeIfEmpty s@W.StackSet {W.visible = vis, W.hidden = hall@(h : hs)}
|
||||||
-- if hidden, delete from hidden
|
-- if hidden, delete from hidden
|
||||||
| Just x <- find isEmptyTarget hall
|
| Just x <- find isEmptyTarget hall =
|
||||||
= s { W.hidden = deleteBy (eq W.tag) x hall }
|
s {W.hidden = deleteBy (eq W.tag) x hall}
|
||||||
-- if visible, delete from visible and move first hidden to its place
|
-- if visible, delete from visible and move first hidden to its place
|
||||||
| Just x <- find (isEmptyTarget . W.workspace) vis
|
| Just x <- find (isEmptyTarget . W.workspace) vis =
|
||||||
= s { W.visible = x { W.workspace = h } : deleteBy (eq W.screen) x vis
|
s
|
||||||
, W.hidden = hs }
|
{ W.visible = x {W.workspace = h} : deleteBy (eq W.screen) x vis
|
||||||
|
, W.hidden = hs
|
||||||
|
}
|
||||||
-- if current, move the first hidden workspace to the current
|
-- if current, move the first hidden workspace to the current
|
||||||
| isEmptyTarget $ W.workspace $ W.current s
|
| isEmptyTarget $ W.workspace $ W.current s =
|
||||||
= s { W.current = (W.current s) { W.workspace = h }, W.hidden = hs }
|
s {W.current = (W.current s) {W.workspace = h}, W.hidden = hs}
|
||||||
-- otherwise do nothing
|
-- otherwise do nothing
|
||||||
| otherwise = s
|
| otherwise = s
|
||||||
removeIfEmpty s = s
|
removeIfEmpty s = s
|
||||||
|
|
|
@ -1,25 +1,23 @@
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
{-# LANGUAGE ScopedTypeVariables #-}
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | VirtualBox-specific functions
|
-- VirtualBox-specific functions
|
||||||
|
|
||||||
module XMonad.Internal.Concurrent.VirtualBox
|
module XMonad.Internal.Concurrent.VirtualBox
|
||||||
( vmExists
|
( vmExists
|
||||||
, vmInstanceConfig
|
, vmInstanceConfig
|
||||||
, qual
|
, qual
|
||||||
) where
|
)
|
||||||
|
where
|
||||||
|
|
||||||
import Data.Internal.Dependency
|
import Data.Internal.Dependency
|
||||||
|
import RIO hiding (try)
|
||||||
import Text.XML.Light
|
import RIO.Directory
|
||||||
|
import RIO.FilePath
|
||||||
import RIO hiding (try)
|
import qualified RIO.Text as T
|
||||||
import RIO.Directory
|
import Text.XML.Light
|
||||||
import RIO.FilePath
|
import XMonad.Internal.Shell
|
||||||
import qualified RIO.Text as T
|
|
||||||
|
|
||||||
import XMonad.Internal.Shell
|
|
||||||
|
|
||||||
vmExists :: T.Text -> IO (Maybe Msg)
|
vmExists :: T.Text -> IO (Maybe Msg)
|
||||||
vmExists vm = either (Just . Msg LevelError) (const Nothing) <$> vmInstanceConfig vm
|
vmExists vm = either (Just . Msg LevelError) (const Nothing) <$> vmInstanceConfig vm
|
||||||
|
@ -32,7 +30,7 @@ vmInstanceConfig vmName = do
|
||||||
findInstance dir = do
|
findInstance dir = do
|
||||||
res <- findFile [dir] path
|
res <- findFile [dir] path
|
||||||
return $ case res of
|
return $ case res of
|
||||||
Just p -> Right p
|
Just p -> Right p
|
||||||
Nothing -> Left $ T.append "could not find VM instance: " $ singleQuote vmName
|
Nothing -> Left $ T.append "could not find VM instance: " $ singleQuote vmName
|
||||||
|
|
||||||
vmDirectory :: IO (Either String String)
|
vmDirectory :: IO (Either String String)
|
||||||
|
@ -41,15 +39,17 @@ vmDirectory = do
|
||||||
s <- tryIO $ readFile p
|
s <- tryIO $ readFile p
|
||||||
return $ case s of
|
return $ case s of
|
||||||
(Left _) -> Left "could not read VirtualBox config file"
|
(Left _) -> Left "could not read VirtualBox config file"
|
||||||
(Right x) -> maybe (Left "Could not parse VirtualBox config file") Right
|
(Right x) ->
|
||||||
$ findDir =<< parseXMLDoc x
|
maybe (Left "Could not parse VirtualBox config file") Right $
|
||||||
|
findDir =<< parseXMLDoc x
|
||||||
where
|
where
|
||||||
findDir e = findAttr (unqual "defaultMachineFolder")
|
findDir e =
|
||||||
=<< findChild (qual e "SystemProperties")
|
findAttr (unqual "defaultMachineFolder")
|
||||||
=<< findChild (qual e "Global") e
|
=<< findChild (qual e "SystemProperties")
|
||||||
|
=<< findChild (qual e "Global") e
|
||||||
|
|
||||||
qual :: Element -> String -> QName
|
qual :: Element -> String -> QName
|
||||||
qual e n = (elName e) { qName = n }
|
qual e n = (elName e) {qName = n}
|
||||||
|
|
||||||
vmConfig :: IO FilePath
|
vmConfig :: IO FilePath
|
||||||
vmConfig = getXdgDirectory XdgConfig "VirtualBox/VirtualBox.xml"
|
vmConfig = getXdgDirectory XdgConfig "VirtualBox/VirtualBox.xml"
|
||||||
|
|
|
@ -1,7 +1,7 @@
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | DBus module for Clevo Keyboard control
|
-- DBus module for Clevo Keyboard control
|
||||||
|
|
||||||
module XMonad.Internal.DBus.Brightness.ClevoKeyboard
|
module XMonad.Internal.DBus.Brightness.ClevoKeyboard
|
||||||
( callGetBrightnessCK
|
( callGetBrightnessCK
|
||||||
|
@ -10,24 +10,21 @@ module XMonad.Internal.DBus.Brightness.ClevoKeyboard
|
||||||
, clevoKeyboardControls
|
, clevoKeyboardControls
|
||||||
, clevoKeyboardSignalDep
|
, clevoKeyboardSignalDep
|
||||||
, blPath
|
, blPath
|
||||||
) where
|
)
|
||||||
|
where
|
||||||
|
|
||||||
import Control.Monad (when)
|
import Control.Monad (when)
|
||||||
|
import DBus
|
||||||
import Data.Int (Int32)
|
import Data.Int (Int32)
|
||||||
import Data.Internal.DBus
|
import Data.Internal.DBus
|
||||||
import Data.Internal.Dependency
|
import Data.Internal.Dependency
|
||||||
|
import RIO.FilePath
|
||||||
import DBus
|
import XMonad.Internal.DBus.Brightness.Common
|
||||||
|
import XMonad.Internal.IO
|
||||||
import RIO.FilePath
|
|
||||||
|
|
||||||
import XMonad.Internal.DBus.Brightness.Common
|
|
||||||
import XMonad.Internal.IO
|
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Low level sysfs functions
|
-- Low level sysfs functions
|
||||||
--
|
|
||||||
type Brightness = Float
|
type Brightness = Float
|
||||||
|
|
||||||
type RawBrightness = Int32
|
type RawBrightness = Int32
|
||||||
|
@ -84,7 +81,7 @@ decBrightness bounds = do
|
||||||
return b
|
return b
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | DBus interface
|
-- DBus interface
|
||||||
|
|
||||||
blPath :: ObjectPath
|
blPath :: ObjectPath
|
||||||
blPath = objectPath_ "/clevo_keyboard"
|
blPath = objectPath_ "/clevo_keyboard"
|
||||||
|
@ -93,21 +90,22 @@ interface :: InterfaceName
|
||||||
interface = interfaceName_ "org.xmonad.Brightness"
|
interface = interfaceName_ "org.xmonad.Brightness"
|
||||||
|
|
||||||
clevoKeyboardConfig :: BrightnessConfig RawBrightness Brightness
|
clevoKeyboardConfig :: BrightnessConfig RawBrightness Brightness
|
||||||
clevoKeyboardConfig = BrightnessConfig
|
clevoKeyboardConfig =
|
||||||
{ bcMin = minBrightness
|
BrightnessConfig
|
||||||
, bcMax = maxBrightness
|
{ bcMin = minBrightness
|
||||||
, bcInc = incBrightness
|
, bcMax = maxBrightness
|
||||||
, bcDec = decBrightness
|
, bcInc = incBrightness
|
||||||
, bcGet = getBrightness
|
, bcDec = decBrightness
|
||||||
, bcGetMax = return maxRawBrightness
|
, bcGet = getBrightness
|
||||||
, bcMinRaw = minRawBrightness
|
, bcGetMax = return maxRawBrightness
|
||||||
, bcPath = blPath
|
, bcMinRaw = minRawBrightness
|
||||||
, bcInterface = interface
|
, bcPath = blPath
|
||||||
, bcName = "Clevo keyboard"
|
, bcInterface = interface
|
||||||
}
|
, bcName = "Clevo keyboard"
|
||||||
|
}
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Exported haskell API
|
-- Exported haskell API
|
||||||
|
|
||||||
stateFileDep :: IODependency_
|
stateFileDep :: IODependency_
|
||||||
stateFileDep = pathRW stateFile [Package AUR "tuxedo-keyboard"]
|
stateFileDep = pathRW stateFile [Package AUR "tuxedo-keyboard"]
|
||||||
|
@ -119,8 +117,12 @@ clevoKeyboardSignalDep :: DBusDependency_ SesClient
|
||||||
clevoKeyboardSignalDep = signalDep clevoKeyboardConfig
|
clevoKeyboardSignalDep = signalDep clevoKeyboardConfig
|
||||||
|
|
||||||
exportClevoKeyboard :: Maybe SesClient -> SometimesIO
|
exportClevoKeyboard :: Maybe SesClient -> SometimesIO
|
||||||
exportClevoKeyboard = brightnessExporter xpfClevoBacklight []
|
exportClevoKeyboard =
|
||||||
[stateFileDep, brightnessFileDep] clevoKeyboardConfig
|
brightnessExporter
|
||||||
|
xpfClevoBacklight
|
||||||
|
[]
|
||||||
|
[stateFileDep, brightnessFileDep]
|
||||||
|
clevoKeyboardConfig
|
||||||
|
|
||||||
clevoKeyboardControls :: Maybe SesClient -> BrightnessControls
|
clevoKeyboardControls :: Maybe SesClient -> BrightnessControls
|
||||||
clevoKeyboardControls = brightnessControls xpfClevoBacklight clevoKeyboardConfig
|
clevoKeyboardControls = brightnessControls xpfClevoBacklight clevoKeyboardConfig
|
||||||
|
|
|
@ -1,35 +1,32 @@
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | DBus module for DBus brightness controls
|
-- DBus module for DBus brightness controls
|
||||||
|
|
||||||
module XMonad.Internal.DBus.Brightness.Common
|
module XMonad.Internal.DBus.Brightness.Common
|
||||||
( BrightnessConfig(..)
|
( BrightnessConfig (..)
|
||||||
, BrightnessControls(..)
|
, BrightnessControls (..)
|
||||||
, brightnessControls
|
, brightnessControls
|
||||||
, brightnessExporter
|
, brightnessExporter
|
||||||
, callGetBrightness
|
, callGetBrightness
|
||||||
, matchSignal
|
, matchSignal
|
||||||
, signalDep
|
, signalDep
|
||||||
) where
|
)
|
||||||
|
where
|
||||||
|
|
||||||
import Control.Monad (void)
|
import Control.Monad (void)
|
||||||
|
import DBus
|
||||||
import Data.Int (Int32)
|
import DBus.Client
|
||||||
import Data.Internal.DBus
|
import qualified DBus.Introspection as I
|
||||||
import Data.Internal.Dependency
|
import Data.Int (Int32)
|
||||||
|
import Data.Internal.DBus
|
||||||
import DBus
|
import Data.Internal.Dependency
|
||||||
import DBus.Client
|
import qualified RIO.Text as T
|
||||||
import qualified DBus.Introspection as I
|
import XMonad.Core (io)
|
||||||
|
import XMonad.Internal.DBus.Common
|
||||||
import qualified RIO.Text as T
|
|
||||||
|
|
||||||
import XMonad.Core (io)
|
|
||||||
import XMonad.Internal.DBus.Common
|
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | External API
|
-- External API
|
||||||
--
|
--
|
||||||
-- Define four methods to increase, decrease, maximize, or minimize the
|
-- Define four methods to increase, decrease, maximize, or minimize the
|
||||||
-- brightness. These methods will all return the current brightness as a 32-bit
|
-- brightness. These methods will all return the current brightness as a 32-bit
|
||||||
|
@ -37,16 +34,16 @@ import XMonad.Internal.DBus.Common
|
||||||
-- is one method to get the current brightness.
|
-- is one method to get the current brightness.
|
||||||
|
|
||||||
data BrightnessConfig a b = BrightnessConfig
|
data BrightnessConfig a b = BrightnessConfig
|
||||||
{ bcMin :: (a, a) -> IO b
|
{ bcMin :: (a, a) -> IO b
|
||||||
, bcMax :: (a, a) -> IO b
|
, bcMax :: (a, a) -> IO b
|
||||||
, bcDec :: (a, a) -> IO b
|
, bcDec :: (a, a) -> IO b
|
||||||
, bcInc :: (a, a) -> IO b
|
, bcInc :: (a, a) -> IO b
|
||||||
, bcGet :: (a, a) -> IO b
|
, bcGet :: (a, a) -> IO b
|
||||||
, bcMinRaw :: a
|
, bcMinRaw :: a
|
||||||
, bcGetMax :: IO a
|
, bcGetMax :: IO a
|
||||||
, bcPath :: ObjectPath
|
, bcPath :: ObjectPath
|
||||||
, bcInterface :: InterfaceName
|
, bcInterface :: InterfaceName
|
||||||
, bcName :: T.Text
|
, bcName :: T.Text
|
||||||
}
|
}
|
||||||
|
|
||||||
data BrightnessControls = BrightnessControls
|
data BrightnessControls = BrightnessControls
|
||||||
|
@ -56,46 +53,63 @@ data BrightnessControls = BrightnessControls
|
||||||
, bctlDec :: SometimesX
|
, bctlDec :: SometimesX
|
||||||
}
|
}
|
||||||
|
|
||||||
brightnessControls :: XPQuery -> BrightnessConfig a b -> Maybe SesClient
|
brightnessControls
|
||||||
|
:: XPQuery
|
||||||
|
-> BrightnessConfig a b
|
||||||
|
-> Maybe SesClient
|
||||||
-> BrightnessControls
|
-> BrightnessControls
|
||||||
brightnessControls q bc cl =
|
brightnessControls q bc cl =
|
||||||
BrightnessControls
|
BrightnessControls
|
||||||
{ bctlMax = cb "max brightness" memMax
|
{ bctlMax = cb "max brightness" memMax
|
||||||
, bctlMin = cb "min brightness" memMin
|
, bctlMin = cb "min brightness" memMin
|
||||||
, bctlInc = cb "increase brightness" memInc
|
, bctlInc = cb "increase brightness" memInc
|
||||||
, bctlDec = cb "decrease brightness" memDec
|
, bctlDec = cb "decrease brightness" memDec
|
||||||
}
|
}
|
||||||
where
|
where
|
||||||
cb = callBacklight q cl bc
|
cb = callBacklight q cl bc
|
||||||
|
|
||||||
callGetBrightness :: (SafeClient c, Num n) => BrightnessConfig a b -> c
|
callGetBrightness
|
||||||
|
:: (SafeClient c, Num n)
|
||||||
|
=> BrightnessConfig a b
|
||||||
|
-> c
|
||||||
-> IO (Maybe n)
|
-> IO (Maybe n)
|
||||||
callGetBrightness BrightnessConfig { bcPath = p, bcInterface = i } client =
|
callGetBrightness BrightnessConfig {bcPath = p, bcInterface = i} client =
|
||||||
either (const Nothing) bodyGetBrightness
|
either (const Nothing) bodyGetBrightness
|
||||||
<$> callMethod client xmonadBusName p i memGet
|
<$> callMethod client xmonadBusName p i memGet
|
||||||
|
|
||||||
signalDep :: BrightnessConfig a b -> DBusDependency_ SesClient
|
signalDep :: BrightnessConfig a b -> DBusDependency_ SesClient
|
||||||
signalDep BrightnessConfig { bcPath = p, bcInterface = i } =
|
signalDep BrightnessConfig {bcPath = p, bcInterface = i} =
|
||||||
Endpoint [] xmonadBusName p i $ Signal_ memCur
|
Endpoint [] xmonadBusName p i $ Signal_ memCur
|
||||||
|
|
||||||
matchSignal :: (SafeClient c, Num n) => BrightnessConfig a b
|
matchSignal
|
||||||
-> (Maybe n-> IO ()) -> c -> IO ()
|
:: (SafeClient c, Num n)
|
||||||
matchSignal BrightnessConfig { bcPath = p, bcInterface = i } cb =
|
=> BrightnessConfig a b
|
||||||
|
-> (Maybe n -> IO ())
|
||||||
|
-> c
|
||||||
|
-> IO ()
|
||||||
|
matchSignal BrightnessConfig {bcPath = p, bcInterface = i} cb =
|
||||||
void . addMatchCallback brMatcher (cb . bodyGetBrightness)
|
void . addMatchCallback brMatcher (cb . bodyGetBrightness)
|
||||||
where
|
where
|
||||||
-- TODO add busname to this
|
-- TODO add busname to this
|
||||||
brMatcher = matchAny
|
brMatcher =
|
||||||
{ matchPath = Just p
|
matchAny
|
||||||
, matchInterface = Just i
|
{ matchPath = Just p
|
||||||
, matchMember = Just memCur
|
, matchInterface = Just i
|
||||||
}
|
, matchMember = Just memCur
|
||||||
|
}
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Internal DBus Crap
|
-- Internal DBus Crap
|
||||||
|
|
||||||
brightnessExporter :: RealFrac b => XPQuery -> [Fulfillment] -> [IODependency_]
|
brightnessExporter
|
||||||
-> BrightnessConfig a b -> Maybe SesClient -> SometimesIO
|
:: RealFrac b
|
||||||
brightnessExporter q ful deps bc@BrightnessConfig { bcName = n } cl =
|
=> XPQuery
|
||||||
|
-> [Fulfillment]
|
||||||
|
-> [IODependency_]
|
||||||
|
-> BrightnessConfig a b
|
||||||
|
-> Maybe SesClient
|
||||||
|
-> SometimesIO
|
||||||
|
brightnessExporter q ful deps bc@BrightnessConfig {bcName = n} cl =
|
||||||
Sometimes (T.append n " DBus Interface") q [Subfeature root "exporter"]
|
Sometimes (T.append n " DBus Interface") q [Subfeature root "exporter"]
|
||||||
where
|
where
|
||||||
root = DBusRoot_ (exportBrightnessControls' bc) tree cl
|
root = DBusRoot_ (exportBrightnessControls' bc) tree cl
|
||||||
|
@ -108,51 +122,66 @@ exportBrightnessControls' bc cl = io $ do
|
||||||
let bounds = (bcMinRaw bc, maxval)
|
let bounds = (bcMinRaw bc, maxval)
|
||||||
let autoMethod' m f = autoMethod m $ emitBrightness bc ses =<< f bc bounds
|
let autoMethod' m f = autoMethod m $ emitBrightness bc ses =<< f bc bounds
|
||||||
let funget = bcGet bc
|
let funget = bcGet bc
|
||||||
export ses (bcPath bc) defaultInterface
|
export
|
||||||
{ interfaceName = bcInterface bc
|
ses
|
||||||
, interfaceMethods =
|
(bcPath bc)
|
||||||
[ autoMethod' memMax bcMax
|
defaultInterface
|
||||||
, autoMethod' memMin bcMin
|
{ interfaceName = bcInterface bc
|
||||||
, autoMethod' memInc bcInc
|
, interfaceMethods =
|
||||||
, autoMethod' memDec bcDec
|
[ autoMethod' memMax bcMax
|
||||||
, autoMethod memGet (round <$> funget bounds :: IO Int32)
|
, autoMethod' memMin bcMin
|
||||||
]
|
, autoMethod' memInc bcInc
|
||||||
, interfaceSignals = [sig]
|
, autoMethod' memDec bcDec
|
||||||
}
|
, autoMethod memGet (round <$> funget bounds :: IO Int32)
|
||||||
where
|
]
|
||||||
sig = I.Signal
|
, interfaceSignals = [sig]
|
||||||
{ I.signalName = memCur
|
|
||||||
, I.signalArgs =
|
|
||||||
[
|
|
||||||
I.SignalArg
|
|
||||||
{ I.signalArgName = "brightness"
|
|
||||||
, I.signalArgType = TypeInt32
|
|
||||||
}
|
|
||||||
]
|
|
||||||
}
|
}
|
||||||
|
where
|
||||||
|
sig =
|
||||||
|
I.Signal
|
||||||
|
{ I.signalName = memCur
|
||||||
|
, I.signalArgs =
|
||||||
|
[ I.SignalArg
|
||||||
|
{ I.signalArgName = "brightness"
|
||||||
|
, I.signalArgType = TypeInt32
|
||||||
|
}
|
||||||
|
]
|
||||||
|
}
|
||||||
|
|
||||||
emitBrightness :: RealFrac b => BrightnessConfig a b -> Client -> b -> IO ()
|
emitBrightness :: RealFrac b => BrightnessConfig a b -> Client -> b -> IO ()
|
||||||
emitBrightness BrightnessConfig{ bcPath = p, bcInterface = i } client cur =
|
emitBrightness BrightnessConfig {bcPath = p, bcInterface = i} client cur =
|
||||||
emit client $ sig { signalBody = [toVariant (round cur :: Int32)] }
|
emit client $ sig {signalBody = [toVariant (round cur :: Int32)]}
|
||||||
where
|
where
|
||||||
sig = signal p i memCur
|
sig = signal p i memCur
|
||||||
|
|
||||||
callBacklight :: XPQuery -> Maybe SesClient -> BrightnessConfig a b -> T.Text
|
callBacklight
|
||||||
-> MemberName -> SometimesX
|
:: XPQuery
|
||||||
callBacklight q cl BrightnessConfig { bcPath = p
|
-> Maybe SesClient
|
||||||
, bcInterface = i
|
-> BrightnessConfig a b
|
||||||
, bcName = n } controlName m =
|
-> T.Text
|
||||||
Sometimes (T.unwords [n, controlName]) q [Subfeature root "method call"]
|
-> MemberName
|
||||||
where
|
-> SometimesX
|
||||||
root = DBusRoot_ cmd (Only_ $ Endpoint [] xmonadBusName p i $ Method_ m) cl
|
callBacklight
|
||||||
cmd c = io $ void $ callMethod c xmonadBusName p i m
|
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 = io $ void $ callMethod c xmonadBusName p i m
|
||||||
|
|
||||||
bodyGetBrightness :: Num a => [Variant] -> Maybe a
|
bodyGetBrightness :: Num a => [Variant] -> Maybe a
|
||||||
bodyGetBrightness [b] = fromIntegral <$> (fromVariant b :: Maybe Int32)
|
bodyGetBrightness [b] = fromIntegral <$> (fromVariant b :: Maybe Int32)
|
||||||
bodyGetBrightness _ = Nothing
|
bodyGetBrightness _ = Nothing
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | DBus Members
|
-- DBus Members
|
||||||
|
|
||||||
memCur :: MemberName
|
memCur :: MemberName
|
||||||
memCur = memberName_ "CurrentBrightness"
|
memCur = memberName_ "CurrentBrightness"
|
||||||
|
|
|
@ -1,7 +1,7 @@
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | DBus module for Intel Backlight control
|
-- DBus module for Intel Backlight control
|
||||||
|
|
||||||
module XMonad.Internal.DBus.Brightness.IntelBacklight
|
module XMonad.Internal.DBus.Brightness.IntelBacklight
|
||||||
( callGetBrightnessIB
|
( callGetBrightnessIB
|
||||||
|
@ -10,22 +10,20 @@ module XMonad.Internal.DBus.Brightness.IntelBacklight
|
||||||
, intelBacklightControls
|
, intelBacklightControls
|
||||||
, intelBacklightSignalDep
|
, intelBacklightSignalDep
|
||||||
, blPath
|
, blPath
|
||||||
) where
|
)
|
||||||
|
where
|
||||||
|
|
||||||
import Data.Int (Int32)
|
import DBus
|
||||||
import Data.Internal.DBus
|
import Data.Int (Int32)
|
||||||
import Data.Internal.Dependency
|
import Data.Internal.DBus
|
||||||
|
import Data.Internal.Dependency
|
||||||
import DBus
|
import RIO.FilePath
|
||||||
|
import XMonad.Internal.DBus.Brightness.Common
|
||||||
import RIO.FilePath
|
import XMonad.Internal.IO
|
||||||
|
|
||||||
import XMonad.Internal.DBus.Brightness.Common
|
|
||||||
import XMonad.Internal.IO
|
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Low level sysfs functions
|
-- Low level sysfs functions
|
||||||
--
|
|
||||||
type Brightness = Float
|
type Brightness = Float
|
||||||
|
|
||||||
type RawBrightness = Int32
|
type RawBrightness = Int32
|
||||||
|
@ -66,7 +64,7 @@ decBrightness :: RawBounds -> IO Brightness
|
||||||
decBrightness = decPercent steps curFile
|
decBrightness = decPercent steps curFile
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | DBus interface
|
-- DBus interface
|
||||||
|
|
||||||
blPath :: ObjectPath
|
blPath :: ObjectPath
|
||||||
blPath = objectPath_ "/intelbacklight"
|
blPath = objectPath_ "/intelbacklight"
|
||||||
|
@ -75,21 +73,22 @@ interface :: InterfaceName
|
||||||
interface = interfaceName_ "org.xmonad.Brightness"
|
interface = interfaceName_ "org.xmonad.Brightness"
|
||||||
|
|
||||||
intelBacklightConfig :: BrightnessConfig RawBrightness Brightness
|
intelBacklightConfig :: BrightnessConfig RawBrightness Brightness
|
||||||
intelBacklightConfig = BrightnessConfig
|
intelBacklightConfig =
|
||||||
{ bcMin = minBrightness
|
BrightnessConfig
|
||||||
, bcMax = maxBrightness
|
{ bcMin = minBrightness
|
||||||
, bcInc = incBrightness
|
, bcMax = maxBrightness
|
||||||
, bcDec = decBrightness
|
, bcInc = incBrightness
|
||||||
, bcGet = getBrightness
|
, bcDec = decBrightness
|
||||||
, bcGetMax = getMaxRawBrightness
|
, bcGet = getBrightness
|
||||||
, bcMinRaw = minRawBrightness
|
, bcGetMax = getMaxRawBrightness
|
||||||
, bcPath = blPath
|
, bcMinRaw = minRawBrightness
|
||||||
, bcInterface = interface
|
, bcPath = blPath
|
||||||
, bcName = "Intel backlight"
|
, bcInterface = interface
|
||||||
}
|
, bcName = "Intel backlight"
|
||||||
|
}
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Exported haskell API
|
-- Exported haskell API
|
||||||
|
|
||||||
curFileDep :: IODependency_
|
curFileDep :: IODependency_
|
||||||
curFileDep = pathRW curFile []
|
curFileDep = pathRW curFile []
|
||||||
|
@ -101,8 +100,12 @@ intelBacklightSignalDep :: DBusDependency_ SesClient
|
||||||
intelBacklightSignalDep = signalDep intelBacklightConfig
|
intelBacklightSignalDep = signalDep intelBacklightConfig
|
||||||
|
|
||||||
exportIntelBacklight :: Maybe SesClient -> SometimesIO
|
exportIntelBacklight :: Maybe SesClient -> SometimesIO
|
||||||
exportIntelBacklight = brightnessExporter xpfIntelBacklight []
|
exportIntelBacklight =
|
||||||
[curFileDep, maxFileDep] intelBacklightConfig
|
brightnessExporter
|
||||||
|
xpfIntelBacklight
|
||||||
|
[]
|
||||||
|
[curFileDep, maxFileDep]
|
||||||
|
intelBacklightConfig
|
||||||
|
|
||||||
intelBacklightControls :: Maybe SesClient -> BrightnessControls
|
intelBacklightControls :: Maybe SesClient -> BrightnessControls
|
||||||
intelBacklightControls = brightnessControls xpfIntelBacklight intelBacklightConfig
|
intelBacklightControls = brightnessControls xpfIntelBacklight intelBacklightConfig
|
||||||
|
|
|
@ -1,5 +1,5 @@
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | High-level interface for managing XMonad's DBus
|
-- High-level interface for managing XMonad's DBus
|
||||||
|
|
||||||
module XMonad.Internal.DBus.Common
|
module XMonad.Internal.DBus.Common
|
||||||
( xmonadBusName
|
( xmonadBusName
|
||||||
|
@ -7,9 +7,10 @@ module XMonad.Internal.DBus.Common
|
||||||
, notifyBus
|
, notifyBus
|
||||||
, notifyPath
|
, notifyPath
|
||||||
, networkManagerBus
|
, networkManagerBus
|
||||||
) where
|
)
|
||||||
|
where
|
||||||
|
|
||||||
import DBus
|
import DBus
|
||||||
|
|
||||||
xmonadBusName :: BusName
|
xmonadBusName :: BusName
|
||||||
xmonadBusName = busName_ "org.xmonad"
|
xmonadBusName = busName_ "org.xmonad"
|
||||||
|
@ -25,4 +26,3 @@ notifyPath = objectPath_ "/org/freedesktop/Notifications"
|
||||||
|
|
||||||
networkManagerBus :: BusName
|
networkManagerBus :: BusName
|
||||||
networkManagerBus = busName_ "org.freedesktop.NetworkManager"
|
networkManagerBus = busName_ "org.freedesktop.NetworkManager"
|
||||||
|
|
||||||
|
|
|
@ -1,11 +1,11 @@
|
||||||
{-# LANGUAGE ScopedTypeVariables #-}
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | High-level interface for managing XMonad's DBus
|
-- High-level interface for managing XMonad's DBus
|
||||||
|
|
||||||
module XMonad.Internal.DBus.Control
|
module XMonad.Internal.DBus.Control
|
||||||
( Client
|
( Client
|
||||||
, DBusState(..)
|
, DBusState (..)
|
||||||
, connectDBus
|
, connectDBus
|
||||||
, connectDBusX
|
, connectDBusX
|
||||||
, disconnectDBus
|
, disconnectDBus
|
||||||
|
@ -15,33 +15,31 @@ module XMonad.Internal.DBus.Control
|
||||||
, withDBusClient_
|
, withDBusClient_
|
||||||
, disconnect
|
, disconnect
|
||||||
, dbusExporters
|
, dbusExporters
|
||||||
) where
|
)
|
||||||
|
where
|
||||||
|
|
||||||
import Control.Monad
|
import Control.Monad
|
||||||
|
import DBus
|
||||||
import Data.Internal.DBus
|
import DBus.Client
|
||||||
import Data.Internal.Dependency
|
import Data.Internal.DBus
|
||||||
|
import Data.Internal.Dependency
|
||||||
import DBus
|
import XMonad.Internal.DBus.Brightness.ClevoKeyboard
|
||||||
import DBus.Client
|
import XMonad.Internal.DBus.Brightness.IntelBacklight
|
||||||
|
import XMonad.Internal.DBus.Common
|
||||||
import XMonad.Internal.DBus.Brightness.ClevoKeyboard
|
import XMonad.Internal.DBus.Screensaver
|
||||||
import XMonad.Internal.DBus.Brightness.IntelBacklight
|
|
||||||
import XMonad.Internal.DBus.Common
|
|
||||||
import XMonad.Internal.DBus.Screensaver
|
|
||||||
|
|
||||||
-- | Current connections to the DBus (session and system buses)
|
-- | Current connections to the DBus (session and system buses)
|
||||||
data DBusState = DBusState
|
data DBusState = DBusState
|
||||||
{ dbSesClient :: Maybe SesClient
|
{ dbSesClient :: Maybe SesClient
|
||||||
, dbSysClient :: Maybe SysClient
|
, dbSysClient :: Maybe SysClient
|
||||||
}
|
}
|
||||||
|
|
||||||
-- | Connect to the DBus
|
-- | Connect to the DBus
|
||||||
connectDBus :: IO DBusState
|
connectDBus :: IO DBusState
|
||||||
connectDBus = do
|
connectDBus = do
|
||||||
ses <- getDBusClient
|
ses <- getDBusClient
|
||||||
sys <- getDBusClient
|
sys <- getDBusClient
|
||||||
return DBusState { dbSesClient = ses, dbSysClient = sys }
|
return DBusState {dbSesClient = ses, dbSysClient = sys}
|
||||||
|
|
||||||
-- | Disconnect from the DBus
|
-- | Disconnect from the DBus
|
||||||
disconnectDBus :: DBusState -> IO ()
|
disconnectDBus :: DBusState -> IO ()
|
||||||
|
@ -73,11 +71,13 @@ requestXMonadName :: SesClient -> IO ()
|
||||||
requestXMonadName ses = do
|
requestXMonadName ses = do
|
||||||
res <- requestName (toClient ses) xmonadBusName []
|
res <- requestName (toClient ses) xmonadBusName []
|
||||||
-- TODO if the client is not released on shutdown the owner will be different
|
-- TODO if the client is not released on shutdown the owner will be different
|
||||||
let msg | res == NamePrimaryOwner = Nothing
|
let msg
|
||||||
| res == NameAlreadyOwner = Just $ "this process already owns " ++ xn
|
| res == NamePrimaryOwner = Nothing
|
||||||
| res == NameInQueue
|
| res == NameAlreadyOwner = Just $ "this process already owns " ++ xn
|
||||||
|| res == NameExists = Just $ "another process owns " ++ xn
|
| res == NameInQueue
|
||||||
| otherwise = Just $ "unknown error when requesting " ++ xn
|
|| res == NameExists =
|
||||||
|
Just $ "another process owns " ++ xn
|
||||||
|
| otherwise = Just $ "unknown error when requesting " ++ xn
|
||||||
forM_ msg putStrLn
|
forM_ msg putStrLn
|
||||||
where
|
where
|
||||||
xn = "'" ++ formatBusName xmonadBusName ++ "'"
|
xn = "'" ++ formatBusName xmonadBusName ++ "'"
|
||||||
|
|
|
@ -1,24 +1,21 @@
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Module for monitoring removable drive events
|
-- Module for monitoring removable drive events
|
||||||
--
|
--
|
||||||
-- Currently, its only purpose is to play Super Mario sounds when a drive is
|
-- Currently, its only purpose is to play Super Mario sounds when a drive is
|
||||||
-- inserted or removed. Why? Because I can.
|
-- inserted or removed. Why? Because I can.
|
||||||
|
|
||||||
module XMonad.Internal.DBus.Removable (runRemovableMon) where
|
module XMonad.Internal.DBus.Removable (runRemovableMon) where
|
||||||
|
|
||||||
import Control.Monad
|
import Control.Monad
|
||||||
|
import DBus
|
||||||
import Data.Internal.DBus
|
import DBus.Client
|
||||||
import Data.Internal.Dependency
|
import Data.Internal.DBus
|
||||||
import Data.Map.Strict (Map, member)
|
import Data.Internal.Dependency
|
||||||
|
import Data.Map.Strict (Map, member)
|
||||||
import DBus
|
import XMonad.Core (io)
|
||||||
import DBus.Client
|
import XMonad.Internal.Command.Desktop
|
||||||
|
|
||||||
import XMonad.Core (io)
|
|
||||||
import XMonad.Internal.Command.Desktop
|
|
||||||
|
|
||||||
bus :: BusName
|
bus :: BusName
|
||||||
bus = busName_ "org.freedesktop.UDisks2"
|
bus = busName_ "org.freedesktop.UDisks2"
|
||||||
|
@ -51,22 +48,29 @@ driveRemovedSound :: FilePath
|
||||||
driveRemovedSound = "smb_pipe.wav"
|
driveRemovedSound = "smb_pipe.wav"
|
||||||
|
|
||||||
ruleUdisks :: MatchRule
|
ruleUdisks :: MatchRule
|
||||||
ruleUdisks = matchAny
|
ruleUdisks =
|
||||||
{ matchPath = Just path
|
matchAny
|
||||||
, matchInterface = Just interface
|
{ matchPath = Just path
|
||||||
}
|
, matchInterface = Just interface
|
||||||
|
}
|
||||||
|
|
||||||
driveFlag :: String
|
driveFlag :: String
|
||||||
driveFlag = "org.freedesktop.UDisks2.Drive"
|
driveFlag = "org.freedesktop.UDisks2.Drive"
|
||||||
|
|
||||||
addedHasDrive :: [Variant] -> Bool
|
addedHasDrive :: [Variant] -> Bool
|
||||||
addedHasDrive [_, a] = maybe False (member driveFlag)
|
addedHasDrive [_, a] =
|
||||||
(fromVariant a :: Maybe (Map String (Map String Variant)))
|
maybe
|
||||||
|
False
|
||||||
|
(member driveFlag)
|
||||||
|
(fromVariant a :: Maybe (Map String (Map String Variant)))
|
||||||
addedHasDrive _ = False
|
addedHasDrive _ = False
|
||||||
|
|
||||||
removedHasDrive :: [Variant] -> Bool
|
removedHasDrive :: [Variant] -> Bool
|
||||||
removedHasDrive [_, a] = maybe False (driveFlag `elem`)
|
removedHasDrive [_, a] =
|
||||||
(fromVariant a :: Maybe [String])
|
maybe
|
||||||
|
False
|
||||||
|
(driveFlag `elem`)
|
||||||
|
(fromVariant a :: Maybe [String])
|
||||||
removedHasDrive _ = False
|
removedHasDrive _ = False
|
||||||
|
|
||||||
playSoundMaybe :: FilePath -> Bool -> IO ()
|
playSoundMaybe :: FilePath -> Bool -> IO ()
|
||||||
|
@ -81,8 +85,10 @@ listenDevices cl = do
|
||||||
addMatch' memAdded driveInsertedSound addedHasDrive
|
addMatch' memAdded driveInsertedSound addedHasDrive
|
||||||
addMatch' memRemoved driveRemovedSound removedHasDrive
|
addMatch' memRemoved driveRemovedSound removedHasDrive
|
||||||
where
|
where
|
||||||
addMatch' m p f = void $ addMatch (toClient cl) ruleUdisks { matchMember = Just m }
|
addMatch' m p f =
|
||||||
$ playSoundMaybe p . f . signalBody
|
void $
|
||||||
|
addMatch (toClient cl) ruleUdisks {matchMember = Just m} $
|
||||||
|
playSoundMaybe p . f . signalBody
|
||||||
|
|
||||||
runRemovableMon :: Maybe SysClient -> SometimesIO
|
runRemovableMon :: Maybe SysClient -> SometimesIO
|
||||||
runRemovableMon cl =
|
runRemovableMon cl =
|
||||||
|
|
|
@ -1,7 +1,7 @@
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | DBus module for X11 screensave/DPMS control
|
-- DBus module for X11 screensave/DPMS control
|
||||||
|
|
||||||
module XMonad.Internal.DBus.Screensaver
|
module XMonad.Internal.DBus.Screensaver
|
||||||
( exportScreensaver
|
( exportScreensaver
|
||||||
|
@ -9,25 +9,22 @@ module XMonad.Internal.DBus.Screensaver
|
||||||
, callQuery
|
, callQuery
|
||||||
, matchSignal
|
, matchSignal
|
||||||
, ssSignalDep
|
, ssSignalDep
|
||||||
) where
|
)
|
||||||
|
where
|
||||||
|
|
||||||
import Data.Internal.DBus
|
import DBus
|
||||||
import Data.Internal.Dependency
|
import DBus.Client
|
||||||
|
import qualified DBus.Introspection as I
|
||||||
import RIO
|
import Data.Internal.DBus
|
||||||
|
import Data.Internal.Dependency
|
||||||
import DBus
|
import Graphics.X11.XScreenSaver
|
||||||
import DBus.Client
|
import Graphics.X11.Xlib.Display
|
||||||
import qualified DBus.Introspection as I
|
import RIO
|
||||||
|
import XMonad.Internal.DBus.Common
|
||||||
import Graphics.X11.XScreenSaver
|
import XMonad.Internal.Shell
|
||||||
import Graphics.X11.Xlib.Display
|
|
||||||
|
|
||||||
import XMonad.Internal.DBus.Common
|
|
||||||
import XMonad.Internal.Shell
|
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Low-level functions
|
-- Low-level functions
|
||||||
|
|
||||||
type SSState = Bool -- true is enabled
|
type SSState = Bool -- true is enabled
|
||||||
|
|
||||||
|
@ -50,13 +47,13 @@ query = do
|
||||||
xssi <- xScreenSaverQueryInfo dpy
|
xssi <- xScreenSaverQueryInfo dpy
|
||||||
closeDisplay dpy
|
closeDisplay dpy
|
||||||
return $ case xssi of
|
return $ case xssi of
|
||||||
Just XScreenSaverInfo { xssi_state = ScreenSaverDisabled } -> False
|
Just XScreenSaverInfo {xssi_state = ScreenSaverDisabled} -> False
|
||||||
Just XScreenSaverInfo { xssi_state = _ } -> True
|
Just XScreenSaverInfo {xssi_state = _} -> True
|
||||||
-- TODO handle errors better (at least log them?)
|
-- TODO handle errors better (at least log them?)
|
||||||
Nothing -> False
|
Nothing -> False
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | DBus Interface
|
-- DBus Interface
|
||||||
--
|
--
|
||||||
-- Define a methods to toggle the screensaver. This methods will emit signal
|
-- Define a methods to toggle the screensaver. This methods will emit signal
|
||||||
-- with the new state when called. Define another method to get the current
|
-- with the new state when called. Define another method to get the current
|
||||||
|
@ -81,51 +78,64 @@ sigCurrentState :: Signal
|
||||||
sigCurrentState = signal ssPath interface memState
|
sigCurrentState = signal ssPath interface memState
|
||||||
|
|
||||||
ruleCurrentState :: MatchRule
|
ruleCurrentState :: MatchRule
|
||||||
ruleCurrentState = matchAny
|
ruleCurrentState =
|
||||||
{ matchPath = Just ssPath
|
matchAny
|
||||||
, matchInterface = Just interface
|
{ matchPath = Just ssPath
|
||||||
, matchMember = Just memState
|
, matchInterface = Just interface
|
||||||
}
|
, matchMember = Just memState
|
||||||
|
}
|
||||||
|
|
||||||
emitState :: Client -> SSState -> IO ()
|
emitState :: Client -> SSState -> IO ()
|
||||||
emitState client sss = emit client $ sigCurrentState { signalBody = [toVariant sss] }
|
emitState client sss = emit client $ sigCurrentState {signalBody = [toVariant sss]}
|
||||||
|
|
||||||
bodyGetCurrentState :: [Variant] -> Maybe SSState
|
bodyGetCurrentState :: [Variant] -> Maybe SSState
|
||||||
bodyGetCurrentState [b] = fromVariant b :: Maybe SSState
|
bodyGetCurrentState [b] = fromVariant b :: Maybe SSState
|
||||||
bodyGetCurrentState _ = Nothing
|
bodyGetCurrentState _ = Nothing
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Exported haskell API
|
-- Exported haskell API
|
||||||
|
|
||||||
exportScreensaver :: Maybe SesClient -> SometimesIO
|
exportScreensaver :: Maybe SesClient -> SometimesIO
|
||||||
exportScreensaver ses =
|
exportScreensaver ses =
|
||||||
sometimesDBus ses "screensaver toggle" "xset" (toAnd_ bus ssx) cmd
|
sometimesDBus ses "screensaver toggle" "xset" (toAnd_ bus ssx) cmd
|
||||||
where
|
where
|
||||||
cmd cl = let cl' = toClient cl in
|
cmd cl =
|
||||||
liftIO $ export cl' ssPath defaultInterface
|
let cl' = toClient cl
|
||||||
{ interfaceName = interface
|
in liftIO $
|
||||||
, interfaceMethods =
|
export
|
||||||
[ autoMethod memToggle $ emitState cl' =<< toggle
|
cl'
|
||||||
, autoMethod memQuery query
|
ssPath
|
||||||
]
|
defaultInterface
|
||||||
, interfaceSignals = [sig]
|
{ interfaceName = interface
|
||||||
}
|
, interfaceMethods =
|
||||||
sig = I.Signal
|
[ autoMethod memToggle $ emitState cl' =<< toggle
|
||||||
{ I.signalName = memState
|
, autoMethod memQuery query
|
||||||
, I.signalArgs =
|
]
|
||||||
[
|
, interfaceSignals = [sig]
|
||||||
I.SignalArg
|
}
|
||||||
{ I.signalArgName = "enabled"
|
sig =
|
||||||
, I.signalArgType = TypeBoolean
|
I.Signal
|
||||||
}
|
{ I.signalName = memState
|
||||||
]
|
, I.signalArgs =
|
||||||
}
|
[ I.SignalArg
|
||||||
|
{ I.signalArgName = "enabled"
|
||||||
|
, I.signalArgType = TypeBoolean
|
||||||
|
}
|
||||||
|
]
|
||||||
|
}
|
||||||
bus = Bus [] xmonadBusName
|
bus = Bus [] xmonadBusName
|
||||||
ssx = DBusIO $ sysExe [Package Official "xorg-xset"] ssExecutable
|
ssx = DBusIO $ sysExe [Package Official "xorg-xset"] ssExecutable
|
||||||
|
|
||||||
callToggle :: Maybe SesClient -> SometimesX
|
callToggle :: Maybe SesClient -> SometimesX
|
||||||
callToggle = sometimesEndpoint "screensaver toggle" "dbus switch" []
|
callToggle =
|
||||||
xmonadBusName ssPath interface memToggle
|
sometimesEndpoint
|
||||||
|
"screensaver toggle"
|
||||||
|
"dbus switch"
|
||||||
|
[]
|
||||||
|
xmonadBusName
|
||||||
|
ssPath
|
||||||
|
interface
|
||||||
|
memToggle
|
||||||
|
|
||||||
callQuery :: SesClient -> IO (Maybe SSState)
|
callQuery :: SesClient -> IO (Maybe SSState)
|
||||||
callQuery ses = do
|
callQuery ses = do
|
||||||
|
@ -133,8 +143,12 @@ callQuery ses = do
|
||||||
return $ either (const Nothing) bodyGetCurrentState reply
|
return $ either (const Nothing) bodyGetCurrentState reply
|
||||||
|
|
||||||
matchSignal :: (Maybe SSState -> IO ()) -> SesClient -> IO ()
|
matchSignal :: (Maybe SSState -> IO ()) -> SesClient -> IO ()
|
||||||
matchSignal cb ses = void $ addMatchCallback ruleCurrentState
|
matchSignal cb ses =
|
||||||
(cb . bodyGetCurrentState) ses
|
void $
|
||||||
|
addMatchCallback
|
||||||
|
ruleCurrentState
|
||||||
|
(cb . bodyGetCurrentState)
|
||||||
|
ses
|
||||||
|
|
||||||
ssSignalDep :: DBusDependency_ SesClient
|
ssSignalDep :: DBusDependency_ SesClient
|
||||||
ssSignalDep = Endpoint [] xmonadBusName ssPath interface $ Signal_ memState
|
ssSignalDep = Endpoint [] xmonadBusName ssPath interface $ Signal_ memState
|
||||||
|
|
|
@ -1,7 +1,7 @@
|
||||||
{-# LANGUAGE ViewPatterns #-}
|
{-# LANGUAGE ViewPatterns #-}
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Random IO-ish functions used throughtout xmonad
|
-- Random IO-ish functions used throughtout xmonad
|
||||||
--
|
--
|
||||||
-- Most (probably all) of these functions are intended to work with sysfs where
|
-- Most (probably all) of these functions are intended to work with sysfs where
|
||||||
-- some safe assumptions can be made about file contents.
|
-- some safe assumptions can be made about file contents.
|
||||||
|
@ -19,32 +19,31 @@ module XMonad.Internal.IO
|
||||||
, incPercent
|
, incPercent
|
||||||
-- , isReadable
|
-- , isReadable
|
||||||
-- , isWritable
|
-- , isWritable
|
||||||
, PermResult(..)
|
, PermResult (..)
|
||||||
, getPermissionsSafe
|
, getPermissionsSafe
|
||||||
, waitUntilExit
|
, waitUntilExit
|
||||||
) where
|
)
|
||||||
|
where
|
||||||
|
|
||||||
import Data.Char
|
import Data.Char
|
||||||
import Data.Text (pack, unpack)
|
import Data.Text (pack, unpack)
|
||||||
import Data.Text.IO as T (readFile, writeFile)
|
import Data.Text.IO as T (readFile, writeFile)
|
||||||
|
import RIO
|
||||||
import RIO
|
import RIO.Directory
|
||||||
import RIO.Directory
|
import RIO.FilePath
|
||||||
import RIO.FilePath
|
import System.IO.Error
|
||||||
|
|
||||||
import System.IO.Error
|
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | read
|
-- read
|
||||||
|
|
||||||
readInt :: (Read a, Integral a) => FilePath -> IO a
|
readInt :: (Read a, Integral a) => FilePath -> IO a
|
||||||
readInt = fmap (read . takeWhile isDigit . unpack) . T.readFile
|
readInt = fmap (read . takeWhile isDigit . unpack) . T.readFile
|
||||||
|
|
||||||
readBool :: FilePath -> IO Bool
|
readBool :: FilePath -> IO Bool
|
||||||
readBool = fmap (==(1 :: Int)) . readInt
|
readBool = fmap (== (1 :: Int)) . readInt
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | write
|
-- write
|
||||||
|
|
||||||
writeInt :: (Show a, Integral a) => FilePath -> a -> IO ()
|
writeInt :: (Show a, Integral a) => FilePath -> a -> IO ()
|
||||||
writeInt f = T.writeFile f . pack . show
|
writeInt f = T.writeFile f . pack . show
|
||||||
|
@ -53,16 +52,16 @@ writeBool :: FilePath -> Bool -> IO ()
|
||||||
writeBool f b = writeInt f ((if b then 1 else 0) :: Int)
|
writeBool f b = writeInt f ((if b then 1 else 0) :: Int)
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | percent-based read/write
|
-- percent-based read/write
|
||||||
--
|
--
|
||||||
-- "Raw" values are whatever is stored in sysfs and "percent" is the user-facing
|
-- "Raw" values are whatever is stored in sysfs and "percent" is the user-facing
|
||||||
-- value. Assume that the file being read has a min of 0 and an unchanging max
|
-- value. Assume that the file being read has a min of 0 and an unchanging max
|
||||||
-- given by a runtime argument, which is scaled linearly to the range 0-100
|
-- given by a runtime argument, which is scaled linearly to the range 0-100
|
||||||
-- (percent).
|
-- (percent).
|
||||||
|
|
||||||
rawToPercent :: (Integral a, Integral b, Read b, RealFrac c) => (a, a) -> b -> c
|
rawToPercent :: (Integral a, Integral b, Read b, RealFrac c) => (a, a) -> b -> c
|
||||||
rawToPercent (lower, upper) raw =
|
rawToPercent (lower, upper) raw =
|
||||||
100 * (fromIntegral raw - fromIntegral lower) / fromIntegral (upper - lower)
|
100 * (fromIntegral raw - fromIntegral lower) / fromIntegral (upper - lower)
|
||||||
|
|
||||||
-- rawToPercent upper raw = 100 * fromIntegral raw / fromIntegral upper
|
-- rawToPercent upper raw = 100 * fromIntegral raw / fromIntegral upper
|
||||||
|
|
||||||
readPercent :: (Integral a, RealFrac b) => (a, a) -> FilePath -> IO b
|
readPercent :: (Integral a, RealFrac b) => (a, a) -> FilePath -> IO b
|
||||||
|
@ -71,12 +70,14 @@ readPercent bounds path = do
|
||||||
return $ rawToPercent bounds (i :: Integer)
|
return $ rawToPercent bounds (i :: Integer)
|
||||||
|
|
||||||
percentToRaw :: (Integral a, RealFrac b, Integral c) => (a, a) -> b -> c
|
percentToRaw :: (Integral a, RealFrac b, Integral c) => (a, a) -> b -> c
|
||||||
percentToRaw (lower, upper) perc = round $
|
percentToRaw (lower, upper) perc =
|
||||||
fromIntegral lower + perc / 100.0 * (fromIntegral upper - fromIntegral lower)
|
round $
|
||||||
|
fromIntegral lower + perc / 100.0 * (fromIntegral upper - fromIntegral lower)
|
||||||
|
|
||||||
writePercent :: (Integral a, RealFrac b) => (a, a) -> FilePath -> b -> IO b
|
writePercent :: (Integral a, RealFrac b) => (a, a) -> FilePath -> b -> IO b
|
||||||
writePercent bounds path perc = do
|
writePercent bounds path perc = do
|
||||||
let t | perc > 100 = 100
|
let t
|
||||||
|
| perc > 100 = 100
|
||||||
| perc < 0 = 0
|
| perc < 0 = 0
|
||||||
| otherwise = perc
|
| otherwise = perc
|
||||||
writeInt path (percentToRaw bounds t :: Int)
|
writeInt path (percentToRaw bounds t :: Int)
|
||||||
|
@ -88,9 +89,15 @@ writePercentMin bounds path = writePercent bounds path 0
|
||||||
writePercentMax :: (Integral a, RealFrac b) => (a, a) -> FilePath -> IO b
|
writePercentMax :: (Integral a, RealFrac b) => (a, a) -> FilePath -> IO b
|
||||||
writePercentMax bounds path = writePercent bounds path 100
|
writePercentMax bounds path = writePercent bounds path 100
|
||||||
|
|
||||||
shiftPercent :: (Integral a, RealFrac b) => (b -> b -> b) -> Int -> FilePath
|
shiftPercent
|
||||||
-> (a, a) -> IO b
|
:: (Integral a, RealFrac b)
|
||||||
shiftPercent f steps path bounds = writePercent bounds path . f stepsize
|
=> (b -> b -> b)
|
||||||
|
-> Int
|
||||||
|
-> FilePath
|
||||||
|
-> (a, a)
|
||||||
|
-> IO b
|
||||||
|
shiftPercent f steps path bounds =
|
||||||
|
writePercent bounds path . f stepsize
|
||||||
=<< readPercent bounds path
|
=<< readPercent bounds path
|
||||||
where
|
where
|
||||||
stepsize = 100 / fromIntegral steps
|
stepsize = 100 / fromIntegral steps
|
||||||
|
@ -102,7 +109,7 @@ decPercent :: (Integral a, RealFrac b) => Int -> FilePath -> (a, a) -> IO b
|
||||||
decPercent = shiftPercent subtract -- silly (-) operator thingy error
|
decPercent = shiftPercent subtract -- silly (-) operator thingy error
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | permission query
|
-- permission query
|
||||||
|
|
||||||
data PermResult a = PermResult a | NotFoundError | PermError
|
data PermResult a = PermResult a | NotFoundError | PermError
|
||||||
deriving (Show, Eq)
|
deriving (Show, Eq)
|
||||||
|
@ -116,12 +123,12 @@ getPermissionsSafe :: FilePath -> IO (PermResult Permissions)
|
||||||
getPermissionsSafe f = do
|
getPermissionsSafe f = do
|
||||||
r <- tryIOError $ getPermissions f
|
r <- tryIOError $ getPermissions f
|
||||||
return $ case r of
|
return $ case r of
|
||||||
Right z -> PermResult z
|
Right z -> PermResult z
|
||||||
Left (isPermissionError -> True) -> PermError
|
Left (isPermissionError -> True) -> PermError
|
||||||
Left (isDoesNotExistError -> True) -> NotFoundError
|
Left (isDoesNotExistError -> True) -> NotFoundError
|
||||||
-- the above error should be the only ones thrown by getPermission,
|
-- the above error should be the only ones thrown by getPermission,
|
||||||
-- so the catchall case should never happen
|
-- so the catchall case should never happen
|
||||||
_ -> error "Unknown permission error"
|
_ -> error "Unknown permission error"
|
||||||
|
|
||||||
-- isReadable :: FilePath -> IO (PermResult Bool)
|
-- isReadable :: FilePath -> IO (PermResult Bool)
|
||||||
-- isReadable = fmap (fmap readable) . getPermissionsSafe
|
-- isReadable = fmap (fmap readable) . getPermissionsSafe
|
||||||
|
|
|
@ -1,7 +1,7 @@
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Functions for formatting and sending notifications
|
-- Functions for formatting and sending notifications
|
||||||
--
|
--
|
||||||
-- NOTE I use the DBus.Notify lib even though I don't actually use the DBus for
|
-- NOTE I use the DBus.Notify lib even though I don't actually use the DBus for
|
||||||
-- notifications (just formation them into 'notify-send' commands and spawn a
|
-- notifications (just formation them into 'notify-send' commands and spawn a
|
||||||
|
@ -9,42 +9,45 @@
|
||||||
-- decide to switch to using the DBus it will be easy.
|
-- decide to switch to using the DBus it will be easy.
|
||||||
|
|
||||||
module XMonad.Internal.Notify
|
module XMonad.Internal.Notify
|
||||||
( Note(..)
|
( Note (..)
|
||||||
, Body(..)
|
, Body (..)
|
||||||
, defNote
|
, defNote
|
||||||
, defNoteInfo
|
, defNoteInfo
|
||||||
, defNoteError
|
, defNoteError
|
||||||
, fmtNotifyCmd
|
, fmtNotifyCmd
|
||||||
, spawnNotify
|
, spawnNotify
|
||||||
) where
|
)
|
||||||
|
where
|
||||||
|
|
||||||
import DBus.Notify
|
import DBus.Notify
|
||||||
|
import RIO
|
||||||
import RIO
|
import qualified RIO.Text as T
|
||||||
import qualified RIO.Text as T
|
import XMonad.Internal.Shell
|
||||||
|
|
||||||
import XMonad.Internal.Shell
|
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Some nice default notes
|
-- Some nice default notes
|
||||||
|
|
||||||
defNote :: Note
|
defNote :: Note
|
||||||
defNote = blankNote { summary = "\"xmonad\"" }
|
defNote = blankNote {summary = "\"xmonad\""}
|
||||||
|
|
||||||
defNoteInfo :: Note
|
defNoteInfo :: Note
|
||||||
defNoteInfo = defNote
|
defNoteInfo =
|
||||||
{ appImage = Just $ Icon "dialog-information-symbolic" }
|
defNote
|
||||||
|
{ appImage = Just $ Icon "dialog-information-symbolic"
|
||||||
|
}
|
||||||
|
|
||||||
defNoteError :: Note
|
defNoteError :: Note
|
||||||
defNoteError = defNote
|
defNoteError =
|
||||||
{ appImage = Just $ Icon "dialog-error-symbolic" }
|
defNote
|
||||||
|
{ appImage = Just $ Icon "dialog-error-symbolic"
|
||||||
|
}
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Format a 'notify-send' command to be send to the shell
|
-- Format a 'notify-send' command to be send to the shell
|
||||||
|
|
||||||
parseBody :: Body -> Maybe T.Text
|
parseBody :: Body -> Maybe T.Text
|
||||||
parseBody (Text s) = Just $ T.pack s
|
parseBody (Text s) = Just $ T.pack s
|
||||||
parseBody _ = Nothing
|
parseBody _ = Nothing
|
||||||
|
|
||||||
fmtNotifyCmd :: Note -> T.Text
|
fmtNotifyCmd :: Note -> T.Text
|
||||||
fmtNotifyCmd = fmtCmd "notify-send" . fmtNotifyArgs
|
fmtNotifyCmd = fmtCmd "notify-send" . fmtNotifyArgs
|
||||||
|
@ -56,8 +59,8 @@ fmtNotifyArgs :: Note -> [T.Text]
|
||||||
fmtNotifyArgs n = getIcon n ++ getSummary n ++ getBody n
|
fmtNotifyArgs n = getIcon n ++ getSummary n ++ getBody n
|
||||||
where
|
where
|
||||||
-- TODO add the rest of the options as needed
|
-- TODO add the rest of the options as needed
|
||||||
getSummary = (:[]) . doubleQuote . T.pack . summary
|
getSummary = (: []) . doubleQuote . T.pack . summary
|
||||||
getIcon n' =
|
getIcon n' =
|
||||||
maybe [] (\i -> ["-i", T.pack $ case i of { Icon s -> s; File s -> s }])
|
maybe [] (\i -> ["-i", T.pack $ case i of Icon s -> s; File s -> s]) $
|
||||||
$ appImage n'
|
appImage n'
|
||||||
getBody n' = maybeToList $ (fmap doubleQuote . parseBody) =<< body n'
|
getBody n' = maybeToList $ (fmap doubleQuote . parseBody) =<< body n'
|
||||||
|
|
|
@ -1,17 +0,0 @@
|
||||||
--------------------------------------------------------------------------------
|
|
||||||
-- | Functions for managing processes
|
|
||||||
|
|
||||||
module XMonad.Internal.Process where
|
|
||||||
|
|
||||||
-- import Control.Exception
|
|
||||||
-- import Control.Monad
|
|
||||||
-- import Control.Monad.IO.Class
|
|
||||||
|
|
||||||
-- import qualified RIO.Text as T
|
|
||||||
|
|
||||||
-- import System.Exit
|
|
||||||
-- import System.IO
|
|
||||||
-- import System.Process
|
|
||||||
|
|
||||||
-- import XMonad.Core hiding (spawn)
|
|
||||||
|
|
|
@ -1,7 +1,7 @@
|
||||||
-- | Functions for formatting and spawning shell commands
|
|
||||||
|
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
|
-- Functions for formatting and spawning shell commands
|
||||||
|
|
||||||
module XMonad.Internal.Shell
|
module XMonad.Internal.Shell
|
||||||
( fmtCmd
|
( fmtCmd
|
||||||
, spawnCmd
|
, spawnCmd
|
||||||
|
@ -17,15 +17,14 @@ module XMonad.Internal.Shell
|
||||||
, (#!||)
|
, (#!||)
|
||||||
, (#!|)
|
, (#!|)
|
||||||
, (#!>>)
|
, (#!>>)
|
||||||
) where
|
)
|
||||||
|
where
|
||||||
import RIO
|
|
||||||
import qualified RIO.Text as T
|
|
||||||
|
|
||||||
|
import RIO
|
||||||
|
import qualified RIO.Text as T
|
||||||
import qualified System.Process.Typed as P
|
import qualified System.Process.Typed as P
|
||||||
|
import qualified XMonad.Core as X
|
||||||
import qualified XMonad.Core as X
|
import qualified XMonad.Util.Run as XR
|
||||||
import qualified XMonad.Util.Run as XR
|
|
||||||
|
|
||||||
-- | Fork a new process and wait for its exit code.
|
-- | Fork a new process and wait for its exit code.
|
||||||
--
|
--
|
||||||
|
|
|
@ -1,7 +1,7 @@
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Theme for XMonad and Xmobar
|
-- Theme for XMonad and Xmobar
|
||||||
|
|
||||||
module XMonad.Internal.Theme
|
module XMonad.Internal.Theme
|
||||||
( baseColor
|
( baseColor
|
||||||
|
@ -18,9 +18,9 @@ module XMonad.Internal.Theme
|
||||||
, backdropTextColor
|
, backdropTextColor
|
||||||
, blend'
|
, blend'
|
||||||
, darken'
|
, darken'
|
||||||
, Slant(..)
|
, Slant (..)
|
||||||
, Weight(..)
|
, Weight (..)
|
||||||
, FontData(..)
|
, FontData (..)
|
||||||
, FontBuilder
|
, FontBuilder
|
||||||
, buildFont
|
, buildFont
|
||||||
, fallbackFont
|
, fallbackFont
|
||||||
|
@ -28,18 +28,17 @@ module XMonad.Internal.Theme
|
||||||
, defFontData
|
, defFontData
|
||||||
, tabbedTheme
|
, tabbedTheme
|
||||||
, promptTheme
|
, promptTheme
|
||||||
) where
|
)
|
||||||
|
where
|
||||||
import Data.Colour
|
|
||||||
import Data.Colour.SRGB
|
|
||||||
|
|
||||||
import qualified RIO.Text as T
|
|
||||||
|
|
||||||
|
import Data.Colour
|
||||||
|
import Data.Colour.SRGB
|
||||||
|
import qualified RIO.Text as T
|
||||||
import qualified XMonad.Layout.Decoration as D
|
import qualified XMonad.Layout.Decoration as D
|
||||||
import qualified XMonad.Prompt as P
|
import qualified XMonad.Prompt as P
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Colors - vocabulary roughly based on GTK themes
|
-- Colors - vocabulary roughly based on GTK themes
|
||||||
|
|
||||||
baseColor :: T.Text
|
baseColor :: T.Text
|
||||||
baseColor = "#f7f7f7"
|
baseColor = "#f7f7f7"
|
||||||
|
@ -78,7 +77,7 @@ backdropFgColor :: T.Text
|
||||||
backdropFgColor = blend' 0.75 fgColor bgColor
|
backdropFgColor = blend' 0.75 fgColor bgColor
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Color functions
|
-- Color functions
|
||||||
|
|
||||||
blend' :: Float -> T.Text -> T.Text -> T.Text
|
blend' :: Float -> T.Text -> T.Text -> T.Text
|
||||||
blend' wt c0 c1 = sRGB24showT $ blend wt (sRGB24readT c0) (sRGB24readT c1)
|
blend' wt c0 c1 = sRGB24showT $ blend wt (sRGB24readT c0) (sRGB24readT c1)
|
||||||
|
@ -93,64 +92,73 @@ sRGB24showT :: (RealFrac a, Floating a) => Colour a -> T.Text
|
||||||
sRGB24showT = T.pack . sRGB24show
|
sRGB24showT = T.pack . sRGB24show
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Fonts
|
-- Fonts
|
||||||
|
|
||||||
data Slant = Roman
|
data Slant
|
||||||
| Italic
|
= Roman
|
||||||
| Oblique
|
| Italic
|
||||||
deriving (Eq, Show)
|
| Oblique
|
||||||
|
deriving (Eq, Show)
|
||||||
|
|
||||||
data Weight = Light
|
data Weight
|
||||||
| Medium
|
= Light
|
||||||
| Demibold
|
| Medium
|
||||||
| Bold
|
| Demibold
|
||||||
| Black
|
| Bold
|
||||||
deriving (Eq, Show)
|
| Black
|
||||||
|
deriving (Eq, Show)
|
||||||
|
|
||||||
data FontData = FontData
|
data FontData = FontData
|
||||||
{ weight :: Maybe Weight
|
{ weight :: Maybe Weight
|
||||||
, slant :: Maybe Slant
|
, slant :: Maybe Slant
|
||||||
, size :: Maybe Int
|
, size :: Maybe Int
|
||||||
, pixelsize :: Maybe Int
|
, pixelsize :: Maybe Int
|
||||||
, antialias :: Maybe Bool
|
, antialias :: Maybe Bool
|
||||||
}
|
}
|
||||||
|
|
||||||
type FontBuilder = FontData -> T.Text
|
type FontBuilder = FontData -> T.Text
|
||||||
|
|
||||||
buildFont :: Maybe T.Text -> FontData -> T.Text
|
buildFont :: Maybe T.Text -> FontData -> T.Text
|
||||||
buildFont Nothing _ = "fixed"
|
buildFont Nothing _ = "fixed"
|
||||||
buildFont (Just fam) FontData { weight = w
|
buildFont
|
||||||
, slant = l
|
(Just fam)
|
||||||
, size = s
|
FontData
|
||||||
, pixelsize = p
|
{ weight = w
|
||||||
, antialias = a
|
, slant = l
|
||||||
}
|
, size = s
|
||||||
= T.intercalate ":" $ ["xft", fam] ++ elems
|
, pixelsize = p
|
||||||
where
|
, antialias = a
|
||||||
elems = [ T.concat [k, "=", v] | (k, Just v) <- [ ("weight", showLower w)
|
} =
|
||||||
, ("slant", showLower l)
|
T.intercalate ":" $ ["xft", fam] ++ elems
|
||||||
, ("size", showLower s)
|
where
|
||||||
, ("pixelsize", showLower p)
|
elems =
|
||||||
, ("antialias", showLower a)
|
[ T.concat [k, "=", v]
|
||||||
]
|
| (k, Just v) <-
|
||||||
]
|
[ ("weight", showLower w)
|
||||||
showLower :: Show a => Maybe a -> Maybe T.Text
|
, ("slant", showLower l)
|
||||||
showLower = fmap (T.toLower . T.pack . show)
|
, ("size", showLower s)
|
||||||
|
, ("pixelsize", showLower p)
|
||||||
|
, ("antialias", showLower a)
|
||||||
|
]
|
||||||
|
]
|
||||||
|
showLower :: Show a => Maybe a -> Maybe T.Text
|
||||||
|
showLower = fmap (T.toLower . T.pack . show)
|
||||||
|
|
||||||
fallbackFont :: FontBuilder
|
fallbackFont :: FontBuilder
|
||||||
fallbackFont = buildFont Nothing
|
fallbackFont = buildFont Nothing
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Default font and data
|
-- Default font and data
|
||||||
|
|
||||||
defFontData :: FontData
|
defFontData :: FontData
|
||||||
defFontData = FontData
|
defFontData =
|
||||||
{ size = Just 10
|
FontData
|
||||||
, antialias = Just True
|
{ size = Just 10
|
||||||
, weight = Nothing
|
, antialias = Just True
|
||||||
, slant = Nothing
|
, weight = Nothing
|
||||||
, pixelsize = Nothing
|
, slant = Nothing
|
||||||
}
|
, pixelsize = Nothing
|
||||||
|
}
|
||||||
|
|
||||||
defFontFamily :: T.Text
|
defFontFamily :: T.Text
|
||||||
defFontFamily = "DejaVu Sans"
|
defFontFamily = "DejaVu Sans"
|
||||||
|
@ -162,44 +170,42 @@ defFontFamily = "DejaVu Sans"
|
||||||
-- defFontTree = fontTree "DejaVu Sans"
|
-- defFontTree = fontTree "DejaVu Sans"
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Complete themes
|
-- Complete themes
|
||||||
|
|
||||||
tabbedTheme :: FontBuilder -> D.Theme
|
tabbedTheme :: FontBuilder -> D.Theme
|
||||||
tabbedTheme fb = D.def
|
tabbedTheme fb =
|
||||||
{ D.fontName = T.unpack $ fb $ defFontData { weight = Just Bold }
|
D.def
|
||||||
|
{ D.fontName = T.unpack $ fb $ defFontData {weight = Just Bold}
|
||||||
|
, D.activeTextColor = T.unpack fgColor
|
||||||
|
, D.activeColor = T.unpack bgColor
|
||||||
|
, D.activeBorderColor = T.unpack bgColor
|
||||||
|
, D.inactiveTextColor = T.unpack backdropTextColor
|
||||||
|
, D.inactiveColor = T.unpack backdropFgColor
|
||||||
|
, D.inactiveBorderColor = T.unpack backdropFgColor
|
||||||
|
, D.urgentTextColor = T.unpack $ darken' 0.5 errorColor
|
||||||
|
, D.urgentColor = T.unpack errorColor
|
||||||
|
, D.urgentBorderColor = T.unpack errorColor
|
||||||
|
, -- this is in a newer version
|
||||||
|
-- , D.activeBorderWidth = 0
|
||||||
|
-- , D.inactiveBorderWidth = 0
|
||||||
|
-- , D.urgentBorderWidth = 0
|
||||||
|
|
||||||
, D.activeTextColor = T.unpack fgColor
|
D.decoHeight = 20
|
||||||
, D.activeColor = T.unpack bgColor
|
, D.windowTitleAddons = []
|
||||||
, D.activeBorderColor = T.unpack bgColor
|
, D.windowTitleIcons = []
|
||||||
|
}
|
||||||
, D.inactiveTextColor = T.unpack backdropTextColor
|
|
||||||
, D.inactiveColor = T.unpack backdropFgColor
|
|
||||||
, D.inactiveBorderColor = T.unpack backdropFgColor
|
|
||||||
|
|
||||||
, D.urgentTextColor = T.unpack $ darken' 0.5 errorColor
|
|
||||||
, D.urgentColor = T.unpack errorColor
|
|
||||||
, D.urgentBorderColor = T.unpack errorColor
|
|
||||||
|
|
||||||
-- this is in a newer version
|
|
||||||
-- , D.activeBorderWidth = 0
|
|
||||||
-- , D.inactiveBorderWidth = 0
|
|
||||||
-- , D.urgentBorderWidth = 0
|
|
||||||
|
|
||||||
, D.decoHeight = 20
|
|
||||||
, D.windowTitleAddons = []
|
|
||||||
, D.windowTitleIcons = []
|
|
||||||
}
|
|
||||||
|
|
||||||
promptTheme :: FontBuilder -> P.XPConfig
|
promptTheme :: FontBuilder -> P.XPConfig
|
||||||
promptTheme fb = P.def
|
promptTheme fb =
|
||||||
{ P.font = T.unpack $ fb $ defFontData { size = Just 12 }
|
P.def
|
||||||
, P.bgColor = T.unpack bgColor
|
{ P.font = T.unpack $ fb $ defFontData {size = Just 12}
|
||||||
, P.fgColor = T.unpack fgColor
|
, P.bgColor = T.unpack bgColor
|
||||||
, P.fgHLight = T.unpack selectedFgColor
|
, P.fgColor = T.unpack fgColor
|
||||||
, P.bgHLight = T.unpack selectedBgColor
|
, P.fgHLight = T.unpack selectedFgColor
|
||||||
, P.borderColor = T.unpack bordersColor
|
, P.bgHLight = T.unpack selectedBgColor
|
||||||
, P.promptBorderWidth = 1
|
, P.borderColor = T.unpack bordersColor
|
||||||
, P.height = 35
|
, P.promptBorderWidth = 1
|
||||||
, P.position = P.CenteredAt 0.5 0.5
|
, P.height = 35
|
||||||
, P.historySize = 0
|
, P.position = P.CenteredAt 0.5 0.5
|
||||||
}
|
, P.historySize = 0
|
||||||
|
}
|
||||||
|
|
|
@ -1,25 +1,26 @@
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
-- Common backlight plugin bits
|
||||||
-- | Common backlight plugin bits
|
|
||||||
--
|
--
|
||||||
-- Use the custom DBus interface exported by the XMonad process so I can react
|
-- Use the custom DBus interface exported by the XMonad process so I can react
|
||||||
-- to signals spawned by commands
|
-- to signals spawned by commands
|
||||||
|
|
||||||
module Xmobar.Plugins.BacklightCommon (startBacklight) where
|
module Xmobar.Plugins.BacklightCommon (startBacklight) where
|
||||||
|
|
||||||
import Data.Internal.DBus
|
import Data.Internal.DBus
|
||||||
|
import qualified RIO.Text as T
|
||||||
|
import Xmobar.Plugins.Common
|
||||||
|
|
||||||
import qualified RIO.Text as T
|
startBacklight
|
||||||
|
:: RealFrac a
|
||||||
import Xmobar.Plugins.Common
|
=> ((Maybe a -> IO ()) -> SesClient -> IO ())
|
||||||
|
-> (SesClient -> IO (Maybe a))
|
||||||
startBacklight :: RealFrac a => ((Maybe a -> IO ()) -> SesClient -> IO ())
|
-> T.Text
|
||||||
-> (SesClient -> IO (Maybe a)) -> T.Text -> Callback -> IO ()
|
-> Callback
|
||||||
|
-> IO ()
|
||||||
startBacklight matchSignal callGetBrightness icon cb = do
|
startBacklight matchSignal callGetBrightness icon cb = do
|
||||||
withDBusClientConnection cb $ \c -> do
|
withDBusClientConnection cb $ \c -> do
|
||||||
matchSignal display c
|
matchSignal display c
|
||||||
display =<< callGetBrightness c
|
display =<< callGetBrightness c
|
||||||
where
|
where
|
||||||
formatBrightness b = return $ T.concat [icon, T.pack $ show (round b :: Integer), "%"]
|
formatBrightness b = return $ T.concat [icon, T.pack $ show (round b :: Integer), "%"]
|
||||||
display = displayMaybe cb formatBrightness
|
display = displayMaybe cb formatBrightness
|
||||||
|
|
|
@ -1,7 +1,7 @@
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Bluetooth plugin
|
-- Bluetooth plugin
|
||||||
--
|
--
|
||||||
-- Use the bluez interface on DBus to check status
|
-- Use the bluez interface on DBus to check status
|
||||||
--
|
--
|
||||||
|
@ -33,36 +33,34 @@
|
||||||
-- adapter changing.
|
-- adapter changing.
|
||||||
|
|
||||||
module Xmobar.Plugins.Bluetooth
|
module Xmobar.Plugins.Bluetooth
|
||||||
( Bluetooth(..)
|
( Bluetooth (..)
|
||||||
, btAlias
|
, btAlias
|
||||||
, btDep
|
, btDep
|
||||||
) where
|
)
|
||||||
|
where
|
||||||
|
|
||||||
import Control.Concurrent.MVar
|
import Control.Concurrent.MVar
|
||||||
import Control.Monad
|
import Control.Monad
|
||||||
|
import DBus
|
||||||
import Data.Internal.DBus
|
import DBus.Client
|
||||||
import Data.Internal.Dependency
|
import Data.Internal.DBus
|
||||||
import Data.List
|
import Data.Internal.Dependency
|
||||||
import Data.List.Split
|
import Data.List
|
||||||
import qualified Data.Map as M
|
import Data.List.Split
|
||||||
import Data.Maybe
|
import qualified Data.Map as M
|
||||||
|
import Data.Maybe
|
||||||
import DBus
|
import qualified RIO.Text as T
|
||||||
import DBus.Client
|
import XMonad.Internal.DBus.Common
|
||||||
|
import Xmobar
|
||||||
import qualified RIO.Text as T
|
import Xmobar.Plugins.Common
|
||||||
|
|
||||||
import XMonad.Internal.DBus.Common
|
|
||||||
import Xmobar
|
|
||||||
import Xmobar.Plugins.Common
|
|
||||||
|
|
||||||
btAlias :: T.Text
|
btAlias :: T.Text
|
||||||
btAlias = "bluetooth"
|
btAlias = "bluetooth"
|
||||||
|
|
||||||
btDep :: DBusDependency_ SysClient
|
btDep :: DBusDependency_ SysClient
|
||||||
btDep = Endpoint [Package Official "bluez"] btBus btOMPath omInterface
|
btDep =
|
||||||
$ Method_ getManagedObjects
|
Endpoint [Package Official "bluez"] btBus btOMPath omInterface $
|
||||||
|
Method_ getManagedObjects
|
||||||
|
|
||||||
data Bluetooth = Bluetooth Icons Colors deriving (Read, Show)
|
data Bluetooth = Bluetooth Icons Colors deriving (Read, Show)
|
||||||
|
|
||||||
|
@ -90,7 +88,7 @@ startAdapter is cs cb cl = do
|
||||||
display
|
display
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Icon Display
|
-- Icon Display
|
||||||
--
|
--
|
||||||
-- Color corresponds to the adaptor powered state, and the icon corresponds to
|
-- Color corresponds to the adaptor powered state, and the icon corresponds to
|
||||||
-- if it is paired or not. If the adaptor state is undefined, display "N/A"
|
-- if it is paired or not. If the adaptor state is undefined, display "N/A"
|
||||||
|
@ -111,7 +109,7 @@ iconFormatter (iconConn, iconDisc) cs powered connected =
|
||||||
icon = if connected then iconConn else iconDisc
|
icon = if connected then iconConn else iconDisc
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Connection State
|
-- Connection State
|
||||||
--
|
--
|
||||||
-- The signal handlers all run on separate threads, yet the icon depends on
|
-- The signal handlers all run on separate threads, yet the icon depends on
|
||||||
-- the state reflected by all these signals. The best (only?) way to do this is
|
-- the state reflected by all these signals. The best (only?) way to do this is
|
||||||
|
@ -119,7 +117,7 @@ iconFormatter (iconConn, iconDisc) cs powered connected =
|
||||||
-- an MVar.
|
-- an MVar.
|
||||||
|
|
||||||
data BTDevice = BTDevice
|
data BTDevice = BTDevice
|
||||||
{ btDevConnected :: Maybe Bool
|
{ btDevConnected :: Maybe Bool
|
||||||
, btDevSigHandler :: SignalHandler
|
, btDevSigHandler :: SignalHandler
|
||||||
}
|
}
|
||||||
|
|
||||||
|
@ -133,10 +131,11 @@ data BtState = BtState
|
||||||
type MutableBtState = MVar BtState
|
type MutableBtState = MVar BtState
|
||||||
|
|
||||||
emptyState :: BtState
|
emptyState :: BtState
|
||||||
emptyState = BtState
|
emptyState =
|
||||||
{ btDevices = M.empty
|
BtState
|
||||||
, btPowered = Nothing
|
{ btDevices = M.empty
|
||||||
}
|
, btPowered = Nothing
|
||||||
|
}
|
||||||
|
|
||||||
readState :: MutableBtState -> IO (Maybe Bool, Bool)
|
readState :: MutableBtState -> IO (Maybe Bool, Bool)
|
||||||
readState state = do
|
readState state = do
|
||||||
|
@ -145,7 +144,7 @@ readState state = do
|
||||||
return (p, anyDevicesConnected c)
|
return (p, anyDevicesConnected c)
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Object manager
|
-- Object manager
|
||||||
|
|
||||||
findAdapter :: ObjectTree -> Maybe ObjectPath
|
findAdapter :: ObjectTree -> Maybe ObjectPath
|
||||||
findAdapter = find (("/org/bluez/hci" `isPrefixOf`) . formatObjectPath) . M.keys
|
findAdapter = find (("/org/bluez/hci" `isPrefixOf`) . formatObjectPath) . M.keys
|
||||||
|
@ -156,10 +155,10 @@ findDevices adapter = filter (adaptorHasDevice adapter) . M.keys
|
||||||
adaptorHasDevice :: ObjectPath -> ObjectPath -> Bool
|
adaptorHasDevice :: ObjectPath -> ObjectPath -> Bool
|
||||||
adaptorHasDevice adaptor device = case splitPath device of
|
adaptorHasDevice adaptor device = case splitPath device of
|
||||||
[org, bluez, hciX, _] -> splitPath adaptor == [org, bluez, hciX]
|
[org, bluez, hciX, _] -> splitPath adaptor == [org, bluez, hciX]
|
||||||
_ -> False
|
_ -> False
|
||||||
|
|
||||||
splitPath :: ObjectPath -> [T.Text]
|
splitPath :: ObjectPath -> [T.Text]
|
||||||
splitPath = fmap T.pack . splitOn "/" . dropWhile (=='/') . formatObjectPath
|
splitPath = fmap T.pack . splitOn "/" . dropWhile (== '/') . formatObjectPath
|
||||||
|
|
||||||
getBtObjectTree :: SysClient -> IO ObjectTree
|
getBtObjectTree :: SysClient -> IO ObjectTree
|
||||||
getBtObjectTree sys = callGetManagedObjects sys btBus btOMPath
|
getBtObjectTree sys = callGetManagedObjects sys btBus btOMPath
|
||||||
|
@ -191,7 +190,7 @@ pathCallback adapter display f [device, _] = forM_ (fromVariant device) $ \d ->
|
||||||
pathCallback _ _ _ _ = return ()
|
pathCallback _ _ _ _ = return ()
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Adapter
|
-- Adapter
|
||||||
|
|
||||||
initAdapter :: MutableBtState -> ObjectPath -> SysClient -> IO ()
|
initAdapter :: MutableBtState -> ObjectPath -> SysClient -> IO ()
|
||||||
initAdapter state adapter client = do
|
initAdapter state adapter client = do
|
||||||
|
@ -201,7 +200,11 @@ initAdapter state adapter client = do
|
||||||
matchBTProperty :: SysClient -> ObjectPath -> IO (Maybe MatchRule)
|
matchBTProperty :: SysClient -> ObjectPath -> IO (Maybe MatchRule)
|
||||||
matchBTProperty sys p = matchPropertyFull sys btBus (Just p)
|
matchBTProperty sys p = matchPropertyFull sys btBus (Just p)
|
||||||
|
|
||||||
addAdaptorListener :: MutableBtState -> IO () -> ObjectPath -> SysClient
|
addAdaptorListener
|
||||||
|
:: MutableBtState
|
||||||
|
-> IO ()
|
||||||
|
-> ObjectPath
|
||||||
|
-> SysClient
|
||||||
-> IO (Maybe SignalHandler)
|
-> IO (Maybe SignalHandler)
|
||||||
addAdaptorListener state display adaptor sys = do
|
addAdaptorListener state display adaptor sys = do
|
||||||
rule <- matchBTProperty sys adaptor
|
rule <- matchBTProperty sys adaptor
|
||||||
|
@ -210,14 +213,16 @@ addAdaptorListener state display adaptor sys = do
|
||||||
procMatch = withSignalMatch $ \b -> putPowered state b >> display
|
procMatch = withSignalMatch $ \b -> putPowered state b >> display
|
||||||
|
|
||||||
callGetPowered :: ObjectPath -> SysClient -> IO [Variant]
|
callGetPowered :: ObjectPath -> SysClient -> IO [Variant]
|
||||||
callGetPowered adapter = callPropertyGet btBus adapter adapterInterface
|
callGetPowered adapter =
|
||||||
$ memberName_ $ T.unpack adaptorPowered
|
callPropertyGet btBus adapter adapterInterface $
|
||||||
|
memberName_ $
|
||||||
|
T.unpack adaptorPowered
|
||||||
|
|
||||||
matchPowered :: [Variant] -> SignalMatch Bool
|
matchPowered :: [Variant] -> SignalMatch Bool
|
||||||
matchPowered = matchPropertyChanged adapterInterface adaptorPowered
|
matchPowered = matchPropertyChanged adapterInterface adaptorPowered
|
||||||
|
|
||||||
putPowered :: MutableBtState -> Maybe Bool -> IO ()
|
putPowered :: MutableBtState -> Maybe Bool -> IO ()
|
||||||
putPowered m ds = modifyMVar_ m (\s -> return s { btPowered = ds })
|
putPowered m ds = modifyMVar_ m (\s -> return s {btPowered = ds})
|
||||||
|
|
||||||
readPowered :: MutableBtState -> IO (Maybe Bool)
|
readPowered :: MutableBtState -> IO (Maybe Bool)
|
||||||
readPowered = fmap btPowered . readMVar
|
readPowered = fmap btPowered . readMVar
|
||||||
|
@ -229,7 +234,7 @@ adaptorPowered :: T.Text
|
||||||
adaptorPowered = "Powered"
|
adaptorPowered = "Powered"
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Devices
|
-- Devices
|
||||||
|
|
||||||
addAndInitDevice :: MutableBtState -> IO () -> ObjectPath -> SysClient -> IO ()
|
addAndInitDevice :: MutableBtState -> IO () -> ObjectPath -> SysClient -> IO ()
|
||||||
addAndInitDevice state display device client = do
|
addAndInitDevice state display device client = do
|
||||||
|
@ -240,12 +245,18 @@ addAndInitDevice state display device client = do
|
||||||
initDevice :: MutableBtState -> SignalHandler -> ObjectPath -> SysClient -> IO ()
|
initDevice :: MutableBtState -> SignalHandler -> ObjectPath -> SysClient -> IO ()
|
||||||
initDevice state sh device sys = do
|
initDevice state sh device sys = do
|
||||||
reply <- callGetConnected device sys
|
reply <- callGetConnected device sys
|
||||||
void $ insertDevice state device $
|
void $
|
||||||
BTDevice { btDevConnected = fromVariant =<< listToMaybe reply
|
insertDevice state device $
|
||||||
, btDevSigHandler = sh
|
BTDevice
|
||||||
}
|
{ btDevConnected = fromVariant =<< listToMaybe reply
|
||||||
|
, btDevSigHandler = sh
|
||||||
|
}
|
||||||
|
|
||||||
addDeviceListener :: MutableBtState -> IO () -> ObjectPath -> SysClient
|
addDeviceListener
|
||||||
|
:: MutableBtState
|
||||||
|
-> IO ()
|
||||||
|
-> ObjectPath
|
||||||
|
-> SysClient
|
||||||
-> IO (Maybe SignalHandler)
|
-> IO (Maybe SignalHandler)
|
||||||
addDeviceListener state display device sys = do
|
addDeviceListener state display device sys = do
|
||||||
rule <- matchBTProperty sys device
|
rule <- matchBTProperty sys device
|
||||||
|
@ -257,18 +268,19 @@ matchConnected :: [Variant] -> SignalMatch Bool
|
||||||
matchConnected = matchPropertyChanged devInterface devConnected
|
matchConnected = matchPropertyChanged devInterface devConnected
|
||||||
|
|
||||||
callGetConnected :: ObjectPath -> SysClient -> IO [Variant]
|
callGetConnected :: ObjectPath -> SysClient -> IO [Variant]
|
||||||
callGetConnected p = callPropertyGet btBus p devInterface
|
callGetConnected p =
|
||||||
$ memberName_ (T.unpack devConnected)
|
callPropertyGet btBus p devInterface $
|
||||||
|
memberName_ (T.unpack devConnected)
|
||||||
|
|
||||||
insertDevice :: MutableBtState -> ObjectPath -> BTDevice -> IO Bool
|
insertDevice :: MutableBtState -> ObjectPath -> BTDevice -> IO Bool
|
||||||
insertDevice m device dev = modifyMVar m $ \s -> do
|
insertDevice m device dev = modifyMVar m $ \s -> do
|
||||||
let new = M.insert device dev $ btDevices s
|
let new = M.insert device dev $ btDevices s
|
||||||
return (s { btDevices = new }, anyDevicesConnected new)
|
return (s {btDevices = new}, anyDevicesConnected new)
|
||||||
|
|
||||||
updateDevice :: MutableBtState -> ObjectPath -> Maybe Bool -> IO Bool
|
updateDevice :: MutableBtState -> ObjectPath -> Maybe Bool -> IO Bool
|
||||||
updateDevice m device status = modifyMVar m $ \s -> do
|
updateDevice m device status = modifyMVar m $ \s -> do
|
||||||
let new = M.update (\d -> Just d { btDevConnected = status }) device $ btDevices s
|
let new = M.update (\d -> Just d {btDevConnected = status}) device $ btDevices s
|
||||||
return (s { btDevices = new }, anyDevicesConnected new)
|
return (s {btDevices = new}, anyDevicesConnected new)
|
||||||
|
|
||||||
anyDevicesConnected :: ConnectedDevices -> Bool
|
anyDevicesConnected :: ConnectedDevices -> Bool
|
||||||
anyDevicesConnected = or . mapMaybe btDevConnected . M.elems
|
anyDevicesConnected = or . mapMaybe btDevConnected . M.elems
|
||||||
|
@ -276,7 +288,7 @@ anyDevicesConnected = or . mapMaybe btDevConnected . M.elems
|
||||||
removeDevice :: MutableBtState -> ObjectPath -> IO (Maybe BTDevice)
|
removeDevice :: MutableBtState -> ObjectPath -> IO (Maybe BTDevice)
|
||||||
removeDevice m device = modifyMVar m $ \s -> do
|
removeDevice m device = modifyMVar m $ \s -> do
|
||||||
let devs = btDevices s
|
let devs = btDevices s
|
||||||
return (s { btDevices = M.delete device devs }, M.lookup device devs)
|
return (s {btDevices = M.delete device devs}, M.lookup device devs)
|
||||||
|
|
||||||
readDevices :: MutableBtState -> IO ConnectedDevices
|
readDevices :: MutableBtState -> IO ConnectedDevices
|
||||||
readDevices = fmap btDevices . readMVar
|
readDevices = fmap btDevices . readMVar
|
||||||
|
|
|
@ -1,23 +1,21 @@
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Clevo Keyboard plugin
|
-- Clevo Keyboard plugin
|
||||||
--
|
--
|
||||||
-- Use the custom DBus interface exported by the XMonad process so I can react
|
-- Use the custom DBus interface exported by the XMonad process so I can react
|
||||||
-- to signals spawned by commands
|
-- to signals spawned by commands
|
||||||
|
|
||||||
module Xmobar.Plugins.ClevoKeyboard
|
module Xmobar.Plugins.ClevoKeyboard
|
||||||
( ClevoKeyboard(..)
|
( ClevoKeyboard (..)
|
||||||
, ckAlias
|
, ckAlias
|
||||||
) where
|
)
|
||||||
|
where
|
||||||
|
|
||||||
import qualified RIO.Text as T
|
import qualified RIO.Text as T
|
||||||
|
import XMonad.Internal.DBus.Brightness.ClevoKeyboard
|
||||||
import Xmobar
|
import Xmobar
|
||||||
|
import Xmobar.Plugins.BacklightCommon
|
||||||
import Xmobar.Plugins.BacklightCommon
|
|
||||||
|
|
||||||
import XMonad.Internal.DBus.Brightness.ClevoKeyboard
|
|
||||||
|
|
||||||
newtype ClevoKeyboard = ClevoKeyboard T.Text deriving (Read, Show)
|
newtype ClevoKeyboard = ClevoKeyboard T.Text deriving (Read, Show)
|
||||||
|
|
||||||
|
@ -27,4 +25,4 @@ ckAlias = "clevokeyboard"
|
||||||
instance Exec ClevoKeyboard where
|
instance Exec ClevoKeyboard where
|
||||||
alias (ClevoKeyboard _) = T.unpack ckAlias
|
alias (ClevoKeyboard _) = T.unpack ckAlias
|
||||||
start (ClevoKeyboard icon) =
|
start (ClevoKeyboard icon) =
|
||||||
startBacklight matchSignalCK callGetBrightnessCK icon
|
startBacklight matchSignalCK callGetBrightnessCK icon
|
||||||
|
|
|
@ -8,36 +8,38 @@ module Xmobar.Plugins.Common
|
||||||
, fromSingletonVariant
|
, fromSingletonVariant
|
||||||
, withDBusClientConnection
|
, withDBusClientConnection
|
||||||
, Callback
|
, Callback
|
||||||
, Colors(..)
|
, Colors (..)
|
||||||
, displayMaybe
|
, displayMaybe
|
||||||
, displayMaybe'
|
, displayMaybe'
|
||||||
, xmobarFGColor
|
, xmobarFGColor
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
|
||||||
import Control.Monad
|
import Control.Monad
|
||||||
|
import DBus
|
||||||
import Data.Internal.DBus
|
import DBus.Client
|
||||||
|
import Data.Internal.DBus
|
||||||
import DBus
|
import qualified RIO.Text as T
|
||||||
import DBus.Client
|
import XMonad.Hooks.DynamicLog (xmobarColor)
|
||||||
|
|
||||||
import qualified RIO.Text as T
|
|
||||||
|
|
||||||
import XMonad.Hooks.DynamicLog (xmobarColor)
|
|
||||||
|
|
||||||
-- use string here since all the callbacks in xmobar use strings :(
|
-- use string here since all the callbacks in xmobar use strings :(
|
||||||
type Callback = String -> IO ()
|
type Callback = String -> IO ()
|
||||||
|
|
||||||
data Colors = Colors
|
data Colors = Colors
|
||||||
{ colorsOn :: T.Text
|
{ colorsOn :: T.Text
|
||||||
, colorsOff :: T.Text
|
, colorsOff :: T.Text
|
||||||
}
|
}
|
||||||
deriving (Eq, Show, Read)
|
deriving (Eq, Show, Read)
|
||||||
|
|
||||||
startListener :: (SafeClient c, IsVariant a) => MatchRule -> (c -> IO [Variant])
|
startListener
|
||||||
-> ([Variant] -> SignalMatch a) -> (a -> IO T.Text) -> Callback
|
:: (SafeClient c, IsVariant a)
|
||||||
-> c -> IO ()
|
=> MatchRule
|
||||||
|
-> (c -> IO [Variant])
|
||||||
|
-> ([Variant] -> SignalMatch a)
|
||||||
|
-> (a -> IO T.Text)
|
||||||
|
-> Callback
|
||||||
|
-> c
|
||||||
|
-> IO ()
|
||||||
startListener rule getProp fromSignal toColor cb client = do
|
startListener rule getProp fromSignal toColor cb client = do
|
||||||
reply <- getProp client
|
reply <- getProp client
|
||||||
displayMaybe cb toColor $ fromSingletonVariant reply
|
displayMaybe cb toColor $ fromSingletonVariant reply
|
||||||
|
@ -49,8 +51,8 @@ procSignalMatch :: Callback -> (a -> IO T.Text) -> SignalMatch a -> IO ()
|
||||||
procSignalMatch cb f = withSignalMatch (displayMaybe cb f)
|
procSignalMatch cb f = withSignalMatch (displayMaybe cb f)
|
||||||
|
|
||||||
colorText :: Colors -> Bool -> T.Text -> T.Text
|
colorText :: Colors -> Bool -> T.Text -> T.Text
|
||||||
colorText Colors { colorsOn = c } True = xmobarFGColor c
|
colorText Colors {colorsOn = c} True = xmobarFGColor c
|
||||||
colorText Colors { colorsOff = c } False = xmobarFGColor c
|
colorText Colors {colorsOff = c} False = xmobarFGColor c
|
||||||
|
|
||||||
xmobarFGColor :: T.Text -> T.Text -> T.Text
|
xmobarFGColor :: T.Text -> T.Text -> T.Text
|
||||||
xmobarFGColor c = T.pack . xmobarColor (T.unpack c) "" . T.unpack
|
xmobarFGColor c = T.pack . xmobarColor (T.unpack c) "" . T.unpack
|
||||||
|
|
|
@ -1,30 +1,27 @@
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Device plugin
|
-- Device plugin
|
||||||
--
|
--
|
||||||
-- Display different text depending on whether or not the interface has
|
-- Display different text depending on whether or not the interface has
|
||||||
-- connectivity
|
-- connectivity
|
||||||
|
|
||||||
module Xmobar.Plugins.Device
|
module Xmobar.Plugins.Device
|
||||||
( Device(..)
|
( Device (..)
|
||||||
, devDep
|
, devDep
|
||||||
) where
|
)
|
||||||
|
where
|
||||||
|
|
||||||
import Control.Monad
|
import Control.Monad
|
||||||
|
import DBus
|
||||||
import Data.Internal.DBus
|
import Data.Internal.DBus
|
||||||
import Data.Internal.Dependency
|
import Data.Internal.Dependency
|
||||||
import Data.Word
|
import Data.Word
|
||||||
|
import qualified RIO.Text as T
|
||||||
import DBus
|
import XMonad.Internal.Command.Desktop
|
||||||
|
import XMonad.Internal.DBus.Common
|
||||||
import qualified RIO.Text as T
|
import Xmobar
|
||||||
|
import Xmobar.Plugins.Common
|
||||||
import XMonad.Internal.Command.Desktop
|
|
||||||
import XMonad.Internal.DBus.Common
|
|
||||||
import Xmobar
|
|
||||||
import Xmobar.Plugins.Common
|
|
||||||
|
|
||||||
newtype Device = Device (T.Text, T.Text, Colors) deriving (Read, Show)
|
newtype Device = Device (T.Text, T.Text, Colors) deriving (Read, Show)
|
||||||
|
|
||||||
|
@ -44,19 +41,23 @@ devSignal :: T.Text
|
||||||
devSignal = "Ip4Connectivity"
|
devSignal = "Ip4Connectivity"
|
||||||
|
|
||||||
devDep :: DBusDependency_ SysClient
|
devDep :: DBusDependency_ SysClient
|
||||||
devDep = Endpoint networkManagerPkgs networkManagerBus nmPath nmInterface
|
devDep =
|
||||||
$ Method_ getByIP
|
Endpoint networkManagerPkgs networkManagerBus nmPath nmInterface $
|
||||||
|
Method_ getByIP
|
||||||
|
|
||||||
getDevice :: SysClient -> T.Text -> IO (Maybe ObjectPath)
|
getDevice :: SysClient -> T.Text -> IO (Maybe ObjectPath)
|
||||||
getDevice sys iface = bodyToMaybe <$> callMethod' sys mc
|
getDevice sys iface = bodyToMaybe <$> callMethod' sys mc
|
||||||
where
|
where
|
||||||
mc = (methodCallBus networkManagerBus nmPath nmInterface getByIP)
|
mc =
|
||||||
{ methodCallBody = [toVariant iface]
|
(methodCallBus networkManagerBus nmPath nmInterface getByIP)
|
||||||
}
|
{ methodCallBody = [toVariant iface]
|
||||||
|
}
|
||||||
|
|
||||||
getDeviceConnected :: ObjectPath -> SysClient -> IO [Variant]
|
getDeviceConnected :: ObjectPath -> SysClient -> IO [Variant]
|
||||||
getDeviceConnected path = callPropertyGet networkManagerBus path nmDeviceInterface
|
getDeviceConnected path =
|
||||||
$ memberName_ $ T.unpack devSignal
|
callPropertyGet networkManagerBus path nmDeviceInterface $
|
||||||
|
memberName_ $
|
||||||
|
T.unpack devSignal
|
||||||
|
|
||||||
matchStatus :: [Variant] -> SignalMatch Word32
|
matchStatus :: [Variant] -> SignalMatch Word32
|
||||||
matchStatus = matchPropertyChanged nmDeviceInterface devSignal
|
matchStatus = matchPropertyChanged nmDeviceInterface devSignal
|
||||||
|
|
|
@ -1,23 +1,21 @@
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Intel backlight plugin
|
-- Intel backlight plugin
|
||||||
--
|
--
|
||||||
-- Use the custom DBus interface exported by the XMonad process so I can react
|
-- Use the custom DBus interface exported by the XMonad process so I can react
|
||||||
-- to signals spawned by commands
|
-- to signals spawned by commands
|
||||||
|
|
||||||
module Xmobar.Plugins.IntelBacklight
|
module Xmobar.Plugins.IntelBacklight
|
||||||
( IntelBacklight(..)
|
( IntelBacklight (..)
|
||||||
, blAlias
|
, blAlias
|
||||||
) where
|
)
|
||||||
|
where
|
||||||
|
|
||||||
import qualified RIO.Text as T
|
import qualified RIO.Text as T
|
||||||
|
import XMonad.Internal.DBus.Brightness.IntelBacklight
|
||||||
import Xmobar
|
import Xmobar
|
||||||
|
import Xmobar.Plugins.BacklightCommon
|
||||||
import Xmobar.Plugins.BacklightCommon
|
|
||||||
|
|
||||||
import XMonad.Internal.DBus.Brightness.IntelBacklight
|
|
||||||
|
|
||||||
newtype IntelBacklight = IntelBacklight T.Text deriving (Read, Show)
|
newtype IntelBacklight = IntelBacklight T.Text deriving (Read, Show)
|
||||||
|
|
||||||
|
@ -27,4 +25,4 @@ blAlias = "intelbacklight"
|
||||||
instance Exec IntelBacklight where
|
instance Exec IntelBacklight where
|
||||||
alias (IntelBacklight _) = T.unpack blAlias
|
alias (IntelBacklight _) = T.unpack blAlias
|
||||||
start (IntelBacklight icon) =
|
start (IntelBacklight icon) =
|
||||||
startBacklight matchSignalIB callGetBrightnessIB icon
|
startBacklight matchSignalIB callGetBrightnessIB icon
|
||||||
|
|
|
@ -1,22 +1,21 @@
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Screensaver plugin
|
-- Screensaver plugin
|
||||||
--
|
--
|
||||||
-- Use the custom DBus interface exported by the XMonad process so I can react
|
-- Use the custom DBus interface exported by the XMonad process so I can react
|
||||||
-- to signals spawned by commands
|
-- to signals spawned by commands
|
||||||
|
|
||||||
module Xmobar.Plugins.Screensaver
|
module Xmobar.Plugins.Screensaver
|
||||||
( Screensaver(..)
|
( Screensaver (..)
|
||||||
, ssAlias
|
, ssAlias
|
||||||
) where
|
)
|
||||||
|
where
|
||||||
|
|
||||||
import qualified RIO.Text as T
|
import qualified RIO.Text as T
|
||||||
|
import XMonad.Internal.DBus.Screensaver
|
||||||
import Xmobar
|
import Xmobar
|
||||||
|
import Xmobar.Plugins.Common
|
||||||
import XMonad.Internal.DBus.Screensaver
|
|
||||||
import Xmobar.Plugins.Common
|
|
||||||
|
|
||||||
newtype Screensaver = Screensaver (T.Text, Colors) deriving (Read, Show)
|
newtype Screensaver = Screensaver (T.Text, Colors) deriving (Read, Show)
|
||||||
|
|
||||||
|
@ -31,4 +30,3 @@ instance Exec Screensaver where
|
||||||
display =<< callQuery sys
|
display =<< callQuery sys
|
||||||
where
|
where
|
||||||
display = displayMaybe cb $ return . (\s -> colorText colors s text)
|
display = displayMaybe cb $ return . (\s -> colorText colors s text)
|
||||||
|
|
||||||
|
|
|
@ -1,35 +1,32 @@
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | VPN plugin
|
-- VPN plugin
|
||||||
--
|
--
|
||||||
-- Use the networkmanager to detect when a VPN interface is added or removed.
|
-- Use the networkmanager to detect when a VPN interface is added or removed.
|
||||||
-- Specifically, monitor the object tree to detect paths with the interface
|
-- Specifically, monitor the object tree to detect paths with the interface
|
||||||
-- "org.freedesktop.NetworkManager.Device.Tun".
|
-- "org.freedesktop.NetworkManager.Device.Tun".
|
||||||
|
|
||||||
module Xmobar.Plugins.VPN
|
module Xmobar.Plugins.VPN
|
||||||
( VPN(..)
|
( VPN (..)
|
||||||
, vpnAlias
|
, vpnAlias
|
||||||
, vpnDep
|
, vpnDep
|
||||||
) where
|
)
|
||||||
|
where
|
||||||
|
|
||||||
import Control.Concurrent.MVar
|
import Control.Concurrent.MVar
|
||||||
import Control.Monad
|
import Control.Monad
|
||||||
|
import DBus
|
||||||
import Data.Internal.DBus
|
import Data.Internal.DBus
|
||||||
import Data.Internal.Dependency
|
import Data.Internal.Dependency
|
||||||
import qualified Data.Map as M
|
import qualified Data.Map as M
|
||||||
import Data.Maybe
|
import Data.Maybe
|
||||||
import qualified Data.Set as S
|
import qualified Data.Set as S
|
||||||
|
import qualified RIO.Text as T
|
||||||
import DBus
|
import XMonad.Internal.Command.Desktop
|
||||||
|
import XMonad.Internal.DBus.Common
|
||||||
import qualified RIO.Text as T
|
import Xmobar
|
||||||
|
import Xmobar.Plugins.Common
|
||||||
import XMonad.Internal.Command.Desktop
|
|
||||||
import XMonad.Internal.DBus.Common
|
|
||||||
import Xmobar
|
|
||||||
import Xmobar.Plugins.Common
|
|
||||||
|
|
||||||
newtype VPN = VPN (T.Text, Colors) deriving (Read, Show)
|
newtype VPN = VPN (T.Text, Colors) deriving (Read, Show)
|
||||||
|
|
||||||
|
@ -37,17 +34,17 @@ instance Exec VPN where
|
||||||
alias (VPN _) = T.unpack vpnAlias
|
alias (VPN _) = T.unpack vpnAlias
|
||||||
start (VPN (text, colors)) cb =
|
start (VPN (text, colors)) cb =
|
||||||
withDBusClientConnection cb $ \c -> do
|
withDBusClientConnection cb $ \c -> do
|
||||||
state <- initState c
|
state <- initState c
|
||||||
let display = displayMaybe cb iconFormatter . Just =<< readState state
|
let display = displayMaybe cb iconFormatter . Just =<< readState state
|
||||||
let signalCallback' f = f state display
|
let signalCallback' f = f state display
|
||||||
vpnAddedListener (signalCallback' addedCallback) c
|
vpnAddedListener (signalCallback' addedCallback) c
|
||||||
vpnRemovedListener (signalCallback' removedCallback) c
|
vpnRemovedListener (signalCallback' removedCallback) c
|
||||||
display
|
display
|
||||||
where
|
where
|
||||||
iconFormatter b = return $ colorText colors b text
|
iconFormatter b = return $ colorText colors b text
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | VPN State
|
-- VPN State
|
||||||
--
|
--
|
||||||
-- Maintain a set of paths which are the currently active VPNs. Most of the time
|
-- Maintain a set of paths which are the currently active VPNs. Most of the time
|
||||||
-- this will be a null or singleton set, but this setup could handle the edge
|
-- this will be a null or singleton set, but this setup could handle the edge
|
||||||
|
@ -65,13 +62,15 @@ initState client = do
|
||||||
readState :: MutableVPNState -> IO Bool
|
readState :: MutableVPNState -> IO Bool
|
||||||
readState = fmap (not . null) . readMVar
|
readState = fmap (not . null) . readMVar
|
||||||
|
|
||||||
updateState :: (ObjectPath -> VPNState -> VPNState) -> MutableVPNState
|
updateState
|
||||||
-> ObjectPath -> IO ()
|
:: (ObjectPath -> VPNState -> VPNState)
|
||||||
|
-> MutableVPNState
|
||||||
|
-> ObjectPath
|
||||||
|
-> IO ()
|
||||||
updateState f state op = modifyMVar_ state $ return . f op
|
updateState f state op = modifyMVar_ state $ return . f op
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Tunnel Device Detection
|
-- Tunnel Device Detection
|
||||||
--
|
|
||||||
|
|
||||||
getVPNObjectTree :: SysClient -> IO ObjectTree
|
getVPNObjectTree :: SysClient -> IO ObjectTree
|
||||||
getVPNObjectTree sys = callGetManagedObjects sys vpnBus vpnPath
|
getVPNObjectTree sys = callGetManagedObjects sys vpnBus vpnPath
|
||||||
|
@ -91,25 +90,30 @@ addedCallback state display [device, added] = update >> display
|
||||||
added' = fromVariant added :: Maybe (M.Map T.Text (M.Map T.Text Variant))
|
added' = fromVariant added :: Maybe (M.Map T.Text (M.Map T.Text Variant))
|
||||||
is = M.keys $ fromMaybe M.empty added'
|
is = M.keys $ fromMaybe M.empty added'
|
||||||
update = updateDevice S.insert state device is
|
update = updateDevice S.insert state device is
|
||||||
addedCallback _ _ _ = return ()
|
addedCallback _ _ _ = return ()
|
||||||
|
|
||||||
removedCallback :: MutableVPNState -> IO () -> SignalCallback
|
removedCallback :: MutableVPNState -> IO () -> SignalCallback
|
||||||
removedCallback state display [device, interfaces] = update >> display
|
removedCallback state display [device, interfaces] = update >> display
|
||||||
where
|
where
|
||||||
is = fromMaybe [] $ fromVariant interfaces :: [T.Text]
|
is = fromMaybe [] $ fromVariant interfaces :: [T.Text]
|
||||||
update = updateDevice S.delete state device is
|
update = updateDevice S.delete state device is
|
||||||
removedCallback _ _ _ = return ()
|
removedCallback _ _ _ = return ()
|
||||||
|
|
||||||
updateDevice :: (ObjectPath -> VPNState -> VPNState) -> MutableVPNState
|
updateDevice
|
||||||
-> Variant -> [T.Text] -> IO ()
|
:: (ObjectPath -> VPNState -> VPNState)
|
||||||
updateDevice f state device interfaces = when (vpnDeviceTun `elem` interfaces) $
|
-> MutableVPNState
|
||||||
forM_ d $ updateState f state
|
-> Variant
|
||||||
|
-> [T.Text]
|
||||||
|
-> IO ()
|
||||||
|
updateDevice f state device interfaces =
|
||||||
|
when (vpnDeviceTun `elem` interfaces) $
|
||||||
|
forM_ d $
|
||||||
|
updateState f state
|
||||||
where
|
where
|
||||||
d = fromVariant device :: Maybe ObjectPath
|
d = fromVariant device :: Maybe ObjectPath
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | DBus Interface
|
-- DBus Interface
|
||||||
--
|
|
||||||
|
|
||||||
vpnBus :: BusName
|
vpnBus :: BusName
|
||||||
vpnBus = busName_ "org.freedesktop.NetworkManager"
|
vpnBus = busName_ "org.freedesktop.NetworkManager"
|
||||||
|
@ -124,5 +128,6 @@ vpnAlias :: T.Text
|
||||||
vpnAlias = "vpn"
|
vpnAlias = "vpn"
|
||||||
|
|
||||||
vpnDep :: DBusDependency_ SysClient
|
vpnDep :: DBusDependency_ SysClient
|
||||||
vpnDep = Endpoint networkManagerPkgs networkManagerBus vpnPath omInterface
|
vpnDep =
|
||||||
$ Method_ getManagedObjects
|
Endpoint networkManagerPkgs networkManagerBus vpnPath omInterface $
|
||||||
|
Method_ getManagedObjects
|
||||||
|
|
|
@ -7,7 +7,7 @@ copyright: "2022 Nathan Dwarshuis"
|
||||||
|
|
||||||
extra-source-files:
|
extra-source-files:
|
||||||
- README.md
|
- README.md
|
||||||
- .stylish-haskell.yaml
|
- fourmolu.yaml
|
||||||
- make_pkgs
|
- make_pkgs
|
||||||
- icons/*
|
- icons/*
|
||||||
- scripts/*
|
- scripts/*
|
||||||
|
|
Loading…
Reference in New Issue