REF reformat everything with fourmolu

This commit is contained in:
Nathan Dwarshuis 2022-12-30 14:58:23 -05:00
parent b2b0f72178
commit adf0257533
34 changed files with 2472 additions and 2038 deletions

View File

@ -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,19 +14,14 @@
-- 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 Text.XML.Light
import System.Environment import System.Environment
import Text.XML.Light
import XMonad.Internal.Concurrent.VirtualBox import XMonad.Internal.Concurrent.VirtualBox
import XMonad.Internal.IO import XMonad.Internal.IO
@ -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,7 +49,9 @@ 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: " _ ->
logError $
"Failed to start VM: "
<> displayBytesUtf8 (encodeUtf8 i) <> displayBytesUtf8 (encodeUtf8 i)
vmPID :: T.Text -> RIO SimpleApp (Maybe Int) vmPID :: T.Text -> RIO SimpleApp (Maybe Int)
@ -73,8 +68,9 @@ vmMachineID iPath = do
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.stripSuffix "}"
=<< T.stripPrefix "{" =<< T.stripPrefix "{"
=<< (fmap T.pack . findAttr (blank_name { qName = "uuid" })) =<< (fmap T.pack . findAttr (blank_name {qName = "uuid"}))
=<< (\e -> findChild (qual e "Machine") e) =<< (\e -> findChild (qual e "Machine") e)
=<< parseXMLDoc c =<< parseXMLDoc c

View File

