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

ENH use new dependency framework throughout

This commit is contained in:
Nathan Dwarshuis 2022-06-22 01:28:46 -04:00
parent d8a88531b0
commit 5326b49ce2
13 changed files with 221 additions and 192 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

86
bin/xmobar.hs
View File

@ -239,7 +239,7 @@ dateCmd = CmdSpec
-- which case ethernet interfaces always start with "en" and wireless -- which case ethernet interfaces always start with "en" and wireless
-- interfaces always start with "wl" -- interfaces always start with "wl"
type BarFeature = Feature CmdSpec type BarFeature = Sometimes CmdSpec
isWireless :: String -> Bool isWireless :: String -> Bool
isWireless ('w':'l':_) = True isWireless ('w':'l':_) = True
@ -255,13 +255,14 @@ listInterfaces = fromRight [] <$> tryIOError (listDirectory sysfsNet)
sysfsNet :: FilePath sysfsNet :: FilePath
sysfsNet = "/sys/class/net" sysfsNet = "/sys/class/net"
readInterface :: (String -> Bool) -> IO (Either [String] String) readInterface :: (String -> Bool) -> IO (Either String String)
readInterface f = do readInterface f = do
ns <- filter f <$> listInterfaces ns <- filter f <$> listInterfaces
case ns of case ns of
[] -> return $ Left ["no interfaces found"] [] -> return $ Left "no interfaces found"
(x:xs) -> do (x:xs) -> do
unless (null xs) $ unless (null xs) $
-- TODO store this somehow intead of printing
putStrLn $ "WARNING: extra interfaces found, using " ++ x putStrLn $ "WARNING: extra interfaces found, using " ++ x
return $ Right x return $ Right x
@ -275,66 +276,71 @@ vpnPresent = do
where where
args = ["-c", "no", "-t", "-f", "TYPE", "c", "show"] args = ["-c", "no", "-t", "-f", "TYPE", "c", "show"]
rightPlugins :: Maybe Client -> Maybe Client -> IO [MaybeAction CmdSpec] rightPlugins :: Maybe Client -> Maybe Client -> IO [Maybe CmdSpec]
rightPlugins sysClient sesClient = mapM evalFeature rightPlugins sysClient sesClient = mapM evalFeature
[ getWireless [ Left getWireless
, getEthernet sysClient , Left $ getEthernet sysClient
, getVPN sysClient , Left $ getVPN sysClient
, getBt sysClient , Left $ getBt sysClient
, getAlsa , Left getAlsa
, getBattery , Left getBattery
, getBl sesClient , Left $ getBl sesClient
, getCk sesClient , Left $ getCk sesClient
, getSs sesClient , Left $ getSs sesClient
, ConstFeature lockCmd , Right $ Always lockCmd
, ConstFeature dateCmd , Right $ Always dateCmd
] ]
getWireless :: BarFeature getWireless :: BarFeature
getWireless = feature "wireless status indicator" Default getWireless = sometimes1 "wireless status indicator"
-- TODO this is stupid $ IOTree (Consumer wirelessCmd)
$ GenTree (Double wirelessCmd $ readInterface isWireless) (Only $ exe "ls") $ Only $ IORead "get wifi interface" $ fmap Just <$> readInterface isWireless
getEthernet :: Maybe Client -> BarFeature getEthernet :: Maybe Client -> BarFeature
getEthernet client = feature "ethernet status indicator" Default getEthernet client = sometimes1 "ethernet status indicator" $
$ DBusTree action client (Only $ fullDep devDep) DBusTree (Consumer act) client deps
where where
action = Double (\i _ -> ethernetCmd i) (readInterface isEthernet) act i = const $ ethernetCmd i
deps = And (\_ s -> s) (Only devDep) (Only readEth)
readEth = DBusIO $ IORead "read ethernet interface"
$ fmap Just <$> readInterface isEthernet
getBattery :: BarFeature getBattery :: BarFeature
getBattery = feature "battery level indicator" Default getBattery = sometimesIO "battery level indicator"
$ GenTree (Single batteryCmd) (Only $ fullDep $ IOTest desc hasBattery) (Only $ IOTest "Test if battery is present" hasBattery)
where batteryCmd
desc = "Test if battery is present"
getVPN :: Maybe Client -> BarFeature getVPN :: Maybe Client -> BarFeature
getVPN client = feature "VPN status indicator" Default getVPN client = sometimesDBus client "VPN status indicator"
$ DBusTree (Single (const vpnCmd)) client $ And (Only $ fullDep vpnDep) (Only dp) (toAnd vpnDep test) (const vpnCmd)
where where
dp = fullDep $ DBusGenDep $ IOTest desc vpnPresent test = DBusIO $ IOTest "Use nmcli to test if VPN is present" vpnPresent
desc = "Use nmcli to test if VPN is present"
getBt :: Maybe Client -> BarFeature getBt :: Maybe Client -> BarFeature
getBt client = feature "bluetooth status indicator" Default getBt client = sometimesDBus client "bluetooth status indicator"
$ DBusTree (Single (const btCmd)) client (Only $ fullDep btDep) (Only btDep)
(const btCmd)
getAlsa :: BarFeature getAlsa :: BarFeature
getAlsa = feature "volume level indicator" Default getAlsa = sometimesIO "volume level indicator"
$ GenTree (Single alsaCmd) (Only $ exe "alsactl") (Only $ Executable True "alsact")
alsaCmd
getBl :: Maybe Client -> BarFeature getBl :: Maybe Client -> BarFeature
getBl client = feature "Intel backlight indicator" Default getBl client = sometimesDBus client "Intel backlight indicator"
$ DBusTree (Single (const blCmd)) client (Only $ fullDep intelBacklightSignalDep) (Only intelBacklightSignalDep)
(const blCmd)
getCk :: Maybe Client -> BarFeature getCk :: Maybe Client -> BarFeature
getCk client = feature "Clevo keyboard indicator" Default getCk client = sometimesDBus client "Clevo keyboard indicator"
$ DBusTree (Single (const ckCmd)) client (Only $ fullDep clevoKeyboardSignalDep) (Only clevoKeyboardSignalDep)
(const ckCmd)
getSs :: Maybe Client -> BarFeature getSs :: Maybe Client -> BarFeature
getSs client = feature "screensaver indicator" Default getSs client = sometimesDBus client "screensaver indicator"
$ DBusTree (Single (const ssCmd)) client (Only $ fullDep ssSignalDep) (Only ssSignalDep) $ const ssCmd
getAllCommands :: [MaybeAction CmdSpec] -> IO BarRegions getAllCommands :: [Maybe CmdSpec] -> IO BarRegions
getAllCommands right = do getAllCommands right = do
let left = let left =
[ CmdSpec [ CmdSpec

118
bin/xmonad.hs
View File

@ -20,9 +20,6 @@ import Data.List
, sortOn , sortOn
) )
import Data.Maybe import Data.Maybe
( isJust
, mapMaybe
)
import Data.Monoid (All (..)) import Data.Monoid (All (..))
import Graphics.X11.Types import Graphics.X11.Types
@ -88,15 +85,15 @@ run :: IO ()
run = do run = do
db <- connectXDBus db <- connectXDBus
(h, p) <- spawnPipe "xmobar" (h, p) <- spawnPipe "xmobar"
executeFeature_ $ runRemovableMon $ dbSystemClient db void $ executeSometimes $ runRemovableMon $ dbSystemClient db
executeFeatureWith_ forkIO_ runPowermon forkIO_ $ void $ executeSometimes runPowermon
forkIO_ $ runWorkspaceMon allDWs forkIO_ $ runWorkspaceMon allDWs
let ts = ThreadState let ts = ThreadState
{ tsChildPIDs = [p] { tsChildPIDs = [p]
, tsChildHandles = [h] , tsChildHandles = [h]
} }
lockRes <- evalFeature runScreenLock lockRes <- evalSometimes runScreenLock
let lock = whenSatisfied lockRes let lock = fromMaybe skip lockRes
ext <- evalExternal $ externalBindings ts db lock ext <- evalExternal $ externalBindings ts db lock
-- IDK why this is necessary; nothing prior to this line will print if missing -- IDK why this is necessary; nothing prior to this line will print if missing
hFlush stdout hFlush stdout
@ -127,7 +124,7 @@ printDeps = skip
-- mapM_ printDep $ concatMap extractFeatures i ++ concatMap extractFeatures x -- mapM_ printDep $ concatMap extractFeatures i ++ concatMap extractFeatures x
-- where -- where
-- extractFeatures (Feature f _) = dtDeps $ ftrDepTree f -- extractFeatures (Feature f _) = dtDeps $ ftrDepTree f
-- extractFeatures (ConstFeature _) = [] -- extractFeatures (Always _) = []
-- dtDeps (GenTree _ ds) = ds -- dtDeps (GenTree _ ds) = ds
-- dtDeps (DBusTree _ _ ds) = ds -- dtDeps (DBusTree _ _ ds) = ds
-- printDep (FullDep d) = putStrLn . depName d -- printDep (FullDep d) = putStrLn . depName d
@ -540,13 +537,13 @@ data KeyGroup a = KeyGroup
, kgBindings :: [KeyBinding a] , kgBindings :: [KeyBinding a]
} }
evalExternal :: [KeyGroup FeatureX] -> IO [KeyGroup MaybeX] evalExternal :: [KeyGroup (FeatureX)] -> IO [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 -> IO (KeyBinding MaybeX) evalKeyBinding :: KeyBinding (FeatureX) -> IO (KeyBinding MaybeX)
evalKeyBinding k@KeyBinding { kbMaybeAction = a } = evalKeyBinding k@KeyBinding { kbMaybeAction = a } =
(\f -> k { kbMaybeAction = f }) <$> evalFeature a (\f -> k { kbMaybeAction = f }) <$> evalFeature a
@ -560,51 +557,51 @@ flagKeyBinding k@KeyBinding{ kbDesc = d, kbMaybeAction = a } = case a of
(Just x) -> Just $ k{ kbMaybeAction = x } (Just x) -> Just $ k{ kbMaybeAction = x }
Nothing -> Just $ k{ kbDesc = "[!!!]" ++ d, kbMaybeAction = skip } Nothing -> Just $ k{ kbDesc = "[!!!]" ++ d, kbMaybeAction = skip }
externalBindings :: ThreadState -> DBusState -> X () -> [KeyGroup FeatureX] externalBindings :: ThreadState -> DBusState -> X () -> [KeyGroup (FeatureX)]
externalBindings ts db lock = externalBindings ts db lock =
[ KeyGroup "Launchers" [ KeyGroup "Launchers"
[ KeyBinding "<XF86Search>" "select/launch app" runAppMenu [ KeyBinding "<XF86Search>" "select/launch app" $ Left runAppMenu
, KeyBinding "M-g" "launch clipboard manager" runClipMenu , KeyBinding "M-g" "launch clipboard manager" $ Left runClipMenu
, KeyBinding "M-a" "launch network selector" runNetMenu , KeyBinding "M-a" "launch network selector" $ Left runNetMenu
, KeyBinding "M-w" "launch window selector" runWinMenu , KeyBinding "M-w" "launch window selector" $ Left runWinMenu
, KeyBinding "M-u" "launch device selector" runDevMenu , KeyBinding "M-u" "launch device selector" $ Left runDevMenu
, KeyBinding "M-b" "launch bitwarden selector" runBwMenu , KeyBinding "M-b" "launch bitwarden selector" $ Left runBwMenu
, KeyBinding "M-v" "launch ExpressVPN selector" runVPNMenu , KeyBinding "M-v" "launch ExpressVPN selector" $ Left runVPNMenu
, KeyBinding "M-e" "launch bluetooth selector" runBTMenu , KeyBinding "M-e" "launch bluetooth selector" $ Left runBTMenu
, KeyBinding "M-C-e" "launch editor" runEditor , KeyBinding "M-C-e" "launch editor" $ Left runEditor
, KeyBinding "M-C-w" "launch browser" runBrowser , KeyBinding "M-C-w" "launch browser" $ Left runBrowser
, KeyBinding "M-C-t" "launch terminal with tmux" runTMux , KeyBinding "M-C-t" "launch terminal with tmux" $ Left runTMux
, KeyBinding "M-C-S-t" "launch terminal" runTerm , KeyBinding "M-C-S-t" "launch terminal" $ Left runTerm
, KeyBinding "M-C-q" "launch calc" runCalc , KeyBinding "M-C-q" "launch calc" $ Left runCalc
, KeyBinding "M-C-f" "launch file manager" runFileManager , KeyBinding "M-C-f" "launch file manager" $ Left runFileManager
] ]
, KeyGroup "Actions" , KeyGroup "Actions"
[ KeyBinding "M-q" "close window" $ ConstFeature kill1 [ KeyBinding "M-q" "close window" $ ftrAlways kill1
, KeyBinding "M-r" "run program" runCmdMenu , KeyBinding "M-r" "run program" $ Left runCmdMenu
, KeyBinding "M-<Space>" "warp pointer" $ ConstFeature $ warpToWindow 0.5 0.5 , KeyBinding "M-<Space>" "warp pointer" $ ftrAlways $ warpToWindow 0.5 0.5
, KeyBinding "M-C-s" "capture area" runAreaCapture , KeyBinding "M-C-s" "capture area" $ Left runAreaCapture
, KeyBinding "M-C-S-s" "capture screen" runScreenCapture , KeyBinding "M-C-S-s" "capture screen" $ Left runScreenCapture
, KeyBinding "M-C-d" "capture desktop" runDesktopCapture , KeyBinding "M-C-d" "capture desktop" $ Left runDesktopCapture
, KeyBinding "M-C-b" "browse captures" 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 "Multimedia" , KeyGroup "Multimedia"
[ KeyBinding "<XF86AudioPlay>" "toggle play/pause" runTogglePlay [ KeyBinding "<XF86AudioPlay>" "toggle play/pause" $ Left runTogglePlay
, KeyBinding "<XF86AudioPrev>" "previous track" runPrevTrack , KeyBinding "<XF86AudioPrev>" "previous track" $ Left runPrevTrack
, KeyBinding "<XF86AudioNext>" "next track" runNextTrack , KeyBinding "<XF86AudioNext>" "next track" $ Left runNextTrack
, KeyBinding "<XF86AudioStop>" "stop" runStopPlay , KeyBinding "<XF86AudioStop>" "stop" $ Left runStopPlay
, KeyBinding "<XF86AudioLowerVolume>" "volume down" runVolumeDown , KeyBinding "<XF86AudioLowerVolume>" "volume down" $ Left runVolumeDown
, KeyBinding "<XF86AudioRaiseVolume>" "volume up" runVolumeUp , KeyBinding "<XF86AudioRaiseVolume>" "volume up" $ Left runVolumeUp
, KeyBinding "<XF86AudioMute>" "volume mute" runVolumeMute , KeyBinding "<XF86AudioMute>" "volume mute" $ Left runVolumeMute
] ]
, KeyGroup "Dunst" , KeyGroup "Dunst"
[ KeyBinding "M-`" "dunst history" runNotificationHistory [ KeyBinding "M-`" "dunst history" $ Left runNotificationHistory
, KeyBinding "M-S-`" "dunst close" runNotificationClose , KeyBinding "M-S-`" "dunst close" $ Left runNotificationClose
, KeyBinding "M-M1-`" "dunst context menu" runNotificationContext , KeyBinding "M-M1-`" "dunst context menu" $ Left runNotificationContext
, KeyBinding "M-C-`" "dunst close all" runNotificationCloseAll , KeyBinding "M-C-`" "dunst close all" $ Left runNotificationCloseAll
] ]
, KeyGroup "System" , KeyGroup "System"
@ -616,23 +613,28 @@ externalBindings ts db lock =
, KeyBinding "M-S-," "keyboard down" $ ck bctlDec , KeyBinding "M-S-," "keyboard down" $ ck bctlDec
, KeyBinding "M-S-M1-," "keyboard min" $ ck bctlMin , KeyBinding "M-S-M1-," "keyboard min" $ ck bctlMin
, KeyBinding "M-S-M1-." "keyboard max" $ ck bctlMax , KeyBinding "M-S-M1-." "keyboard max" $ ck bctlMax
, KeyBinding "M-<End>" "power menu" $ ConstFeature $ runPowerPrompt lock , KeyBinding "M-<End>" "power menu" $ ftrAlways $ runPowerPrompt lock
, KeyBinding "M-<Home>" "quit xmonad" $ ConstFeature runQuitPrompt , KeyBinding "M-<Home>" "quit xmonad" $ ftrAlways runQuitPrompt
, KeyBinding "M-<Delete>" "lock screen" 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" $ ConstFeature (runCleanup ts db >> runRestart) , KeyBinding "M-<F2>" "restart xmonad" $ ftrAlways (runCleanup ts db >> runRestart)
, KeyBinding "M-<F3>" "recompile xmonad" $ ConstFeature runRecompile , KeyBinding "M-<F3>" "recompile xmonad" $ ftrAlways runRecompile
, KeyBinding "M-<F7>" "start Isync Service" runStartISyncService , KeyBinding "M-<F7>" "start Isync Service" $ Left runStartISyncService
, KeyBinding "M-C-<F7>" "start Isync Timer" runStartISyncTimer , KeyBinding "M-C-<F7>" "start Isync Timer" $ Left runStartISyncTimer
, KeyBinding "M-<F8>" "select autorandr profile" runAutorandrMenu , KeyBinding "M-<F8>" "select autorandr profile" $ Left runAutorandrMenu
, KeyBinding "M-<F9>" "toggle ethernet" runToggleEthernet , KeyBinding "M-<F9>" "toggle ethernet" $ Left runToggleEthernet
, KeyBinding "M-<F10>" "toggle bluetooth" runToggleBluetooth , KeyBinding "M-<F10>" "toggle bluetooth" $ Left runToggleBluetooth
, KeyBinding "M-<F11>" "toggle screensaver" $ ioFeature $ callToggle cl , KeyBinding "M-<F11>" "toggle screensaver" $ Left $ ioSometimes $ callToggle cl
, KeyBinding "M-<F12>" "switch gpu" runOptimusPrompt , KeyBinding "M-<F12>" "switch gpu" $ Left runOptimusPrompt
] ]
] ]
where where
cl = dbSessionClient db cl = dbSessionClient db
brightessControls ctl getter = (ioFeature . getter . ctl) cl brightessControls ctl getter = (ioSometimes . getter . ctl) cl
ib = brightessControls intelBacklightControls ib = Left . brightessControls intelBacklightControls
ck = brightessControls clevoKeyboardControls ck = Left . brightessControls clevoKeyboardControls
ftrAlways = Right . Always
type MaybeX = Maybe (X ())
type FeatureX = Feature (X ())

46
lib/XMonad/Internal/Command/DMenu.hs
View File

@ -15,17 +15,17 @@ module XMonad.Internal.Command.DMenu
, runAutorandrMenu , runAutorandrMenu
) where ) where
import Control.Monad.Reader -- import Control.Monad.Reader
import Graphics.X11.Types import Graphics.X11.Types
import System.Directory (XdgDirectory (..), getXdgDirectory) import System.Directory (XdgDirectory (..), getXdgDirectory)
import System.IO -- import System.IO
import XMonad.Core hiding (spawn) import XMonad.Core hiding (spawn)
import XMonad.Internal.Dependency import XMonad.Internal.Dependency
import XMonad.Internal.Notify -- import XMonad.Internal.Notify
import XMonad.Internal.Process -- import XMonad.Internal.Process
import XMonad.Internal.Shell import XMonad.Internal.Shell
import XMonad.Util.NamedActions import XMonad.Util.NamedActions
@ -103,27 +103,27 @@ runShowKeys :: [((KeyMask, KeySym), NamedAction)] -> NamedAction
runShowKeys _ = NamedAction (skip :: (X ())) runShowKeys _ = NamedAction (skip :: (X ()))
-- addName "Show Keybindings" $ evalAlways $ runDMenuShowKeys x -- addName "Show Keybindings" $ evalAlways $ runDMenuShowKeys x
runDMenuShowKeys :: [((KeyMask, KeySym), NamedAction)] -> AlwaysX -- runDMenuShowKeys :: [((KeyMask, KeySym), NamedAction)] -> AlwaysX
runDMenuShowKeys kbs = -- runDMenuShowKeys kbs =
Option (runDMenuShowKeys' kbs) (Always runNotifyShowKeys) -- Option (runDMenuShowKeys' kbs) (Always runNotifyShowKeys)
runNotifyShowKeys :: X () -- runNotifyShowKeys :: X ()
runNotifyShowKeys = spawnNotify -- runNotifyShowKeys = spawnNotify
$ defNoteError { body = Just $ Text "could not display keymap" } -- $ defNoteError { body = Just $ Text "could not display keymap" }
runDMenuShowKeys' :: [((KeyMask, KeySym), NamedAction)] -> Subfeature (X ()) Tree -- runDMenuShowKeys' :: [((KeyMask, KeySym), NamedAction)] -> Subfeature (X ()) Tree
runDMenuShowKeys' kbs = Subfeature -- runDMenuShowKeys' kbs = Subfeature
{ sfName = "keyboard shortcut menu" -- { sfName = "keyboard shortcut menu"
, sfTree = IOTree (Standalone act) deps -- , sfTree = IOTree (Standalone act) deps
, sfLevel = Warn -- , sfLevel = Warn
} -- }
where -- where
deps = Only $ Executable True myDmenuCmd -- deps = Only $ Executable True myDmenuCmd
act = io $ do -- act = io $ do
(h, _, _, _) <- createProcess' $ (shell' cmd) { std_in = CreatePipe } -- (h, _, _, _) <- createProcess' $ (shell' cmd) { std_in = CreatePipe }
forM_ h $ \h' -> hPutStr h' (unlines $ showKm kbs) >> hClose h' -- forM_ h $ \h' -> hPutStr h' (unlines $ showKm kbs) >> hClose h'
cmd = fmtCmd myDmenuCmd $ ["-dmenu", "-p", "commands"] -- cmd = fmtCmd myDmenuCmd $ ["-dmenu", "-p", "commands"]
++ themeArgs "#7f66ff" ++ myDmenuMatchingArgs -- ++ themeArgs "#7f66ff" ++ myDmenuMatchingArgs
runCmdMenu :: SometimesX runCmdMenu :: SometimesX
runCmdMenu = spawnDmenuCmd "command menu" ["-show", "run"] runCmdMenu = spawnDmenuCmd "command menu" ["-show", "run"]

