From da1e4a1c79122f4db9478befb14796286dbc869e Mon Sep 17 00:00:00 2001 From: ndwarshuis Date: Sun, 21 Nov 2021 10:26:28 -0500 Subject: [PATCH] REF arrange dependency module sanely --- bin/xmobar.hs | 23 +- bin/xmonad.hs | 20 +- lib/XMonad/Internal/Command/DMenu.hs | 17 +- lib/XMonad/Internal/Command/Desktop.hs | 30 +-- lib/XMonad/Internal/Command/Power.hs | 24 +- lib/XMonad/Internal/Concurrent/ACPIEvent.hs | 2 +- lib/XMonad/Internal/Concurrent/Removable.hs | 2 +- lib/XMonad/Internal/DBus/Brightness/Common.hs | 4 +- lib/XMonad/Internal/DBus/Screensaver.hs | 4 +- lib/XMonad/Internal/Dependency.hs | 231 ++++++++++-------- 10 files changed, 193 insertions(+), 164 deletions(-) diff --git a/bin/xmobar.hs b/bin/xmobar.hs index f82b121..e1719a0 100644 --- a/bin/xmobar.hs +++ b/bin/xmobar.hs @@ -40,6 +40,7 @@ import XMonad.Hooks.DynamicLog ) import XMonad.Internal.Command.Power (hasBattery) import XMonad.Internal.DBus.Brightness.IntelBacklight +import XMonad.Internal.Shell -- import XMonad.Internal.DBus.Common (xmonadBus) -- import XMonad.Internal.DBus.Control (pathExists) import XMonad.Internal.DBus.Screensaver (ssSignalDep) @@ -263,7 +264,7 @@ vpnPresent = do where args = ["-c", "no", "-t", "-f", "TYPE", "c", "show"] -rightPlugins :: [IO (MaybeExe CmdSpec)] +rightPlugins :: [IO (MaybeAction CmdSpec)] rightPlugins = [ getWireless , getEthernet @@ -280,21 +281,21 @@ rightPlugins = where nocheck = return . Right -getWireless :: IO (MaybeExe CmdSpec) +getWireless :: IO (MaybeAction CmdSpec) getWireless = do i <- readInterface isWireless return $ maybe (Left []) (Right . wirelessCmd) i -getEthernet :: IO (MaybeExe CmdSpec) +getEthernet :: IO (MaybeAction CmdSpec) getEthernet = do i <- readInterface isEthernet - evalFeature $ maybe BlankFeature (featureRun "ethernet status indicator" [dep] . ethernetCmd) i + evalFeature $ maybe BlankFeature (featureDefault "ethernet status indicator" [dep] . ethernetCmd) i where dep = dbusDep True devBus devPath devInterface $ Method_ devGetByIP getBattery :: BarFeature getBattery = Feature - { ftrAction = batteryCmd + { ftrMaybeAction = batteryCmd , ftrName = "battery level indicator" , ftrWarning = Default , ftrChildren = [IOTest hasBattery] @@ -304,7 +305,7 @@ type BarFeature = Feature CmdSpec getVPN :: BarFeature getVPN = Feature - { ftrAction = vpnCmd + { ftrMaybeAction = vpnCmd , ftrName = "VPN status indicator" , ftrWarning = Default , ftrChildren = [d, v] @@ -315,7 +316,7 @@ getVPN = Feature getBt :: BarFeature getBt = Feature - { ftrAction = btCmd + { ftrMaybeAction = btCmd , ftrName = "bluetooth status indicator" , ftrWarning = Default , ftrChildren = [dep] @@ -325,7 +326,7 @@ getBt = Feature getAlsa :: BarFeature getAlsa = Feature - { ftrAction = alsaCmd + { ftrMaybeAction = alsaCmd , ftrName = "volume level indicator" , ftrWarning = Default , ftrChildren = [Executable "alsactl"] @@ -333,7 +334,7 @@ getAlsa = Feature getBl :: BarFeature getBl = Feature - { ftrAction = blCmd + { ftrMaybeAction = blCmd , ftrName = "Intel backlight indicator" , ftrWarning = Default , ftrChildren = [intelBacklightSignalDep] @@ -341,13 +342,13 @@ getBl = Feature getSs :: BarFeature getSs = Feature - { ftrAction = ssCmd + { ftrMaybeAction = ssCmd , ftrName = "screensaver indicator" , ftrWarning = Default , ftrChildren = [ssSignalDep] } -getAllCommands :: [MaybeExe CmdSpec] -> IO BarRegions +getAllCommands :: [MaybeAction CmdSpec] -> IO BarRegions getAllCommands right = do let left = [ CmdSpec diff --git a/bin/xmonad.hs b/bin/xmonad.hs index bb6df9e..3738976 100644 --- a/bin/xmonad.hs +++ b/bin/xmonad.hs @@ -86,7 +86,7 @@ main = do , tsChildHandles = [h] } lockRes <- evalFeature runScreenLock - let lock = whenInstalled lockRes + let lock = whenSatisfied lockRes ext <- evalExternal $ externalBindings ts lock warnMissing $ externalToMissing ext -- IDK why this is necessary; nothing prior to this line will print if missing @@ -464,13 +464,13 @@ internalBindings c = mkNamedSubmap :: XConfig Layout -> KeyGroup (X ()) -> [((KeyMask, KeySym), NamedAction)] mkNamedSubmap c KeyGroup { kgHeader = h, kgBindings = b } = (subtitle h:) $ mkNamedKeymap c - $ (\KeyBinding{kbSyms = s, kbDesc = d, kbAction = a} -> (s, addName d a)) + $ (\KeyBinding{kbSyms = s, kbDesc = d, kbMaybeAction = a} -> (s, addName d a)) <$> b data KeyBinding a = KeyBinding { kbSyms :: String , kbDesc :: String - , kbAction :: a + , kbMaybeAction :: a } data KeyGroup a = KeyGroup @@ -485,23 +485,23 @@ evalExternal = mapM go (\bs' -> k { kgBindings = bs' }) <$> mapM evalKeyBinding bs evalKeyBinding :: KeyBinding FeatureX -> IO (KeyBinding MaybeX) -evalKeyBinding k@KeyBinding { kbAction = a } = - (\f -> k { kbAction = f }) <$> evalFeature a +evalKeyBinding k@KeyBinding { kbMaybeAction = a } = + (\f -> k { kbMaybeAction = f }) <$> evalFeature a filterExternal :: [KeyGroup MaybeX] -> [KeyGroup (X ())] filterExternal = fmap go where go k@KeyGroup { kgBindings = bs } = k { kgBindings = mapMaybe flagKeyBinding bs } -externalToMissing :: [KeyGroup (MaybeExe a)] -> [MaybeExe a] +externalToMissing :: [KeyGroup (MaybeAction a)] -> [MaybeAction a] externalToMissing = concatMap go where - go KeyGroup { kgBindings = bs } = fmap kbAction bs + go KeyGroup { kgBindings = bs } = fmap kbMaybeAction bs flagKeyBinding :: KeyBinding MaybeX -> Maybe (KeyBinding (X ())) -flagKeyBinding k@KeyBinding{ kbDesc = d, kbAction = a } = case a of - (Right x) -> Just $ k{ kbAction = x } - (Left _) -> Just $ k{ kbDesc = "[!!!]" ++ d, kbAction = skip } +flagKeyBinding k@KeyBinding{ kbDesc = d, kbMaybeAction = a } = case a of + (Right x) -> Just $ k{ kbMaybeAction = x } + (Left _) -> Just $ k{ kbDesc = "[!!!]" ++ d, kbMaybeAction = skip } externalBindings :: ThreadState -> X () -> [KeyGroup FeatureX] externalBindings ts lock = diff --git a/lib/XMonad/Internal/Command/DMenu.hs b/lib/XMonad/Internal/Command/DMenu.hs index eab36b3..6382084 100644 --- a/lib/XMonad/Internal/Command/DMenu.hs +++ b/lib/XMonad/Internal/Command/DMenu.hs @@ -24,6 +24,7 @@ import XMonad.Core hiding (spawn) import XMonad.Internal.Dependency import XMonad.Internal.Notify import XMonad.Internal.Process +import XMonad.Internal.Shell import XMonad.Util.NamedActions -------------------------------------------------------------------------------- @@ -48,7 +49,7 @@ myDmenuNetworks = "networkmanager_dmenu" -- | Other internal functions spawnDmenuCmd :: String -> [String] -> FeatureX -spawnDmenuCmd n = featureSpawnCmd n myDmenuCmd +spawnDmenuCmd n = featureExeArgs n myDmenuCmd themeArgs :: String -> [String] themeArgs hexColor = @@ -63,7 +64,7 @@ myDmenuMatchingArgs = ["-i"] -- case insensitivity -- | Exported Commands runDevMenu :: FeatureX -runDevMenu = featureRun "device manager" [Executable myDmenuDevices] $ do +runDevMenu = featureDefault "device manager" [Executable myDmenuDevices] $ do c <- io $ getXdgDirectory XdgConfig "rofi/devices.yml" spawnCmd myDmenuDevices $ ["-c", c] @@ -71,20 +72,20 @@ runDevMenu = featureRun "device manager" [Executable myDmenuDevices] $ do ++ myDmenuMatchingArgs runBwMenu :: FeatureX -runBwMenu = featureRun "password manager" [Executable myDmenuPasswords] $ +runBwMenu = featureDefault "password manager" [Executable myDmenuPasswords] $ spawnCmd myDmenuPasswords $ ["-c"] ++ themeArgs "#bb6600" ++ myDmenuMatchingArgs -- TODO this is weirdly inverted runShowKeys :: [((KeyMask, KeySym), NamedAction)] -> NamedAction runShowKeys x = addName "Show Keybindings" $ do s <- io $ evalFeature $ runDMenuShowKeys x - ifInstalled s + ifSatisfied s $ spawnNotify $ defNoteError { body = Just $ Text "could not display keymap" } runDMenuShowKeys :: [((KeyMask, KeySym), NamedAction)] -> FeatureX runDMenuShowKeys kbs = - featureRun "keyboard shortcut menu" [Executable myDmenuCmd] $ io $ do + featureDefault "keyboard shortcut menu" [Executable myDmenuCmd] $ io $ do (h, _, _, _) <- createProcess' $ (shell' cmd) { std_in = CreatePipe } forM_ h $ \h' -> hPutStr h' (unlines $ showKm kbs) >> hClose h' where @@ -99,7 +100,7 @@ runAppMenu = spawnDmenuCmd "app launcher" ["-show", "drun"] runClipMenu :: FeatureX runClipMenu = - featureRun "clipboard manager" [Executable myDmenuCmd, Executable "greenclip"] + featureDefault "clipboard manager" [Executable myDmenuCmd, Executable "greenclip"] $ spawnCmd myDmenuCmd args where args = [ "-modi", "\"clipboard:greenclip print\"" @@ -112,8 +113,8 @@ runWinMenu = spawnDmenuCmd "window switcher" ["-show", "window"] runNetMenu :: FeatureX runNetMenu = - featureSpawnCmd "network control menu" myDmenuNetworks $ themeArgs "#ff3333" + featureExeArgs "network control menu" myDmenuNetworks $ themeArgs "#ff3333" runAutorandrMenu :: FeatureX runAutorandrMenu = - featureSpawnCmd "autorandr menu" myDmenuMonitors $ themeArgs "#ff0066" + featureExeArgs "autorandr menu" myDmenuMonitors $ themeArgs "#ff0066" diff --git a/lib/XMonad/Internal/Command/Desktop.hs b/lib/XMonad/Internal/Command/Desktop.hs index be83121..b886b11 100644 --- a/lib/XMonad/Internal/Command/Desktop.hs +++ b/lib/XMonad/Internal/Command/Desktop.hs @@ -91,10 +91,10 @@ ethernetIface = "enp7s0f1" -- | Some nice apps runTerm :: FeatureX -runTerm = featureSpawn "terminal" myTerm +runTerm = featureExe "terminal" myTerm runTMux :: FeatureX -runTMux = featureRun "terminal multiplexer" deps cmd +runTMux = featureDefault "terminal multiplexer" deps cmd where deps = [Executable myTerm, Executable "tmux", Executable "bash"] cmd = spawn @@ -105,25 +105,25 @@ runTMux = featureRun "terminal multiplexer" deps cmd msg = "could not connect to tmux session" runCalc :: FeatureX -runCalc = featureRun "calculator" [Executable myTerm, Executable "R"] +runCalc = featureDefault "calculator" [Executable myTerm, Executable "R"] $ spawnCmd myTerm ["-e", "R"] runBrowser :: FeatureX -runBrowser = featureSpawn "web browser" myBrowser +runBrowser = featureExe "web browser" myBrowser runEditor :: FeatureX -runEditor = featureSpawnCmd "text editor" myEditor +runEditor = featureExeArgs "text editor" myEditor ["-c", "-e", doubleQuote "(select-frame-set-input-focus (selected-frame))"] runFileManager :: FeatureX -runFileManager = featureSpawn "file browser" "pcmanfm" +runFileManager = featureExe "file browser" "pcmanfm" -------------------------------------------------------------------------------- -- | Multimedia Commands runMultimediaIfInstalled :: String -> String -> FeatureX runMultimediaIfInstalled n cmd = - featureSpawnCmd (n ++ " multimedia control") myMultimediaCtl [cmd] + featureExeArgs (n ++ " multimedia control") myMultimediaCtl [cmd] runTogglePlay :: FeatureX runTogglePlay = runMultimediaIfInstalled "play/pause" "play-pause" @@ -151,7 +151,7 @@ playSound file = do featureSound :: String -> FilePath -> X () -> X () -> FeatureX featureSound n file pre post = - featureRun ("volume " ++ n ++ " control") [Executable "paplay"] + featureDefault ("volume " ++ n ++ " control") [Executable "paplay"] $ pre >> playSound file >> post runVolumeDown :: FeatureX @@ -168,7 +168,7 @@ runVolumeMute = featureSound "mute" volumeChangeSound (void toggleMute) $ return runNotificationCmd :: String -> String -> FeatureX runNotificationCmd n cmd = - featureSpawnCmd (n ++ " control") myNotificationCtrl [cmd] + featureExeArgs (n ++ " control") myNotificationCtrl [cmd] runNotificationClose :: FeatureX runNotificationClose = runNotificationCmd "close notification" "close" @@ -190,7 +190,7 @@ runNotificationContext = runToggleBluetooth :: FeatureX runToggleBluetooth = - featureRun "bluetooth toggle" [Executable myBluetooth] + featureDefault "bluetooth toggle" [Executable myBluetooth] $ spawn $ myBluetooth ++ " show | grep -q \"Powered: no\"" #!&& "a=on" @@ -199,7 +199,7 @@ runToggleBluetooth = #!&& fmtNotifyCmd defNoteInfo { body = Just $ Text "bluetooth powered $a" } runToggleEthernet :: FeatureX -runToggleEthernet = featureRun "ethernet toggle" [Executable "nmcli"] +runToggleEthernet = featureDefault "ethernet toggle" [Executable "nmcli"] $ spawn $ "nmcli -g GENERAL.STATE device show " ++ ethernetIface ++ " | grep -q disconnected" #!&& "a=connect" @@ -208,14 +208,14 @@ runToggleEthernet = featureRun "ethernet toggle" [Executable "nmcli"] #!&& fmtNotifyCmd defNoteInfo { body = Just $ Text "ethernet \"$a\"ed" } runStartISyncTimer :: FeatureX -runStartISyncTimer = featureRun "isync timer" [userUnit "mbsync.timer"] +runStartISyncTimer = featureDefault "isync timer" [userUnit "mbsync.timer"] $ spawn $ "systemctl --user start mbsync.timer" #!&& fmtNotifyCmd defNoteInfo { body = Just $ Text "Isync timer started" } #!|| fmtNotifyCmd defNoteError { body = Just $ Text "Isync timer failed to start" } runStartISyncService :: FeatureX -runStartISyncService = featureRun "isync" [userUnit "mbsync.service"] +runStartISyncService = featureDefault "isync" [userUnit "mbsync.service"] $ spawn $ "systemctl --user start mbsync.service" #!&& fmtNotifyCmd defNoteInfo { body = Just $ Text "Isync completed" } @@ -260,7 +260,7 @@ getCaptureDir = do fallback = ( ".local/share") <$> getHomeDirectory runFlameshot :: String -> String -> FeatureX -runFlameshot n mode = featureRun n [Executable myCapture] $ do +runFlameshot n mode = featureDefault n [Executable myCapture] $ do ssDir <- io getCaptureDir spawnCmd myCapture $ mode : ["-p", ssDir] @@ -279,6 +279,6 @@ runScreenCapture = runFlameshot "screen capture" "screen" runCaptureBrowser :: FeatureX runCaptureBrowser = - featureRun "screen capture browser" [Executable myImageBrowser] $ do + featureDefault "screen capture browser" [Executable myImageBrowser] $ do dir <- io getCaptureDir spawnCmd myImageBrowser [dir] diff --git a/lib/XMonad/Internal/Command/Power.hs b/lib/XMonad/Internal/Command/Power.hs index 367dc08..54fea83 100644 --- a/lib/XMonad/Internal/Command/Power.hs +++ b/lib/XMonad/Internal/Command/Power.hs @@ -46,7 +46,7 @@ myOptimusManager = "optimus-manager" -- | Core commands runScreenLock :: Feature (X ()) -runScreenLock = featureSpawn "screen locker" myScreenlock +runScreenLock = featureExe "screen locker" myScreenlock runPowerOff :: X () runPowerOff = spawn "systemctl poweroff" @@ -101,24 +101,24 @@ runOptimusPrompt' = do #!&& "killall xmonad" runOptimusPrompt :: FeatureX -runOptimusPrompt = featureRun "graphics switcher" [Executable myOptimusManager] +runOptimusPrompt = featureDefault "graphics switcher" [Executable myOptimusManager] runOptimusPrompt' -------------------------------------------------------------------------------- -- | Universal power prompt -data PowerAction = Poweroff +data PowerMaybeAction = Poweroff | Shutdown | Hibernate | Reboot deriving (Eq) -instance Enum PowerAction where +instance Enum PowerMaybeAction where toEnum 0 = Poweroff toEnum 1 = Shutdown toEnum 2 = Hibernate toEnum 3 = Reboot - toEnum _ = errorWithoutStackTrace "Main.Enum.PowerAction.toEnum: bad argument" + toEnum _ = errorWithoutStackTrace "Main.Enum.PowerMaybeAction.toEnum: bad argument" fromEnum Poweroff = 0 fromEnum Shutdown = 1 @@ -131,22 +131,22 @@ instance XPrompt PowerPrompt where showXPrompt PowerPrompt = "(P)oweroff (S)uspend (H)ibernate (R)eboot:" runPowerPrompt :: X () -> X () -runPowerPrompt lock = mkXPrompt PowerPrompt theme comp executeAction +runPowerPrompt lock = mkXPrompt PowerPrompt theme comp executeMaybeAction where comp = mkComplFunFromList [] theme = T.promptTheme { promptKeymap = keymap } keymap = M.fromList $ ((controlMask, xK_g), quit) : map (first $ (,) 0) - [ (xK_p, sendAction Poweroff) - , (xK_s, sendAction Shutdown) - , (xK_h, sendAction Hibernate) - , (xK_r, sendAction Reboot) + [ (xK_p, sendMaybeAction Poweroff) + , (xK_s, sendMaybeAction Shutdown) + , (xK_h, sendMaybeAction Hibernate) + , (xK_r, sendMaybeAction Reboot) , (xK_Return, quit) , (xK_Escape, quit) ] - sendAction a = setInput (show $ fromEnum a) >> setSuccess True >> setDone True - executeAction a = case toEnum $ read a of + sendMaybeAction a = setInput (show $ fromEnum a) >> setSuccess True >> setDone True + executeMaybeAction a = case toEnum $ read a of Poweroff -> runPowerOff Shutdown -> lock >> runSuspend Hibernate -> lock >> runHibernate diff --git a/lib/XMonad/Internal/Concurrent/ACPIEvent.hs b/lib/XMonad/Internal/Concurrent/ACPIEvent.hs index fa8c165..f6e3155 100644 --- a/lib/XMonad/Internal/Concurrent/ACPIEvent.hs +++ b/lib/XMonad/Internal/Concurrent/ACPIEvent.hs @@ -95,7 +95,7 @@ acpiPath = "/var/run/acpid.socket" -- | Spawn a new thread that will listen for ACPI events on the acpid socket -- and send ClientMessage events when it receives them runPowermon :: FeatureIO -runPowermon = featureRun "ACPI event monitor" [pathR acpiPath] listenACPI +runPowermon = featureDefault "ACPI event monitor" [pathR acpiPath] listenACPI -- | Handle ClientMessage event containing and ACPI event (to be used in -- Xmonad's event hook) diff --git a/lib/XMonad/Internal/Concurrent/Removable.hs b/lib/XMonad/Internal/Concurrent/Removable.hs index 7501a0d..3d12a64 100644 --- a/lib/XMonad/Internal/Concurrent/Removable.hs +++ b/lib/XMonad/Internal/Concurrent/Removable.hs @@ -86,4 +86,4 @@ listenDevices = do runRemovableMon :: FeatureIO runRemovableMon = - featureRun "removeable device monitor" [addedDep, removedDep] listenDevices + featureDefault "removeable device monitor" [addedDep, removedDep] listenDevices diff --git a/lib/XMonad/Internal/DBus/Brightness/Common.hs b/lib/XMonad/Internal/DBus/Brightness/Common.hs index ae8484c..7f461d4 100644 --- a/lib/XMonad/Internal/DBus/Brightness/Common.hs +++ b/lib/XMonad/Internal/DBus/Brightness/Common.hs @@ -89,7 +89,7 @@ matchSignal BrightnessConfig { bcPath = p, bcInterface = i } cb = do brightnessExporter :: RealFrac b => [Dependency] -> BrightnessConfig a b -> Client -> FeatureIO brightnessExporter deps bc@BrightnessConfig { bcName = n } client = Feature - { ftrAction = exportBrightnessControls' bc client + { ftrMaybeAction = exportBrightnessControls' bc client , ftrName = n ++ " exporter" , ftrWarning = Default , ftrChildren = DBusBus xmonadBus:deps @@ -133,7 +133,7 @@ emitBrightness BrightnessConfig{ bcPath = p, bcInterface = i } client cur = callBacklight :: BrightnessConfig a b -> String -> MemberName -> FeatureIO callBacklight BrightnessConfig { bcPath = p, bcInterface = i, bcName = n } controlName m = Feature - { ftrAction = void $ callMethod $ methodCall p i m + { ftrMaybeAction = void $ callMethod $ methodCall p i m , ftrName = unwords [n, controlName] , ftrWarning = Default , ftrChildren = [xDbusDep p i $ Method_ m] diff --git a/lib/XMonad/Internal/DBus/Screensaver.hs b/lib/XMonad/Internal/DBus/Screensaver.hs index 28453e5..d272aa5 100644 --- a/lib/XMonad/Internal/DBus/Screensaver.hs +++ b/lib/XMonad/Internal/DBus/Screensaver.hs @@ -95,7 +95,7 @@ bodyGetCurrentState _ = Nothing exportScreensaver :: Client -> FeatureIO exportScreensaver client = Feature - { ftrAction = cmd + { ftrMaybeAction = cmd , ftrName = "screensaver interface" , ftrWarning = Default , ftrChildren = [Executable ssExecutable, DBusBus xmonadBus] @@ -122,7 +122,7 @@ exportScreensaver client = Feature callToggle :: FeatureIO callToggle = Feature - { ftrAction = cmd + { ftrMaybeAction = cmd , ftrName = "screensaver toggle" , ftrWarning = Default , ftrChildren = [xDbusDep ssPath interface $ Method_ memToggle] diff --git a/lib/XMonad/Internal/Dependency.hs b/lib/XMonad/Internal/Dependency.hs index 32f4cd5..1836f21 100644 --- a/lib/XMonad/Internal/Dependency.hs +++ b/lib/XMonad/Internal/Dependency.hs @@ -2,17 +2,17 @@ -- | Functions for handling dependencies module XMonad.Internal.Dependency - ( MaybeExe - , UnitType(..) - , Dependency(..) - , Bus(..) - , Endpoint(..) - , DBusMember(..) - , Warning(..) + ( MaybeAction , MaybeX , FeatureX , FeatureIO , Feature(..) + , Warning(..) + , Dependency(..) + , UnitType(..) + , Bus(..) + , Endpoint(..) + , DBusMember(..) , ioFeature , evalFeature , systemUnit @@ -20,14 +20,12 @@ module XMonad.Internal.Dependency , pathR , pathW , pathRW - , featureRun - , featureSpawnCmd - , featureSpawn + , featureDefault + , featureExeArgs + , featureExe , warnMissing - , whenInstalled - , ifInstalled - , fmtCmd - , spawnCmd + , whenSatisfied + , ifSatisfied , executeFeature , executeFeature_ , applyFeature @@ -54,51 +52,71 @@ import XMonad.Internal.Process import XMonad.Internal.Shell -------------------------------------------------------------------------------- --- | Gracefully handling missing binaries - -data UnitType = SystemUnit | UserUnit deriving (Eq, Show) - -data DBusMember = Method_ MemberName - | Signal_ MemberName - | Property_ String - deriving (Eq, Show) - -data Bus = Bus Bool BusName deriving (Eq, Show) - -data Endpoint = Endpoint ObjectPath InterfaceName DBusMember deriving (Eq, Show) - -data Dependency = Executable String - | AccessiblePath FilePath Bool Bool - | IOTest (IO (Maybe String)) - | DBusEndpoint Bus Endpoint - | DBusBus Bus - | Systemd UnitType String - -data Warning = Silent | Default +-- | Features +-- +-- A 'feature' is an 'action' (usually an IO ()) that requires one or more +-- 'dependencies'. Features also have a useful name and an error logging +-- protocol. +-- +-- NOTE: there is no way to make a feature depend on another feature. This is +-- very complicated to implement and would only be applicable to a few instances +-- (notable the dbus interfaces). In order to implement a dependency tree, use +-- 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 - { ftrAction :: a - , ftrName :: String - , ftrWarning :: Warning - , ftrChildren :: [Dependency] + { ftrMaybeAction :: a + , ftrName :: String + , ftrWarning :: Warning + , ftrChildren :: [Dependency] } | ConstFeature a | BlankFeature +-- TODO this is silly as is, and could be made more useful by representing +-- loglevels +data Warning = Silent | Default + type FeatureX = Feature (X ()) type FeatureIO = Feature (IO ()) ioFeature :: (MonadIO m) => Feature (IO a) -> Feature (m a) -ioFeature f@Feature { ftrAction = a } = f { ftrAction = liftIO a } -ioFeature (ConstFeature f) = ConstFeature $ liftIO f -ioFeature BlankFeature = BlankFeature +ioFeature f@Feature { ftrMaybeAction = a } = f { ftrMaybeAction = liftIO a } +ioFeature (ConstFeature f) = ConstFeature $ liftIO f +ioFeature BlankFeature = BlankFeature -evalFeature :: Feature a -> IO (MaybeExe a) +featureDefault :: String -> [Dependency] -> a -> Feature a +featureDefault n ds x = Feature + { ftrMaybeAction = x + , ftrName = n + , ftrWarning = Default + , ftrChildren = ds + } + +featureExe :: MonadIO m => String -> String -> Feature (m ()) +featureExe n cmd = featureExeArgs n cmd [] + +featureExeArgs :: MonadIO m => String -> String -> [String] -> Feature (m ()) +featureExeArgs n cmd args = + featureDefault n [Executable cmd] $ spawnCmd cmd args + +-------------------------------------------------------------------------------- +-- | Feature evaluation +-- +-- Evaluate a feature by testing if its dependencies are satisfied, and return +-- either the action of the feature or 0 or more error messages that signify +-- what dependencies are missing and why. + +type MaybeAction a = Either [String] a + +type MaybeX = MaybeAction (X ()) + +evalFeature :: Feature a -> IO (MaybeAction a) evalFeature (ConstFeature x) = return $ Right x evalFeature BlankFeature = return $ Left [] evalFeature Feature - { ftrAction = a + { ftrMaybeAction = a , ftrName = n , ftrWarning = w , ftrChildren = c @@ -113,6 +131,48 @@ evalFeature Feature Silent -> [] Default -> fmap (fmtMsg procName "WARNING" . ((n ++ " disabled; ") ++)) es +applyFeature :: MonadIO m => (m a -> m a) -> a -> Feature (IO a) -> m a +applyFeature iof def ftr = do + a <- io $ evalFeature ftr + either (\es -> io $ warnMissing' es >> return def) (iof . io) a + +applyFeature_ :: MonadIO m => (m () -> m ()) -> Feature (IO ()) -> m () +applyFeature_ iof = applyFeature iof () + +executeFeature :: MonadIO m => a -> Feature (IO a) -> m a +executeFeature = applyFeature id + +executeFeature_ :: Feature (IO ()) -> IO () +executeFeature_ = executeFeature () + +whenSatisfied :: Monad m => MaybeAction (m ()) -> m () +whenSatisfied = flip ifSatisfied skip + +ifSatisfied :: MaybeAction a -> a -> a +ifSatisfied (Right x) _ = x +ifSatisfied _ alt = alt + +-------------------------------------------------------------------------------- +-- | Dependencies + +data Dependency = Executable String + | AccessiblePath FilePath Bool Bool + | IOTest (IO (Maybe String)) + | DBusEndpoint Bus Endpoint + | DBusBus Bus + | Systemd UnitType String + +data UnitType = SystemUnit | UserUnit deriving (Eq, Show) + +data DBusMember = Method_ MemberName + | Signal_ MemberName + | Property_ String + deriving (Eq, Show) + +data Bus = Bus Bool BusName deriving (Eq, Show) + +data Endpoint = Endpoint ObjectPath InterfaceName DBusMember deriving (Eq, Show) + pathR :: String -> Dependency pathR n = AccessiblePath n True False @@ -128,35 +188,29 @@ systemUnit = Systemd SystemUnit userUnit :: String -> Dependency userUnit = Systemd UserUnit --- TODO this is poorly named. This actually represents an action that has --- one or more dependencies (where "action" is not necessarily executing an exe) -type MaybeExe a = Either [String] a +-------------------------------------------------------------------------------- +-- | Dependency evaluation +-- +-- Test the existence of dependencies and return either Nothing (which actually +-- means success) or Just . -type MaybeX = MaybeExe (X ()) +evalDependency :: Dependency -> IO (Maybe String) +evalDependency (Executable n) = exeSatisfied n +evalDependency (IOTest t) = t +evalDependency (Systemd t n) = unitSatisfied t n +evalDependency (AccessiblePath p r w) = pathSatisfied p r w +evalDependency (DBusEndpoint b e) = endpointSatisfied b e +evalDependency (DBusBus b) = busSatisfied b -featureRun :: String -> [Dependency] -> a -> Feature a -featureRun n ds x = Feature - { ftrAction = x - , ftrName = n - , ftrWarning = Default - , ftrChildren = ds - } - -featureSpawnCmd :: MonadIO m => String -> String -> [String] -> Feature (m ()) -featureSpawnCmd n cmd args = featureRun n [Executable cmd] $ spawnCmd cmd args - -featureSpawn :: MonadIO m => String -> String -> Feature (m ()) -featureSpawn n cmd = featureSpawnCmd n cmd [] - -exeInstalled :: String -> IO (Maybe String) -exeInstalled x = do +exeSatisfied :: String -> IO (Maybe String) +exeSatisfied x = do r <- findExecutable x return $ case r of (Just _) -> Nothing _ -> Just $ "executable '" ++ x ++ "' not found" -unitInstalled :: UnitType -> String -> IO (Maybe String) -unitInstalled u x = do +unitSatisfied :: UnitType -> String -> IO (Maybe String) +unitSatisfied u x = do (rc, _, _) <- readCreateProcessWithExitCode' (shell cmd) "" return $ case rc of ExitSuccess -> Nothing @@ -166,8 +220,8 @@ unitInstalled u x = do unitType SystemUnit = "system" unitType UserUnit = "user" -pathAccessible :: FilePath -> Bool -> Bool -> IO (Maybe String) -pathAccessible p testread testwrite = do +pathSatisfied :: FilePath -> Bool -> Bool -> IO (Maybe String) +pathSatisfied p testread testwrite = do res <- getPermissionsSafe p let msg = permMsg res return msg @@ -197,8 +251,8 @@ callMethod (Bus usesys bus) path iface mem = do disconnect client return $ bimap methodErrorMessage methodReturnBody reply -dbusBusExists :: Bus -> IO (Maybe String) -dbusBusExists (Bus usesystem bus) = do +busSatisfied :: Bus -> IO (Maybe String) +busSatisfied (Bus usesystem bus) = do ret <- callMethod (Bus usesystem queryBus) queryPath queryIface queryMem return $ case ret of Left e -> Just e @@ -214,8 +268,8 @@ dbusBusExists (Bus usesystem bus) = do bodyGetNames [v] = fromMaybe [] $ fromVariant v :: [String] bodyGetNames _ = [] -dbusEndpointExists :: Bus -> Endpoint -> IO (Maybe String) -dbusEndpointExists b@(Bus _ bus) (Endpoint objpath iface mem) = do +endpointSatisfied :: Bus -> Endpoint -> IO (Maybe String) +endpointSatisfied b@(Bus _ bus) (Endpoint objpath iface mem) = do ret <- callMethod b objpath introspectInterface introspectMethod return $ case ret of Left e -> Just e @@ -245,43 +299,16 @@ dbusEndpointExists b@(Bus _ bus) (Endpoint objpath iface mem) = do , formatBusName bus ] -evalDependency :: Dependency -> IO (Maybe String) -evalDependency (Executable n) = exeInstalled n -evalDependency (IOTest t) = t -evalDependency (Systemd t n) = unitInstalled t n -evalDependency (AccessiblePath p r w) = pathAccessible p r w -evalDependency (DBusEndpoint b e) = dbusEndpointExists b e -evalDependency (DBusBus b) = dbusBusExists b +-------------------------------------------------------------------------------- +-- | Logging functions -whenInstalled :: Monad m => MaybeExe (m ()) -> m () -whenInstalled = flip ifInstalled skip - -ifInstalled :: MaybeExe a -> a -> a -ifInstalled (Right x) _ = x -ifInstalled _ alt = alt - -warnMissing :: [MaybeExe a] -> IO () +warnMissing :: [MaybeAction a] -> IO () warnMissing xs = warnMissing' $ concat $ [ m | (Left m) <- xs ] warnMissing' :: [String] -> IO () warnMissing' = mapM_ putStrLn -applyFeature :: MonadIO m => (m a -> m a) -> a -> Feature (IO a) -> m a -applyFeature iof def ftr = do - a <- io $ evalFeature ftr - either (\es -> io $ warnMissing' es >> return def) (iof . io) a - -applyFeature_ :: MonadIO m => (m () -> m ()) -> Feature (IO ()) -> m () -applyFeature_ iof = applyFeature iof () - -executeFeature :: MonadIO m => a -> Feature (IO a) -> m a -executeFeature = applyFeature id - -executeFeature_ :: Feature (IO ()) -> IO () -executeFeature_ = executeFeature () - fmtMsg :: String -> String -> String -> String fmtMsg procName level msg = unwords [bracket procName, bracket level, msg] where bracket s = "[" ++ s ++ "]" -