@ -1,8 +1,5 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
module Main (main) where
--------------------------------------------------------------------------------
-- | Xmobar binary -- | Xmobar binary
-- --
-- Features: -- Features:
@ -12,29 +9,19 @@ 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 RIO hiding (hFlush)
import qualified RIO.ByteString.Lazy as BL import qualified RIO.ByteString.Lazy as BL
import RIO.Process import RIO.Process
import qualified RIO.Text as T import qualified RIO.Text as T
import System.Environment import System.Environment
import System.IO import System.IO
import Xmobar.Plugins.Bluetooth
import Xmobar.Plugins.ClevoKeyboard
import Xmobar.Plugins.Device
import Xmobar.Plugins.IntelBacklight
import Xmobar.Plugins.Screensaver
import Xmobar.Plugins.VPN
import XMonad.Core hiding (config) import XMonad.Core hiding (config)
import XMonad.Internal.Command.Desktop import XMonad.Internal.Command.Desktop
import XMonad.Internal.Command.Power import XMonad.Internal.Command.Power
@ -47,8 +34,13 @@ import Xmobar hiding
( iconOffset ( iconOffset
, run , run
) )
import Xmobar.Plugins.Bluetooth
import Xmobar.Plugins.ClevoKeyboard
import Xmobar.Plugins.Common import Xmobar.Plugins.Common
import Xmobar.Plugins.Device
import Xmobar.Plugins.IntelBacklight
import Xmobar.Plugins.Screensaver
import Xmobar.Plugins.VPN
main :: IO () main :: IO ()
main = getArgs >>= parse main = getArgs >>= parse
@ -84,13 +76,16 @@ printDeps = do
io $ disconnectDBus db io $ disconnectDBus db
usage :: IO () usage :: IO ()
usage = putStrLn $ intercalate "\n" usage =
putStrLn $
intercalate
"\n"
[ "xmobar: run greatest taskbar" [ "xmobar: run greatest taskbar"
, "xmobar --deps: print dependencies" , "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,11 +97,14 @@ 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 =
fontSometimes
"XMobar Icon Font"
"Symbols Nerd Font"
[Package Official "ttf-nerd-fonts-symbols-2048-em"] [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)
@ -125,14 +123,15 @@ 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 =
defaultConfig
{ font = T.unpack bf { font = T.unpack bf
, additionalFonts = fmap T.unpack ifs , additionalFonts = fmap T.unpack ifs
, textOffset = textFontOffset , textOffset = textFontOffset
@ -142,32 +141,31 @@ config bf ifs ios br confDir = defaultConfig
, position = BottomSize C 100 24 , position = BottomSize C 100 24
, border = NoBorder , border = NoBorder
, borderColor = T.unpack XT.bordersColor , 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
{ brLeft =
[ CmdSpec
{ csAlias = "UnsafeStdinReader" { csAlias = "UnsafeStdinReader"
, csRunnable = Run UnsafeStdinReader , csRunnable = Run UnsafeStdinReader
} }
@ -177,13 +175,15 @@ getAllCommands right = BarRegions
} }
rightPlugins :: DBusState -> FIO [Maybe CmdSpec] rightPlugins :: DBusState -> FIO [Maybe CmdSpec]
rightPlugins db = mapM evalFeature $ allFeatures db rightPlugins db =
mapM evalFeature $
allFeatures db
++ [always' "date indicator" dateCmd] ++ [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,7 +200,10 @@ 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 =
Sometimes
"wireless status indicator"
xpfWireless
[Subfeature (IORoot wirelessCmd $ Only readWireless) "sysfs path"] [Subfeature (IORoot wirelessCmd $ Only readWireless) "sysfs path"]
getEthernet :: Maybe SysClient -> BarFeature getEthernet :: Maybe SysClient -> BarFeature
@ -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,29 +269,58 @@ 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_)
-> T.Text
-> XPQuery
-> (Fontifier -> t -> Root CmdSpec)
-> t
-> BarFeature
iconSometimes' c d n q r t =
Sometimes
n
q
[ Subfeature icon "icon indicator" [ Subfeature icon "icon indicator"
, Subfeature text "text indicator" , Subfeature text "text indicator"
] ]
@ -280,125 +329,170 @@ iconSometimes' c d n q r t = Sometimes n q
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 =
CmdSpec
{ csAlias = T.append iface "wi" { csAlias = T.append iface "wi"
, csRunnable = Run $ Wireless (T.unpack iface) args 5 , csRunnable = Run $ Wireless (T.unpack iface) args 5
} }
where where
args = fmap T.unpack args =
[ "-t", "<qualityipat><essid>" fmap
T.unpack
[ "-t"
, "<qualityipat><essid>"
, "--" , "--"
, "--quality-icon-pattern", "<icon=wifi_%%.xpm/>" , "--quality-icon-pattern"
, "<icon=wifi_%%.xpm/>"
] ]
ethernetCmd :: Fontifier -> T.Text -> CmdSpec ethernetCmd :: Fontifier -> T.Text -> CmdSpec
ethernetCmd fontify iface = CmdSpec ethernetCmd fontify iface =
CmdSpec
{ csAlias = iface { csAlias = iface
, csRunnable = Run , csRunnable =
$ Device (iface, fontify IconMedium "\xf0e8" "ETH", colors) Run $
Device (iface, fontify IconMedium "\xf0e8" "ETH", colors)
} }
batteryCmd :: Fontifier -> CmdSpec batteryCmd :: Fontifier -> CmdSpec
batteryCmd fontify = CmdSpec batteryCmd fontify =
CmdSpec
{ csAlias = "battery" { csAlias = "battery"
, csRunnable = Run $ Battery args 50 , 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"
, "80"
, "--low"
, "red"
, "--normal"
, XT.fgColor
, "--high"
, XT.fgColor
, "--" , "--"
, "-P" , "-P"
, "-o" , fontify' "\xf0e7" "BAT" , "-o"
, "-O" , fontify' "\xf1e6" "AC" , fontify' "\xf0e7" "BAT"
, "-i" , fontify' "\xf1e6" "AC" , "-O"
, fontify' "\xf1e6" "AC"
, "-i"
, fontify' "\xf1e6" "AC"
] ]
vpnCmd :: Fontifier -> CmdSpec vpnCmd :: Fontifier -> CmdSpec
vpnCmd fontify = CmdSpec vpnCmd fontify =
CmdSpec
{ csAlias = vpnAlias { csAlias = vpnAlias
, csRunnable = Run $ VPN (fontify IconMedium "\xf023" "VPN", colors) , csRunnable = Run $ VPN (fontify IconMedium "\xf023" "VPN", colors)
} }
btCmd :: Fontifier -> CmdSpec btCmd :: Fontifier -> CmdSpec
btCmd fontify = CmdSpec btCmd fontify =
CmdSpec
{ csAlias = btAlias { csAlias = btAlias
, csRunnable = Run , csRunnable =
$ Bluetooth (fontify' "\xf5b0" "+", fontify' "\xf5ae" "-") colors 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 =
CmdSpec
{ csAlias = "alsa:default:Master" { csAlias = "alsa:default:Master"
, csRunnable = Run , csRunnable =
$ Alsa "default" "Master" Run $
$ fmap T.unpack Alsa "default" "Master" $
[ "-t", "<status><volume>%" fmap
T.unpack
[ "-t"
, "<status><volume>%"
, "--" , "--"
, "-O", fontify' "\xf028" "+" , "-O"
, "-o", T.append (fontify' "\xf026" "-") " " , fontify' "\xf028" "+"
, "-c", XT.fgColor , "-o"
, "-C", XT.fgColor , 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 =
CmdSpec
{ csAlias = blAlias { csAlias = blAlias
, csRunnable = Run $ IntelBacklight $ fontify IconSmall "\xf185" "BL: " , csRunnable = Run $ IntelBacklight $ fontify IconSmall "\xf185" "BL: "
} }
ckCmd :: Fontifier -> CmdSpec ckCmd :: Fontifier -> CmdSpec
ckCmd fontify = CmdSpec ckCmd fontify =
CmdSpec
{ csAlias = ckAlias { csAlias = ckAlias
, csRunnable = Run $ ClevoKeyboard $ fontify IconSmall "\xf40b" "KB: " , csRunnable = Run $ ClevoKeyboard $ fontify IconSmall "\xf40b" "KB: "
} }
ssCmd :: Fontifier -> CmdSpec ssCmd :: Fontifier -> CmdSpec
ssCmd fontify = CmdSpec ssCmd fontify =
CmdSpec
{ csAlias = ssAlias { csAlias = ssAlias
, csRunnable = Run $ Screensaver (fontify IconSmall "\xf254" "SS", colors) , csRunnable = Run $ Screensaver (fontify IconSmall "\xf254" "SS", colors)
} }
lockCmd :: Fontifier -> CmdSpec lockCmd :: Fontifier -> CmdSpec
lockCmd fontify = CmdSpec lockCmd fontify =
CmdSpec
{ csAlias = "locks" { csAlias = "locks"
, csRunnable = Run , csRunnable =
$ Locks Run $
$ fmap T.unpack Locks $
[ "-N", numIcon fmap
, "-n", disabledColor numIcon T.unpack
, "-C", capIcon [ "-N"
, "-c", disabledColor capIcon , numIcon
, "-s", "" , "-n"
, "-S", "" , disabledColor numIcon
, "-d", " " , "-C"
, capIcon
, "-c"
, disabledColor capIcon
, "-s"
, ""
, "-S"
, ""
, "-d"
, " "
] ]
} }
where where
@ -408,33 +502,37 @@ lockCmd fontify = CmdSpec
disabledColor = xmobarFGColor XT.backdropFgColor disabledColor = xmobarFGColor XT.backdropFgColor
dateCmd :: CmdSpec dateCmd :: CmdSpec
dateCmd = CmdSpec dateCmd =
CmdSpec
{ csAlias = "date" { csAlias = "date"
, csRunnable = Run $ Date "%Y-%m-%d %H:%M:%S " "date" 10 , 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, _)
| "vpn" `elem` BL.split 10 out -> Nothing
| otherwise -> Just $ Msg LevelError "vpn not found" | otherwise -> Just $ Msg LevelError "vpn not found"
(ExitFailure c, _, err) -> Just $ Msg LevelError (ExitFailure c, _, err) ->
$ T.concat Just $
["vpn search exited with code " Msg LevelError $
T.concat
[ "vpn search exited with code "
, T.pack $ show c , T.pack $ show c
, ": " , ": "
, T.decodeUtf8With T.lenientDecode , T.decodeUtf8With T.lenientDecode $
$ BL.toStrict err 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 =
unzip $
(\i -> (iconString fb i, iconOffset i + textFontOffset))
<$> iconFonts <$> 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} =
T.concat
[fmtSpecs l, T.singleton lSep, fmtSpecs c, T.singleton rSep, fmtSpecs r] [fmtSpecs l, T.singleton lSep, fmtSpecs c, T.singleton rSep, fmtSpecs r]

View File

@ -4,35 +4,30 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | XMonad binary -- XMonad binary
module Main (main) where 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 Data.Monoid import Data.Monoid
import Data.Text.IO (hPutStrLn) import Data.Text.IO (hPutStrLn)
import Graphics.X11.Types import Graphics.X11.Types
import Graphics.X11.Xlib.Atom import Graphics.X11.Xlib.Atom
import Graphics.X11.Xlib.Extras import Graphics.X11.Xlib.Extras
import RIO import RIO
import RIO.Directory import RIO.Directory
import RIO.Process import RIO.Process
import qualified RIO.Text as T import qualified RIO.Text as T
import System.Environment import System.Environment
import System.Posix.Signals import System.Posix.Signals
import System.Process import System.Process
( getPid ( getPid
, getProcessExitCode , getProcessExitCode
) )
import XMonad import XMonad
import XMonad.Actions.CopyWindow import XMonad.Actions.CopyWindow
import XMonad.Actions.CycleWS import XMonad.Actions.CycleWS
@ -110,10 +105,12 @@ run = do
sk <- evalAlways $ fsShowKeys fs sk <- evalAlways $ fsShowKeys fs
ha <- evalAlways $ fsACPIHandler fs ha <- evalAlways $ fsACPIHandler fs
tt <- evalAlways $ fsTabbedTheme fs tt <- evalAlways $ fsTabbedTheme fs
let conf = ewmh let conf =
$ addKeymap dws sk kbs ewmh $
$ docks addKeymap dws sk kbs $
$ def { terminal = myTerm docks $
def
{ terminal = myTerm
, modMask = myModMask , modMask = myModMask
, layoutHook = myLayouts tt , layoutHook = myLayouts tt
, manageHook = myManageHook dws , manageHook = myManageHook dws
@ -128,8 +125,11 @@ run = do
} }
io $ runXMonad conf io $ runXMonad conf
where where
startRemovableMon db fs = void $ executeSometimes $ fsRemovableMon fs startRemovableMon db fs =
$ dbSysClient db void $
executeSometimes $
fsRemovableMon fs $
dbSysClient db
startPowerMon fs = void $ async $ void $ executeSometimes $ fsPowerMon fs startPowerMon fs = void $ async $ void $ executeSometimes $ fsPowerMon fs
startDynWorkspaces fs = do startDynWorkspaces fs = do
dws <- catMaybes <$> mapM evalSometimes (fsDynWorkspaces fs) dws <- catMaybes <$> mapM evalSometimes (fsDynWorkspaces fs)
@ -142,8 +142,9 @@ runXMonad conf = do
launch conf dirs launch conf dirs
startDBusInterfaces :: DBusState -> FeatureSet -> FIO () startDBusInterfaces :: DBusState -> FeatureSet -> FIO ()
startDBusInterfaces db fs = mapM_ (\f -> executeSometimes $ f $ dbSesClient db) startDBusInterfaces db fs =
$ fsDBusExporters fs mapM_ (\f -> executeSometimes $ f $ dbSesClient db) $
fsDBusExporters fs
getCreateDirectories :: IO Directories getCreateDirectories :: IO Directories
getCreateDirectories = do getCreateDirectories = do
@ -178,7 +179,8 @@ tabbedFeature = Always "theme for tabbed windows" $ Option sf fallback
fallback = Always_ $ FallbackAlone $ XT.tabbedTheme XT.fallbackFont fallback = Always_ $ FallbackAlone $ XT.tabbedTheme XT.fallbackFont
features :: Maybe SysClient -> FeatureSet features :: Maybe SysClient -> FeatureSet
features cl = FeatureSet features cl =
FeatureSet
{ fsKeys = externalBindings { fsKeys = externalBindings
, fsDBusExporters = dbusExporters , fsDBusExporters = dbusExporters
, fsPowerMon = runPowermon , fsPowerMon = runPowermon
@ -196,7 +198,8 @@ startXmobar = do
io $ hSetBuffering (getStdin p) LineBuffering io $ hSetBuffering (getStdin p) LineBuffering
return p return p
where where
start = startProcess start =
startProcess
. setStdin createPipe . setStdin createPipe
. setCreateGroup True . setCreateGroup True
@ -228,32 +231,37 @@ printDeps :: FIO ()
printDeps = do printDeps = do
db <- io connectDBus db <- io connectDBus
(i, f, d) <- allFeatures db (i, f, d) <- allFeatures db
io $ mapM_ (putStrLn . T.unpack) io $
$ fmap showFulfillment mapM_ (putStrLn . T.unpack) $
$ sort fmap showFulfillment $
$ nub sort $
$ concat nub $
$ fmap dumpFeature f ++ fmap dumpSometimes i ++ fmap dumpSometimes d concat $
fmap dumpFeature f ++ fmap dumpSometimes i ++ fmap dumpSometimes d
io $ disconnectDBus db io $ disconnectDBus db
allFeatures :: DBusState -> FIO ([SometimesIO], [FeatureX], [Sometimes DynWorkspace]) allFeatures :: DBusState -> FIO ([SometimesIO], [FeatureX], [Sometimes DynWorkspace])
allFeatures db = do allFeatures db = do
let bfs = concatMap (fmap kbMaybeAction . kgBindings) let bfs =
$ externalBindings ts db concatMap (fmap kbMaybeAction . kgBindings) $
externalBindings ts db
let dbus = fmap (\f -> f $ dbSesClient db) dbusExporters let dbus = fmap (\f -> f $ dbSesClient db) dbusExporters
let others = [runRemovableMon $ dbSysClient db, runPowermon] let others = [runRemovableMon $ dbSysClient db, runPowermon]
return (dbus ++ others, Left runScreenLock:bfs, allDWs') return (dbus ++ others, Left runScreenLock : bfs, allDWs')
where where
ts = ThreadState { tsChildPIDs = [], tsXmobar = Nothing } ts = ThreadState {tsChildPIDs = [], tsXmobar = Nothing}
usage :: IO () usage :: IO ()
usage = putStrLn $ intercalate "\n" usage =
putStrLn $
intercalate
"\n"
[ "xmonad: run greatest window manager" [ "xmonad: run greatest window manager"
, "xmonad --deps: print dependencies" , "xmonad --deps: print dependencies"
] ]
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Concurrency configuration -- Concurrency configuration
data ThreadState = ThreadState data ThreadState = ThreadState
{ tsChildPIDs :: [Process () () ()] { tsChildPIDs :: [Process () () ()]
@ -294,18 +302,19 @@ killNoWait p = do
handleIO (\_ -> return ()) $ stopProcess p handleIO (\_ -> return ()) $ stopProcess p
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Startuphook configuration -- Startuphook configuration
-- TODO add _NET_DESKTOP_VIEWPORTS to _NET_SUPPORTED? -- TODO add _NET_DESKTOP_VIEWPORTS to _NET_SUPPORTED?
myStartupHook :: X () myStartupHook :: X ()
myStartupHook = setDefaultCursor xC_left_ptr myStartupHook =
setDefaultCursor xC_left_ptr
<+> startupHook def <+> startupHook def
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Workspace configuration -- Workspace configuration
myWorkspaces :: [WorkspaceId] myWorkspaces :: [WorkspaceId]
myWorkspaces = map show [1..10 :: Int] myWorkspaces = map show [1 .. 10 :: Int]
gimpTag :: String gimpTag :: String
gimpTag = "GIMP" gimpTag = "GIMP"
@ -323,7 +332,8 @@ gimpDynamicWorkspace :: Sometimes DynWorkspace
gimpDynamicWorkspace = sometimesIO_ "gimp workspace" "gimp" tree dw gimpDynamicWorkspace = sometimesIO_ "gimp workspace" "gimp" tree dw
where where
tree = Only_ $ sysExe [Package Official "gimp"] exe tree = Only_ $ sysExe [Package Official "gimp"] exe
dw = DynWorkspace dw =
DynWorkspace
{ dwName = "Gimp" { dwName = "Gimp"
, dwTag = gimpTag , dwTag = gimpTag
, dwClass = c , dwClass = c
@ -337,96 +347,121 @@ gimpDynamicWorkspace = sometimesIO_ "gimp workspace" "gimp" tree dw
, dwCmd = Just $ spawnCmd exe [] , dwCmd = Just $ spawnCmd exe []
} }
exe = "gimp-2.10" exe = "gimp-2.10"
matchGimpRole role = isPrefixOf role <$> stringProperty "WM_WINDOW_ROLE" matchGimpRole role =
<&&> className =? c isPrefixOf role
<$> stringProperty "WM_WINDOW_ROLE"
<&&> className
=? c
c = "Gimp-2.10" -- TODO I don't feel like changing the version long term c = "Gimp-2.10" -- TODO I don't feel like changing the version long term
-- TODO don't hardcode the VM name/title/shortcut -- TODO don't hardcode the VM name/title/shortcut
vmDynamicWorkspace :: Sometimes DynWorkspace vmDynamicWorkspace :: Sometimes DynWorkspace
vmDynamicWorkspace = Sometimes "virtualbox workspace" xpfVirtualBox vmDynamicWorkspace =
Sometimes
"virtualbox workspace"
xpfVirtualBox
[Subfeature root "windows 8 VM"] [Subfeature root "windows 8 VM"]
where where
root = IORoot_ dw $ toAnd_ (sysExe [Package Official "virtualbox"] "VBoxManage") root =
$ IOTest_ name [] $ io $ vmExists vm IORoot_ dw $
toAnd_ (sysExe [Package Official "virtualbox"] "VBoxManage") $
IOTest_ name [] $
io $
vmExists vm
name = T.unwords ["test if", vm, "exists"] name = T.unwords ["test if", vm, "exists"]
c = "VirtualBoxVM" c = "VirtualBoxVM"
vm = "win8raw" vm = "win8raw"
dw = DynWorkspace dw =
DynWorkspace
{ dwName = "Windows VirtualBox" { dwName = "Windows VirtualBox"
, dwTag = vmTag , dwTag = vmTag
, dwClass = c , dwClass = c
, dwHook = [ className =? c -?> appendViewShift vmTag ] , dwHook = [className =? c -?> appendViewShift vmTag]
, dwKey = 'v' , dwKey = 'v'
, dwCmd = Just $ spawnCmd "vbox-start" [vm] , dwCmd = Just $ spawnCmd "vbox-start" [vm]
} }
xsaneDynamicWorkspace :: Sometimes DynWorkspace xsaneDynamicWorkspace :: Sometimes DynWorkspace
xsaneDynamicWorkspace = Sometimes "scanner workspace" xpfXSANE xsaneDynamicWorkspace =
Sometimes
"scanner workspace"
xpfXSANE
[Subfeature (IORoot_ dw tree) "xsane"] [Subfeature (IORoot_ dw tree) "xsane"]
where where
tree = Only_ $ sysExe [Package Official "xsane"] "xsane" tree = Only_ $ sysExe [Package Official "xsane"] "xsane"
dw = DynWorkspace dw =
DynWorkspace
{ dwName = "XSane" { dwName = "XSane"
, dwTag = xsaneTag , dwTag = xsaneTag
, dwClass = c , dwClass = c
, dwHook = [ className =? c -?> appendViewShift xsaneTag >> doFloat ] , dwHook = [className =? c -?> appendViewShift xsaneTag >> doFloat]
, dwKey = 'x' , dwKey = 'x'
, dwCmd = Just $ spawnCmd "xsane" [] , dwCmd = Just $ spawnCmd "xsane" []
} }
c = "Xsane" c = "Xsane"
f5vpnDynamicWorkspace :: Sometimes DynWorkspace f5vpnDynamicWorkspace :: Sometimes DynWorkspace
f5vpnDynamicWorkspace = Sometimes "F5 VPN workspace" xpfF5VPN f5vpnDynamicWorkspace =
Sometimes
"F5 VPN workspace"
xpfF5VPN
[Subfeature (IORoot_ dw tree) "f5vpn"] [Subfeature (IORoot_ dw tree) "f5vpn"]
where where
tree = Only_ $ sysExe [Package AUR "f5vpn"] "f5vpn" tree = Only_ $ sysExe [Package AUR "f5vpn"] "f5vpn"
dw = DynWorkspace dw =
DynWorkspace
{ dwName = "F5Vpn" { dwName = "F5Vpn"
, dwTag = f5Tag , dwTag = f5Tag
, dwClass = c , dwClass = c
, dwHook = [ className =? c -?> appendShift f5Tag ] , dwHook = [className =? c -?> appendShift f5Tag]
, dwKey = 'i' , dwKey = 'i'
, dwCmd = Just skip , dwCmd = Just skip
} }
c = "F5 VPN" c = "F5 VPN"
allDWs' :: [Sometimes DynWorkspace] allDWs' :: [Sometimes DynWorkspace]
allDWs' = [xsaneDynamicWorkspace allDWs' =
[ xsaneDynamicWorkspace
, vmDynamicWorkspace , vmDynamicWorkspace
, gimpDynamicWorkspace , gimpDynamicWorkspace
, f5vpnDynamicWorkspace , f5vpnDynamicWorkspace
] ]
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Layout configuration -- Layout configuration
-- NOTE this will have all available layouts, even those that may be for -- NOTE this will have all available layouts, even those that may be for
-- features that failed. Trying to dynamically take out a layout seems to -- features that failed. Trying to dynamically take out a layout seems to
-- make a new type :/ -- make a new type :/
myLayouts tt = onWorkspace vmTag vmLayout myLayouts tt =
$ onWorkspace gimpTag gimpLayout onWorkspace vmTag vmLayout $
$ mkToggle (single HIDE) onWorkspace gimpTag gimpLayout $
$ tall ||| fulltab ||| full mkToggle (single HIDE) $
tall ||| fulltab ||| full
where where
addTopBar = noFrillsDeco shrinkText tt addTopBar = noFrillsDeco shrinkText tt
tall = renamed [Replace "Tall"] tall =
$ avoidStruts renamed [Replace "Tall"] $
$ addTopBar avoidStruts $
$ noBorders addTopBar $
$ Tall 1 0.03 0.5 noBorders $
fulltab = renamed [Replace "Tabbed"] Tall 1 0.03 0.5
$ avoidStruts fulltab =
$ noBorders renamed [Replace "Tabbed"] $
$ tabbedAlways shrinkText tt avoidStruts $
full = renamed [Replace "Full"] noBorders $
$ noBorders Full tabbedAlways shrinkText tt
full =
renamed [Replace "Full"] $
noBorders Full
vmLayout = noBorders Full vmLayout = noBorders Full
-- TODO use a tabbed layout for multiple master windows -- TODO use a tabbed layout for multiple master windows
gimpLayout = renamed [Replace "Gimp Layout"] gimpLayout =
$ avoidStruts renamed [Replace "Gimp Layout"] $
$ noBorders avoidStruts $
$ addTopBar noBorders $
$ Tall 1 0.025 0.8 addTopBar $
Tall 1 0.025 0.8
-- | Make a new empty layout and add a message to show/hide it. This is useful -- | Make a new empty layout and add a message to show/hide it. This is useful
-- for quickly showing conky. -- for quickly showing conky.
@ -448,8 +483,7 @@ runHide :: X ()
runHide = sendMessage $ Toggle HIDE runHide = sendMessage $ Toggle HIDE
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Loghook configuration -- Loghook configuration
--
myLoghook :: Process Handle () () -> X () myLoghook :: Process Handle () () -> X ()
myLoghook h = do myLoghook h = do
@ -467,7 +501,7 @@ myLoghook h = do
-- _NET_DESKTOP_VIEWPORT, but for now there seems to be no ill effects so why -- _NET_DESKTOP_VIEWPORT, but for now there seems to be no ill effects so why
-- bother...(if that were necessary it would go in the startup hook) -- bother...(if that were necessary it would go in the startup hook)
newtype DesktopViewports = DesktopViewports [Int] newtype DesktopViewports = DesktopViewports [Int]
deriving Eq deriving (Eq)
instance ExtensionClass DesktopViewports where instance ExtensionClass DesktopViewports where
initialValue = DesktopViewports [] initialValue = DesktopViewports []
@ -480,8 +514,9 @@ logViewports = withWindowSet $ \s -> do
whenChanged (DesktopViewports desktopViewports) $ whenChanged (DesktopViewports desktopViewports) $
setDesktopViewports desktopViewports setDesktopViewports desktopViewports
where where
wsToViewports s w = let cur = W.current s in wsToViewports s w =
if W.tag w == currentTag cur then currentPos cur else [0, 0] let cur = W.current s
in if W.tag w == currentTag cur then currentPos cur else [0, 0]
currentTag = W.tag . W.workspace currentTag = W.tag . W.workspace
currentPos = rectXY . screenRect . W.screenDetail currentPos = rectXY . screenRect . W.screenDetail
rectXY (Rectangle x y _ _) = [fromIntegral x, fromIntegral y] rectXY (Rectangle x y _ _) = [fromIntegral x, fromIntegral y]
@ -507,20 +542,22 @@ whenChanged v action = do
-- currently visible and the order reflects the physical location of each -- currently visible and the order reflects the physical location of each
-- screen. The "<>" is the workspace that currently has focus. N is the number -- screen. The "<>" is the workspace that currently has focus. N is the number
-- of windows on the current workspace. -- of windows on the current workspace.
logXinerama :: Process Handle () () -> X () logXinerama :: Process Handle () () -> X ()
logXinerama p = withWindowSet $ \ws -> io logXinerama p = withWindowSet $ \ws ->
$ hPutStrLn (getStdin p) io $
$ T.unwords hPutStrLn (getStdin p) $
$ filter (not . T.null) [onScreen ws, offScreen ws, sep, layout ws, nWindows ws] T.unwords $
filter (not . T.null) [onScreen ws, offScreen ws, sep, layout ws, nWindows ws]
where where
onScreen ws = xmobarColor_ hilightFgColor hilightBgColor onScreen ws =
$ (T.pack . pad . T.unpack) xmobarColor_ hilightFgColor hilightBgColor $
$ T.unwords (T.pack . pad . T.unpack) $
$ map (fmtTags ws . W.tag . W.workspace) T.unwords $
$ sortBy compareXCoord map (fmtTags ws . W.tag . W.workspace) $
$ W.current ws : W.visible ws sortBy compareXCoord $
offScreen = xmobarColor_ XT.backdropFgColor "" W.current ws : W.visible ws
offScreen =
xmobarColor_ XT.backdropFgColor ""
. T.unwords . T.unwords
. fmap (T.pack . W.tag) . fmap (T.pack . W.tag)
. filter (isJust . W.stack) . filter (isJust . W.stack)
@ -528,7 +565,8 @@ logXinerama p = withWindowSet $ \ws -> io
. W.hidden . W.hidden
sep = xmobarColor_ XT.backdropFgColor "" ":" sep = xmobarColor_ XT.backdropFgColor "" ":"
layout = T.pack . description . W.layout . W.workspace . W.current layout = T.pack . description . W.layout . W.workspace . W.current
nWindows = (\x -> T.concat ["(", x, ")"]) nWindows =
(\x -> T.concat ["(", x, ")"])
. T.pack . T.pack
. show . show
. length . length
@ -538,53 +576,57 @@ logXinerama p = withWindowSet $ \ws -> io
. W.current . W.current
hilightBgColor = "#A6D3FF" hilightBgColor = "#A6D3FF"
hilightFgColor = XT.blend' 0.4 hilightBgColor XT.fgColor hilightFgColor = XT.blend' 0.4 hilightBgColor XT.fgColor
fmtTags ws t = let t_ = T.pack t in fmtTags ws t =
if t == W.currentTag ws let t_ = T.pack t
in if t == W.currentTag ws
then xmobarColor_ XT.fgColor hilightBgColor t_ then xmobarColor_ XT.fgColor hilightBgColor t_
else t_ else t_
xmobarColor_ a b c = T.pack $ xmobarColor (T.unpack a) (T.unpack b) (T.unpack c) xmobarColor_ a b c = T.pack $ xmobarColor (T.unpack a) (T.unpack b) (T.unpack c)
compareXCoord compareXCoord
:: W.Screen i1 l1 a1 ScreenId ScreenDetail :: W.Screen i1 l1 a1 ScreenId ScreenDetail
-> W.Screen i2 l2 a2 ScreenId ScreenDetail -> Ordering -> W.Screen i2 l2 a2 ScreenId ScreenDetail
-> Ordering
compareXCoord s0 s1 = compare (go s0) (go s1) compareXCoord s0 s1 = compare (go s0) (go s1)
where where
go = (\(Rectangle x _ _ _) -> x) . snd . getScreenIdAndRectangle go = (\(Rectangle x _ _ _) -> x) . snd . getScreenIdAndRectangle
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Managehook configuration -- Managehook configuration
myManageHook :: [DynWorkspace] -> ManageHook myManageHook :: [DynWorkspace] -> ManageHook
myManageHook dws = manageApps dws <+> manageHook def myManageHook dws = manageApps dws <+> manageHook def
manageApps :: [DynWorkspace] -> ManageHook manageApps :: [DynWorkspace] -> ManageHook
manageApps dws = composeOne $ concatMap dwHook dws ++ manageApps dws =
[ isDialog -?> doCenterFloat composeOne $
-- the seafile applet concatMap dwHook dws
, className =? "Seafile Client" -?> doFloat ++ [ isDialog -?> doCenterFloat
-- gnucash , -- the seafile applet
, (className =? "Gnucash" <&&> title =? "Transaction Import Assistant") -?> doFloat className =? "Seafile Client" -?> doFloat
-- plots and graphics , -- gnucash
, className =? "R_x11" -?> doFloat (className =? "Gnucash" <&&> title =? "Transaction Import Assistant") -?> doFloat
, -- plots and graphics
className =? "R_x11" -?> doFloat
, className =? "Matplotlib" -?> doFloat , className =? "Matplotlib" -?> doFloat
, className =? "mpv" -?> doFloat , className =? "mpv" -?> doFloat
-- the floating windows created by the brave browser , -- the floating windows created by the brave browser
, stringProperty "WM_NAME" =? "Brave" -?> doFloat stringProperty "WM_NAME" =? "Brave" -?> doFloat
-- , (stringProperty "WM_WINDOW_ROLE" =? "pop-up" , -- , (stringProperty "WM_WINDOW_ROLE" =? "pop-up"
-- <&&> className =? "Brave-browser") -?> doFloat -- <&&> className =? "Brave-browser") -?> doFloat
-- the dialog windows created by the zotero addon in Google Docs -- the dialog windows created by the zotero addon in Google Docs
, (className =? "Zotero" <&&> resource =? "Toplevel") -?> doFloat (className =? "Zotero" <&&> resource =? "Toplevel") -?> doFloat
] ]
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Eventhook configuration -- Eventhook configuration
myEventHook :: (String -> X ()) -> Event -> X All myEventHook :: (String -> X ()) -> Event -> X All
myEventHook handler = xMsgEventHook handler <+> handleEventHook def myEventHook handler = xMsgEventHook handler <+> handleEventHook def
-- | React to ClientMessage events from concurrent threads -- | React to ClientMessage events from concurrent threads
xMsgEventHook :: (String -> X ()) -> Event -> X All xMsgEventHook :: (String -> X ()) -> Event -> X All
xMsgEventHook handler ClientMessageEvent { ev_message_type = t, ev_data = d } xMsgEventHook handler ClientMessageEvent {ev_message_type = t, ev_data = d}
| t == bITMAP = do | t == bITMAP = do
let (xtype, tag) = splitXMsg d let (xtype, tag) = splitXMsg d
case xtype of case xtype of
@ -595,19 +637,26 @@ xMsgEventHook handler ClientMessageEvent { ev_message_type = t, ev_data = d }
xMsgEventHook _ _ = return (All True) xMsgEventHook _ _ = return (All True)
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Keymap configuration -- Keymap configuration
myModMask :: KeyMask myModMask :: KeyMask
myModMask = mod4Mask myModMask = mod4Mask
addKeymap :: [DynWorkspace] -> ([((KeyMask, KeySym), NamedAction)] -> X ()) addKeymap
-> [KeyGroup (X ())] -> XConfig l -> XConfig l :: [DynWorkspace]
addKeymap dws showKeys external = addDescrKeys' ((myModMask, xK_F1), showKeys) -> ([((KeyMask, KeySym), NamedAction)] -> X ())
-> [KeyGroup (X ())]
-> XConfig l
-> XConfig l
addKeymap dws showKeys external =
addDescrKeys'
((myModMask, xK_F1), showKeys)
(\c -> concatMap (mkNamedSubmap c) $ internalBindings dws c ++ external) (\c -> concatMap (mkNamedSubmap c) $ internalBindings dws c ++ external)
internalBindings :: [DynWorkspace] -> XConfig Layout -> [KeyGroup (X ())] internalBindings :: [DynWorkspace] -> XConfig Layout -> [KeyGroup (X ())]
internalBindings dws c = internalBindings dws c =
[ KeyGroup "Window Layouts" [ KeyGroup
"Window Layouts"
[ KeyBinding "M-j" "focus down" $ windows W.focusDown [ KeyBinding "M-j" "focus down" $ windows W.focusDown
, KeyBinding "M-k" "focus up" $ windows W.focusUp , KeyBinding "M-k" "focus up" $ windows W.focusUp
, KeyBinding "M-m" "focus master" $ windows W.focusMaster , KeyBinding "M-m" "focus master" $ windows W.focusMaster
@ -624,32 +673,36 @@ internalBindings dws c =
, KeyBinding "M-S--" "remove master window" $ sendMessage $ IncMasterN (-1) , KeyBinding "M-S--" "remove master window" $ sendMessage $ IncMasterN (-1)
, KeyBinding "M-S-=" "add master window" $ sendMessage $ IncMasterN 1 , KeyBinding "M-S-=" "add master window" $ sendMessage $ IncMasterN 1
] ]
, KeyGroup
, KeyGroup "Workspaces" "Workspaces"
-- ASSUME standard workspaces only use numbers 0-9 (otherwise we won't get -- ASSUME standard workspaces only use numbers 0-9 (otherwise we won't get
-- valid keysyms) -- valid keysyms)
([ KeyBinding (mods ++ n) (msg ++ n) (f n) | n <- myWorkspaces ( [ KeyBinding (mods ++ n) (msg ++ n) (f n) | n <- myWorkspaces, (mods, msg, f) <-
, (mods, msg, f) <-
[ ("M-", "switch to workspace ", windows . W.view) [ ("M-", "switch to workspace ", windows . W.view)
, ("M-S-", "move client to workspace ", windows . W.shift) , ("M-S-", "move client to workspace ", windows . W.shift)
, ("M-C-", "follow client to workspace ", \n' -> do ,
( "M-C-"
, "follow client to workspace "
, \n' -> do
windows $ W.shift n' windows $ W.shift n'
windows $ W.view n') windows $ W.view n'
)
] ]
] ++ ]
[ KeyBinding "M-M1-l" "move up workspace" $ moveTo Next (hiddenWS :&: Not emptyWS) ++ [ KeyBinding "M-M1-l" "move up workspace" $ moveTo Next (hiddenWS :&: Not emptyWS)
, KeyBinding "M-M1-h" "move down workspace" $ moveTo Prev (hiddenWS :&: Not emptyWS) , KeyBinding "M-M1-h" "move down workspace" $ moveTo Prev (hiddenWS :&: Not emptyWS)
]) ]
)
, KeyGroup "Dynamic Workspaces" , KeyGroup
"Dynamic Workspaces"
[ KeyBinding ("M-C-" ++ [k]) ("launch/switch to " ++ n) cmd [ KeyBinding ("M-C-" ++ [k]) ("launch/switch to " ++ n) cmd
| DynWorkspace { dwTag = t, dwKey = k, dwCmd = a, dwName = n } <- dws, | DynWorkspace {dwTag = t, dwKey = k, dwCmd = a, dwName = n} <- dws
let cmd = case a of , let cmd = case a of
Just a' -> spawnOrSwitch t a' Just a' -> spawnOrSwitch t a'
Nothing -> windows $ W.view t Nothing -> windows $ W.view t
] ]
, KeyGroup
, KeyGroup "Screens" "Screens"
[ KeyBinding "M-l" "move up screen" nextScr [ KeyBinding "M-l" "move up screen" nextScr
, KeyBinding "M-h" "move down screen" prevScr , KeyBinding "M-h" "move down screen" prevScr
, KeyBinding "M-C-l" "follow client up screen" $ nextScr' W.shift , KeyBinding "M-C-l" "follow client up screen" $ nextScr' W.shift
@ -667,9 +720,10 @@ internalBindings dws c =
nextScr' f = next f >> nextScr nextScr' f = next f >> nextScr
mkNamedSubmap :: XConfig Layout -> KeyGroup (X ()) -> [((KeyMask, KeySym), NamedAction)] mkNamedSubmap :: XConfig Layout -> KeyGroup (X ()) -> [((KeyMask, KeySym), NamedAction)]
mkNamedSubmap c KeyGroup { kgHeader = h, kgBindings = b } = mkNamedSubmap c KeyGroup {kgHeader = h, kgBindings = b} =
(subtitle h:) $ mkNamedKeymap c (subtitle h :) $
$ (\KeyBinding{kbSyms = s, kbDesc = d, kbMaybeAction = a} -> (s, addName d a)) mkNamedKeymap c $
(\KeyBinding {kbSyms = s, kbDesc = d, kbMaybeAction = a} -> (s, addName d a))
<$> b <$> b
data KeyBinding a = KeyBinding data KeyBinding a = KeyBinding
@ -686,25 +740,28 @@ data KeyGroup a = KeyGroup
evalExternal :: [KeyGroup FeatureX] -> FIO [KeyGroup MaybeX] evalExternal :: [KeyGroup FeatureX] -> FIO [KeyGroup MaybeX]
evalExternal = mapM go evalExternal = mapM go
where where
go k@KeyGroup { kgBindings = bs } = go k@KeyGroup {kgBindings = bs} =
(\bs' -> k { kgBindings = bs' }) <$> mapM evalKeyBinding bs (\bs' -> k {kgBindings = bs'}) <$> mapM evalKeyBinding bs
evalKeyBinding :: KeyBinding FeatureX -> FIO (KeyBinding MaybeX) evalKeyBinding :: KeyBinding FeatureX -> FIO (KeyBinding MaybeX)
evalKeyBinding k@KeyBinding { kbMaybeAction = a } = evalKeyBinding k@KeyBinding {kbMaybeAction = a} =
(\f -> k { kbMaybeAction = f }) <$> evalFeature a (\f -> k {kbMaybeAction = f}) <$> evalFeature a
filterExternal :: [KeyGroup MaybeX] -> [KeyGroup (X ())] filterExternal :: [KeyGroup MaybeX] -> [KeyGroup (X ())]
filterExternal = fmap go filterExternal = fmap go
where where
go k@KeyGroup { kgBindings = bs } = go k@KeyGroup {kgBindings = bs} =
k { kgBindings = [ kb { kbMaybeAction = x } k
| kb@KeyBinding { kbMaybeAction = Just x } <- bs { kgBindings =
[ kb {kbMaybeAction = x}
| kb@KeyBinding {kbMaybeAction = Just x} <- bs
] ]
} }
externalBindings :: ThreadState -> DBusState -> [KeyGroup FeatureX] externalBindings :: ThreadState -> DBusState -> [KeyGroup FeatureX]
externalBindings ts db = externalBindings ts db =
[ KeyGroup "Launchers" [ KeyGroup
"Launchers"
[ KeyBinding "<XF86Search>" "select/launch app" $ Left runAppMenu [ KeyBinding "<XF86Search>" "select/launch app" $ Left runAppMenu
, KeyBinding "M-g" "launch clipboard manager" $ Left runClipMenu , KeyBinding "M-g" "launch clipboard manager" $ Left runClipMenu
, KeyBinding "M-a" "launch network selector" $ Left $ runNetMenu sys , KeyBinding "M-a" "launch network selector" $ Left $ runNetMenu sys
@ -720,8 +777,8 @@ externalBindings ts db =
, KeyBinding "M-C-q" "launch calc" $ Left runCalc , KeyBinding "M-C-q" "launch calc" $ Left runCalc
, KeyBinding "M-C-f" "launch file manager" $ Left runFileManager , KeyBinding "M-C-f" "launch file manager" $ Left runFileManager
] ]
, KeyGroup
, KeyGroup "Actions" "Actions"
[ KeyBinding "M-q" "close window" $ ftrAlways "kill window function" kill1 [ KeyBinding "M-q" "close window" $ ftrAlways "kill window function" kill1
, KeyBinding "M-r" "run program" $ Left runCmdMenu , KeyBinding "M-r" "run program" $ Left runCmdMenu
, KeyBinding "M-<Space>" "warp pointer" $ ftrAlways "warp function" $ warpToWindow 0.5 0.5 , KeyBinding "M-<Space>" "warp pointer" $ ftrAlways "warp function" $ warpToWindow 0.5 0.5
@ -731,8 +788,8 @@ externalBindings ts db =
, KeyBinding "M-C-b" "browse captures" $ Left runCaptureBrowser , KeyBinding "M-C-b" "browse captures" $ Left runCaptureBrowser
-- , ("M-C-S-s", "capture focused window", spawn myWindowCap) -- , ("M-C-S-s", "capture focused window", spawn myWindowCap)
] ]
, KeyGroup
, KeyGroup "Multimedia" "Multimedia"
[ KeyBinding "<XF86AudioPlay>" "toggle play/pause" $ Left runTogglePlay [ KeyBinding "<XF86AudioPlay>" "toggle play/pause" $ Left runTogglePlay
, KeyBinding "<XF86AudioPrev>" "previous track" $ Left runPrevTrack , KeyBinding "<XF86AudioPrev>" "previous track" $ Left runPrevTrack
, KeyBinding "<XF86AudioNext>" "next track" $ Left runNextTrack , KeyBinding "<XF86AudioNext>" "next track" $ Left runNextTrack
@ -741,15 +798,15 @@ externalBindings ts db =
, KeyBinding "<XF86AudioRaiseVolume>" "volume up" $ Left runVolumeUp , KeyBinding "<XF86AudioRaiseVolume>" "volume up" $ Left runVolumeUp
, KeyBinding "<XF86AudioMute>" "volume mute" $ Left runVolumeMute , KeyBinding "<XF86AudioMute>" "volume mute" $ Left runVolumeMute
] ]
, KeyGroup
, KeyGroup "Dunst" "Dunst"
[ KeyBinding "M-`" "dunst history" $ Left $ runNotificationHistory ses [ KeyBinding "M-`" "dunst history" $ Left $ runNotificationHistory ses
, KeyBinding "M-S-`" "dunst close" $ Left $ runNotificationClose ses , KeyBinding "M-S-`" "dunst close" $ Left $ runNotificationClose ses
, KeyBinding "M-M1-`" "dunst context menu" $ Left $ runNotificationContext ses , KeyBinding "M-M1-`" "dunst context menu" $ Left $ runNotificationContext ses
, KeyBinding "M-C-`" "dunst close all" $ Left $ runNotificationCloseAll ses , KeyBinding "M-C-`" "dunst close all" $ Left $ runNotificationCloseAll ses
] ]
, KeyGroup
, KeyGroup "System" "System"
[ KeyBinding "M-." "backlight up" $ ib bctlInc [ KeyBinding "M-." "backlight up" $ ib bctlInc
, KeyBinding "M-," "backlight down" $ ib bctlDec , KeyBinding "M-," "backlight down" $ ib bctlDec
, KeyBinding "M-M1-," "backlight min" $ ib bctlMin , KeyBinding "M-M1-," "backlight min" $ ib bctlMin
@ -761,8 +818,8 @@ externalBindings ts db =
, KeyBinding "M-<End>" "power menu" $ Left runPowerPrompt , KeyBinding "M-<End>" "power menu" $ Left runPowerPrompt
, KeyBinding "M-<Home>" "quit xmonad" $ Left runQuitPrompt , KeyBinding "M-<Home>" "quit xmonad" $ Left runQuitPrompt
, KeyBinding "M-<Delete>" "lock screen" $ Left runScreenLock , KeyBinding "M-<Delete>" "lock screen" $ Left runScreenLock
-- M-<F1> reserved for showing the keymap , -- M-<F1> reserved for showing the keymap
, KeyBinding "M-<F2>" "restart xmonad" restartf KeyBinding "M-<F2>" "restart xmonad" restartf
, KeyBinding "M-<F3>" "recompile xmonad" recompilef , KeyBinding "M-<F3>" "recompile xmonad" recompilef
, KeyBinding "M-<F8>" "select autorandr profile" $ Left runAutorandrMenu , KeyBinding "M-<F8>" "select autorandr profile" $ Left runAutorandrMenu
, KeyBinding "M-<F9>" "toggle ethernet" $ Left runToggleEthernet , KeyBinding "M-<F9>" "toggle ethernet" $ Left runToggleEthernet

View File

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

View File

@ -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 DBus.Client
import Data.Bifunctor import Data.Bifunctor
import qualified Data.Map.Strict as M import qualified Data.Map.Strict as M
import Data.Maybe 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
@ -86,24 +84,33 @@ getDBusClient' sys = do
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 =
fmap (bimap (T.pack . methodErrorMessage) methodReturnBody)
. call (toClient cl) . 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
-> Maybe InterfaceName
-> Maybe MemberName
-> MatchRule
matchSignal b p i m =
matchAny
{ matchPath = p { matchPath = p
, matchSender = b , matchSender = b
, matchInterface = i , matchInterface = i
, matchMember = m , 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)
@ -177,14 +213,19 @@ 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)
then maybe NoMatch Match $ fromVariant =<< M.lookup property b'
else NoMatch else NoMatch
_ -> Failure _ -> Failure
where where
@ -192,7 +233,7 @@ matchPropertyChanged iface property [i, body, _] =
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

View File

@ -6,56 +6,52 @@
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Functions for handling dependencies -- Functions for handling dependencies
module Data.Internal.Dependency module Data.Internal.Dependency
-- feature types -- feature types
( Feature ( Feature
, Always(..) , Always (..)
, Always_(..) , Always_ (..)
, FallbackRoot(..) , FallbackRoot (..)
, FallbackStack(..) , FallbackStack (..)
, Sometimes(..) , Sometimes (..)
, Sometimes_ , Sometimes_
, AlwaysX , AlwaysX
, AlwaysIO , AlwaysIO
, SometimesX , SometimesX
, SometimesIO , SometimesIO
, PostPass(..) , PostPass (..)
, Subfeature(..) , Subfeature (..)
, SubfeatureRoot , SubfeatureRoot
, Msg(..) , Msg (..)
-- configuration -- configuration
, XParams(..) , XParams (..)
, XPFeatures(..) , XPFeatures (..)
, XPQuery , XPQuery
-- dependency tree types -- dependency tree types
, Root(..) , Root (..)
, Tree(..) , Tree (..)
, Tree_(..) , Tree_ (..)
, IOTree , IOTree
, IOTree_ , IOTree_
, DBusTree , DBusTree
, DBusTree_ , DBusTree_
, SafeClient(..) , SafeClient (..)
, IODependency(..) , IODependency (..)
, IODependency_(..) , IODependency_ (..)
, SystemDependency(..) , SystemDependency (..)
, DBusDependency_(..) , DBusDependency_ (..)
, DBusMember(..) , DBusMember (..)
, UnitType(..) , UnitType (..)
, Result , Result
, Fulfillment(..) , Fulfillment (..)
, ArchPkg(..) , ArchPkg (..)
-- dumping -- dumping
, dumpFeature , dumpFeature
, dumpAlways , dumpAlways
, dumpSometimes , dumpSometimes
, showFulfillment , showFulfillment
-- testing -- testing
, FIO , FIO
, withCache , withCache
@ -72,11 +68,9 @@ module Data.Internal.Dependency
, readEthernet , readEthernet
, readWireless , readWireless
, socketExists , socketExists
-- lifting -- lifting
, ioSometimes , ioSometimes
, ioAlways , ioAlways
-- feature construction -- feature construction
, always1 , always1
, sometimes1 , sometimes1
@ -86,7 +80,6 @@ module Data.Internal.Dependency
, sometimesExe , sometimesExe
, sometimesExeArgs , sometimesExeArgs
, sometimesEndpoint , sometimesEndpoint
-- dependency construction -- dependency construction
, sysExe , sysExe
, localExe , localExe
@ -101,15 +94,16 @@ module Data.Internal.Dependency
, voidResult , voidResult
, voidRead , voidRead
, process , process
-- misc -- misc
, shellTest , shellTest
) where )
where
import Control.Monad.IO.Class import Control.Monad.IO.Class
import Control.Monad.Identity import Control.Monad.Identity
import Control.Monad.Reader import Control.Monad.Reader
import DBus hiding (typeOf)
import qualified DBus.Introspection as I
import Data.Aeson hiding (Error, Result) import Data.Aeson hiding (Error, Result)
import Data.Aeson.Key import Data.Aeson.Key
import Data.Bifunctor import Data.Bifunctor
@ -118,30 +112,23 @@ import Data.Internal.DBus
import Data.List import Data.List
import Data.Maybe import Data.Maybe
import Data.Yaml import Data.Yaml
import GHC.IO.Exception (ioe_description) import GHC.IO.Exception (ioe_description)
import DBus hiding (typeOf)
import qualified DBus.Introspection as I
import RIO hiding (bracket, fromString) import RIO hiding (bracket, fromString)
import RIO.FilePath import RIO.FilePath
import RIO.Process hiding (findExecutable) import RIO.Process hiding (findExecutable)
import qualified RIO.Text as T import qualified RIO.Text as T
import System.Directory import System.Directory
import System.Environment import System.Environment
import System.IO.Error import System.IO.Error
import System.Posix.Files import System.Posix.Files
import System.Process.Typed (nullStream) import System.Process.Typed (nullStream)
import XMonad.Core (X, io) import XMonad.Core (X, io)
import XMonad.Internal.IO import XMonad.Internal.IO
import XMonad.Internal.Shell hiding (proc, runProcess) import XMonad.Internal.Shell hiding (proc, runProcess)
import XMonad.Internal.Theme import XMonad.Internal.Theme
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Feature Evaluation -- Feature Evaluation
-- --
-- Here we attempt to build and return the monadic actions encoded by each -- Here we attempt to build and return the monadic actions encoded by each
-- feature. -- feature.
@ -195,15 +182,16 @@ logMsg (FMsg fn n (Msg ll m)) = do
llFun LevelWarn = ("WARN", logWarn) llFun LevelWarn = ("WARN", logWarn)
llFun _ = ("DEBUG", logDebug) llFun _ = ("DEBUG", logDebug)
(s, f) = llFun ll (s, f) = llFun ll
fmt p l = [ bracket p fmt p l =
[ bracket p
, bracket l , bracket l
, bracket fn , bracket fn
] ]
++ maybe [] ((:[]) . bracket) n ++ maybe [] ((: []) . bracket) n
++ [m] ++ [m]
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Package status -- Package status
showFulfillment :: Fulfillment -> T.Text showFulfillment :: Fulfillment -> T.Text
showFulfillment (Package t n) = T.concat [T.pack $ show t, "\t", n] showFulfillment (Package t n) = T.concat [T.pack $ show t, "\t", n]
@ -220,7 +208,7 @@ dumpSometimes :: Sometimes a -> [Fulfillment]
dumpSometimes (Sometimes _ _ xs) = nub $ concatMap dataSubfeatureRoot xs dumpSometimes (Sometimes _ _ xs) = nub $ concatMap dataSubfeatureRoot xs
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Wrapper types -- Wrapper types
type AlwaysX = Always (X ()) type AlwaysX = Always (X ())
@ -233,7 +221,7 @@ type SometimesIO = Sometimes (FIO ())
type Feature a = Either (Sometimes a) (Always a) type Feature a = Either (Sometimes a) (Always a)
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Feature declaration -- Feature declaration
-- | Feature that is guaranteed to work -- | Feature that is guaranteed to work
-- This is composed of sub-features that are tested in order, and if all fail -- This is composed of sub-features that are tested in order, and if all fail
@ -241,17 +229,20 @@ type Feature a = Either (Sometimes a) (Always a)
data Always a = Always T.Text (Always_ a) data Always a = Always T.Text (Always_ a)
-- | Feature that is guaranteed to work (inner data) -- | Feature that is guaranteed to work (inner data)
data Always_ a = Option (SubfeatureRoot a) (Always_ a) data Always_ a
= Option (SubfeatureRoot a) (Always_ a)
| Always_ (FallbackRoot a) | Always_ (FallbackRoot a)
-- | Root of a fallback action for an always -- | Root of a fallback action for an always
-- This may either be a lone action or a function that depends on the results -- This may either be a lone action or a function that depends on the results
-- from other Always features. -- from other Always features.
data FallbackRoot a = FallbackAlone a data FallbackRoot a
= FallbackAlone a
| forall p. FallbackTree (p -> a) (FallbackStack p) | forall p. FallbackTree (p -> a) (FallbackStack p)
-- | Always features that are used as a payload for a fallback action -- | Always features that are used as a payload for a fallback action
data FallbackStack p = FallbackBottom (Always p) data FallbackStack p
= FallbackBottom (Always p)
| forall x y. FallbackStack (x -> y -> p) (Always x) (FallbackStack y) | forall x y. FallbackStack (x -> y -> p) (Always x) (FallbackStack y)
-- | Feature that might not be present -- | Feature that might not be present
@ -276,14 +267,15 @@ type SubfeatureRoot a = Subfeature (Root a)
-- | An action and its dependencies -- | An action and its dependencies
-- May be a plain old monad or be DBus-dependent, in which case a client is -- May be a plain old monad or be DBus-dependent, in which case a client is
-- needed -- needed
data Root a = forall p. IORoot (p -> a) (IOTree p) data Root a
= forall p. IORoot (p -> a) (IOTree p)
| IORoot_ a IOTree_ | IORoot_ a IOTree_
| forall c p. SafeClient c => DBusRoot (p -> c -> a) (DBusTree c p) (Maybe c) | forall c p. SafeClient c => DBusRoot (p -> c -> a) (DBusTree c p) (Maybe c)
| forall c. SafeClient c => DBusRoot_ (c -> a) (DBusTree_ c) (Maybe c) | forall c. SafeClient c => DBusRoot_ (c -> a) (DBusTree_ c) (Maybe c)
-- | The dependency tree with rule to merge results when needed -- | The dependency tree with rule to merge results when needed
data Tree d d_ p = data Tree d d_ p
forall x y. And12 (x -> y -> p) (Tree d d_ x) (Tree d d_ y) = forall x y. And12 (x -> y -> p) (Tree d d_ x) (Tree d d_ y)
| And1 (Tree d d_ p) (Tree_ d_) | And1 (Tree d d_ p) (Tree_ d_)
| And2 (Tree_ d_) (Tree d d_ p) | And2 (Tree_ d_) (Tree d d_ p)
| Or (Tree d d_ p) (Tree d d_ p) | Or (Tree d d_ p) (Tree d d_ p)
@ -294,36 +286,41 @@ data Tree_ d = And_ (Tree_ d) (Tree_ d) | Or_ (Tree_ d) (Tree_ d) | Only_ d
-- | Shorthand tree types for lazy typers -- | Shorthand tree types for lazy typers
type IOTree p = Tree IODependency IODependency_ p type IOTree p = Tree IODependency IODependency_ p
type DBusTree c p = Tree IODependency (DBusDependency_ c) p type DBusTree c p = Tree IODependency (DBusDependency_ c) p
type IOTree_ = Tree_ IODependency_ type IOTree_ = Tree_ IODependency_
type DBusTree_ c = Tree_ (DBusDependency_ c) type DBusTree_ c = Tree_ (DBusDependency_ c)
-- | A dependency that only requires IO to evaluate (with payload) -- | A dependency that only requires IO to evaluate (with payload)
data IODependency p = data IODependency p
-- an IO action that yields a payload = -- an IO action that yields a payload
IORead T.Text [Fulfillment] (FIO (Result p)) IORead T.Text [Fulfillment] (FIO (Result p))
-- always yields a payload | -- always yields a payload
| IOConst p IOConst p
-- an always that yields a payload | -- an always that yields a payload
| forall a. IOAlways (Always a) (a -> p) forall a. IOAlways (Always a) (a -> p)
-- a sometimes that yields a payload | -- a sometimes that yields a payload
| forall a. IOSometimes (Sometimes a) (a -> p) forall a. IOSometimes (Sometimes a) (a -> p)
-- | A dependency pertaining to the DBus -- | A dependency pertaining to the DBus
data DBusDependency_ c = Bus [Fulfillment] BusName data DBusDependency_ c
= Bus [Fulfillment] BusName
| Endpoint [Fulfillment] BusName ObjectPath InterfaceName DBusMember | Endpoint [Fulfillment] BusName ObjectPath InterfaceName DBusMember
| DBusIO IODependency_ | DBusIO IODependency_
deriving (Generic) deriving (Generic)
-- | A dependency that only requires IO to evaluate (no payload) -- | A dependency that only requires IO to evaluate (no payload)
data IODependency_ = IOSystem_ [Fulfillment] SystemDependency data IODependency_
= IOSystem_ [Fulfillment] SystemDependency
| IOTest_ T.Text [Fulfillment] (FIO (Maybe Msg)) | IOTest_ T.Text [Fulfillment] (FIO (Maybe Msg))
| forall a. IOSometimes_ (Sometimes a) | forall a. IOSometimes_ (Sometimes a)
-- | A system component to an IODependency -- | A system component to an IODependency
-- This name is dumb, but most constructors should be obvious -- This name is dumb, but most constructors should be obvious
data SystemDependency = data SystemDependency
Executable Bool FilePath = Executable Bool FilePath
| AccessiblePath FilePath Bool Bool | AccessiblePath FilePath Bool Bool
| Systemd UnitType T.Text | Systemd UnitType T.Text
| Process T.Text | Process T.Text
@ -333,7 +330,8 @@ data SystemDependency =
data UnitType = SystemUnit | UserUnit deriving (Eq, Show, Generic) data UnitType = SystemUnit | UserUnit deriving (Eq, Show, Generic)
-- | Wrapper type to describe and endpoint -- | Wrapper type to describe and endpoint
data DBusMember = Method_ MemberName data DBusMember
= Method_ MemberName
| Signal_ MemberName | Signal_ MemberName
| Property_ T.Text | Property_ T.Text
deriving (Eq, Show, Generic) deriving (Eq, Show, Generic)
@ -345,7 +343,7 @@ data Fulfillment = Package ArchPkg T.Text deriving (Eq, Show, Ord)
data ArchPkg = Official | AUR | Custom deriving (Eq, Show, Generic, Ord) data ArchPkg = Official | AUR | Custom deriving (Eq, Show, Generic, Ord)
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Tested dependency tree -- Tested dependency tree
-- --
-- The main reason I need this is so I have a "result" I can convert to JSON -- The main reason I need this is so I have a "result" I can convert to JSON
-- and dump on the CLI (unless there is a way to make Aeson work inside an IO) -- and dump on the CLI (unless there is a way to make Aeson work inside an IO)
@ -357,7 +355,8 @@ data Msg = Msg LogLevel T.Text
data FMsg = FMsg T.Text (Maybe T.Text) Msg data FMsg = FMsg T.Text (Maybe T.Text) Msg
-- | Tested Always feature -- | Tested Always feature
data PostAlways a = Primary (SubfeaturePass a) [SubfeatureFail] (Always_ a) data PostAlways a
= Primary (SubfeaturePass a) [SubfeatureFail] (Always_ a)
| Fallback a [SubfeatureFail] | Fallback a [SubfeatureFail]
-- | Tested Sometimes feature -- | Tested Sometimes feature
@ -382,7 +381,7 @@ addMsgs (PostPass a ms) ms' = PostPass a $ ms ++ ms'
data PostFail = PostFail [Msg] | PostMissing Msg data PostFail = PostFail [Msg] | PostMissing Msg
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Configuration -- Configuration
type FIO a = RIO DepStage a type FIO a = RIO DepStage a
@ -393,10 +392,10 @@ data DepStage = DepStage
} }
instance HasLogFunc DepStage where instance HasLogFunc DepStage where
logFuncL = lens dsLogFun (\x y -> x { dsLogFun = y }) logFuncL = lens dsLogFun (\x y -> x {dsLogFun = y})
instance HasProcessContext DepStage where instance HasProcessContext DepStage where
processContextL = lens dsProcCxt (\x y -> x { dsProcCxt = y }) processContextL = lens dsProcCxt (\x y -> x {dsProcCxt = y})
data XParams = XParams data XParams = XParams
{ xpLogLevel :: LogLevel { xpLogLevel :: LogLevel
@ -434,34 +433,48 @@ data XPFeatures = XPFeatures
} }
instance FromJSON XPFeatures where instance FromJSON XPFeatures where
parseJSON = withObject "features" $ \o -> XPFeatures parseJSON = withObject "features" $ \o ->
<$> o .:+ "optimus" XPFeatures
<*> o .:+ "virtualbox" <$> o
<*> o .:+ "xsane" .:+ "optimus"
<*> o .:+ "ethernet" <*> o
<*> o .:+ "wireless" .:+ "virtualbox"
<*> o .:+ "vpn" <*> o
<*> o .:+ "bluetooth" .:+ "xsane"
<*> o .:+ "intel_backlight" <*> o
<*> o .:+ "clevo_backlight" .:+ "ethernet"
<*> o .:+ "battery" <*> o
<*> o .:+ "f5vpn" .:+ "wireless"
<*> o
.:+ "vpn"
<*> o
.:+ "bluetooth"
<*> o
.:+ "intel_backlight"
<*> o
.:+ "clevo_backlight"
<*> o
.:+ "battery"
<*> o
.:+ "f5vpn"
defParams :: XParams defParams :: XParams
defParams = XParams defParams =
XParams
{ xpLogLevel = LevelError { xpLogLevel = LevelError
, xpFeatures = defXPFeatures , xpFeatures = defXPFeatures
} }
defXPFeatures :: XPFeatures defXPFeatures :: XPFeatures
defXPFeatures = XPFeatures defXPFeatures =
XPFeatures
{ xpfOptimus = False { xpfOptimus = False
, xpfVirtualBox = False , xpfVirtualBox = False
, xpfXSANE = False , xpfXSANE = False
, xpfEthernet = False , xpfEthernet = False
, xpfWireless = False , xpfWireless = False
-- TODO this might be broken down into different flags (expressvpn, etc) , -- TODO this might be broken down into different flags (expressvpn, etc)
, xpfVPN = False xpfVPN = False
, xpfBluetooth = False , xpfBluetooth = False
, xpfIntelBacklight = False , xpfIntelBacklight = False
, xpfClevoBacklight = False , xpfClevoBacklight = False
@ -476,7 +489,8 @@ getParams = do
p <- getParamFile p <- getParamFile
maybe (return defParams) decodeYaml p maybe (return defParams) decodeYaml p
where where
decodeYaml p = either (\e -> print e >> return defParams) return decodeYaml p =
either (\e -> print e >> return defParams) return
=<< decodeFileEither p =<< decodeFileEither p
getParamFile :: IO (Maybe FilePath) getParamFile :: IO (Maybe FilePath)
@ -495,16 +509,18 @@ getParamFile = do
(.:+) :: Object -> String -> Parser Bool (.:+) :: Object -> String -> Parser Bool
(.:+) o n = o .:? fromString n .!= False (.:+) o n = o .:? fromString n .!= False
infix .:+ infix 9 .:+
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Testing pipeline -- Testing pipeline
evalSometimesMsg :: Sometimes a -> FIO (Either [FMsg] (a, [FMsg])) evalSometimesMsg :: Sometimes a -> FIO (Either [FMsg] (a, [FMsg]))
evalSometimesMsg (Sometimes n u xs) = do evalSometimesMsg (Sometimes n u xs) = do
r <- asks (u . xpFeatures . dsParams) r <- asks (u . xpFeatures . dsParams)
if not r then return $ Left [dis n] else do if not r
PostSometimes { psSuccess = s, psFailed = fs } <- testSometimes xs then return $ Left [dis n]
else do
PostSometimes {psSuccess = s, psFailed = fs} <- testSometimes xs
let fs' = failedMsgs n fs let fs' = failedMsgs n fs
return $ case s of return $ case s of
(Just p) -> Right $ second (++ fs') $ passActMsg n p (Just p) -> Right $ second (++ fs') $ passActMsg n p
@ -520,13 +536,13 @@ evalAlwaysMsg (Always n x) = do
(Fallback act fs) -> (act, failedMsgs n fs) (Fallback act fs) -> (act, failedMsgs n fs)
passActMsg :: T.Text -> SubfeaturePass a -> (a, [FMsg]) passActMsg :: T.Text -> SubfeaturePass a -> (a, [FMsg])
passActMsg fn Subfeature { sfData = PostPass a ws, sfName = n } = (a, fmap (FMsg fn (Just n)) ws) passActMsg fn Subfeature {sfData = PostPass a ws, sfName = n} = (a, fmap (FMsg fn (Just n)) ws)
failedMsgs :: T.Text -> [SubfeatureFail] -> [FMsg] failedMsgs :: T.Text -> [SubfeatureFail] -> [FMsg]
failedMsgs n = concatMap (failedMsg n) failedMsgs n = concatMap (failedMsg n)
failedMsg :: T.Text -> SubfeatureFail -> [FMsg] failedMsg :: T.Text -> SubfeatureFail -> [FMsg]
failedMsg fn Subfeature { sfData = d, sfName = n } = case d of failedMsg fn Subfeature {sfData = d, sfName = n} = case d of
(PostFail es) -> f es (PostFail es) -> f es
(PostMissing e) -> f [e] (PostMissing e) -> f [e]
where where
@ -538,7 +554,7 @@ testAlways = go []
go failed (Option fd next) = do go failed (Option fd next) = do
r <- testSubfeature fd r <- testSubfeature fd
case r of case r of
(Left l) -> go (l:failed) next (Left l) -> go (l : failed) next
(Right pass) -> return $ Primary pass failed next (Right pass) -> return $ Primary pass failed next
go failed (Always_ ar) = (`Fallback` failed) <$> evalFallbackRoot ar go failed (Always_ ar) = (`Fallback` failed) <$> evalFallbackRoot ar
@ -557,17 +573,17 @@ testSometimes :: Sometimes_ a -> FIO (PostSometimes a)
testSometimes = go (PostSometimes Nothing []) testSometimes = go (PostSometimes Nothing [])
where where
go ts [] = return ts go ts [] = return ts
go ts (x:xs) = do go ts (x : xs) = do
sf <- testSubfeature x sf <- testSubfeature x
case sf of case sf of
(Left l) -> go (ts { psFailed = l:psFailed ts }) xs (Left l) -> go (ts {psFailed = l : psFailed ts}) xs
(Right pass) -> return $ ts { psSuccess = Just pass } (Right pass) -> return $ ts {psSuccess = Just pass}
testSubfeature :: SubfeatureRoot a -> FIO (Either SubfeatureFail (SubfeaturePass a)) testSubfeature :: SubfeatureRoot a -> FIO (Either SubfeatureFail (SubfeaturePass a))
testSubfeature sf@Subfeature{ sfData = t } = do testSubfeature sf@Subfeature {sfData = t} = do
t' <- testRoot t t' <- testRoot t
-- monomorphism restriction :( -- monomorphism restriction :(
return $ bimap (\n -> sf { sfData = n }) (\n -> sf { sfData = n }) t' return $ bimap (\n -> sf {sfData = n}) (\n -> sf {sfData = n}) t'
testRoot :: Root a -> FIO (Either PostFail (PostPass a)) testRoot :: Root a -> FIO (Either PostFail (PostPass a))
testRoot r = do testRoot r = do
@ -576,8 +592,11 @@ testRoot r = do
(IORoot_ a t) -> go_ a testIODep_ t (IORoot_ a t) -> go_ a testIODep_ t
(DBusRoot a t (Just cl)) -> go (`a` cl) (testDBusDep_ cl) testIODep t (DBusRoot a t (Just cl)) -> go (`a` cl) (testDBusDep_ cl) testIODep t
(DBusRoot_ a t (Just cl)) -> go_ (a cl) (testDBusDep_ cl) t (DBusRoot_ a t (Just cl)) -> go_ (a cl) (testDBusDep_ cl) t
_ -> return $ Left $ PostMissing _ ->
$ Msg LevelError "client not available" return $
Left $
PostMissing $
Msg LevelError "client not available"
where where
-- rank N polymorphism is apparently undecidable...gross -- rank N polymorphism is apparently undecidable...gross
go a f_ (f :: forall q. d q -> FIO (MResult q)) t = go a f_ (f :: forall q. d q -> FIO (MResult q)) t =
@ -585,13 +604,15 @@ testRoot r = do
go_ a f_ t = bimap PostFail (PostPass a) <$> testTree_ f_ t go_ a f_ t = bimap PostFail (PostPass a) <$> testTree_ f_ t
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Payloaded dependency testing -- Payloaded dependency testing
type Result p = Either [Msg] (PostPass p) type Result p = Either [Msg] (PostPass p)
type MResult p = Memoized (Result p) type MResult p = Memoized (Result p)
testTree :: forall d d_ p. (d_ -> FIO MResult_) testTree
:: forall d d_ p
. (d_ -> FIO MResult_)
-> (forall q. d q -> FIO (MResult q)) -> (forall q. d q -> FIO (MResult q))
-> Tree d d_ p -> Tree d d_ p
-> FIO (Either [Msg] (PostPass p)) -> FIO (Either [Msg] (PostPass p))
@ -622,18 +643,22 @@ testIODep d = memoizeMVar $ case d of
-- succeed, which kinda makes this pointless. The only reason I would want -- succeed, which kinda makes this pointless. The only reason I would want
-- this is if I want to have a built-in logic to "choose" a payload to use in -- this is if I want to have a built-in logic to "choose" a payload to use in
-- building a higher-level feature -- building a higher-level feature
IOAlways a f -> Right . uncurry PostPass IOAlways a f ->
Right
. uncurry PostPass
-- TODO this is wetter than Taco Bell shit -- TODO this is wetter than Taco Bell shit
. bimap f (fmap stripMsg) <$> evalAlwaysMsg a . bimap f (fmap stripMsg)
IOSometimes x f -> bimap (fmap stripMsg) (uncurry PostPass . bimap f (fmap stripMsg)) <$> evalAlwaysMsg a
IOSometimes x f ->
bimap (fmap stripMsg) (uncurry PostPass . bimap f (fmap stripMsg))
<$> evalSometimesMsg x <$> evalSometimesMsg x
stripMsg :: FMsg -> Msg stripMsg :: FMsg -> Msg
stripMsg (FMsg _ _ m) = m stripMsg (FMsg _ _ m) = m
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Standalone dependency testing
-- | Standalone dependency testing
type Result_ = Either [Msg] [Msg] type Result_ = Either [Msg] [Msg]
type MResult_ = Memoized Result_ type MResult_ = Memoized Result_
@ -652,14 +677,17 @@ testIODep_ d = memoizeMVar $ testIODepNoCache_ d
testIODepNoCache_ :: IODependency_ -> FIO Result_ testIODepNoCache_ :: IODependency_ -> FIO Result_
testIODepNoCache_ (IOSystem_ _ s) = readResult_ <$> testSysDependency s testIODepNoCache_ (IOSystem_ _ s) = readResult_ <$> testSysDependency s
testIODepNoCache_ (IOTest_ _ _ t) = readResult_ <$> t testIODepNoCache_ (IOTest_ _ _ t) = readResult_ <$> t
testIODepNoCache_ (IOSometimes_ x) = bimap (fmap stripMsg) (fmap stripMsg . snd) testIODepNoCache_ (IOSometimes_ x) =
bimap (fmap stripMsg) (fmap stripMsg . snd)
<$> evalSometimesMsg x <$> evalSometimesMsg x
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | System Dependency Testing
-- | System Dependency Testing
testSysDependency :: SystemDependency -> FIO (Maybe Msg) testSysDependency :: SystemDependency -> FIO (Maybe Msg)
testSysDependency (Executable sys bin) = io $ maybe (Just msg) (const Nothing) testSysDependency (Executable sys bin) =
io $
maybe (Just msg) (const Nothing)
<$> findExecutable bin <$> findExecutable bin
where where
msg = Msg LevelError $ T.unwords [e, "executable", singleQuote $ T.pack bin, "not found"] msg = Msg LevelError $ T.unwords [e, "executable", singleQuote $ T.pack bin, "not found"]
@ -668,8 +696,9 @@ testSysDependency (Systemd t n) = shellTest "systemctl" args msg
where where
msg = T.unwords ["systemd", unitType t, "unit", singleQuote n, "not found"] msg = T.unwords ["systemd", unitType t, "unit", singleQuote n, "not found"]
args = ["--user" | t == UserUnit] ++ ["status", n] args = ["--user" | t == UserUnit] ++ ["status", n]
testSysDependency (Process n) = shellTest "pidof" [n] testSysDependency (Process n) =
$ T.unwords ["Process", singleQuote n, "not found"] shellTest "pidof" [n] $
T.unwords ["Process", singleQuote n, "not found"]
testSysDependency (AccessiblePath p r w) = io $ permMsg <$> getPermissionsSafe p testSysDependency (AccessiblePath p r w) = io $ permMsg <$> getPermissionsSafe p
where where
testPerm False _ _ = Nothing testPerm False _ _ = Nothing
@ -696,7 +725,7 @@ unitType SystemUnit = "system"
unitType UserUnit = "user" unitType UserUnit = "user"
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Font testers -- Font testers
-- --
-- Make a special case for these since we end up testing the font alot, and it -- Make a special case for these since we end up testing the font alot, and it
-- would be nice if I can cache them. -- would be nice if I can cache them.
@ -706,7 +735,7 @@ fontAlways n fam ful = always1 n (fontFeatureName fam) root fallbackFont
where where
root = IORoot id $ fontTree fam ful root = IORoot id $ fontTree fam ful
fontSometimes :: T.Text -> T.Text -> [Fulfillment]-> Sometimes FontBuilder fontSometimes :: T.Text -> T.Text -> [Fulfillment] -> Sometimes FontBuilder
fontSometimes n fam ful = sometimes1 n (fontFeatureName fam) root fontSometimes n fam ful = sometimes1 n (fontFeatureName fam) root
where where
root = IORoot id $ fontTree fam ful root = IORoot id $ fontTree fam ful
@ -736,7 +765,7 @@ fontTestName fam = T.unwords ["test if font", singleQuote fam, "exists"]
-- testFont = liftIO . testFont' -- testFont = liftIO . testFont'
testFont :: T.Text -> FIO (Result FontBuilder) testFont :: T.Text -> FIO (Result FontBuilder)
testFont fam = maybe pass (Left . (:[])) <$> shellTest "fc-list" args msg testFont fam = maybe pass (Left . (: [])) <$> shellTest "fc-list" args msg
where where
msg = T.unwords ["font family", qFam, "not found"] msg = T.unwords ["font family", qFam, "not found"]
args = [qFam] args = [qFam]
@ -744,7 +773,7 @@ testFont fam = maybe pass (Left . (:[])) <$> shellTest "fc-list" args msg
pass = Right $ PostPass (buildFont $ Just fam) [] pass = Right $ PostPass (buildFont $ Just fam) []
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Network Testers -- Network Testers
-- --
-- ASSUME that the system uses systemd in which case ethernet interfaces always -- ASSUME that the system uses systemd in which case ethernet interfaces always
-- start with "en" and wireless interfaces always start with "wl" -- start with "en" and wireless interfaces always start with "wl"
@ -762,7 +791,8 @@ isEthernet :: T.Text -> Bool
isEthernet = T.isPrefixOf "en" isEthernet = T.isPrefixOf "en"
listInterfaces :: IO [T.Text] listInterfaces :: IO [T.Text]
listInterfaces = fromRight [] listInterfaces =
fromRight []
<$> tryIOError (fmap T.pack <$> listDirectory sysfsNet) <$> tryIOError (fmap T.pack <$> listDirectory sysfsNet)
sysfsNet :: FilePath sysfsNet :: FilePath
@ -777,16 +807,20 @@ readInterface n f = IORead n [] go
ns <- filter f <$> listInterfaces ns <- filter f <$> listInterfaces
case ns of case ns of
[] -> return $ Left [Msg LevelError "no interfaces found"] [] -> return $ Left [Msg LevelError "no interfaces found"]
(x:xs) -> do (x : xs) -> do
return $ Right $ PostPass x return $
$ fmap (Msg LevelWarn . T.append "ignoring extra interface: ") xs Right $
PostPass x $
fmap (Msg LevelWarn . T.append "ignoring extra interface: ") xs
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Misc testers -- Misc testers
socketExists :: T.Text -> [Fulfillment] -> IO FilePath -> IODependency_ socketExists :: T.Text -> [Fulfillment] -> IO FilePath -> IODependency_
socketExists n ful = IOTest_ (T.unwords ["test if", n, "socket exists"]) ful socketExists n ful =
. io . socketExists' IOTest_ (T.unwords ["test if", n, "socket exists"]) ful
. io
. socketExists'
socketExists' :: IO FilePath -> IO (Maybe Msg) socketExists' :: IO FilePath -> IO (Maybe Msg)
socketExists' getPath = do socketExists' getPath = do
@ -799,7 +833,7 @@ socketExists' getPath = do
toErr = Just . Msg LevelError toErr = Just . Msg LevelError
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | DBus Dependency Testing -- DBus Dependency Testing
introspectInterface :: InterfaceName introspectInterface :: InterfaceName
introspectInterface = interfaceName_ "org.freedesktop.DBus.Introspectable" introspectInterface = interfaceName_ "org.freedesktop.DBus.Introspectable"
@ -815,10 +849,13 @@ testDBusDepNoCache_ cl (Bus _ bus) = io $ do
ret <- callMethod cl queryBus queryPath queryIface queryMem ret <- callMethod cl queryBus queryPath queryIface queryMem
return $ case ret of return $ case ret of
Left e -> Left [Msg LevelError e] Left e -> Left [Msg LevelError e]
Right b -> let ns = bodyGetNames b in Right b ->
if bus' `elem` ns then Right [] let ns = bodyGetNames b
else Left [ in if bus' `elem` ns
Msg LevelError $ T.unwords ["name", singleQuote bus', "not found on dbus"] then Right []
else
Left
[ Msg LevelError $ T.unwords ["name", singleQuote bus', "not found on dbus"]
] ]
where where
bus' = T.pack $ formatBusName bus bus' = T.pack $ formatBusName bus
@ -828,19 +865,23 @@ testDBusDepNoCache_ cl (Bus _ bus) = io $ do
queryMem = memberName_ "ListNames" queryMem = memberName_ "ListNames"
bodyGetNames [v] = fromMaybe [] $ fromVariant v :: [T.Text] bodyGetNames [v] = fromMaybe [] $ fromVariant v :: [T.Text]
bodyGetNames _ = [] bodyGetNames _ = []
testDBusDepNoCache_ cl (Endpoint _ busname objpath iface mem) = io $ do testDBusDepNoCache_ cl (Endpoint _ busname objpath iface mem) = io $ do
ret <- callMethod cl busname objpath introspectInterface introspectMethod ret <- callMethod cl busname objpath introspectInterface introspectMethod
return $ case ret of return $ case ret of
Left e -> Left [Msg LevelError e] Left e -> Left [Msg LevelError e]
Right body -> procBody body Right body -> procBody body
where where
procBody body = let res = findMem =<< I.parseXML objpath =<< fromVariant procBody body =
=<< listToMaybe body in let res =
case res of findMem
=<< I.parseXML objpath
=<< fromVariant
=<< listToMaybe body
in case res of
Just True -> Right [] Just True -> Right []
_ -> Left [Msg LevelError $ fmtMsg' mem] _ -> Left [Msg LevelError $ fmtMsg' mem]
findMem = fmap (matchMem mem) findMem =
fmap (matchMem mem)
. find (\i -> I.interfaceName i == iface) . find (\i -> I.interfaceName i == iface)
. I.objectInterfaces . I.objectInterfaces
matchMem (Method_ n) = elemMember n I.methodName I.interfaceMethods matchMem (Method_ n) = elemMember n I.methodName I.interfaceMethods
@ -850,7 +891,8 @@ testDBusDepNoCache_ cl (Endpoint _ busname objpath iface mem) = io $ do
fmtMem (Method_ n) = T.unwords ["method", singleQuote (T.pack $ formatMemberName n)] fmtMem (Method_ n) = T.unwords ["method", singleQuote (T.pack $ formatMemberName n)]
fmtMem (Signal_ n) = T.unwords ["signal", singleQuote (T.pack $ formatMemberName n)] fmtMem (Signal_ n) = T.unwords ["signal", singleQuote (T.pack $ formatMemberName n)]
fmtMem (Property_ n) = T.unwords ["property", singleQuote n] fmtMem (Property_ n) = T.unwords ["property", singleQuote n]
fmtMsg' m = T.unwords fmtMsg' m =
T.unwords
[ "could not find" [ "could not find"
, fmtMem m , fmtMem m
, "on interface" , "on interface"
@ -858,11 +900,10 @@ testDBusDepNoCache_ cl (Endpoint _ busname objpath iface mem) = io $ do
, "on bus" , "on bus"
, T.pack $ formatBusName busname , T.pack $ formatBusName busname
] ]
testDBusDepNoCache_ _ (DBusIO i) = testIODepNoCache_ i testDBusDepNoCache_ _ (DBusIO i) = testIODepNoCache_ i
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | IO Lifting functions -- IO Lifting functions
ioSometimes :: MonadIO m => Sometimes (IO a) -> Sometimes (m a) ioSometimes :: MonadIO m => Sometimes (IO a) -> Sometimes (m a)
ioSometimes (Sometimes n t xs) = Sometimes n t $ fmap ioSubfeature xs ioSometimes (Sometimes n t xs) = Sometimes n t $ fmap ioSubfeature xs
@ -879,7 +920,7 @@ ioFallbackRoot (FallbackAlone a) = FallbackAlone $ io a
ioFallbackRoot (FallbackTree a s) = FallbackTree (io . a) s ioFallbackRoot (FallbackTree a s) = FallbackTree (io . a) s
ioSubfeature :: MonadIO m => SubfeatureRoot (IO a) -> SubfeatureRoot (m a) ioSubfeature :: MonadIO m => SubfeatureRoot (IO a) -> SubfeatureRoot (m a)
ioSubfeature sf = sf { sfData = ioRoot $ sfData sf } ioSubfeature sf = sf {sfData = ioRoot $ sfData sf}
ioRoot :: MonadIO m => Root (IO a) -> Root (m a) ioRoot :: MonadIO m => Root (IO a) -> Root (m a)
ioRoot (IORoot a t) = IORoot (io . a) t ioRoot (IORoot a t) = IORoot (io . a) t
@ -888,15 +929,19 @@ ioRoot (DBusRoot a t cl) = DBusRoot (\p c -> io $ a p c) t cl
ioRoot (DBusRoot_ a t cl) = DBusRoot_ (io . a) t cl ioRoot (DBusRoot_ a t cl) = DBusRoot_ (io . a) t cl
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Feature constructors -- Feature constructors
sometimes1_ :: XPQuery -> T.Text -> T.Text -> Root a -> Sometimes a sometimes1_ :: XPQuery -> T.Text -> T.Text -> Root a -> Sometimes a
sometimes1_ x fn n t = Sometimes fn x sometimes1_ x fn n t =
[Subfeature{ sfData = t, sfName = n }] Sometimes
fn
x
[Subfeature {sfData = t, sfName = n}]
always1_ :: T.Text -> T.Text -> Root a -> a -> Always a always1_ :: T.Text -> T.Text -> Root a -> a -> Always a
always1_ fn n t x = Always fn always1_ fn n t x =
$ Option (Subfeature{ sfData = t, sfName = n }) (Always_ $ FallbackAlone x) Always fn $
Option (Subfeature {sfData = t, sfName = n}) (Always_ $ FallbackAlone x)
sometimes1 :: T.Text -> T.Text -> Root a -> Sometimes a sometimes1 :: T.Text -> T.Text -> Root a -> Sometimes a
sometimes1 = sometimes1_ (const True) sometimes1 = sometimes1_ (const True)
@ -910,22 +955,49 @@ sometimesIO_ fn n t x = sometimes1 fn n $ IORoot_ x t
sometimesIO :: T.Text -> T.Text -> IOTree p -> (p -> a) -> Sometimes a sometimesIO :: T.Text -> T.Text -> IOTree p -> (p -> a) -> Sometimes a
sometimesIO fn n t x = sometimes1 fn n $ IORoot x t sometimesIO fn n t x = sometimes1 fn n $ IORoot x t
sometimesExe :: MonadIO m => T.Text -> T.Text -> [Fulfillment] -> Bool sometimesExe
-> FilePath -> Sometimes (m ()) :: MonadIO m
=> T.Text
-> T.Text
-> [Fulfillment]
-> Bool
-> FilePath
-> Sometimes (m ())
sometimesExe fn n ful sys path = sometimesExeArgs fn n ful sys path [] sometimesExe fn n ful sys path = sometimesExeArgs fn n ful sys path []
sometimesExeArgs :: MonadIO m => T.Text -> T.Text -> [Fulfillment] -> Bool sometimesExeArgs
-> FilePath -> [T.Text] -> Sometimes (m ()) :: MonadIO m
=> T.Text
-> T.Text
-> [Fulfillment]
-> Bool
-> FilePath
-> [T.Text]
-> Sometimes (m ())
sometimesExeArgs fn n ful sys path args = sometimesExeArgs fn n ful sys path args =
sometimesIO_ fn n (Only_ (IOSystem_ ful $ Executable sys path)) $ spawnCmd path args sometimesIO_ fn n (Only_ (IOSystem_ ful $ Executable sys path)) $ spawnCmd path args
sometimesDBus :: SafeClient c => Maybe c -> T.Text -> T.Text sometimesDBus
-> Tree_ (DBusDependency_ c) -> (c -> a) -> Sometimes a :: SafeClient c
=> Maybe c
-> T.Text
-> T.Text
-> Tree_ (DBusDependency_ c)
-> (c -> a)
-> Sometimes a
sometimesDBus c fn n t x = sometimes1 fn n $ DBusRoot_ x t c sometimesDBus c fn n t x = sometimes1 fn n $ DBusRoot_ x t c
sometimesEndpoint :: (SafeClient c, MonadIO m) => T.Text -> T.Text sometimesEndpoint
-> [Fulfillment] -> BusName -> ObjectPath -> InterfaceName -> MemberName :: (SafeClient c, MonadIO m)
-> Maybe c -> Sometimes (m ()) => T.Text
-> T.Text
-> [Fulfillment]
-> BusName
-> ObjectPath
-> InterfaceName
-> MemberName
-> Maybe c
-> Sometimes (m ())
sometimesEndpoint fn name ful busname path iface mem cl = sometimesEndpoint fn name ful busname path iface mem cl =
sometimesDBus cl fn name deps cmd sometimesDBus cl fn name deps cmd
where where
@ -933,7 +1005,7 @@ sometimesEndpoint fn name ful busname path iface mem cl =
cmd c = io $ void $ callMethod c busname path iface mem cmd c = io $ void $ callMethod c busname path iface mem
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Dependency Tree Constructors -- Dependency Tree Constructors
listToAnds :: d -> [d] -> Tree_ d listToAnds :: d -> [d] -> Tree_ d
listToAnds i = foldr (And_ . Only_) (Only_ i) listToAnds i = foldr (And_ . Only_) (Only_ i)
@ -950,7 +1022,7 @@ voidResult (Right (PostPass _ ws)) = Right ws
voidRead :: Result p -> Maybe Msg voidRead :: Result p -> Maybe Msg
voidRead (Left []) = Just $ Msg LevelError "unspecified error" voidRead (Left []) = Just $ Msg LevelError "unspecified error"
voidRead (Left (e:_)) = Just e voidRead (Left (e : _)) = Just e
voidRead (Right _) = Nothing voidRead (Right _) = Nothing
readResult_ :: Maybe Msg -> Result_ readResult_ :: Maybe Msg -> Result_
@ -958,7 +1030,7 @@ readResult_ (Just w) = Left [w]
readResult_ _ = Right [] readResult_ _ = Right []
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | IO Dependency Constructors -- IO Dependency Constructors
exe :: Bool -> [Fulfillment] -> FilePath -> IODependency_ exe :: Bool -> [Fulfillment] -> FilePath -> IODependency_
exe b ful = IOSystem_ ful . Executable b exe b ful = IOSystem_ ful . Executable b
@ -994,12 +1066,12 @@ process :: [Fulfillment] -> T.Text -> IODependency_
process ful = IOSystem_ ful . Process process ful = IOSystem_ ful . Process
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Dependency data for JSON -- Dependency data for JSON
type DependencyData = [Fulfillment] type DependencyData = [Fulfillment]
dataSubfeatureRoot :: SubfeatureRoot a -> DependencyData dataSubfeatureRoot :: SubfeatureRoot a -> DependencyData
dataSubfeatureRoot Subfeature { sfData = r } = dataRoot r dataSubfeatureRoot Subfeature {sfData = r} = dataRoot r
dataRoot :: Root a -> DependencyData dataRoot :: Root a -> DependencyData
dataRoot (IORoot _ t) = dataTree dataIODependency dataIODependency_ t dataRoot (IORoot _ t) = dataTree dataIODependency dataIODependency_ t
@ -1007,8 +1079,12 @@ dataRoot (IORoot_ _ t) = dataTree_ dataIODependency_ t
dataRoot (DBusRoot _ t _) = dataTree dataIODependency dataDBusDependency t dataRoot (DBusRoot _ t _) = dataTree dataIODependency dataDBusDependency t
dataRoot (DBusRoot_ _ t _) = dataTree_ dataDBusDependency t dataRoot (DBusRoot_ _ t _) = dataTree_ dataDBusDependency t
dataTree :: forall d d_ p. (forall q. d q -> DependencyData) dataTree
-> (d_ -> DependencyData) -> Tree d d_ p -> DependencyData :: forall d d_ p
. (forall q. d q -> DependencyData)
-> (d_ -> DependencyData)
-> Tree d d_ p
-> DependencyData
dataTree f f_ = go dataTree f f_ = go
where where
go :: forall q. Tree d d_ q -> DependencyData go :: forall q. Tree d d_ q -> DependencyData
@ -1045,8 +1121,7 @@ dataDBusDependency d = case d of
(DBusIO x) -> dataIODependency_ x (DBusIO x) -> dataIODependency_ x
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | JSON formatting -- formatting
bracket :: T.Text -> T.Text bracket :: T.Text -> T.Text
bracket s = T.concat ["[", s, "]"] bracket s = T.concat ["[", s, "]"]

View File

@ -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,23 +15,19 @@ module XMonad.Internal.Command.DMenu
, runBTMenu , runBTMenu
, runShowKeys , runShowKeys
, runAutorandrMenu , runAutorandrMenu
) where )
where
import Data.Internal.DBus
import Data.Internal.Dependency
import DBus import DBus
import Data.Internal.DBus
import Data.Internal.Dependency
import Graphics.X11.Types import Graphics.X11.Types
import qualified RIO.Text as T import qualified RIO.Text as T
import System.Directory import System.Directory
( XdgDirectory (..) ( XdgDirectory (..)
, getXdgDirectory , getXdgDirectory
) )
import System.IO import System.IO
import XMonad.Core hiding (spawn) import XMonad.Core hiding (spawn)
import XMonad.Internal.Command.Desktop import XMonad.Internal.Command.Desktop
import XMonad.Internal.DBus.Common import XMonad.Internal.DBus.Common
@ -40,7 +36,7 @@ import XMonad.Internal.Shell
import XMonad.Util.NamedActions 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" ++ "--"
: themeArgs "#999933"
++ myDmenuMatchingArgs ++ myDmenuMatchingArgs
-- TODO test that bluetooth interface exists -- TODO test that bluetooth interface exists
runBTMenu :: SometimesX runBTMenu :: SometimesX
runBTMenu = Sometimes "bluetooth selector" xpfBluetooth runBTMenu =
Sometimes
"bluetooth selector"
xpfBluetooth
[Subfeature (IORoot_ cmd tree) "rofi bluetooth"] [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 =
Sometimes
"VPN selector"
xpfVPN
[Subfeature (IORoot_ cmd tree) "rofi VPN"] [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 =
Sometimes
"network control menu"
enabled
[Subfeature root "network control menu"] [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,44 +168,60 @@ 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 =
listToAnds
dmenuDep
[ sysExe clipboardPkgs myClipboardManager
, process [] $ T.pack myClipboardManager , process [] $ T.pack myClipboardManager
] ]
args = [ "-modi", "\"clipboard:greenclip print\"" args =
, "-show", "clipboard" [ "-modi"
, "-run-command", "'{cmd}'" , "\"clipboard:greenclip print\""
] ++ themeArgs "#00c44e" , "-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 =
Subfeature
{ sfName = "keyboard shortcut menu" { sfName = "keyboard shortcut menu"
, sfData = IORoot_ showKeys $ Only_ dmenuDep , sfData = IORoot_ showKeys $ Only_ dmenuDep
} }
@ -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

View File

@ -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,28 +32,23 @@ 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 Data.Internal.Dependency
import DBus import DBus
import Data.Internal.DBus
import Data.Internal.Dependency
import RIO import RIO
import RIO.FilePath import RIO.FilePath
import qualified RIO.Process as P import qualified RIO.Process as P
import qualified RIO.Text as T import qualified RIO.Text as T
import System.Directory import System.Directory
import System.Environment import System.Environment
import System.Posix.User import System.Posix.User
import XMonad.Actions.Volume import XMonad.Actions.Volume
import XMonad.Core hiding (spawn) import XMonad.Core hiding (spawn)
import XMonad.Internal.DBus.Common import XMonad.Internal.DBus.Common
@ -63,7 +57,7 @@ import XMonad.Internal.Shell as S
import XMonad.Operations import XMonad.Operations
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | My Executables -- My Executables
myTerm :: FilePath myTerm :: FilePath
myTerm = "urxvt" myTerm = "urxvt"
@ -96,10 +90,11 @@ myNotificationCtrl :: FilePath
myNotificationCtrl = "dunstctl" myNotificationCtrl = "dunstctl"
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Packages -- Packages
myTermPkgs :: [Fulfillment] myTermPkgs :: [Fulfillment]
myTermPkgs = [ Package Official "rxvt-unicode" myTermPkgs =
[ Package Official "rxvt-unicode"
, Package Official "urxvt-perls" , Package Official "urxvt-perls"
] ]
@ -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 =
S.spawn $
fmtCmd "tmux" ["has-session"]
#!&& fmtCmd myTerm ["-e", "bash", "-c", singleQuote c] #!&& fmtCmd myTerm ["-e", "bash", "-c", singleQuote c]
#!|| fmtNotifyCmd defNoteError { body = Just $ Text msg } #!|| 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 =
spawnCmd
myEditor
["-c", "-e", doubleQuote "(select-frame-set-input-focus (selected-frame))"] ["-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,11 +261,14 @@ 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 =
Sometimes
"network applet"
xpfVPN
[Subfeature (DBusRoot_ cmd tree cl) "NM-applet"] [Subfeature (DBusRoot_ cmd tree cl) "NM-applet"]
where where
tree = toAnd_ app $ Bus networkManagerPkgs networkManagerBus tree = toAnd_ app $ Bus networkManagerPkgs networkManagerBus
@ -256,35 +276,46 @@ runNetAppDaemon cl = Sometimes "network applet" xpfVPN
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 =
Sometimes
"bluetooth toggle"
xpfBluetooth
[Subfeature (DBusRoot_ cmd tree cl) "bluetoothctl"] [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 $
fmtCmd myBluetooth ["show"]
#!| "grep -q \"Powered: no\"" #!| "grep -q \"Powered: no\""
#!&& "a=on" #!&& "a=on"
#!|| "a=off" #!|| "a=off"
#!>> fmtCmd myBluetooth ["power", "$a", ">", "/dev/null"] #!>> fmtCmd myBluetooth ["power", "$a", ">", "/dev/null"]
#!&& fmtNotifyCmd defNoteInfo { body = Just $ Text "bluetooth powered $a" } #!&& fmtNotifyCmd defNoteInfo {body = Just $ Text "bluetooth powered $a"}
runToggleEthernet :: SometimesX runToggleEthernet :: SometimesX
runToggleEthernet = Sometimes "ethernet toggle" xpfEthernet runToggleEthernet =
Sometimes
"ethernet toggle"
xpfEthernet
[Subfeature root "nmcli"] [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 $
fmtCmd "nmcli" ["-g", "GENERAL.STATE", "device", "show", iface]
#!| "grep -q disconnected" #!| "grep -q disconnected"
#!&& "a=connect" #!&& "a=connect"
#!|| "a=disconnect" #!|| "a=disconnect"
#!>> fmtCmd "nmcli" ["device", "$a", iface] #!>> fmtCmd "nmcli" ["device", "$a", iface]
#!&& fmtNotifyCmd defNoteInfo { body = Just $ Text "ethernet \"$a\"ed" } #!&& 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"
"feh"
(Only_ $ sysExe [Package Official "feh"] myImageBrowser)
$ do
dir <- io getCaptureDir dir <- io getCaptureDir
spawnCmd myImageBrowser [T.pack dir] spawnCmd myImageBrowser [T.pack dir]

View File

@ -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,23 +23,19 @@ module XMonad.Internal.Command.Power
, powerPrompt , powerPrompt
, defFontPkgs , defFontPkgs
, promptFontDep , promptFontDep
) where )
where
import Data.Internal.Dependency
import Data.Either import Data.Either
import Data.Internal.Dependency
import qualified Data.Map as M import qualified Data.Map as M
import Graphics.X11.Types import Graphics.X11.Types
import RIO import RIO
import RIO.FilePath import RIO.FilePath
import qualified RIO.Process as P import qualified RIO.Process as P
import qualified RIO.Text as T import qualified RIO.Text as T
import System.Directory import System.Directory
import System.IO.Error import System.IO.Error
import XMonad.Core hiding (spawn) import XMonad.Core hiding (spawn)
import XMonad.Internal.Shell import XMonad.Internal.Shell
import qualified XMonad.Internal.Theme as XT import qualified XMonad.Internal.Theme as XT
@ -49,8 +43,7 @@ import XMonad.Prompt
import XMonad.Prompt.ConfirmPrompt 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,26 +148,32 @@ 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.pack myPrimeOffload
#!&& T.unwords [T.pack myOptimusManager, "--switch", mode, "--no-confirm"] #!&& T.unwords [T.pack myOptimusManager, "--switch", mode, "--no-confirm"]
#!&& "killall xmonad" #!&& "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
= Poweroff
| Shutdown | Shutdown
| Hibernate | Hibernate
| Reboot | Reboot
@ -202,10 +208,12 @@ 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)
: map
(first $ (,) 0)
[ (xK_p, sendMaybeAction Poweroff) [ (xK_p, sendMaybeAction Poweroff)
, (xK_s, sendMaybeAction Shutdown) , (xK_s, sendMaybeAction Shutdown)
, (xK_h, sendMaybeAction Hibernate) , (xK_h, sendMaybeAction Hibernate)

View File

@ -2,21 +2,19 @@
{-# 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 RIO
import qualified RIO.ByteString as B import qualified RIO.ByteString as B
import XMonad.Core import XMonad.Core
import XMonad.Internal.Command.Power import XMonad.Internal.Command.Power
import XMonad.Internal.Concurrent.ClientMessage import XMonad.Internal.Concurrent.ClientMessage
@ -24,12 +22,13 @@ import XMonad.Internal.Shell
import XMonad.Internal.Theme (FontBuilder) 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
= Power
| Sleep | Sleep
| LidClose | LidClose
deriving (Eq) deriving (Eq)
@ -45,18 +44,18 @@ instance Enum ACPIEvent where
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
@ -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

View File

@ -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,29 +16,29 @@
-- 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
= ACPI
| Workspace | Workspace
| Unknown | Unknown
deriving (Eq, Show) deriving (Eq, Show)
@ -53,13 +53,13 @@ instance Enum XMsgType where
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

View File

@ -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,41 +24,35 @@
-- 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 Data.Maybe
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.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 System.Process
import XMonad.Actions.DynamicWorkspaces import XMonad.Actions.DynamicWorkspaces
import XMonad.Core import XMonad.Core
( ManageHook ( ManageHook
@ -75,8 +69,8 @@ import XMonad.Operations
import qualified XMonad.StackSet as W 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
@ -89,7 +83,7 @@ data DynWorkspace = DynWorkspace
} }
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | 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
@ -120,22 +114,23 @@ 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
@ -143,28 +138,32 @@ handleEvent MapNotifyEvent { ev_window = w } = do
-- 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
$ unless (pid `elem` pids)
$ bracket_
(modifyMVar_ ps (return . S.insert pid)) (modifyMVar_ ps (return . S.insert pid))
(modifyMVar_ ps (return . S.delete 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 =
elem tag $
map W.tag $
filter (isJust . W.stack)
-- list of all workspaces with windows on them -- list of all workspaces with windows on them
-- TODO is there not a better way to do this? -- TODO is there not a better way to do this?
$ W.workspace (W.current ws) : W.hidden ws ++ map W.workspace (W.visible ws) $
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)
@ -197,25 +196,27 @@ doSink = doF $ \s -> case W.stack $ W.workspace $ W.current s of
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

View File

@ -2,23 +2,21 @@
{-# 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 Text.XML.Light
import RIO hiding (try) import RIO hiding (try)
import RIO.Directory import RIO.Directory
import RIO.FilePath import RIO.FilePath
import qualified RIO.Text as T import qualified RIO.Text as T
import Text.XML.Light
import XMonad.Internal.Shell import XMonad.Internal.Shell
vmExists :: T.Text -> IO (Maybe Msg) vmExists :: T.Text -> IO (Maybe Msg)
@ -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 =
findAttr (unqual "defaultMachineFolder")
=<< findChild (qual e "SystemProperties") =<< findChild (qual e "SystemProperties")
=<< findChild (qual e "Global") e =<< 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"

View File

@ -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 DBus
import RIO.FilePath import RIO.FilePath
import XMonad.Internal.DBus.Brightness.Common import XMonad.Internal.DBus.Brightness.Common
import XMonad.Internal.IO 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,7 +90,8 @@ interface :: InterfaceName
interface = interfaceName_ "org.xmonad.Brightness" interface = interfaceName_ "org.xmonad.Brightness"
clevoKeyboardConfig :: BrightnessConfig RawBrightness Brightness clevoKeyboardConfig :: BrightnessConfig RawBrightness Brightness
clevoKeyboardConfig = BrightnessConfig clevoKeyboardConfig =
BrightnessConfig
{ bcMin = minBrightness { bcMin = minBrightness
, bcMax = maxBrightness , bcMax = maxBrightness
, bcInc = incBrightness , bcInc = incBrightness
@ -107,7 +105,7 @@ clevoKeyboardConfig = BrightnessConfig
} }
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | 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

View File

@ -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 Data.Int (Int32)
import Data.Internal.DBus
import Data.Internal.Dependency
import DBus import DBus
import DBus.Client import DBus.Client
import qualified DBus.Introspection as I import qualified DBus.Introspection as I
import Data.Int (Int32)
import Data.Internal.DBus
import Data.Internal.Dependency
import qualified RIO.Text as T import qualified RIO.Text as T
import XMonad.Core (io) import XMonad.Core (io)
import XMonad.Internal.DBus.Common 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
@ -56,7 +53,10 @@ 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
@ -68,34 +68,48 @@ brightnessControls q bc cl =
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 =
matchAny
{ matchPath = Just p { matchPath = Just p
, matchInterface = Just i , matchInterface = Just i
, matchMember = Just memCur , 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,7 +122,10 @@ 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
ses
(bcPath bc)
defaultInterface
{ interfaceName = bcInterface bc { interfaceName = bcInterface bc
, interfaceMethods = , interfaceMethods =
[ autoMethod' memMax bcMax [ autoMethod' memMax bcMax
@ -120,11 +137,11 @@ exportBrightnessControls' bc cl = io $ do
, interfaceSignals = [sig] , interfaceSignals = [sig]
} }
where where
sig = I.Signal sig =
I.Signal
{ I.signalName = memCur { I.signalName = memCur
, I.signalArgs = , I.signalArgs =
[ [ I.SignalArg
I.SignalArg
{ I.signalArgName = "brightness" { I.signalArgName = "brightness"
, I.signalArgType = TypeInt32 , I.signalArgType = TypeInt32
} }
@ -132,16 +149,28 @@ exportBrightnessControls' bc cl = io $ do
} }
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
-> BrightnessConfig a b
-> T.Text
-> MemberName
-> SometimesX
callBacklight
q
cl
BrightnessConfig
{ bcPath = p
, bcInterface = i , bcInterface = i
, bcName = n } controlName m = , bcName = n
}
controlName
m =
Sometimes (T.unwords [n, controlName]) q [Subfeature root "method call"] Sometimes (T.unwords [n, controlName]) q [Subfeature root "method call"]
where where
root = DBusRoot_ cmd (Only_ $ Endpoint [] xmonadBusName p i $ Method_ m) cl root = DBusRoot_ cmd (Only_ $ Endpoint [] xmonadBusName p i $ Method_ m) cl
@ -152,7 +181,7 @@ 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"

View File

@ -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 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 DBus
import RIO.FilePath import RIO.FilePath
import XMonad.Internal.DBus.Brightness.Common import XMonad.Internal.DBus.Brightness.Common
import XMonad.Internal.IO 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,7 +73,8 @@ interface :: InterfaceName
interface = interfaceName_ "org.xmonad.Brightness" interface = interfaceName_ "org.xmonad.Brightness"
intelBacklightConfig :: BrightnessConfig RawBrightness Brightness intelBacklightConfig :: BrightnessConfig RawBrightness Brightness
intelBacklightConfig = BrightnessConfig intelBacklightConfig =
BrightnessConfig
{ bcMin = minBrightness { bcMin = minBrightness
, bcMax = maxBrightness , bcMax = maxBrightness
, bcInc = incBrightness , bcInc = incBrightness
@ -89,7 +88,7 @@ intelBacklightConfig = BrightnessConfig
} }
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | 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

View File

@ -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,7 +7,8 @@ module XMonad.Internal.DBus.Common
, notifyBus , notifyBus
, notifyPath , notifyPath
, networkManagerBus , networkManagerBus
) where )
where
import DBus import DBus
@ -25,4 +26,3 @@ notifyPath = objectPath_ "/org/freedesktop/Notifications"
networkManagerBus :: BusName networkManagerBus :: BusName
networkManagerBus = busName_ "org.freedesktop.NetworkManager" networkManagerBus = busName_ "org.freedesktop.NetworkManager"

View File

@ -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,16 +15,14 @@ module XMonad.Internal.DBus.Control
, withDBusClient_ , withDBusClient_
, disconnect , disconnect
, dbusExporters , dbusExporters
) where )
where
import Control.Monad import Control.Monad
import Data.Internal.DBus
import Data.Internal.Dependency
import DBus import DBus
import DBus.Client import DBus.Client
import Data.Internal.DBus
import Data.Internal.Dependency
import XMonad.Internal.DBus.Brightness.ClevoKeyboard import XMonad.Internal.DBus.Brightness.ClevoKeyboard
import XMonad.Internal.DBus.Brightness.IntelBacklight import XMonad.Internal.DBus.Brightness.IntelBacklight
import XMonad.Internal.DBus.Common import XMonad.Internal.DBus.Common
@ -41,7 +39,7 @@ 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,10 +71,12 @@ 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 == NamePrimaryOwner = Nothing
| res == NameAlreadyOwner = Just $ "this process already owns " ++ xn | res == NameAlreadyOwner = Just $ "this process already owns " ++ xn
| res == NameInQueue | res == NameInQueue
|| res == NameExists = Just $ "another process owns " ++ xn || res == NameExists =
Just $ "another process owns " ++ xn
| otherwise = Just $ "unknown error when requesting " ++ xn | otherwise = Just $ "unknown error when requesting " ++ xn
forM_ msg putStrLn forM_ msg putStrLn
where where

View File

@ -1,7 +1,7 @@
{-# 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.
@ -9,14 +9,11 @@
module XMonad.Internal.DBus.Removable (runRemovableMon) where module XMonad.Internal.DBus.Removable (runRemovableMon) where
import Control.Monad import Control.Monad
import DBus
import DBus.Client
import Data.Internal.DBus import Data.Internal.DBus
import Data.Internal.Dependency import Data.Internal.Dependency
import Data.Map.Strict (Map, member) import Data.Map.Strict (Map, member)
import DBus
import DBus.Client
import XMonad.Core (io) import XMonad.Core (io)
import XMonad.Internal.Command.Desktop import XMonad.Internal.Command.Desktop
@ -51,7 +48,8 @@ driveRemovedSound :: FilePath
driveRemovedSound = "smb_pipe.wav" driveRemovedSound = "smb_pipe.wav"
ruleUdisks :: MatchRule ruleUdisks :: MatchRule
ruleUdisks = matchAny ruleUdisks =
matchAny
{ matchPath = Just path { matchPath = Just path
, matchInterface = Just interface , matchInterface = Just interface
} }
@ -60,12 +58,18 @@ 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] =
maybe
False
(member driveFlag)
(fromVariant a :: Maybe (Map String (Map String Variant))) (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] =
maybe
False
(driveFlag `elem`)
(fromVariant a :: Maybe [String]) (fromVariant a :: Maybe [String])
removedHasDrive _ = False removedHasDrive _ = False
@ -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 =

View File

@ -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 Data.Internal.Dependency
import RIO
import DBus import DBus
import DBus.Client import DBus.Client
import qualified DBus.Introspection as I import qualified DBus.Introspection as I
import Data.Internal.DBus
import Data.Internal.Dependency
import Graphics.X11.XScreenSaver import Graphics.X11.XScreenSaver
import Graphics.X11.Xlib.Display import Graphics.X11.Xlib.Display
import RIO
import XMonad.Internal.DBus.Common import XMonad.Internal.DBus.Common
import XMonad.Internal.Shell 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,28 +78,34 @@ sigCurrentState :: Signal
sigCurrentState = signal ssPath interface memState sigCurrentState = signal ssPath interface memState
ruleCurrentState :: MatchRule ruleCurrentState :: MatchRule
ruleCurrentState = matchAny ruleCurrentState =
matchAny
{ matchPath = Just ssPath { matchPath = Just ssPath
, matchInterface = Just interface , matchInterface = Just interface
, matchMember = Just memState , 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
in liftIO $
export
cl'
ssPath
defaultInterface
{ interfaceName = interface { interfaceName = interface
, interfaceMethods = , interfaceMethods =
[ autoMethod memToggle $ emitState cl' =<< toggle [ autoMethod memToggle $ emitState cl' =<< toggle
@ -110,11 +113,11 @@ exportScreensaver ses =
] ]
, interfaceSignals = [sig] , interfaceSignals = [sig]
} }
sig = I.Signal sig =
I.Signal
{ I.signalName = memState { I.signalName = memState
, I.signalArgs = , I.signalArgs =
[ [ I.SignalArg
I.SignalArg
{ I.signalArgName = "enabled" { I.signalArgName = "enabled"
, I.signalArgType = TypeBoolean , I.signalArgType = TypeBoolean
} }
@ -124,8 +127,15 @@ exportScreensaver ses =
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

View File

@ -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 =
round $
fromIntegral lower + perc / 100.0 * (fromIntegral upper - fromIntegral lower) 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)

View File

@ -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,38 +9,41 @@
-- 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
@ -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'

View File

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

View File

@ -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,13 +17,12 @@ module XMonad.Internal.Shell
, (#!||) , (#!||)
, (#!|) , (#!|)
, (#!>>) , (#!>>)
) where )
where
import RIO import RIO
import qualified RIO.Text as T 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

View File

@ -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
import Data.Colour.SRGB import Data.Colour.SRGB
import qualified RIO.Text as T 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,14 +92,16 @@ sRGB24showT :: (RealFrac a, Floating a) => Colour a -> T.Text
sRGB24showT = T.pack . sRGB24show sRGB24showT = T.pack . sRGB24show
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Fonts -- Fonts
data Slant = Roman data Slant
= Roman
| Italic | Italic
| Oblique | Oblique
deriving (Eq, Show) deriving (Eq, Show)
data Weight = Light data Weight
= Light
| Medium | Medium
| Demibold | Demibold
| Bold | Bold
@ -119,15 +120,21 @@ 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
(Just fam)
FontData
{ weight = w
, slant = l , slant = l
, size = s , size = s
, pixelsize = p , pixelsize = p
, antialias = a , antialias = a
} } =
= T.intercalate ":" $ ["xft", fam] ++ elems T.intercalate ":" $ ["xft", fam] ++ elems
where where
elems = [ T.concat [k, "=", v] | (k, Just v) <- [ ("weight", showLower w) elems =
[ T.concat [k, "=", v]
| (k, Just v) <-
[ ("weight", showLower w)
, ("slant", showLower l) , ("slant", showLower l)
, ("size", showLower s) , ("size", showLower s)
, ("pixelsize", showLower p) , ("pixelsize", showLower p)
@ -141,10 +148,11 @@ fallbackFont :: FontBuilder
fallbackFont = buildFont Nothing fallbackFont = buildFont Nothing
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Default font and data -- Default font and data
defFontData :: FontData defFontData :: FontData
defFontData = FontData defFontData =
FontData
{ size = Just 10 { size = Just 10
, antialias = Just True , antialias = Just True
, weight = Nothing , weight = Nothing
@ -162,37 +170,35 @@ 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.activeTextColor = T.unpack fgColor
, D.activeColor = T.unpack bgColor , D.activeColor = T.unpack bgColor
, D.activeBorderColor = T.unpack bgColor , D.activeBorderColor = T.unpack bgColor
, D.inactiveTextColor = T.unpack backdropTextColor , D.inactiveTextColor = T.unpack backdropTextColor
, D.inactiveColor = T.unpack backdropFgColor , D.inactiveColor = T.unpack backdropFgColor
, D.inactiveBorderColor = T.unpack backdropFgColor , D.inactiveBorderColor = T.unpack backdropFgColor
, D.urgentTextColor = T.unpack $ darken' 0.5 errorColor , D.urgentTextColor = T.unpack $ darken' 0.5 errorColor
, D.urgentColor = T.unpack errorColor , D.urgentColor = T.unpack errorColor
, D.urgentBorderColor = T.unpack errorColor , D.urgentBorderColor = T.unpack errorColor
, -- this is in a newer version
-- this is in a newer version
-- , D.activeBorderWidth = 0 -- , D.activeBorderWidth = 0
-- , D.inactiveBorderWidth = 0 -- , D.inactiveBorderWidth = 0
-- , D.urgentBorderWidth = 0 -- , D.urgentBorderWidth = 0
, D.decoHeight = 20 D.decoHeight = 20
, D.windowTitleAddons = [] , D.windowTitleAddons = []
, D.windowTitleIcons = [] , 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.font = T.unpack $ fb $ defFontData {size = Just 12}
, P.bgColor = T.unpack bgColor , P.bgColor = T.unpack bgColor
, P.fgColor = T.unpack fgColor , P.fgColor = T.unpack fgColor
, P.fgHLight = T.unpack selectedFgColor , P.fgHLight = T.unpack selectedFgColor

View File

@ -1,21 +1,22 @@
{-# 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 qualified RIO.Text as T
import Xmobar.Plugins.Common import Xmobar.Plugins.Common
startBacklight :: RealFrac a => ((Maybe a -> IO ()) -> SesClient -> IO ()) startBacklight
-> (SesClient -> IO (Maybe a)) -> T.Text -> Callback -> IO () :: RealFrac a
=> ((Maybe a -> IO ()) -> SesClient -> IO ())
-> (SesClient -> IO (Maybe a))
-> T.Text
-> 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

View File

@ -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,26 +33,23 @@
-- 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 DBus.Client
import Data.Internal.DBus import Data.Internal.DBus
import Data.Internal.Dependency import Data.Internal.Dependency
import Data.List import Data.List
import Data.List.Split import Data.List.Split
import qualified Data.Map as M import qualified Data.Map as M
import Data.Maybe import Data.Maybe
import DBus
import DBus.Client
import qualified RIO.Text as T import qualified RIO.Text as T
import XMonad.Internal.DBus.Common import XMonad.Internal.DBus.Common
import Xmobar import Xmobar
import Xmobar.Plugins.Common import Xmobar.Plugins.Common
@ -61,8 +58,9 @@ 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
@ -133,7 +131,8 @@ data BtState = BtState
type MutableBtState = MVar BtState type MutableBtState = MVar BtState
emptyState :: BtState emptyState :: BtState
emptyState = BtState emptyState =
BtState
{ btDevices = M.empty { btDevices = M.empty
, btPowered = Nothing , btPowered = Nothing
} }
@ -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
@ -159,7 +158,7 @@ adaptorHasDevice adaptor device = case splitPath device of
_ -> 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 $
BTDevice
{ btDevConnected = fromVariant =<< listToMaybe reply
, btDevSigHandler = sh , 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

View File

@ -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 Xmobar
import Xmobar.Plugins.BacklightCommon
import XMonad.Internal.DBus.Brightness.ClevoKeyboard import XMonad.Internal.DBus.Brightness.ClevoKeyboard
import Xmobar
import Xmobar.Plugins.BacklightCommon
newtype ClevoKeyboard = ClevoKeyboard T.Text deriving (Read, Show) newtype ClevoKeyboard = ClevoKeyboard T.Text deriving (Read, Show)

View File

@ -8,22 +8,18 @@ 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 Data.Internal.DBus
import DBus import DBus
import DBus.Client import DBus.Client
import Data.Internal.DBus
import qualified RIO.Text as T import qualified RIO.Text as T
import XMonad.Hooks.DynamicLog (xmobarColor) 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 :(
@ -35,9 +31,15 @@ data Colors = Colors
} }
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

View File

@ -1,26 +1,23 @@
{-# 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 DBus
import qualified RIO.Text as T import qualified RIO.Text as T
import XMonad.Internal.Command.Desktop import XMonad.Internal.Command.Desktop
import XMonad.Internal.DBus.Common import XMonad.Internal.DBus.Common
import Xmobar import Xmobar
@ -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 =
(methodCallBus networkManagerBus nmPath nmInterface getByIP)
{ methodCallBody = [toVariant iface] { 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

View File

@ -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 Xmobar
import Xmobar.Plugins.BacklightCommon
import XMonad.Internal.DBus.Brightness.IntelBacklight import XMonad.Internal.DBus.Brightness.IntelBacklight
import Xmobar
import Xmobar.Plugins.BacklightCommon
newtype IntelBacklight = IntelBacklight T.Text deriving (Read, Show) newtype IntelBacklight = IntelBacklight T.Text deriving (Read, Show)

View File

@ -1,21 +1,20 @@
{-# 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 Xmobar
import XMonad.Internal.DBus.Screensaver import XMonad.Internal.DBus.Screensaver
import Xmobar
import Xmobar.Plugins.Common 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)

View File

@ -1,31 +1,28 @@
{-# 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 DBus
import qualified RIO.Text as T import qualified RIO.Text as T
import XMonad.Internal.Command.Desktop import XMonad.Internal.Command.Desktop
import XMonad.Internal.DBus.Common import XMonad.Internal.DBus.Common
import Xmobar import Xmobar
@ -47,7 +44,7 @@ instance Exec VPN 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
@ -100,16 +99,21 @@ removedCallback state display [device, interfaces] = update >> display
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

View File

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