6
lib/XMonad/Internal/DBus/Brightness/ClevoKeyboard.hs
View File

@ -107,13 +107,13 @@ clevoKeyboardConfig = BrightnessConfig
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Exported haskell API -- | Exported haskell API
stateFileDep :: IODependency a p stateFileDep :: IODependency p
stateFileDep = pathRW stateFile stateFileDep = pathRW stateFile
brightnessFileDep :: IODependency a p brightnessFileDep :: IODependency p
brightnessFileDep = pathR brightnessFile brightnessFileDep = pathR brightnessFile
clevoKeyboardSignalDep :: DBusDependency RawBrightness p clevoKeyboardSignalDep :: DBusDependency RawBrightness
clevoKeyboardSignalDep = signalDep clevoKeyboardConfig clevoKeyboardSignalDep = signalDep clevoKeyboardConfig
exportClevoKeyboard :: Maybe Client -> SometimesIO exportClevoKeyboard :: Maybe Client -> SometimesIO

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

@ -67,7 +67,7 @@ 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 a p signalDep :: BrightnessConfig a b -> DBusDependency m
signalDep BrightnessConfig { bcPath = p, bcInterface = i } = signalDep BrightnessConfig { bcPath = p, bcInterface = i } =
Endpoint xmonadBusName p i $ Signal_ memCur Endpoint xmonadBusName p i $ Signal_ memCur
@ -85,7 +85,7 @@ matchSignal BrightnessConfig { bcPath = p, bcInterface = i } cb =
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Internal DBus Crap -- | Internal DBus Crap
brightnessExporter :: RealFrac b => [IODependency (IO ()) (Maybe x)] brightnessExporter :: RealFrac b => [IODependency (Maybe x)]
-> BrightnessConfig a b -> Maybe Client -> SometimesIO -> BrightnessConfig a b -> Maybe Client -> SometimesIO
brightnessExporter deps bc@BrightnessConfig { bcName = n } client = brightnessExporter deps bc@BrightnessConfig { bcName = n } client =
sometimesDBus client (n ++ " exporter") ds (exportBrightnessControls' bc) sometimesDBus client (n ++ " exporter") ds (exportBrightnessControls' bc)

