ndwarshuis
/
xmonad-config
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

ENH print out deps (but better this time)

This commit is contained in:
Nathan Dwarshuis 2022-06-16 18:50:24 -04:00
parent d767dc7bc0
commit 01e991f182
8 changed files with 143 additions and 106 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

68
bin/xmobar.hs
View File

@ -291,71 +291,47 @@ rightPlugins sysClient sesClient = mapM evalFeature
]
getWireless :: BarFeature
getWireless = Feature
{ ftrDepTree = GenTree (Double wirelessCmd $ readInterface isWireless) []
, ftrName = "wireless status indicator"
, ftrWarning = Default
}
getWireless = feature "wireless status indicator" Default
$ GenTree (Double wirelessCmd $ readInterface isWireless) []
getEthernet :: Maybe Client -> BarFeature
getEthernet client = Feature
{ ftrDepTree = DBusTree action client [devDep] []
, ftrName = "ethernet status indicator"
, ftrWarning = Default
}
getEthernet client = feature "ethernet status indicator" Default
$ DBusTree action client [devDep] []
where
action = Double (\i _ -> ethernetCmd i) (readInterface isEthernet)
getBattery :: BarFeature
getBattery = Feature
{ ftrDepTree = GenTree (Single batteryCmd) [IOTest hasBattery]
, ftrName = "battery level indicator"
, ftrWarning = Default
}
getBattery = feature "battery level indicator" Default
$ GenTree (Single batteryCmd) [IOTest desc hasBattery]
where
desc = "Test if battery is present"
getVPN :: Maybe Client -> BarFeature
getVPN client = Feature
{ ftrDepTree = DBusTree (Single (const vpnCmd)) client [vpnDep] [dp]
, ftrName = "VPN status indicator"
, ftrWarning = Default
}
getVPN client = feature "VPN status indicator" Default
$ DBusTree (Single (const vpnCmd)) client [vpnDep] [dp]
where
dp = IOTest vpnPresent
dp = IOTest desc vpnPresent
desc = "Use nmcli to test if VPN is present"
getBt :: Maybe Client -> BarFeature
getBt client = Feature
{ ftrDepTree = DBusTree (Single (const btCmd)) client [btDep] []
, ftrName = "bluetooth status indicator"
, ftrWarning = Default
}
getBt client = feature "bluetooth status indicator" Default
$ DBusTree (Single (const btCmd)) client [btDep] []
getAlsa :: BarFeature
getAlsa = Feature
{ ftrDepTree = GenTree (Single alsaCmd) [Executable "alsactl"]
, ftrName = "volume level indicator"
, ftrWarning = Default
}
getAlsa = feature "volume level indicator" Default
$ GenTree (Single alsaCmd) [Executable "alsactl"]
getBl :: Maybe Client -> BarFeature
getBl client = Feature
{ ftrDepTree = DBusTree (Single (const blCmd)) client [intelBacklightSignalDep] []
, ftrName = "Intel backlight indicator"
, ftrWarning = Default
}
getBl client = feature "Intel backlight indicator" Default
$ DBusTree (Single (const blCmd)) client [intelBacklightSignalDep] []
getCk :: Maybe Client -> BarFeature
getCk client = Feature
{ ftrDepTree = DBusTree (Single (const ckCmd)) client [clevoKeyboardSignalDep] []
, ftrName = "Clevo keyboard indicator"
, ftrWarning = Default
}
getCk client = feature "Clevo keyboard indicator" Default
$ DBusTree (Single (const ckCmd)) client [clevoKeyboardSignalDep] []
getSs :: Maybe Client -> BarFeature
getSs client = Feature
{ ftrDepTree = DBusTree (Single (const ssCmd)) client [ssSignalDep] []
, ftrName = "screensaver indicator"
, ftrWarning = Default
}
getSs client = feature "screensaver indicator" Default
$ DBusTree (Single (const ssCmd)) client [ssSignalDep] []
getAllCommands :: [MaybeAction CmdSpec] -> IO BarRegions
getAllCommands right = do

47
bin/xmonad.hs
View File

