From 5326b49ce2c2e3174366383a0366eecb6879f5e7 Mon Sep 17 00:00:00 2001 From: ndwarshuis Date: Wed, 22 Jun 2022 01:28:46 -0400 Subject: [PATCH] ENH use new dependency framework throughout --- bin/xmobar.hs | 86 ++++++------ bin/xmonad.hs | 118 ++++++++-------- lib/XMonad/Internal/Command/DMenu.hs | 46 +++--- .../Internal/DBus/Brightness/ClevoKeyboard.hs | 6 +- lib/XMonad/Internal/DBus/Brightness/Common.hs | 4 +- .../DBus/Brightness/IntelBacklight.hs | 6 +- lib/XMonad/Internal/DBus/Control.hs | 2 +- lib/XMonad/Internal/DBus/Removable.hs | 6 +- lib/XMonad/Internal/DBus/Screensaver.hs | 2 +- lib/XMonad/Internal/Dependency.hs | 131 ++++++++++-------- lib/Xmobar/Plugins/Bluetooth.hs | 2 +- lib/Xmobar/Plugins/Device.hs | 2 +- lib/Xmobar/Plugins/VPN.hs | 2 +- 13 files changed, 221 insertions(+), 192 deletions(-) diff --git a/bin/xmobar.hs b/bin/xmobar.hs index daa983e..0f4fc04 100644 --- a/bin/xmobar.hs +++ b/bin/xmobar.hs @@ -239,7 +239,7 @@ dateCmd = CmdSpec -- which case ethernet interfaces always start with "en" and wireless -- interfaces always start with "wl" -type BarFeature = Feature CmdSpec +type BarFeature = Sometimes CmdSpec isWireless :: String -> Bool isWireless ('w':'l':_) = True @@ -255,13 +255,14 @@ listInterfaces = fromRight [] <$> tryIOError (listDirectory sysfsNet) sysfsNet :: FilePath sysfsNet = "/sys/class/net" -readInterface :: (String -> Bool) -> IO (Either [String] String) +readInterface :: (String -> Bool) -> IO (Either String String) readInterface f = do ns <- filter f <$> listInterfaces case ns of - [] -> return $ Left ["no interfaces found"] + [] -> return $ Left "no interfaces found" (x:xs) -> do unless (null xs) $ + -- TODO store this somehow intead of printing putStrLn $ "WARNING: extra interfaces found, using " ++ x return $ Right x @@ -275,66 +276,71 @@ vpnPresent = do where 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 - [ getWireless - , getEthernet sysClient - , getVPN sysClient - , getBt sysClient - , getAlsa - , getBattery - , getBl sesClient - , getCk sesClient - , getSs sesClient - , ConstFeature lockCmd - , ConstFeature dateCmd + [ Left getWireless + , Left $ getEthernet sysClient + , Left $ getVPN sysClient + , Left $ getBt sysClient + , Left getAlsa + , Left getBattery + , Left $ getBl sesClient + , Left $ getCk sesClient + , Left $ getSs sesClient + , Right $ Always lockCmd + , Right $ Always dateCmd ] getWireless :: BarFeature -getWireless = feature "wireless status indicator" Default - -- TODO this is stupid - $ GenTree (Double wirelessCmd $ readInterface isWireless) (Only $ exe "ls") +getWireless = sometimes1 "wireless status indicator" + $ IOTree (Consumer wirelessCmd) + $ Only $ IORead "get wifi interface" $ fmap Just <$> readInterface isWireless getEthernet :: Maybe Client -> BarFeature -getEthernet client = feature "ethernet status indicator" Default - $ DBusTree action client (Only $ fullDep devDep) +getEthernet client = sometimes1 "ethernet status indicator" $ + DBusTree (Consumer act) client deps 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 = feature "battery level indicator" Default - $ GenTree (Single batteryCmd) (Only $ fullDep $ IOTest desc hasBattery) - where - desc = "Test if battery is present" +getBattery = sometimesIO "battery level indicator" + (Only $ IOTest "Test if battery is present" hasBattery) + batteryCmd getVPN :: Maybe Client -> BarFeature -getVPN client = feature "VPN status indicator" Default - $ DBusTree (Single (const vpnCmd)) client $ And (Only $ fullDep vpnDep) (Only dp) +getVPN client = sometimesDBus client "VPN status indicator" + (toAnd vpnDep test) (const vpnCmd) where - dp = fullDep $ DBusGenDep $ IOTest desc vpnPresent - desc = "Use nmcli to test if VPN is present" + test = DBusIO $ IOTest "Use nmcli to test if VPN is present" vpnPresent getBt :: Maybe Client -> BarFeature -getBt client = feature "bluetooth status indicator" Default - $ DBusTree (Single (const btCmd)) client (Only $ fullDep btDep) +getBt client = sometimesDBus client "bluetooth status indicator" + (Only btDep) + (const btCmd) getAlsa :: BarFeature -getAlsa = feature "volume level indicator" Default - $ GenTree (Single alsaCmd) (Only $ exe "alsactl") +getAlsa = sometimesIO "volume level indicator" + (Only $ Executable True "alsact") + alsaCmd getBl :: Maybe Client -> BarFeature -getBl client = feature "Intel backlight indicator" Default - $ DBusTree (Single (const blCmd)) client (Only $ fullDep intelBacklightSignalDep) +getBl client = sometimesDBus client "Intel backlight indicator" + (Only intelBacklightSignalDep) + (const blCmd) getCk :: Maybe Client -> BarFeature -getCk client = feature "Clevo keyboard indicator" Default - $ DBusTree (Single (const ckCmd)) client (Only $ fullDep clevoKeyboardSignalDep) +getCk client = sometimesDBus client "Clevo keyboard indicator" + (Only clevoKeyboardSignalDep) + (const ckCmd) getSs :: Maybe Client -> BarFeature -getSs client = feature "screensaver indicator" Default - $ DBusTree (Single (const ssCmd)) client (Only $ fullDep ssSignalDep) +getSs client = sometimesDBus client "screensaver indicator" + (Only ssSignalDep) $ const ssCmd -getAllCommands :: [MaybeAction CmdSpec] -> IO BarRegions +getAllCommands :: [Maybe CmdSpec] -> IO BarRegions getAllCommands right = do let left = [ CmdSpec diff --git a/bin/xmonad.hs b/bin/xmonad.hs index e041b22..cf16fbf 100644 --- a/bin/xmonad.hs +++ b/bin/xmonad.hs @@ -20,9 +20,6 @@ import Data.List , sortOn ) import Data.Maybe - ( isJust - , mapMaybe - ) import Data.Monoid (All (..)) import Graphics.X11.Types @@ -88,15 +85,15 @@ run :: IO () run = do db <- connectXDBus (h, p) <- spawnPipe "xmobar" - executeFeature_ $ runRemovableMon $ dbSystemClient db - executeFeatureWith_ forkIO_ runPowermon + void $ executeSometimes $ runRemovableMon $ dbSystemClient db + forkIO_ $ void $ executeSometimes runPowermon forkIO_ $ runWorkspaceMon allDWs let ts = ThreadState { tsChildPIDs = [p] , tsChildHandles = [h] } - lockRes <- evalFeature runScreenLock - let lock = whenSatisfied lockRes + lockRes <- evalSometimes runScreenLock + let lock = fromMaybe skip lockRes ext <- evalExternal $ externalBindings ts db lock -- IDK why this is necessary; nothing prior to this line will print if missing hFlush stdout @@ -127,7 +124,7 @@ printDeps = skip -- mapM_ printDep $ concatMap extractFeatures i ++ concatMap extractFeatures x -- where -- extractFeatures (Feature f _) = dtDeps $ ftrDepTree f - -- extractFeatures (ConstFeature _) = [] + -- extractFeatures (Always _) = [] -- dtDeps (GenTree _ ds) = ds -- dtDeps (DBusTree _ _ ds) = ds -- printDep (FullDep d) = putStrLn . depName d @@ -540,13 +537,13 @@ data KeyGroup a = KeyGroup , kgBindings :: [KeyBinding a] } -evalExternal :: [KeyGroup FeatureX] -> IO [KeyGroup MaybeX] +evalExternal :: [KeyGroup (FeatureX)] -> IO [KeyGroup MaybeX] evalExternal = mapM go where go k@KeyGroup { kgBindings = 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 } = (\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 } Nothing -> Just $ k{ kbDesc = "[!!!]" ++ d, kbMaybeAction = skip } -externalBindings :: ThreadState -> DBusState -> X () -> [KeyGroup FeatureX] +externalBindings :: ThreadState -> DBusState -> X () -> [KeyGroup (FeatureX)] externalBindings ts db lock = [ KeyGroup "Launchers" - [ KeyBinding "" "select/launch app" runAppMenu - , KeyBinding "M-g" "launch clipboard manager" runClipMenu - , KeyBinding "M-a" "launch network selector" runNetMenu - , KeyBinding "M-w" "launch window selector" runWinMenu - , KeyBinding "M-u" "launch device selector" runDevMenu - , KeyBinding "M-b" "launch bitwarden selector" runBwMenu - , KeyBinding "M-v" "launch ExpressVPN selector" runVPNMenu - , KeyBinding "M-e" "launch bluetooth selector" runBTMenu - , KeyBinding "M-C-e" "launch editor" runEditor - , KeyBinding "M-C-w" "launch browser" runBrowser - , KeyBinding "M-C-t" "launch terminal with tmux" runTMux - , KeyBinding "M-C-S-t" "launch terminal" runTerm - , KeyBinding "M-C-q" "launch calc" runCalc - , KeyBinding "M-C-f" "launch file manager" runFileManager + [ KeyBinding "" "select/launch app" $ Left runAppMenu + , KeyBinding "M-g" "launch clipboard manager" $ Left runClipMenu + , KeyBinding "M-a" "launch network selector" $ Left runNetMenu + , KeyBinding "M-w" "launch window selector" $ Left runWinMenu + , KeyBinding "M-u" "launch device selector" $ Left runDevMenu + , KeyBinding "M-b" "launch bitwarden selector" $ Left runBwMenu + , KeyBinding "M-v" "launch ExpressVPN selector" $ Left runVPNMenu + , KeyBinding "M-e" "launch bluetooth selector" $ Left runBTMenu + , KeyBinding "M-C-e" "launch editor" $ Left runEditor + , KeyBinding "M-C-w" "launch browser" $ Left runBrowser + , KeyBinding "M-C-t" "launch terminal with tmux" $ Left runTMux + , KeyBinding "M-C-S-t" "launch terminal" $ Left runTerm + , KeyBinding "M-C-q" "launch calc" $ Left runCalc + , KeyBinding "M-C-f" "launch file manager" $ Left runFileManager ] , KeyGroup "Actions" - [ KeyBinding "M-q" "close window" $ ConstFeature kill1 - , KeyBinding "M-r" "run program" runCmdMenu - , KeyBinding "M-" "warp pointer" $ ConstFeature $ warpToWindow 0.5 0.5 - , KeyBinding "M-C-s" "capture area" runAreaCapture - , KeyBinding "M-C-S-s" "capture screen" runScreenCapture - , KeyBinding "M-C-d" "capture desktop" runDesktopCapture - , KeyBinding "M-C-b" "browse captures" runCaptureBrowser + [ KeyBinding "M-q" "close window" $ ftrAlways kill1 + , KeyBinding "M-r" "run program" $ Left runCmdMenu + , KeyBinding "M-" "warp pointer" $ ftrAlways $ warpToWindow 0.5 0.5 + , KeyBinding "M-C-s" "capture area" $ Left runAreaCapture + , KeyBinding "M-C-S-s" "capture screen" $ Left runScreenCapture + , KeyBinding "M-C-d" "capture desktop" $ Left runDesktopCapture + , KeyBinding "M-C-b" "browse captures" $ Left runCaptureBrowser -- , ("M-C-S-s", "capture focused window", spawn myWindowCap) ] , KeyGroup "Multimedia" - [ KeyBinding "" "toggle play/pause" runTogglePlay - , KeyBinding "" "previous track" runPrevTrack - , KeyBinding "" "next track" runNextTrack - , KeyBinding "" "stop" runStopPlay - , KeyBinding "" "volume down" runVolumeDown - , KeyBinding "" "volume up" runVolumeUp - , KeyBinding "" "volume mute" runVolumeMute + [ KeyBinding "" "toggle play/pause" $ Left runTogglePlay + , KeyBinding "" "previous track" $ Left runPrevTrack + , KeyBinding "" "next track" $ Left runNextTrack + , KeyBinding "" "stop" $ Left runStopPlay + , KeyBinding "" "volume down" $ Left runVolumeDown + , KeyBinding "" "volume up" $ Left runVolumeUp + , KeyBinding "" "volume mute" $ Left runVolumeMute ] , KeyGroup "Dunst" - [ KeyBinding "M-`" "dunst history" runNotificationHistory - , KeyBinding "M-S-`" "dunst close" runNotificationClose - , KeyBinding "M-M1-`" "dunst context menu" runNotificationContext - , KeyBinding "M-C-`" "dunst close all" runNotificationCloseAll + [ KeyBinding "M-`" "dunst history" $ Left runNotificationHistory + , KeyBinding "M-S-`" "dunst close" $ Left runNotificationClose + , KeyBinding "M-M1-`" "dunst context menu" $ Left runNotificationContext + , KeyBinding "M-C-`" "dunst close all" $ Left runNotificationCloseAll ] , KeyGroup "System" @@ -616,23 +613,28 @@ externalBindings ts db lock = , KeyBinding "M-S-," "keyboard down" $ ck bctlDec , KeyBinding "M-S-M1-," "keyboard min" $ ck bctlMin , KeyBinding "M-S-M1-." "keyboard max" $ ck bctlMax - , KeyBinding "M-" "power menu" $ ConstFeature $ runPowerPrompt lock - , KeyBinding "M-" "quit xmonad" $ ConstFeature runQuitPrompt - , KeyBinding "M-" "lock screen" runScreenLock + , KeyBinding "M-" "power menu" $ ftrAlways $ runPowerPrompt lock + , KeyBinding "M-" "quit xmonad" $ ftrAlways runQuitPrompt + , KeyBinding "M-" "lock screen" $ Left runScreenLock -- M- reserved for showing the keymap - , KeyBinding "M-" "restart xmonad" $ ConstFeature (runCleanup ts db >> runRestart) - , KeyBinding "M-" "recompile xmonad" $ ConstFeature runRecompile - , KeyBinding "M-" "start Isync Service" runStartISyncService - , KeyBinding "M-C-" "start Isync Timer" runStartISyncTimer - , KeyBinding "M-" "select autorandr profile" runAutorandrMenu - , KeyBinding "M-" "toggle ethernet" runToggleEthernet - , KeyBinding "M-" "toggle bluetooth" runToggleBluetooth - , KeyBinding "M-" "toggle screensaver" $ ioFeature $ callToggle cl - , KeyBinding "M-" "switch gpu" runOptimusPrompt + , KeyBinding "M-" "restart xmonad" $ ftrAlways (runCleanup ts db >> runRestart) + , KeyBinding "M-" "recompile xmonad" $ ftrAlways runRecompile + , KeyBinding "M-" "start Isync Service" $ Left runStartISyncService + , KeyBinding "M-C-" "start Isync Timer" $ Left runStartISyncTimer + , KeyBinding "M-" "select autorandr profile" $ Left runAutorandrMenu + , KeyBinding "M-" "toggle ethernet" $ Left runToggleEthernet + , KeyBinding "M-" "toggle bluetooth" $ Left runToggleBluetooth + , KeyBinding "M-" "toggle screensaver" $ Left $ ioSometimes $ callToggle cl + , KeyBinding "M-" "switch gpu" $ Left runOptimusPrompt ] ] where cl = dbSessionClient db - brightessControls ctl getter = (ioFeature . getter . ctl) cl - ib = brightessControls intelBacklightControls - ck = brightessControls clevoKeyboardControls + brightessControls ctl getter = (ioSometimes . getter . ctl) cl + ib = Left . brightessControls intelBacklightControls + ck = Left . brightessControls clevoKeyboardControls + ftrAlways = Right . Always + +type MaybeX = Maybe (X ()) + +type FeatureX = Feature (X ()) diff --git a/lib/XMonad/Internal/Command/DMenu.hs b/lib/XMonad/Internal/Command/DMenu.hs index 87cc2ce..2caa05f 100644 --- a/lib/XMonad/Internal/Command/DMenu.hs +++ b/lib/XMonad/Internal/Command/DMenu.hs @@ -15,17 +15,17 @@ module XMonad.Internal.Command.DMenu , runAutorandrMenu ) where -import Control.Monad.Reader +-- import Control.Monad.Reader import Graphics.X11.Types import System.Directory (XdgDirectory (..), getXdgDirectory) -import System.IO +-- import System.IO import XMonad.Core hiding (spawn) import XMonad.Internal.Dependency -import XMonad.Internal.Notify -import XMonad.Internal.Process +-- import XMonad.Internal.Notify +-- import XMonad.Internal.Process import XMonad.Internal.Shell import XMonad.Util.NamedActions @@ -103,27 +103,27 @@ runShowKeys :: [((KeyMask, KeySym), NamedAction)] -> NamedAction runShowKeys _ = NamedAction (skip :: (X ())) -- addName "Show Keybindings" $ evalAlways $ runDMenuShowKeys x -runDMenuShowKeys :: [((KeyMask, KeySym), NamedAction)] -> AlwaysX -runDMenuShowKeys kbs = - Option (runDMenuShowKeys' kbs) (Always runNotifyShowKeys) +-- runDMenuShowKeys :: [((KeyMask, KeySym), NamedAction)] -> AlwaysX +-- runDMenuShowKeys kbs = +-- Option (runDMenuShowKeys' kbs) (Always runNotifyShowKeys) -runNotifyShowKeys :: X () -runNotifyShowKeys = spawnNotify - $ defNoteError { body = Just $ Text "could not display keymap" } +-- runNotifyShowKeys :: X () +-- runNotifyShowKeys = spawnNotify +-- $ defNoteError { body = Just $ Text "could not display keymap" } -runDMenuShowKeys' :: [((KeyMask, KeySym), NamedAction)] -> Subfeature (X ()) Tree -runDMenuShowKeys' kbs = Subfeature - { sfName = "keyboard shortcut menu" - , sfTree = IOTree (Standalone act) deps - , sfLevel = Warn - } - where - deps = Only $ Executable True myDmenuCmd - act = io $ do - (h, _, _, _) <- createProcess' $ (shell' cmd) { std_in = CreatePipe } - forM_ h $ \h' -> hPutStr h' (unlines $ showKm kbs) >> hClose h' - cmd = fmtCmd myDmenuCmd $ ["-dmenu", "-p", "commands"] - ++ themeArgs "#7f66ff" ++ myDmenuMatchingArgs +-- runDMenuShowKeys' :: [((KeyMask, KeySym), NamedAction)] -> Subfeature (X ()) Tree +-- runDMenuShowKeys' kbs = Subfeature +-- { sfName = "keyboard shortcut menu" +-- , sfTree = IOTree (Standalone act) deps +-- , sfLevel = Warn +-- } +-- where +-- deps = Only $ Executable True myDmenuCmd +-- act = io $ do +-- (h, _, _, _) <- createProcess' $ (shell' cmd) { std_in = CreatePipe } +-- forM_ h $ \h' -> hPutStr h' (unlines $ showKm kbs) >> hClose h' +-- cmd = fmtCmd myDmenuCmd $ ["-dmenu", "-p", "commands"] +-- ++ themeArgs "#7f66ff" ++ myDmenuMatchingArgs runCmdMenu :: SometimesX runCmdMenu = spawnDmenuCmd "command menu" ["-show", "run"] diff --git a/lib/XMonad/Internal/DBus/Brightness/ClevoKeyboard.hs b/lib/XMonad/Internal/DBus/Brightness/ClevoKeyboard.hs index 8167f5e..4594206 100644 --- a/lib/XMonad/Internal/DBus/Brightness/ClevoKeyboard.hs +++ b/lib/XMonad/Internal/DBus/Brightness/ClevoKeyboard.hs @@ -107,13 +107,13 @@ clevoKeyboardConfig = BrightnessConfig -------------------------------------------------------------------------------- -- | Exported haskell API -stateFileDep :: IODependency a p +stateFileDep :: IODependency p stateFileDep = pathRW stateFile -brightnessFileDep :: IODependency a p +brightnessFileDep :: IODependency p brightnessFileDep = pathR brightnessFile -clevoKeyboardSignalDep :: DBusDependency RawBrightness p +clevoKeyboardSignalDep :: DBusDependency RawBrightness clevoKeyboardSignalDep = signalDep clevoKeyboardConfig exportClevoKeyboard :: Maybe Client -> SometimesIO diff --git a/lib/XMonad/Internal/DBus/Brightness/Common.hs b/lib/XMonad/Internal/DBus/Brightness/Common.hs index de7df7f..0619c87 100644 --- a/lib/XMonad/Internal/DBus/Brightness/Common.hs +++ b/lib/XMonad/Internal/DBus/Brightness/Common.hs @@ -67,7 +67,7 @@ callGetBrightness BrightnessConfig { bcPath = p, bcInterface = i } client = either (const Nothing) bodyGetBrightness <$> 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 } = Endpoint xmonadBusName p i $ Signal_ memCur @@ -85,7 +85,7 @@ matchSignal BrightnessConfig { bcPath = p, bcInterface = i } cb = -------------------------------------------------------------------------------- -- | Internal DBus Crap -brightnessExporter :: RealFrac b => [IODependency (IO ()) (Maybe x)] +brightnessExporter :: RealFrac b => [IODependency (Maybe x)] -> BrightnessConfig a b -> Maybe Client -> SometimesIO brightnessExporter deps bc@BrightnessConfig { bcName = n } client = sometimesDBus client (n ++ " exporter") ds (exportBrightnessControls' bc) diff --git a/lib/XMonad/Internal/DBus/Brightness/IntelBacklight.hs b/lib/XMonad/Internal/DBus/Brightness/IntelBacklight.hs index 62771d0..6efddaa 100644 --- a/lib/XMonad/Internal/DBus/Brightness/IntelBacklight.hs +++ b/lib/XMonad/Internal/DBus/Brightness/IntelBacklight.hs @@ -89,13 +89,13 @@ intelBacklightConfig = BrightnessConfig -------------------------------------------------------------------------------- -- | Exported haskell API -curFileDep :: IODependency a p +curFileDep :: IODependency p curFileDep = pathRW curFile -maxFileDep :: IODependency a p +maxFileDep :: IODependency p maxFileDep = pathR maxFile -intelBacklightSignalDep :: DBusDependency RawBrightness p +intelBacklightSignalDep :: DBusDependency RawBrightness intelBacklightSignalDep = signalDep intelBacklightConfig exportIntelBacklight :: Maybe Client -> SometimesIO diff --git a/lib/XMonad/Internal/DBus/Control.hs b/lib/XMonad/Internal/DBus/Control.hs index 0b7070a..8d74eca 100644 --- a/lib/XMonad/Internal/DBus/Control.hs +++ b/lib/XMonad/Internal/DBus/Control.hs @@ -30,7 +30,7 @@ startXMonadService :: IO (Maybe Client) startXMonadService = do client <- getDBusClient False forM_ client requestXMonadName - mapM_ (\f -> executeSometimes_ $ f client) dbusExporters + mapM_ (\f -> executeSometimes $ f client) dbusExporters return client stopXMonadService :: Client -> IO () diff --git a/lib/XMonad/Internal/DBus/Removable.hs b/lib/XMonad/Internal/DBus/Removable.hs index 6413c9f..da73fcc 100644 --- a/lib/XMonad/Internal/DBus/Removable.hs +++ b/lib/XMonad/Internal/DBus/Removable.hs @@ -32,13 +32,13 @@ memAdded = memberName_ "InterfacesAdded" memRemoved :: MemberName memRemoved = memberName_ "InterfacesRemoved" -dbusDep :: MemberName -> DBusDependency a p +dbusDep :: MemberName -> DBusDependency p dbusDep m = Endpoint bus path interface $ Signal_ m -addedDep :: DBusDependency a p +addedDep :: DBusDependency p addedDep = dbusDep memAdded -removedDep :: DBusDependency a p +removedDep :: DBusDependency p removedDep = dbusDep memRemoved driveInsertedSound :: FilePath diff --git a/lib/XMonad/Internal/DBus/Screensaver.hs b/lib/XMonad/Internal/DBus/Screensaver.hs index e8fbb48..11fbc63 100644 --- a/lib/XMonad/Internal/DBus/Screensaver.hs +++ b/lib/XMonad/Internal/DBus/Screensaver.hs @@ -132,5 +132,5 @@ matchSignal :: (Maybe SSState -> IO ()) -> Client -> IO () matchSignal cb = fmap void . addMatchCallback ruleCurrentState $ cb . bodyGetCurrentState -ssSignalDep :: DBusDependency a p +ssSignalDep :: DBusDependency p ssSignalDep = Endpoint xmonadBusName ssPath interface $ Signal_ memState diff --git a/lib/XMonad/Internal/Dependency.hs b/lib/XMonad/Internal/Dependency.hs index dd1b075..84540e1 100644 --- a/lib/XMonad/Internal/Dependency.hs +++ b/lib/XMonad/Internal/Dependency.hs @@ -7,13 +7,16 @@ module XMonad.Internal.Dependency ( AlwaysX , AlwaysIO + , Feature , Always(..) + , TestedSometimes(..) , SometimesX , SometimesIO , Sometimes - , executeSometimes_ + , ioSometimes + , ioAlways + , evalFeature , executeSometimes - , executeAlways_ , executeAlways , evalAlways , evalSometimes @@ -50,7 +53,7 @@ import Control.Monad.Identity -- import Data.Aeson import Data.Bifunctor -import Data.Either +-- import Data.Either import Data.List (find) import Data.Maybe -- import qualified Data.Text as T @@ -61,7 +64,7 @@ import DBus.Internal import qualified DBus.Introspection as I import System.Directory (findExecutable, readable, writable) -import System.Environment +-- import System.Environment import System.Exit import XMonad.Core (X, io) @@ -82,10 +85,19 @@ type SometimesX = Sometimes (X ()) type SometimesIO = Sometimes (IO ()) +type Feature a = Either (Sometimes a) (Always a) + data Always a = Option (Subfeature a Tree) (Always a) | Always a 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 = Primary (Finished a p) [FailedFeature a p] (Always a) | 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_ l n t = [Subfeature{ sfTree = t, sfName = n, sfLevel = l }] -always1_ :: LogLevel -> String -> ActionTree a Tree -> a -> Always a -always1_ l n t x = - Option (Subfeature{ sfTree = t, sfName = n, sfLevel = l }) (Always x) +-- always1_ :: LogLevel -> String -> ActionTree a Tree -> a -> Always a +-- always1_ l n t x = +-- Option (Subfeature{ sfTree = t, sfName = n, sfLevel = l }) (Always x) sometimes1 :: String -> ActionTree a Tree -> Sometimes a 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 -sometimesDBus :: Maybe Client -> String -> Tree (DBusDependency a p) p +sometimesDBus :: Maybe Client -> String -> Tree (DBusDependency p) p -> (Client -> a) -> Sometimes a 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 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 data ActionTree a t = - forall p. IOTree (Action a p) (t (IODependency a p) p) - | forall p. DBusTree (Action (Client -> a) p) (Maybe Client) (t (DBusDependency a p) p) + forall p. IOTree (Action a p) (t (IODependency p) p) + | forall p. DBusTree (Action (Client -> a) p) (Maybe Client) + (t (DBusDependency p) p) 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 data Tree d p = @@ -192,30 +214,30 @@ smryNil = const $ Right (Nothing, []) smryFail :: String -> Either [String] a smryFail msg = Left [msg] -smryInit :: Summary p -smryInit = Right (Nothing, []) +-- smryInit :: Summary p +-- smryInit = Right (Nothing, []) -foldResultTreeMsgs :: ResultTree d p -> ([String], [String]) -foldResultTreeMsgs = undefined +-- foldResultTreeMsgs :: ResultTree d p -> ([String], [String]) +-- foldResultTreeMsgs = undefined -------------------------------------------------------------------------------- -- | Result -type Result p = Either [String] (Maybe p) +-- type Result p = Either [String] (Maybe p) -resultNil :: p -> Result q -resultNil = const $ Right Nothing +-- resultNil :: p -> Result q +-- resultNil = const $ Right Nothing -------------------------------------------------------------------------------- -- | IO Dependency -data IODependency a p = Executable Bool FilePath +data IODependency p = Executable Bool FilePath | AccessiblePath FilePath Bool Bool | IOTest String (IO (Maybe String)) | IORead String (IO (Either String (Maybe p))) | Systemd UnitType String - | NestedAlways (Always a) (a -> p) - | NestedSometimes (Sometimes a) (a -> p) + | forall a. NestedAlways (Always a) (a -> p) + | forall a. NestedSometimes (Sometimes a) (a -> p) data UnitType = SystemUnit | UserUnit deriving (Eq, Show) @@ -226,22 +248,22 @@ sometimesExeArgs :: MonadIO m => String -> Bool -> FilePath -> [String] -> Somet sometimesExeArgs n sys 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 -pathW :: String -> IODependency a p +pathW :: String -> IODependency p pathW n = AccessiblePath n False True -pathRW :: String -> IODependency a p +pathRW :: String -> IODependency p pathRW n = AccessiblePath n True True -------------------------------------------------------------------------------- -- | DBus Dependency Result -data DBusDependency a p = +data DBusDependency p = Bus BusName | Endpoint BusName ObjectPath InterfaceName DBusMember - | DBusIO (IODependency a p) + | DBusIO (IODependency p) data DBusMember = Method_ 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 -- feature. -executeSometimes_ :: MonadIO m => Sometimes (m a) -> m () -executeSometimes_ = void . executeSometimes +executeAlways :: MonadIO m => Always (m a) -> m a +executeAlways = join . evalAlways executeSometimes :: MonadIO m => Sometimes (m a) -> m (Maybe 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 evalSometimes :: MonadIO m => Sometimes a -> m (Maybe a) evalSometimes x = either (const Nothing) (Just . fst) <$> evalSometimesMsg x @@ -285,11 +311,6 @@ evalSometimesMsg x = io $ do TestedSometimes { tsSuccess = s, tsFailed = _ } <- testSometimes x 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 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 -- 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 [] where go failed (Option fd next) = do @@ -320,7 +341,7 @@ testAlways = go [] (SuccessfulFtr s) -> return $ Primary s failed next 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 [] []) where go ts [] = return ts @@ -333,7 +354,7 @@ testSometimes = go (TestedSometimes Nothing [] []) addFail ts@(TestedSometimes { tsFailed = f }) new = 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 atm <- testActionTree t return $ either untestable checkAction atm @@ -346,7 +367,7 @@ testSubfeature fd@(Subfeature { sfTree = t }) = do } 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 case t of (IOTree a d) -> do @@ -365,12 +386,12 @@ testActionTree t = do apply (Standalone a) _ = a apply (Consumer a) p = a p -testIOTree :: Tree (IODependency a p) p - -> IO (ResultTree (IODependency a p) p, Maybe (Maybe p)) +testIOTree :: Tree (IODependency p) p + -> IO (ResultTree (IODependency p) p, Maybe (Maybe p)) testIOTree = testTree testIODependency -testDBusTree :: Client -> Tree (DBusDependency a p) p - -> IO (ResultTree (DBusDependency a p) p, Maybe (Maybe p)) +testDBusTree :: Client -> Tree (DBusDependency p) p + -> IO (ResultTree (DBusDependency p) p, Maybe (Maybe p)) testDBusTree client = testTree (testDBusDependency client) testTree :: Monad m => (d -> m (Summary p)) -> Tree d p @@ -395,7 +416,7 @@ testTree test = go (rb, pb) <- go b 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 where err = Left ["executable '" ++ bin ++ "' not found"] @@ -441,7 +462,7 @@ testIODependency (NestedSometimes x f) = do TestedSometimes { tsSuccess = s, tsFailed = _ } <- testSometimes x 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 ret <- callMethod client queryBus queryPath queryIface queryMem return $ case ret of @@ -493,14 +514,14 @@ testDBusDependency _ (DBusIO d) = testIODependency d -------------------------------------------------------------------------------- -- | Printing -printMsgs :: LogLevel -> [Msg] -> IO () -printMsgs lvl ms = do - pn <- getProgName - mapM_ (printMsg pn lvl) ms +-- printMsgs :: LogLevel -> [Msg] -> IO () +-- printMsgs lvl ms = do +-- pn <- getProgName +-- mapM_ (printMsg pn lvl) ms -printMsg :: String -> LogLevel -> Msg -> IO () -printMsg pname lvl (Msg ml mn msg) - | lvl > ml = putStrLn $ unwords [bracket pname, bracket mn, msg] - | otherwise = skip - where - bracket s = "[" ++ s ++ "]" +-- printMsg :: String -> LogLevel -> Msg -> IO () +-- printMsg pname lvl (Msg ml mn msg) +-- | lvl > ml = putStrLn $ unwords [bracket pname, bracket mn, msg] +-- | otherwise = skip +-- where +-- bracket s = "[" ++ s ++ "]" diff --git a/lib/Xmobar/Plugins/Bluetooth.hs b/lib/Xmobar/Plugins/Bluetooth.hs index 5344fa1..323a7df 100644 --- a/lib/Xmobar/Plugins/Bluetooth.hs +++ b/lib/Xmobar/Plugins/Bluetooth.hs @@ -55,7 +55,7 @@ import Xmobar.Plugins.Common btAlias :: String btAlias = "bluetooth" -btDep :: DBusDep +btDep :: DBusDependency p btDep = Endpoint btBus btOMPath omInterface $ Method_ getManagedObjects data Bluetooth = Bluetooth Icons Colors deriving (Read, Show) diff --git a/lib/Xmobar/Plugins/Device.hs b/lib/Xmobar/Plugins/Device.hs index e0aa723..973faa3 100644 --- a/lib/Xmobar/Plugins/Device.hs +++ b/lib/Xmobar/Plugins/Device.hs @@ -41,7 +41,7 @@ getByIP = memberName_ "GetDeviceByIpIface" devSignal :: String devSignal = "Ip4Connectivity" -devDep :: DBusDep +devDep :: DBusDependency p devDep = Endpoint nmBus nmPath nmInterface $ Method_ getByIP getDevice :: Client -> String -> IO (Maybe ObjectPath) diff --git a/lib/Xmobar/Plugins/VPN.hs b/lib/Xmobar/Plugins/VPN.hs index 48f1bb7..190c62e 100644 --- a/lib/Xmobar/Plugins/VPN.hs +++ b/lib/Xmobar/Plugins/VPN.hs @@ -118,5 +118,5 @@ vpnDeviceTun = "org.freedesktop.NetworkManager.Device.Tun" vpnAlias :: String vpnAlias = "vpn" -vpnDep :: DBusDep +vpnDep :: DBusDependency p vpnDep = Endpoint vpnBus vpnPath omInterface $ Method_ getManagedObjects