6
lib/XMonad/Internal/DBus/Brightness/IntelBacklight.hs
View File

@ -89,13 +89,13 @@ intelBacklightConfig = BrightnessConfig
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Exported haskell API -- | Exported haskell API
curFileDep :: IODependency a p curFileDep :: IODependency p
curFileDep = pathRW curFile curFileDep = pathRW curFile
maxFileDep :: IODependency a p maxFileDep :: IODependency p
maxFileDep = pathR maxFile maxFileDep = pathR maxFile
intelBacklightSignalDep :: DBusDependency RawBrightness p intelBacklightSignalDep :: DBusDependency RawBrightness
intelBacklightSignalDep = signalDep intelBacklightConfig intelBacklightSignalDep = signalDep intelBacklightConfig
exportIntelBacklight :: Maybe Client -> SometimesIO exportIntelBacklight :: Maybe Client -> SometimesIO

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

@ -30,7 +30,7 @@ startXMonadService :: IO (Maybe Client)
startXMonadService = do startXMonadService = do
client <- getDBusClient False client <- getDBusClient False
forM_ client requestXMonadName forM_ client requestXMonadName
mapM_ (\f -> executeSometimes_ $ f client) dbusExporters mapM_ (\f -> executeSometimes $ f client) dbusExporters
return client return client
stopXMonadService :: Client -> IO () stopXMonadService :: Client -> IO ()

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