@ -86,7 +86,7 @@ parse _ = usage
run :: IO ()
run = do
db <- connectDBus
db <- connectXDBus
(h, p) <- spawnPipe "xmobar"
executeFeature_ $ runRemovableMon $ dbSystemClient db
executeFeatureWith_ forkIO_ runPowermon
@ -123,17 +123,31 @@ run = do
printDeps :: IO ()
printDeps = do
db <- connectDBus
lockRes <- evalFeature runScreenLock
let lock = whenSatisfied lockRes
mapM_ printDep $ concatMap flatten $ externalBindings ts db lock
(i, x) <- allFeatures
mapM_ printDep $ concatMap extractFeatures i ++ concatMap extractFeatures x
where
ts = ThreadState { tsChildPIDs = [], tsChildHandles = [] }
flatten = concatMap (dtDeps . ftrDepTree . kbMaybeAction) . kgBindings
extractFeatures (Feature f) = dtDeps $ ftrDepTree f
extractFeatures (ConstFeature _) = []
dtDeps (GenTree _ ds) = ds
dtDeps (DBusTree _ _ _ ds) = ds
printDep (Executable s) = putStrLn s
printDep _ = skip
printDep = putStrLn . depName
allFeatures :: IO ([FeatureIO], [FeatureX])
allFeatures = do
ses <- getDBusClient False
sys <- getDBusClient True
let db = DBusState ses sys
lockRes <- evalFeature runScreenLock
let lock = whenSatisfied lockRes
let bfs = concatMap (fmap kbMaybeAction . kgBindings)
$ externalBindings ts db lock
let dbus = fmap (\f -> f ses) dbusExporters
let others = [runRemovableMon sys, runPowermon]
forM_ ses disconnect
forM_ sys disconnect
return (dbus ++ others, bfs)
where
ts = ThreadState { tsChildPIDs = [], tsChildHandles = [] }
usage :: IO ()
usage = putStrLn $ intercalate "\n"
@ -141,13 +155,16 @@ usage = putStrLn $ intercalate "\n"
, "xmonad --deps: print dependencies"
]
connectDBus :: IO DBusState
connectDBus = do
sesClient <- startXMonadService
sysClient <- getDBusClient True
connectXDBus :: IO DBusState
connectXDBus = connectDBus_ startXMonadService
connectDBus_ :: IO (Maybe Client) -> IO DBusState
connectDBus_ getSes = do
ses <- getSes
sys <- getDBusClient True
return DBusState
{ dbSessionClient = sesClient
, dbSystemClient = sysClient
{ dbSessionClient = ses
, dbSystemClient = sys
}
--------------------------------------------------------------------------------

8
lib/XMonad/Internal/DBus/Brightness/Common.hs
View File

@ -87,11 +87,9 @@ matchSignal BrightnessConfig { bcPath = p, bcInterface = i } cb =
brightnessExporter :: RealFrac b => [Dependency] -> BrightnessConfig a b
-> Maybe Client -> FeatureIO
brightnessExporter deps bc@BrightnessConfig { bcName = n } client = Feature
{ ftrDepTree = DBusTree (Single (exportBrightnessControls' bc)) client [Bus xmonadBusName] deps
, ftrName = n ++ " exporter"
, ftrWarning = Default
}
brightnessExporter deps bc@BrightnessConfig { bcName = n } client = feature
(n ++ " exporter") Default
$ DBusTree (Single (exportBrightnessControls' bc)) client [Bus xmonadBusName] deps
exportBrightnessControls' :: RealFrac b => BrightnessConfig a b -> Client -> IO ()
exportBrightnessControls' bc client = do

8
lib/XMonad/Internal/DBus/Control.hs
View File

@ -11,6 +11,7 @@ module XMonad.Internal.DBus.Control
, withDBusClient_
, stopXMonadService
, disconnect
, dbusExporters
) where
import Control.Monad (forM_, void)
@ -29,10 +30,8 @@ startXMonadService :: IO (Maybe Client)
startXMonadService = do
client <- getDBusClient False
forM_ client requestXMonadName
mapM_ (\f -> executeFeature_ $ f client) exporters
mapM_ (\f -> executeFeature_ $ f client) dbusExporters
return client
where
exporters = [exportScreensaver, exportIntelBacklight, exportClevoKeyboard]
stopXMonadService :: Client -> IO ()
stopXMonadService client = do
@ -51,3 +50,6 @@ requestXMonadName client = do
forM_ msg putStrLn
where
xn = "'" ++ formatBusName xmonadBusName ++ "'"
dbusExporters :: [Maybe Client -> FeatureIO]
dbusExporters = [exportScreensaver, exportIntelBacklight, exportClevoKeyboard]

7
lib/XMonad/Internal/DBus/Removable.hs
View File

@ -82,8 +82,5 @@ listenDevices client = do
$ playSoundMaybe p . f . signalBody
runRemovableMon :: Maybe Client -> FeatureIO
runRemovableMon client = Feature
{ ftrDepTree = DBusTree (Single listenDevices) client [addedDep, removedDep] []
, ftrName = "removeable device monitor"
, ftrWarning = Default
}
runRemovableMon client = feature "removeable device monitor" Default
$ DBusTree (Single listenDevices) client [addedDep, removedDep] []

2
lib/XMonad/Internal/DBus/Screensaver.hs
View File

@ -95,7 +95,7 @@ bodyGetCurrentState _ = Nothing
-- | Exported haskell API
exportScreensaver :: Maybe Client -> FeatureIO
exportScreensaver client = Feature
exportScreensaver client = Feature $ Feature_
{ ftrDepTree = DBusTree (Single cmd) client [Bus xmonadBusName] [Executable ssExecutable]
, ftrName = "screensaver interface"
, ftrWarning = Default

100
lib/XMonad/Internal/Dependency.hs
View File

@ -1,5 +1,5 @@
{-# LANGUAGE GADTs #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE OverloadedStrings #-}
--------------------------------------------------------------------------------
-- | Functions for handling dependencies
@ -13,10 +13,12 @@ module XMonad.Internal.Dependency
, FeatureX
, FeatureIO
, Feature(..)
, Feature_(..)
, Warning(..)
, Dependency(..)
, UnitType(..)
, DBusMember(..)
, feature
, ioFeature
, evalFeature
, systemUnit
@ -34,13 +36,16 @@ module XMonad.Internal.Dependency
, executeFeature_
, executeFeatureWith
, executeFeatureWith_
, depName
) where
import Control.Monad.IO.Class
import Control.Monad.Identity
-- import Data.Aeson
import Data.List (find)
import Data.Maybe (catMaybes, fromMaybe, listToMaybe)
-- import qualified Data.Text as T
import DBus
import DBus.Client
@ -68,12 +73,24 @@ import XMonad.Internal.Shell
-- dependencies that target the output/state of another feature; this is more
-- robust anyways, at the cost of being a bit slower.
data Feature a = Feature
-- TODO some things to add to make this more feature-ful (lol)
-- - use AndOr types to encode alternative dependencies into the tree
-- - use an Alt data constructor for Features (which will mean "try A before B"
-- - add an Either String Bool to dependency nodes that encodes testing status
-- (where Right False means untested)
-- - add a lens/functor mapper thingy to walk down the tree and update testing
-- status fields
-- - print to JSON
-- - make sum type to hold all type instances of Feature blabla (eg IO and X)
-- - figure out how to make features a dependency of another feature
data Feature_ a = Feature_
{ ftrDepTree :: DepTree a
, ftrName :: String
, ftrWarning :: Warning
}
| ConstFeature a
data Feature a = Feature (Feature_ a) | ConstFeature a
-- TODO this is silly as is, and could be made more useful by representing
-- loglevels
@ -83,20 +100,19 @@ type FeatureX = Feature (X ())
type FeatureIO = Feature (IO ())
feature :: String -> Warning -> DepTree a -> Feature a
feature n w t = Feature $ Feature_
{ ftrDepTree = t
, ftrName = n
, ftrWarning = w
}
ioFeature :: MonadIO m => Feature (IO b) -> Feature (m b)
ioFeature (ConstFeature a) = ConstFeature $ liftIO a
ioFeature Feature {..} =
-- HACK just doing a normal record update here will make GHC complain about
-- an 'insufficiently polymorphic record update' ...I guess because my
-- GADT isn't polymorphic enough (which is obviously BS)
Feature {ftrDepTree = liftIO <$> ftrDepTree, ..}
ioFeature (Feature f) = Feature $ f {ftrDepTree = liftIO <$> ftrDepTree f}
featureDefault :: String -> [Dependency] -> a -> Feature a
featureDefault n ds x = Feature
{ ftrDepTree = GenTree (Single x) ds
, ftrName = n
, ftrWarning = Default
}
featureDefault n ds x = feature n Default $ GenTree (Single x) ds
featureExe :: MonadIO m => String -> String -> Feature (m ())
featureExe n cmd = featureExeArgs n cmd []
@ -105,13 +121,10 @@ featureExeArgs :: MonadIO m => String -> String -> [String] -> Feature (m ())
featureExeArgs n cmd args =
featureDefault n [Executable cmd] $ spawnCmd cmd args
featureEndpoint :: String -> BusName -> ObjectPath -> InterfaceName -> MemberName
-> Maybe Client -> FeatureIO
featureEndpoint name busname path iface mem client = Feature
{ ftrDepTree = DBusTree (Single cmd) client deps []
, ftrName = name
, ftrWarning = Default
}
featureEndpoint :: String -> BusName -> ObjectPath -> InterfaceName
-> MemberName -> Maybe Client -> FeatureIO
featureEndpoint name busname path iface mem client = feature name Default
$ DBusTree (Single cmd) client deps []
where
cmd c = void $ callMethod c busname path iface mem
deps = [Endpoint busname path iface $ Method_ mem]
@ -156,11 +169,7 @@ type MaybeX = MaybeAction (X ())
evalFeature :: Feature a -> IO (MaybeAction a)
evalFeature (ConstFeature x) = return $ Just x
evalFeature Feature
{ ftrDepTree = a
, ftrName = n
, ftrWarning = w
} = do
evalFeature (Feature (Feature_{ftrDepTree = a, ftrName = n, ftrWarning = w})) = do
procName <- getProgName
res <- evalTree a
either (printWarnings procName) (return . Just) res
@ -229,7 +238,7 @@ ifSatisfied _ alt = alt
data Dependency = Executable String
| AccessiblePath FilePath Bool Bool
| IOTest (IO (Maybe String))
| IOTest String (IO (Maybe String))
| Systemd UnitType String
data UnitType = SystemUnit | UserUnit deriving (Eq, Show)
@ -270,7 +279,7 @@ data DBusDep =
evalDependency :: Dependency -> IO (Maybe String)
evalDependency (Executable n) = exeSatisfied n
evalDependency (IOTest t) = t
evalDependency (IOTest _ t) = t
evalDependency (Systemd t n) = unitSatisfied t n
evalDependency (AccessiblePath p r w) = pathSatisfied p r w
@ -365,3 +374,40 @@ dbusDepSatisfied client (Endpoint busname objpath iface mem) = do
, formatBusName busname
]
--------------------------------------------------------------------------------
-- | Printing dependencies
-- instance ToJSON (DepTree a) where
-- toJSON (GenTree _) = undefined
-- instance ToJSON Dependency where
-- toJSON (Executable n) = depValue "executable" Nothing n
-- toJSON (IOTest d _) = depValue "internal" Nothing d
-- toJSON (Systemd t n) = depValue "systemd" (Just $ tp t) n
-- where
-- tp SystemUnit = "sys"
-- tp UserUnit = "user"
-- toJSON (AccessiblePath p r w) = depValue "path" perms p
-- where
-- perms = case (r, w) of
-- (True, True) -> Just "readwrite"
-- (True, False) -> Just "read"
-- (False, True) -> Just "write"
-- _ -> Nothing
-- depValue :: String -> Maybe String -> String -> Value
-- depValue t s n = object
-- [ "type" .= t
-- , "name" .= n
-- , "subtype" .= maybe Null (String . T.pack) s
-- ]
depName :: Dependency -> String
depName (Executable n) = "executable: " ++ n
depName (IOTest d _) = "internal: " ++ d
depName (Systemd t n) = "systemd (" ++ tp t ++ "): " ++ n
where
tp SystemUnit = "sys"
tp UserUnit = "user"
depName (AccessiblePath p _ _) = "path: " ++ p

7
my-xmonad.cabal
View File

@ -53,7 +53,8 @@ library
, xmonad-extras >= 0.15.2
, xmonad >= 0.13
, xmonad-contrib >= 0.13
ghc-options: -Wall -Werror -fno-warn-missing-signatures
, aeson >= 2.0.3.0
ghc-options: -Wall -Werror -Wpartial-fields -fno-warn-missing-signatures
default-language: Haskell2010
executable xmonad
@ -65,7 +66,7 @@ executable xmonad
, xmonad >= 0.13
, xmonad-contrib >= 0.13
default-language: Haskell2010
ghc-options: -Wall -Werror -fno-warn-missing-signatures -threaded
ghc-options: -Wall -Werror -Wpartial-fields -fno-warn-missing-signatures -threaded
executable xmobar
main-is: bin/xmobar.hs
@ -79,4 +80,4 @@ executable xmobar
, xmonad-contrib >= 0.13
, directory >= 1.3.3.0
default-language: Haskell2010
ghc-options: -Wall -Werror -fno-warn-missing-signatures -threaded
ghc-options: -Wall -Werror -Wpartial-fields -fno-warn-missing-signatures -threaded