@ -32,13 +32,13 @@ memAdded = memberName_ "InterfacesAdded"
memRemoved :: MemberName memRemoved :: MemberName
memRemoved = memberName_ "InterfacesRemoved" memRemoved = memberName_ "InterfacesRemoved"
dbusDep :: MemberName -> DBusDependency a p dbusDep :: MemberName -> DBusDependency p
dbusDep m = Endpoint bus path interface $ Signal_ m dbusDep m = Endpoint bus path interface $ Signal_ m
addedDep :: DBusDependency a p addedDep :: DBusDependency p
addedDep = dbusDep memAdded addedDep = dbusDep memAdded
removedDep :: DBusDependency a p removedDep :: DBusDependency p
removedDep = dbusDep memRemoved removedDep = dbusDep memRemoved
driveInsertedSound :: FilePath driveInsertedSound :: FilePath

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

@ -132,5 +132,5 @@ matchSignal :: (Maybe SSState -> IO ()) -> Client -> IO ()
matchSignal cb = matchSignal cb =
fmap void . addMatchCallback ruleCurrentState $ cb . bodyGetCurrentState fmap void . addMatchCallback ruleCurrentState $ cb . bodyGetCurrentState
ssSignalDep :: DBusDependency a p ssSignalDep :: DBusDependency p
ssSignalDep = Endpoint xmonadBusName ssPath interface $ Signal_ memState ssSignalDep = Endpoint xmonadBusName ssPath interface $ Signal_ memState

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

@ -7,13 +7,16 @@
module XMonad.Internal.Dependency module XMonad.Internal.Dependency
( AlwaysX ( AlwaysX
, AlwaysIO , AlwaysIO
, Feature
, Always(..) , Always(..)
, TestedSometimes(..)
, SometimesX , SometimesX
, SometimesIO , SometimesIO
, Sometimes , Sometimes
, executeSometimes_ , ioSometimes
, ioAlways
, evalFeature
, executeSometimes , executeSometimes
, executeAlways_
, executeAlways , executeAlways
, evalAlways , evalAlways
, evalSometimes , evalSometimes
@ -50,7 +53,7 @@ import Control.Monad.Identity
-- import Data.Aeson -- import Data.Aeson
import Data.Bifunctor import Data.Bifunctor
import Data.Either -- import Data.Either
import Data.List (find) import Data.List (find)
import Data.Maybe import Data.Maybe
-- import qualified Data.Text as T -- import qualified Data.Text as T
@ -61,7 +64,7 @@ import DBus.Internal
import qualified DBus.Introspection as I import qualified DBus.Introspection as I
import System.Directory (findExecutable, readable, writable) import System.Directory (findExecutable, readable, writable)
import System.Environment -- import System.Environment
import System.Exit import System.Exit
import XMonad.Core (X, io) import XMonad.Core (X, io)
@ -82,10 +85,19 @@ type SometimesX = Sometimes (X ())
type SometimesIO = Sometimes (IO ()) type SometimesIO = Sometimes (IO ())
type Feature a = Either (Sometimes a) (Always a)
data Always a = Option (Subfeature a Tree) (Always a) | Always a data Always a = Option (Subfeature a Tree) (Always a) | Always a
type Sometimes a = [Subfeature a Tree] type Sometimes a = [Subfeature a Tree]
ioSometimes :: MonadIO m => Sometimes (IO a) -> Sometimes (m a)
ioSometimes = fmap ioSubfeature
ioAlways :: MonadIO m => Always (IO a) -> Always (m a)
ioAlways (Always x) = Always $ io x
ioAlways (Option sf a) = Option (ioSubfeature sf) $ ioAlways a
data TestedAlways a p = data TestedAlways a p =
Primary (Finished a p) [FailedFeature a p] (Always a) Primary (Finished a p) [FailedFeature a p] (Always a)
| Fallback a [FailedFeature a p] | Fallback a [FailedFeature a p]
@ -115,17 +127,17 @@ type ActionTreeMaybe a p = Either (ActionTree a Tree, String)
sometimes1_ :: LogLevel -> String -> ActionTree a Tree -> Sometimes a sometimes1_ :: LogLevel -> String -> ActionTree a Tree -> Sometimes a
sometimes1_ l n t = [Subfeature{ sfTree = t, sfName = n, sfLevel = l }] sometimes1_ l n t = [Subfeature{ sfTree = t, sfName = n, sfLevel = l }]
always1_ :: LogLevel -> String -> ActionTree a Tree -> a -> Always a -- always1_ :: LogLevel -> String -> ActionTree a Tree -> a -> Always a
always1_ l n t x = -- always1_ l n t x =
Option (Subfeature{ sfTree = t, sfName = n, sfLevel = l }) (Always x) -- Option (Subfeature{ sfTree = t, sfName = n, sfLevel = l }) (Always x)
sometimes1 :: String -> ActionTree a Tree -> Sometimes a sometimes1 :: String -> ActionTree a Tree -> Sometimes a
sometimes1 = sometimes1_ Error sometimes1 = sometimes1_ Error
sometimesIO :: String -> Tree (IODependency a p) p -> a -> Sometimes a sometimesIO :: String -> Tree (IODependency p) p -> a -> Sometimes a
sometimesIO n t x = sometimes1 n $ IOTree (Standalone x) t sometimesIO n t x = sometimes1 n $ IOTree (Standalone x) t
sometimesDBus :: Maybe Client -> String -> Tree (DBusDependency a p) p sometimesDBus :: Maybe Client -> String -> Tree (DBusDependency p) p
-> (Client -> a) -> Sometimes a -> (Client -> a) -> Sometimes a
sometimesDBus c n t x = sometimes1 n $ DBusTree (Standalone x) c t sometimesDBus c n t x = sometimes1 n $ DBusTree (Standalone x) c t
@ -140,18 +152,28 @@ data Subfeature a t = Subfeature
data LogLevel = Silent | Error | Warn | Debug deriving (Eq, Show, Ord) data LogLevel = Silent | Error | Warn | Debug deriving (Eq, Show, Ord)
data Msg = Msg LogLevel String String ioSubfeature :: MonadIO m => Subfeature (IO a) t -> Subfeature (m a) t
ioSubfeature sf = sf { sfTree = ioActionTree $ sfTree sf }
-- data Msg = Msg LogLevel String String
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Action Tree -- | Action Tree
data ActionTree a t = data ActionTree a t =
forall p. IOTree (Action a p) (t (IODependency a p) p) forall p. IOTree (Action a p) (t (IODependency p) p)
| forall p. DBusTree (Action (Client -> a) p) (Maybe Client) (t (DBusDependency a p) p) | forall p. DBusTree (Action (Client -> a) p) (Maybe Client)
(t (DBusDependency p) p)
data Action a p = Standalone a | Consumer (p -> a) data Action a p = Standalone a | Consumer (p -> a)
-------------------------------------------------------------------------------- ioActionTree :: MonadIO m => ActionTree (IO a) t -> ActionTree (m a) t
ioActionTree (IOTree (Standalone a) t) = IOTree (Standalone $ io a) t
ioActionTree (IOTree (Consumer a) t) = IOTree (Consumer $ io . a) t
ioActionTree (DBusTree (Standalone a) cl t) = DBusTree (Standalone $ io . a) cl t
ioActionTree (DBusTree (Consumer a) cl t) = DBusTree (Consumer (\p c -> io $ a p c)) cl t
-- --------------------------------------------------------------------------------
-- | Dependency Tree -- | Dependency Tree
data Tree d p = data Tree d p =
@ -192,30 +214,30 @@ smryNil = const $ Right (Nothing, [])
smryFail :: String -> Either [String] a smryFail :: String -> Either [String] a
smryFail msg = Left [msg] smryFail msg = Left [msg]
smryInit :: Summary p -- smryInit :: Summary p
smryInit = Right (Nothing, []) -- smryInit = Right (Nothing, [])
foldResultTreeMsgs :: ResultTree d p -> ([String], [String]) -- foldResultTreeMsgs :: ResultTree d p -> ([String], [String])
foldResultTreeMsgs = undefined -- foldResultTreeMsgs = undefined
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Result -- | Result
type Result p = Either [String] (Maybe p) -- type Result p = Either [String] (Maybe p)
resultNil :: p -> Result q -- resultNil :: p -> Result q
resultNil = const $ Right Nothing -- resultNil = const $ Right Nothing
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | IO Dependency -- | IO Dependency
data IODependency a p = Executable Bool FilePath data IODependency p = Executable Bool FilePath
| AccessiblePath FilePath Bool Bool | AccessiblePath FilePath Bool Bool
| IOTest String (IO (Maybe String)) | IOTest String (IO (Maybe String))
| IORead String (IO (Either String (Maybe p))) | IORead String (IO (Either String (Maybe p)))
| Systemd UnitType String | Systemd UnitType String
| NestedAlways (Always a) (a -> p) | forall a. NestedAlways (Always a) (a -> p)
| NestedSometimes (Sometimes a) (a -> p) | forall a. NestedSometimes (Sometimes a) (a -> p)
data UnitType = SystemUnit | UserUnit deriving (Eq, Show) data UnitType = SystemUnit | UserUnit deriving (Eq, Show)
@ -226,22 +248,22 @@ sometimesExeArgs :: MonadIO m => String -> Bool -> FilePath -> [String] -> Somet
sometimesExeArgs n sys path args = sometimesExeArgs n sys path args =
sometimesIO n (Only (Executable sys path)) $ spawnCmd path args sometimesIO n (Only (Executable sys path)) $ spawnCmd path args
pathR :: String -> IODependency a p pathR :: String -> IODependency p
pathR n = AccessiblePath n True False pathR n = AccessiblePath n True False
pathW :: String -> IODependency a p pathW :: String -> IODependency p
pathW n = AccessiblePath n False True pathW n = AccessiblePath n False True
pathRW :: String -> IODependency a p pathRW :: String -> IODependency p
pathRW n = AccessiblePath n True True pathRW n = AccessiblePath n True True
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | DBus Dependency Result -- | DBus Dependency Result
data DBusDependency a p = data DBusDependency p =
Bus BusName Bus BusName
| Endpoint BusName ObjectPath InterfaceName DBusMember | Endpoint BusName ObjectPath InterfaceName DBusMember
| DBusIO (IODependency a p) | DBusIO (IODependency p)
data DBusMember = Method_ MemberName data DBusMember = Method_ MemberName
| Signal_ MemberName | Signal_ MemberName
@ -268,12 +290,16 @@ sometimesEndpoint name busname path iface mem client =
-- 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.
executeSometimes_ :: MonadIO m => Sometimes (m a) -> m () executeAlways :: MonadIO m => Always (m a) -> m a
executeSometimes_ = void . executeSometimes executeAlways = join . evalAlways
executeSometimes :: MonadIO m => Sometimes (m a) -> m (Maybe a) executeSometimes :: MonadIO m => Sometimes (m a) -> m (Maybe a)
executeSometimes a = maybe (return Nothing) (fmap Just) =<< evalSometimes a executeSometimes a = maybe (return Nothing) (fmap Just) =<< evalSometimes a
evalFeature :: MonadIO m => Feature a -> m (Maybe a)
evalFeature (Right a) = Just <$> evalAlways a
evalFeature (Left s) = evalSometimes s
-- TODO actually print things -- TODO actually print things
evalSometimes :: MonadIO m => Sometimes a -> m (Maybe a) evalSometimes :: MonadIO m => Sometimes a -> m (Maybe a)
evalSometimes x = either (const Nothing) (Just . fst) <$> evalSometimesMsg x evalSometimes x = either (const Nothing) (Just . fst) <$> evalSometimesMsg x
@ -285,11 +311,6 @@ evalSometimesMsg x = io $ do
TestedSometimes { tsSuccess = s, tsFailed = _ } <- testSometimes x TestedSometimes { tsSuccess = s, tsFailed = _ } <- testSometimes x
return $ maybe (Left []) (\Finished { finAction = a } -> Right (a, [])) s return $ maybe (Left []) (\Finished { finAction = a } -> Right (a, [])) s
executeAlways_ :: MonadIO m => Always (m a) -> m ()
executeAlways_ = void . executeAlways
executeAlways :: MonadIO m => Always (m a) -> m a
executeAlways = join . evalAlways
-- TODO actually print things -- TODO actually print things
evalAlways :: MonadIO m => Always a -> m a evalAlways :: MonadIO m => Always a -> m a
@ -309,7 +330,7 @@ evalAlwaysMsg a = io $ do
-- for diagnostic purposes. This obviously has overlap with feature evaluation -- for diagnostic purposes. This obviously has overlap with feature evaluation
-- since we need to resolve dependencies to build each feature. -- since we need to resolve dependencies to build each feature.
testAlways :: Always a -> IO (TestedAlways a p) testAlways :: Always m -> IO (TestedAlways m p)
testAlways = go [] testAlways = go []
where where
go failed (Option fd next) = do go failed (Option fd next) = do
@ -320,7 +341,7 @@ testAlways = go []
(SuccessfulFtr s) -> return $ Primary s failed next (SuccessfulFtr s) -> return $ Primary s failed next
go failed (Always a) = return $ Fallback a failed go failed (Always a) = return $ Fallback a failed
testSometimes :: Sometimes a -> IO (TestedSometimes a p) testSometimes :: Sometimes m -> IO (TestedSometimes m p)
testSometimes = go (TestedSometimes Nothing [] []) testSometimes = go (TestedSometimes Nothing [] [])
where where
go ts [] = return ts go ts [] = return ts
@ -333,7 +354,7 @@ testSometimes = go (TestedSometimes Nothing [] [])
addFail ts@(TestedSometimes { tsFailed = f }) new addFail ts@(TestedSometimes { tsFailed = f }) new
= ts { tsFailed = new:f } = ts { tsFailed = new:f }
testSubfeature :: Subfeature a Tree -> IO (FeatureResult a p) testSubfeature :: Subfeature m Tree -> IO (FeatureResult m p)
testSubfeature fd@(Subfeature { sfTree = t }) = do testSubfeature fd@(Subfeature { sfTree = t }) = do
atm <- testActionTree t atm <- testActionTree t
return $ either untestable checkAction atm return $ either untestable checkAction atm
@ -346,7 +367,7 @@ testSubfeature fd@(Subfeature { sfTree = t }) = do
} }
checkAction (t', Nothing, ms) = FailedFtr (fd { sfTree = t' }) ms checkAction (t', Nothing, ms) = FailedFtr (fd { sfTree = t' }) ms
testActionTree :: ActionTree a Tree -> IO (ActionTreeMaybe a p) testActionTree :: ActionTree m Tree -> IO (ActionTreeMaybe m p)
testActionTree t = do testActionTree t = do
case t of case t of
(IOTree a d) -> do (IOTree a d) -> do
@ -365,12 +386,12 @@ testActionTree t = do
apply (Standalone a) _ = a apply (Standalone a) _ = a
apply (Consumer a) p = a p apply (Consumer a) p = a p
testIOTree :: Tree (IODependency a p) p testIOTree :: Tree (IODependency p) p
-> IO (ResultTree (IODependency a p) p, Maybe (Maybe p)) -> IO (ResultTree (IODependency p) p, Maybe (Maybe p))
testIOTree = testTree testIODependency testIOTree = testTree testIODependency
testDBusTree :: Client -> Tree (DBusDependency a p) p testDBusTree :: Client -> Tree (DBusDependency p) p
-> IO (ResultTree (DBusDependency a p) p, Maybe (Maybe p)) -> IO (ResultTree (DBusDependency p) p, Maybe (Maybe p))
testDBusTree client = testTree (testDBusDependency client) testDBusTree client = testTree (testDBusDependency client)
testTree :: Monad m => (d -> m (Summary p)) -> Tree d p testTree :: Monad m => (d -> m (Summary p)) -> Tree d p
@ -395,7 +416,7 @@ testTree test = go
(rb, pb) <- go b (rb, pb) <- go b
return (Both ra rb, fmap (f =<<) pb) return (Both ra rb, fmap (f =<<) pb)
testIODependency :: IODependency a p -> IO (Summary p) testIODependency :: IODependency p -> IO (Summary p)
testIODependency (Executable _ bin) = maybe err smryNil <$> findExecutable bin testIODependency (Executable _ bin) = maybe err smryNil <$> findExecutable bin
where where
err = Left ["executable '" ++ bin ++ "' not found"] err = Left ["executable '" ++ bin ++ "' not found"]
@ -441,7 +462,7 @@ testIODependency (NestedSometimes x f) = do
TestedSometimes { tsSuccess = s, tsFailed = _ } <- testSometimes x TestedSometimes { tsSuccess = s, tsFailed = _ } <- testSometimes x
return $ maybe (Left []) (\Finished { finAction = a } -> Right (Just $ f a, [])) s return $ maybe (Left []) (\Finished { finAction = a } -> Right (Just $ f a, [])) s
testDBusDependency :: Client -> DBusDependency a p -> IO (Summary p) testDBusDependency :: Client -> DBusDependency p -> IO (Summary p)
testDBusDependency client (Bus bus) = do testDBusDependency client (Bus bus) = do
ret <- callMethod client queryBus queryPath queryIface queryMem ret <- callMethod client queryBus queryPath queryIface queryMem
return $ case ret of return $ case ret of
@ -493,14 +514,14 @@ testDBusDependency _ (DBusIO d) = testIODependency d
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Printing -- | Printing
printMsgs :: LogLevel -> [Msg] -> IO () -- printMsgs :: LogLevel -> [Msg] -> IO ()
printMsgs lvl ms = do -- printMsgs lvl ms = do
pn <- getProgName -- pn <- getProgName
mapM_ (printMsg pn lvl) ms -- mapM_ (printMsg pn lvl) ms
printMsg :: String -> LogLevel -> Msg -> IO () -- printMsg :: String -> LogLevel -> Msg -> IO ()
printMsg pname lvl (Msg ml mn msg) -- printMsg pname lvl (Msg ml mn msg)
| lvl > ml = putStrLn $ unwords [bracket pname, bracket mn, msg] -- | lvl > ml = putStrLn $ unwords [bracket pname, bracket mn, msg]
| otherwise = skip -- | otherwise = skip
where -- where
bracket s = "[" ++ s ++ "]" -- bracket s = "[" ++ s ++ "]"

2
lib/Xmobar/Plugins/Bluetooth.hs
View File

@ -55,7 +55,7 @@ import Xmobar.Plugins.Common
btAlias :: String btAlias :: String
btAlias = "bluetooth" btAlias = "bluetooth"
btDep :: DBusDep btDep :: DBusDependency p
btDep = Endpoint btBus btOMPath omInterface $ Method_ getManagedObjects btDep = Endpoint btBus btOMPath omInterface $ Method_ getManagedObjects
data Bluetooth = Bluetooth Icons Colors deriving (Read, Show) data Bluetooth = Bluetooth Icons Colors deriving (Read, Show)

2
lib/Xmobar/Plugins/Device.hs
View File

@ -41,7 +41,7 @@ getByIP = memberName_ "GetDeviceByIpIface"
devSignal :: String devSignal :: String
devSignal = "Ip4Connectivity" devSignal = "Ip4Connectivity"
devDep :: DBusDep devDep :: DBusDependency p
devDep = Endpoint nmBus nmPath nmInterface $ Method_ getByIP devDep = Endpoint nmBus nmPath nmInterface $ Method_ getByIP
getDevice :: Client -> String -> IO (Maybe ObjectPath) getDevice :: Client -> String -> IO (Maybe ObjectPath)

2
lib/Xmobar/Plugins/VPN.hs
View File

@ -118,5 +118,5 @@ vpnDeviceTun = "org.freedesktop.NetworkManager.Device.Tun"
vpnAlias :: String vpnAlias :: String
vpnAlias = "vpn" vpnAlias = "vpn"
vpnDep :: DBusDep vpnDep :: DBusDependency p
vpnDep = Endpoint vpnBus vpnPath omInterface $ Method_ getManagedObjects vpnDep = Endpoint vpnBus vpnPath omInterface $ Method_ getManagedObjects