ENH use features in external keymap

bin/xmobar.hs

@@ -306,7 +306,7 @@ getWireless = do
 getEthernet :: IO (MaybeExe CmdSpec)
 getEthernet = do
   i <- readInterface isEthernet
-  maybe (return $ Left []) (runIfInstalled [dep] . ethernetCmd) i
+  evalFeature $ maybe BlankFeature (featureRun [dep] . ethernetCmd) i
   where
     dep = dbusDep True devBus devPath devInterface $ Method_ devGetByIP
 

bin/xmonad.hs

@@ -9,7 +9,6 @@ module Main (main) where
 import           Control.Concurrent
 import           Control.Monad                                (unless)
 
-import           Data.Either                                  (fromRight)
 import           Data.List
     ( isPrefixOf
     , sortBy
@@ -74,7 +73,7 @@ main = do
     , dxScreensaverCtrl = sc
     } <- startXMonadService
   (h, p) <- spawnPipe "xmobar"
-  depActions <- sequence [runPowermon, runRemovableMon]
+  depActions <- mapM evalFeature [runPowermon, runRemovableMon]
   mapM_ (mapM_ forkIO) depActions
   _ <- forkIO $ runWorkspaceMon allDWs
   let ts = ThreadState
@@ -82,7 +81,7 @@ main = do
         , childPIDs = [p]
         , childHandles = [h]
         }
-  lock <- fromRight skip <$> evalFeature runScreenLock
+  lock <- whenInstalled <$> evalFeature runScreenLock
   ext <- evalExternal $ externalBindings bc sc ts lock
   warnMissing $ externalToMissing ext ++ fmap (io <$>) depActions
   -- IDK why this is necessary; nothing prior to this line will print if missing
@@ -472,28 +471,20 @@ data KeyGroup a = KeyGroup
   , kgBindings :: [KeyBinding a]
   }
 
-evalExternal :: [KeyGroup (IO MaybeX)] -> 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 :: Monad m => KeyBinding (m a) -> m (KeyBinding a)
+evalKeyBinding :: KeyBinding FeatureX -> IO (KeyBinding MaybeX)
-evalKeyBinding k@KeyBinding { kbAction = a } = (\b -> k { kbAction = b }) <$> a
+evalKeyBinding k@KeyBinding { kbAction = a } =
+  (\f -> k { kbAction = f }) <$> evalFeature a
 
 filterExternal :: [KeyGroup MaybeX] -> [KeyGroup (X ())]
 filterExternal = fmap go
   where
     go k@KeyGroup { kgBindings = bs } = k { kgBindings = mapMaybe flagKeyBinding bs }
-    -- go k@KeyGroup { kgBindings = bs } =
-    --   ( k { kgBindings = mapMaybe flagKeyBinding bs }
-    --   , concatMap go' bs
-    --   )
-    -- go' KeyBinding{ kbAction = a } = case a of
-    --   Installed _ opt ->  opt
-    --   -- TODO this will mash together the optional and required deps
-    --   Missing req opt ->  req ++ opt
-    --   Ignore          ->  []
 
 externalToMissing :: [KeyGroup (MaybeExe a)] -> [MaybeExe a]
 externalToMissing = concatMap go
@@ -504,10 +495,9 @@ 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 }
-  -- _                     -> Nothing
 
 externalBindings :: BrightnessControls -> SSControls -> ThreadState -> X ()
-  -> [KeyGroup (IO MaybeX)]
+  -> [KeyGroup FeatureX]
 externalBindings bc sc ts lock =
   [ KeyGroup "Launchers"
     [ KeyBinding "<XF86Search>" "select/launch app" runAppMenu
@@ -525,9 +515,9 @@ externalBindings bc sc ts lock =
     ]
 
   , KeyGroup "Actions"
-    [ KeyBinding "M-q" "close window" $ noCheck kill1
+    [ KeyBinding "M-q" "close window" $ ConstFeature kill1
     , KeyBinding "M-r" "run program" runCmdMenu
-    , KeyBinding "M-<Space>" "warp pointer" $ noCheck $ warpToWindow 0.5 0.5
+    , KeyBinding "M-<Space>" "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
@@ -553,28 +543,22 @@ externalBindings bc sc ts lock =
     ]
 
   , KeyGroup "System"
-    [ KeyBinding "M-." "backlight up" $ return $ io <$> bctlInc bc
+    [ KeyBinding "M-." "backlight up" $ ioFeature $ bctlInc bc
-    , KeyBinding "M-," "backlight down" $ return $ io <$> bctlDec bc
+    , KeyBinding "M-," "backlight down" $ ioFeature $ bctlDec bc
-    , KeyBinding "M-M1-," "backlight min" $ return $ io <$> bctlMin bc
+    , KeyBinding "M-M1-," "backlight min" $ ioFeature $ bctlMin bc
-    , KeyBinding "M-M1-." "backlight max" $ return $ io <$> bctlMax bc
+    , KeyBinding "M-M1-." "backlight max" $ ioFeature $ bctlMax bc
-    , KeyBinding "M-<End>" "power menu" $ noCheck $ runPowerPrompt lock
+    , KeyBinding "M-<End>" "power menu" $ ConstFeature $ runPowerPrompt lock
-    , KeyBinding "M-<Home>" "quit xmonad" $ noCheck runQuitPrompt
+    , KeyBinding "M-<Home>" "quit xmonad" $ ConstFeature runQuitPrompt
-    -- TODO this won't be aware of when the lock doesn't exist
+    , KeyBinding "M-<Delete>" "lock screen" runScreenLock
-    , KeyBinding "M-<Delete>" "lock screen" $ noCheck lock
     -- M-<F1> reserved for showing the keymap
-    , KeyBinding "M-<F2>" "restart xmonad" $ noCheck (runCleanup ts >> runRestart)
+    , KeyBinding "M-<F2>" "restart xmonad" $ ConstFeature (runCleanup ts >> runRestart)
-    , KeyBinding "M-<F3>" "recompile xmonad" $ noCheck runRecompile
+    , KeyBinding "M-<F3>" "recompile xmonad" $ ConstFeature runRecompile
     , KeyBinding "M-<F7>" "start Isync Service" runStartISyncService
     , KeyBinding "M-C-<F7>" "start Isync Timer" runStartISyncTimer
     , KeyBinding "M-<F8>" "select autorandr profile" runAutorandrMenu
     , KeyBinding "M-<F9>" "toggle ethernet" runToggleEthernet
     , KeyBinding "M-<F10>" "toggle bluetooth" runToggleBluetooth
-    , KeyBinding "M-<F11>" "toggle screensaver" $ return $ io <$> ssToggle sc
+    , KeyBinding "M-<F11>" "toggle screensaver" $ ioFeature $ ssToggle sc
     , KeyBinding "M-<F12>" "switch gpu" runOptimusPrompt
     ]
   ]
-  -- where
-    -- TODO this is hacky, I shouldn't really need this data structure for
-    -- something that doesn't depend on executables
-    -- runMaybe c f = return $ maybe Ignore (\x -> Installed (io $ f x) []) c
-

lib/XMonad/Internal/Command/DMenu.hs

@@ -47,8 +47,8 @@ myDmenuNetworks = "networkmanager_dmenu"
 --------------------------------------------------------------------------------
 -- | Other internal functions
 
-spawnDmenuCmd :: [String] -> IO MaybeX
+spawnDmenuCmd :: [String] -> FeatureX
-spawnDmenuCmd = spawnCmdIfInstalled myDmenuCmd
+spawnDmenuCmd = featureSpawnCmd myDmenuCmd
 
 themeArgs :: String -> [String]
 themeArgs hexColor =
@@ -62,41 +62,42 @@ myDmenuMatchingArgs = ["-i"] -- case insensitivity
 --------------------------------------------------------------------------------
 -- | Exported Commands
 
-runDevMenu :: IO MaybeX
+runDevMenu :: FeatureX
-runDevMenu = runIfInstalled [exe myDmenuDevices] $ do
+runDevMenu = featureRun [exe myDmenuDevices] $ do
   c <- io $ getXdgDirectory XdgConfig "rofi/devices.yml"
   spawnCmd myDmenuDevices
     $ ["-c", c]
     ++ "--" : themeArgs "#999933"
     ++ myDmenuMatchingArgs
 
-runBwMenu :: IO MaybeX
+runBwMenu :: FeatureX
-runBwMenu = runIfInstalled [exe myDmenuPasswords] $
+runBwMenu = featureRun [exe 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 $ runDMenuShowKeys x
+  s <- io $ evalFeature $ runDMenuShowKeys x
   ifInstalled s
     $ spawnNotify
     $ defNoteError { body = Just $ Text "could not display keymap" }
 
-runDMenuShowKeys :: [((KeyMask, KeySym), NamedAction)] -> IO MaybeX
+runDMenuShowKeys :: [((KeyMask, KeySym), NamedAction)] -> FeatureX
-runDMenuShowKeys kbs = runIfInstalled [exe myDmenuCmd] $ io $ do
+runDMenuShowKeys kbs = featureRun [exe myDmenuCmd] $ io $ do
   (h, _, _, _) <- createProcess' $ (shell' cmd) { std_in = CreatePipe }
   forM_ h $ \h' -> hPutStr h' (unlines $ showKm kbs) >> hClose h'
   where
     cmd = fmtCmd myDmenuCmd $ ["-dmenu", "-p", "commands"]
       ++ themeArgs "#7f66ff" ++ myDmenuMatchingArgs
 
-runCmdMenu :: IO MaybeX
+runCmdMenu :: FeatureX
 runCmdMenu = spawnDmenuCmd ["-show", "run"]
 
-runAppMenu :: IO MaybeX
+runAppMenu :: FeatureX
 runAppMenu = spawnDmenuCmd ["-show", "drun"]
 
-runClipMenu :: IO MaybeX
+runClipMenu :: FeatureX
-runClipMenu = runIfInstalled [exe myDmenuCmd, exe "greenclip"]
+runClipMenu = featureRun [exe myDmenuCmd, exe "greenclip"]
   $ spawnCmd myDmenuCmd args
   where
     args = [ "-modi", "\"clipboard:greenclip print\""
@@ -104,11 +105,11 @@ runClipMenu = runIfInstalled [exe myDmenuCmd, exe "greenclip"]
            , "-run-command", "'{cmd}'"
            ] ++ themeArgs "#00c44e"
 
-runWinMenu :: IO MaybeX
+runWinMenu :: FeatureX
 runWinMenu = spawnDmenuCmd ["-show", "window"]
 
-runNetMenu :: IO MaybeX
+runNetMenu :: FeatureX
-runNetMenu = spawnCmdIfInstalled myDmenuNetworks $ themeArgs "#ff3333"
+runNetMenu = featureSpawnCmd myDmenuNetworks $ themeArgs "#ff3333"
 
-runAutorandrMenu :: IO MaybeX
+runAutorandrMenu :: FeatureX
-runAutorandrMenu = spawnCmdIfInstalled myDmenuMonitors $ themeArgs "#ff0066"
+runAutorandrMenu = featureSpawnCmd myDmenuMonitors $ themeArgs "#ff0066"

lib/XMonad/Internal/Command/Desktop.hs

@@ -17,7 +17,6 @@ module XMonad.Internal.Command.Desktop
   , runVolumeUp
   , runVolumeMute
   , runToggleBluetooth
-  -- , runToggleDPMS
   , runToggleEthernet
   , runRestart
   , runRecompile
@@ -31,9 +30,11 @@ module XMonad.Internal.Command.Desktop
   , runNotificationCloseAll
   , runNotificationHistory
   , runNotificationContext
+  , playSound
   ) where
 
 import           Control.Monad              (void)
+import           Control.Monad.IO.Class
 
 import           System.Directory
     ( createDirectoryIfMissing
@@ -44,10 +45,10 @@ import           System.FilePath
 
 import           XMonad.Actions.Volume
 import           XMonad.Core                hiding (spawn)
--- import           XMonad.Internal.DBus.Screensaver
 import           XMonad.Internal.Dependency
 import           XMonad.Internal.Notify
 import           XMonad.Internal.Process
+import           XMonad.Internal.Shell
 import           XMonad.Operations
 
 --------------------------------------------------------------------------------
@@ -89,15 +90,11 @@ ethernetIface = "enp7s0f1"
 --------------------------------------------------------------------------------
 -- | Some nice apps
 
-runTerm :: IO MaybeX
+runTerm :: FeatureX
-runTerm = spawnIfInstalled myTerm
+runTerm = featureSpawn myTerm
 
-runTMux :: IO MaybeX
+runTMux :: FeatureX
-runTMux = evalFeature $ Feature
+runTMux = featureRun [exe myTerm, exe "tmux", exe "bash"] cmd
-  { ftrAction = cmd
-  , ftrSilent = False
-  , ftrChildren  = [exe myTerm, exe "tmux", exe "bash"]
-  }
   where
     cmd = spawn
       $ "tmux has-session"
@@ -106,95 +103,108 @@ runTMux = evalFeature $ Feature
     c = "exec tmux attach-session -d"
     msg = "could not connect to tmux session"
 
-runCalc :: IO MaybeX
+runCalc :: FeatureX
-runCalc = runIfInstalled [exe myTerm, exe "R"] $ spawnCmd myTerm ["-e", "R"]
+runCalc = featureRun [exe myTerm, exe "R"] $ spawnCmd myTerm ["-e", "R"]
 
-runBrowser :: IO MaybeX
+runBrowser :: FeatureX
-runBrowser = spawnIfInstalled myBrowser
+runBrowser = featureSpawn myBrowser
 
-runEditor :: IO MaybeX
+runEditor :: FeatureX
-runEditor = spawnCmdIfInstalled myEditor
+runEditor = featureSpawnCmd myEditor
   ["-c", "-e", doubleQuote "(select-frame-set-input-focus (selected-frame))"]
 
-runFileManager :: IO MaybeX
+runFileManager :: FeatureX
-runFileManager = spawnIfInstalled "pcmanfm"
+runFileManager = featureSpawn "pcmanfm"
 
 --------------------------------------------------------------------------------
 -- | Multimedia Commands
 
-runMultimediaIfInstalled :: String -> IO MaybeX
+runMultimediaIfInstalled :: String -> FeatureX
-runMultimediaIfInstalled cmd = spawnCmdIfInstalled myMultimediaCtl [cmd]
+runMultimediaIfInstalled cmd = featureSpawnCmd myMultimediaCtl [cmd]
 
-runTogglePlay :: IO MaybeX
+runTogglePlay :: FeatureX
 runTogglePlay = runMultimediaIfInstalled "play-pause"
 
-runPrevTrack :: IO MaybeX
+runPrevTrack :: FeatureX
 runPrevTrack = runMultimediaIfInstalled "previous"
 
-runNextTrack :: IO MaybeX
+runNextTrack :: FeatureX
 runNextTrack = runMultimediaIfInstalled "next"
 
-runStopPlay :: IO MaybeX
+runStopPlay :: FeatureX
 runStopPlay = runMultimediaIfInstalled "stop"
 
-runVolumeDown :: IO MaybeX
+--------------------------------------------------------------------------------
-runVolumeDown =  spawnSound volumeChangeSound (return ()) $ void (lowerVolume 2)
+-- | Volume Commands
 
-runVolumeUp :: IO MaybeX
+soundDir :: FilePath
-runVolumeUp = spawnSound volumeChangeSound (return ()) $ void (raiseVolume 2)
+soundDir = "sound"
 
-runVolumeMute :: IO MaybeX
+playSound :: MonadIO m => FilePath -> m ()
-runVolumeMute = spawnSound volumeChangeSound (void toggleMute) $ return ()
+playSound file = do
+  p <- (</> soundDir </> file) <$> getXMonadDir
+  -- paplay seems to have less latency than aplay
+  spawnCmd "paplay" [p]
+
+featureSound :: FilePath -> X () -> X () -> FeatureX
+featureSound file pre post = featureRun [exe "paplay"]
+  $ pre >> playSound file >> post
+
+runVolumeDown :: FeatureX
+runVolumeDown = featureSound volumeChangeSound (return ()) $ void (lowerVolume 2)
+
+runVolumeUp :: FeatureX
+runVolumeUp = featureSound volumeChangeSound (return ()) $ void (raiseVolume 2)
+
+runVolumeMute :: FeatureX
+runVolumeMute = featureSound volumeChangeSound (void toggleMute) $ return ()
 
 --------------------------------------------------------------------------------
 -- | Notification control
 
-runNotificationCmd :: String -> IO MaybeX
+runNotificationCmd :: String -> FeatureX
-runNotificationCmd cmd = spawnCmdIfInstalled myNotificationCtrl [cmd]
+runNotificationCmd cmd = featureSpawnCmd myNotificationCtrl [cmd]
 
-runNotificationClose :: IO MaybeX
+runNotificationClose :: FeatureX
 runNotificationClose = runNotificationCmd "close"
 
-runNotificationCloseAll :: IO MaybeX
+runNotificationCloseAll :: FeatureX
 runNotificationCloseAll = runNotificationCmd "close-all"
 
-runNotificationHistory :: IO MaybeX
+runNotificationHistory :: FeatureX
 runNotificationHistory = runNotificationCmd "history-pop"
 
-runNotificationContext :: IO MaybeX
+runNotificationContext :: FeatureX
 runNotificationContext = runNotificationCmd "context"
 
 --------------------------------------------------------------------------------
 -- | System commands
 
-runToggleBluetooth :: IO MaybeX
+runToggleBluetooth :: FeatureX
-runToggleBluetooth = runIfInstalled [exe myBluetooth] $ spawn
+runToggleBluetooth = featureRun [exe myBluetooth] $ spawn
   $ myBluetooth ++ " show | grep -q \"Powered: no\""
   #!&& "a=on"
   #!|| "a=off"
   #!>> fmtCmd myBluetooth ["power", "$a", ">", "/dev/null"]
   #!&& fmtNotifyCmd defNoteInfo { body = Just $ Text "bluetooth powered $a"  }
 
--- runToggleDPMS :: IO MaybeX
+runToggleEthernet :: FeatureX
--- runToggleDPMS = io <$> evalFeature callToggle
+runToggleEthernet = featureRun [exe "nmcli"] $ spawn
-
-runToggleEthernet :: IO MaybeX
-runToggleEthernet = runIfInstalled [exe "nmcli"] $ spawn
   $ "nmcli -g GENERAL.STATE device show " ++ ethernetIface ++ " | grep -q disconnected"
   #!&& "a=connect"
   #!|| "a=disconnect"
   #!>> fmtCmd "nmcli" ["device", "$a", ethernetIface]
   #!&& fmtNotifyCmd defNoteInfo { body = Just $ Text "ethernet \"$a\"ed"  }
 
-runStartISyncTimer :: IO MaybeX
+runStartISyncTimer :: FeatureX
-runStartISyncTimer = runIfInstalled [userUnit "mbsync.timer"]
+runStartISyncTimer = featureRun [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 :: IO MaybeX
+runStartISyncService :: FeatureX
-runStartISyncService = runIfInstalled [userUnit "mbsync.service"]
+runStartISyncService = featureRun [userUnit "mbsync.service"]
   $ spawn
   $ "systemctl --user start mbsync.service"
   #!&& fmtNotifyCmd defNoteInfo { body = Just $ Text "Isync completed" }
@@ -238,25 +248,25 @@ getCaptureDir = do
   where
     fallback = (</> ".local/share") <$> getHomeDirectory
 
-runFlameshot :: String -> IO MaybeX
+runFlameshot :: String -> FeatureX
-runFlameshot mode = runIfInstalled [exe myCapture] $ do
+runFlameshot mode = featureRun [exe myCapture] $ do
   ssDir <- io getCaptureDir
   spawnCmd myCapture $ mode : ["-p", ssDir]
 
 -- TODO this will steal focus from the current window (and puts it
 -- in the root window?) ...need to fix
-runAreaCapture :: IO MaybeX
+runAreaCapture :: FeatureX
 runAreaCapture = runFlameshot "gui"
 
 -- myWindowCap = "screencap -w" --external script
 
-runDesktopCapture :: IO MaybeX
+runDesktopCapture :: FeatureX
 runDesktopCapture = runFlameshot "full"
 
-runScreenCapture :: IO MaybeX
+runScreenCapture :: FeatureX
 runScreenCapture = runFlameshot "screen"
 
-runCaptureBrowser :: IO MaybeX
+runCaptureBrowser :: FeatureX
-runCaptureBrowser = runIfInstalled [exe myImageBrowser] $ do
+runCaptureBrowser = featureRun [exe myImageBrowser] $ do
   dir <- io getCaptureDir
   spawnCmd myImageBrowser [dir]

lib/XMonad/Internal/Command/Power.hs

@@ -28,6 +28,7 @@ import           System.IO.Error
 
 import           XMonad.Core
 import           XMonad.Internal.Dependency
+import           XMonad.Internal.Shell
 import qualified XMonad.Internal.Theme       as T
 import           XMonad.Prompt
 import           XMonad.Prompt.ConfirmPrompt
@@ -44,9 +45,6 @@ myOptimusManager = "optimus-manager"
 --------------------------------------------------------------------------------
 -- | Core commands
 
--- runScreenLock :: IO MaybeX
--- runScreenLock = spawnIfInstalled myScreenlock
-
 runScreenLock :: Feature (X ()) (X ())
 runScreenLock = Feature
   { ftrAction = spawn myScreenlock
@@ -69,6 +67,7 @@ runReboot = spawn "systemctl reboot"
 --------------------------------------------------------------------------------
 -- | Confirm prompt wrappers
 
+-- TODO doesn't this need to also lock the screen?
 runSuspendPrompt :: X ()
 runSuspendPrompt = confirmPrompt T.promptTheme "suspend?" runSuspend
 
@@ -88,7 +87,6 @@ hasBattery :: IO (Maybe String)
 hasBattery = do
   ps <- fromRight [] <$> tryIOError (listDirectory syspath)
   ts <- mapM readType ps
-  -- TODO this is obviously stupid
   return $ if "Battery\n" `elem` ts then Nothing else Just "battery not found"
   where
     readType p = fromRight [] <$> tryIOError (readFile $ syspath </> p </> "type")
@@ -106,14 +104,8 @@ runOptimusPrompt' = do
       #!&& unwords [myOptimusManager, "--switch", mode, "--no-confirm"]
       #!&& "killall xmonad"
 
-runOptimusPrompt :: IO MaybeX
+runOptimusPrompt :: FeatureX
-runOptimusPrompt = runIfInstalled [exe myOptimusManager] runOptimusPrompt'
+runOptimusPrompt = featureRun [exe myOptimusManager] runOptimusPrompt'
--- runOptimusPrompt :: Feature (X ()) (X ())
--- runOptimusPrompt = Feature
---   { ftrAction = runOptimusPrompt'
---   , ftrSilent = False
---   , ftrChildren = [exe myOptimusManager]
---   }
 
 --------------------------------------------------------------------------------
 -- | Universal power prompt
@@ -159,36 +151,6 @@ runPowerPrompt lock = mkXPrompt PowerPrompt theme comp executeAction
     sendAction a = setInput (show $ fromEnum a) >> setSuccess True >> setDone True
     executeAction a = case toEnum $ read a of
       Poweroff  -> runPowerOff
-      -- TODO these dependency functions need to be assembled elsewhere and fed
-      -- to this function
-      -- Shutdown  -> (io runScreenLock >>= whenInstalled) >> runSuspend
-      -- Hibernate -> (io runScreenLock >>= whenInstalled) >> runHibernate
       Shutdown  -> lock >> runSuspend
       Hibernate -> lock >> runHibernate
       Reboot    -> runReboot
-
--- runPowerPrompt :: Feature (X ()) (X ()) -> IO (X ())
--- runPowerPrompt lock = do
---   lock' <- evalFeature lock
---   return $ mkXPrompt PowerPrompt theme comp $ executeAction $ fromRight (return ()) lock'
---   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_Return, quit)
---       , (xK_Escape, quit)
---       ]
---     sendAction a = setInput (show $ fromEnum a) >> setSuccess True >> setDone True
---     executeAction l a = case toEnum $ read a of
---       Poweroff  -> runPowerOff
---       -- TODO these dependency functions need to be assembled elsewhere and fed
---       -- to this function
---       Shutdown  -> l >> runSuspend
---       Hibernate -> l >> runHibernate
---       Reboot    -> runReboot

lib/XMonad/Internal/Concurrent/ACPIEvent.hs

@@ -94,8 +94,8 @@ 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 :: IO (MaybeExe (IO ()))
+runPowermon :: FeatureIO
-runPowermon = runIfInstalled [pathR acpiPath] listenACPI
+runPowermon = featureRun [pathR acpiPath] listenACPI
 
 -- | Handle ClientMessage event containing and ACPI event (to be used in
 -- Xmonad's event hook)
@@ -109,6 +109,5 @@ handleACPI lock tag = do
       status <- io isDischarging
       -- only run suspend if battery exists and is discharging
       forM_ status $ flip when runSuspend
-      -- io runScreenLock >>= whenInstalled
       lock
 

lib/XMonad/Internal/Concurrent/Removable.hs

@@ -15,6 +15,7 @@ import           DBus
 import           DBus.Client
 
 -- import           XMonad.Internal.DBus.Control (pathExists)
+import           XMonad.Internal.Command.Desktop
 import           XMonad.Internal.Dependency
 
 bus :: BusName
@@ -91,5 +92,5 @@ listenDevices = do
     addMatch' client m p f = addMatch client ruleUdisks { matchMember = Just m }
       $ playSoundMaybe p . f . signalBody
 
-runRemovableMon :: IO (MaybeExe (IO ()))
+runRemovableMon :: FeatureIO
-runRemovableMon = runIfInstalled [addedDep, removedDep] listenDevices
+runRemovableMon = featureRun [addedDep, removedDep] listenDevices

lib/XMonad/Internal/DBus/Brightness/Common.hs

@@ -39,10 +39,10 @@ data BrightnessConfig a b = BrightnessConfig
   }
 
 data BrightnessControls = BrightnessControls
-  { bctlMax :: MaybeExe (IO ())
+  { bctlMax :: FeatureIO
-  , bctlMin :: MaybeExe (IO ())
+  , bctlMin :: FeatureIO
-  , bctlInc :: MaybeExe (IO ())
+  , bctlInc :: FeatureIO
-  , bctlDec :: MaybeExe (IO ())
+  , bctlDec :: FeatureIO
   }
 
 exportBrightnessControls :: RealFrac b => [Dependency (IO ())] -> BrightnessConfig a b
@@ -50,17 +50,12 @@ exportBrightnessControls :: RealFrac b => [Dependency (IO ())] -> BrightnessConf
 exportBrightnessControls deps bc client =
   initControls client (brightnessExporter deps bc) controls
   where
-    controls exporter = do
+    controls exporter = let callBacklight' = callBacklight bc exporter in
-      let callBacklight' = evalFeature . callBacklight bc exporter
+      BrightnessControls
-      mx <- callBacklight' memMax
+        { bctlMax = callBacklight' memMax
-      mn <- callBacklight' memMin
+        , bctlMin = callBacklight' memMin
-      ic <- callBacklight' memInc
+        , bctlInc = callBacklight' memInc
-      dc <- callBacklight' memDec
+        , bctlDec = callBacklight' memDec
-      return $ BrightnessControls
-        { bctlMax = mx
-        , bctlMin = mn
-        , bctlInc = ic
-        , bctlDec = dc
         }
 
 callGetBrightness :: Num c => BrightnessConfig a b -> IO (Maybe c)
@@ -99,7 +94,7 @@ matchSignal BrightnessConfig { bcPath = p, bcInterface = i } cb = do
 --     }
 
 brightnessExporter :: RealFrac b => [Dependency (IO ())]
-  -> BrightnessConfig a b -> Client -> Feature (IO ()) (IO ())
+  -> BrightnessConfig a b -> Client -> FeatureIO
 brightnessExporter deps bc client = Feature
   { ftrAction = exportBrightnessControls' bc client
   , ftrSilent = False
@@ -132,8 +127,7 @@ emitBrightness BrightnessConfig{ bcPath = p, bcInterface = i } client cur =
 -- callBacklight BrightnessConfig { bcPath = p, bcInterface = i } mem =
 --   void $ callMethod $ methodCall p i mem
 
-callBacklight :: BrightnessConfig a b -> Feature (IO ()) (IO ()) -> MemberName
+callBacklight :: BrightnessConfig a b -> FeatureIO -> MemberName -> FeatureIO
-  -> Feature (IO ()) (IO ())
 callBacklight BrightnessConfig { bcPath = p, bcInterface = i } exporter mem =
   Feature
   { ftrAction = void $ callMethod $ methodCall p i mem

lib/XMonad/Internal/DBus/Brightness/IntelBacklight.hs

@@ -58,37 +58,6 @@ incBrightness = incPercent steps curFile
 decBrightness :: RawBrightness -> IO Brightness
 decBrightness = decPercent steps curFile
 
---------------------------------------------------------------------------------
--- | Access checks
-
--- | determine if backlight is accessible/present
--- Right True -> backlight accessible and present
--- Right False -> backlight not present
--- Left x -> backlight present but could not access (x explaining why)
--- hasBacklight' :: IO (Either String Bool)
--- hasBacklight' = do
---   mx <- isReadable maxFile
---   cx <- isWritable curFile
---   return $ case (mx, cx) of
---     (NotFoundError, NotFoundError) -> Right False
---     (PermResult True, PermResult True) -> Right True
---     (PermResult _, PermResult _) -> Left "Insufficient permissions for backlight files"
---     _ -> Left "Could not determine permissions for backlight files"
-
--- msg :: Either String Bool -> IO ()
--- msg (Right True)  = return ()
--- msg (Right False) = putStrLn "No backlight detected. Controls disabled"
--- msg (Left m)      = putStrLn $ "WARNING: " ++ m
-
--- hasBacklightMsg :: IO Bool
--- hasBacklightMsg = do
---   b <- hasBacklight'
---   msg b
---   return $ fromRight False b
-
--- hasBacklight :: IO Bool
--- hasBacklight = fromRight False <$> hasBacklight'
-
 --------------------------------------------------------------------------------
 -- | DBus interface
 
@@ -122,10 +91,6 @@ maxFileDep = pathR maxFile
 exportIntelBacklight :: Client -> IO BrightnessControls
 exportIntelBacklight =
   exportBrightnessControls [curFileDep, maxFileDep] intelBacklightConfig
-  -- b <- hasBacklightMsg
-  -- if b
-  --   then Just <$> exportBrightnessControls intelBacklightConfig client
-  --   else return Nothing
 
 callGetBrightnessIB :: IO (Maybe Brightness)
 callGetBrightnessIB = callGetBrightness intelBacklightConfig

lib/XMonad/Internal/DBus/Common.hs

@@ -40,12 +40,11 @@ addMatchCallback rule cb = do
   client <- connectSession
   addMatch client rule $ cb . signalBody
 
-initControls :: Client -> (Client -> Feature (IO ()) (IO ()))
+initControls :: Client -> (Client -> FeatureIO) -> (FeatureIO -> a) -> IO a
-  -> (Feature (IO ()) (IO ()) -> IO a) -> IO a
 initControls client exporter controls = do
   let x = exporter client
   e <- evalFeature x
   case e of
     (Right c) -> c
     _         -> return ()
-  controls x
+  return $ controls x

lib/XMonad/Internal/DBus/Control.hs

@@ -21,7 +21,7 @@ import           XMonad.Internal.DBus.Brightness.Common
 import           XMonad.Internal.DBus.Brightness.IntelBacklight
 import           XMonad.Internal.DBus.Common
 import           XMonad.Internal.DBus.Screensaver
--- import           XMonad.Internal.Dependency
+import           XMonad.Internal.Dependency
 
 introspectInterface :: InterfaceName
 introspectInterface = interfaceName_ "org.freedesktop.DBus.Introspectable"
@@ -38,14 +38,14 @@ data DBusXMonad = DBusXMonad
 
 blankControls :: BrightnessControls
 blankControls = BrightnessControls
-  { bctlMax = Left []
+  { bctlMax = BlankFeature
-  , bctlMin = Left []
+  , bctlMin = BlankFeature
-  , bctlInc = Left []
+  , bctlInc = BlankFeature
-  , bctlDec = Left []
+  , bctlDec = BlankFeature
   }
 
 blankSSToggle :: SSControls
-blankSSToggle = SSControls { ssToggle = Left [] }
+blankSSToggle = SSControls { ssToggle = BlankFeature }
 
 startXMonadService :: IO DBusXMonad
 startXMonadService = do

lib/XMonad/Internal/DBus/Screensaver.hs

@@ -97,16 +97,14 @@ bodyGetCurrentState _   = Nothing
 --------------------------------------------------------------------------------
 -- | Exported haskell API
 
-newtype SSControls = SSControls { ssToggle :: MaybeExe (IO ()) }
+newtype SSControls = SSControls { ssToggle :: FeatureIO }
 
 exportScreensaver :: Client -> IO SSControls
 exportScreensaver client = initControls client exportScreensaver' controls
   where
-    controls exporter = do
+    controls exporter = SSControls { ssToggle = callToggle exporter }
-      t <- evalFeature $ callToggle exporter
-      return $ SSControls { ssToggle = t }
 
-exportScreensaver' :: Client -> Feature (IO ()) (IO ())
+exportScreensaver' :: Client -> FeatureIO
 exportScreensaver' client = Feature
   { ftrAction = cmd
   , ftrSilent = False
@@ -121,7 +119,7 @@ exportScreensaver' client = Feature
         ]
       }
 
-callToggle :: Feature (IO ()) (IO ()) -> Feature (IO ()) (IO ())
+callToggle :: FeatureIO -> FeatureIO
 callToggle exporter = Feature
   { ftrAction = cmd
   , ftrSilent = False

lib/XMonad/Internal/Dependency.hs

@@ -8,7 +8,10 @@ module XMonad.Internal.Dependency
   , DependencyData(..)
   , DBusMember(..)
   , MaybeX
+  , FeatureX
+  , FeatureIO
   , Feature(..)
+  , ioFeature
   , evalFeature
   , exe
   , systemUnit
@@ -16,25 +19,14 @@ module XMonad.Internal.Dependency
   , pathR
   , pathW
   , pathRW
-  -- , checkInstalled
+  , featureRun
-  , runIfInstalled
+  , featureSpawnCmd
-  , depInstalled
+  , featureSpawn
   , warnMissing
   , whenInstalled
   , ifInstalled
-  , spawnIfInstalled
-  , spawnCmdIfInstalled
-  , noCheck
   , fmtCmd
   , spawnCmd
-  , doubleQuote
-  , singleQuote
-  , (#!&&)
-  , (#!||)
-  , (#!|)
-  , (#!>>)
-  , playSound
-  , spawnSound
   ) where
 
 import           Control.Monad.IO.Class
@@ -48,9 +40,8 @@ import qualified DBus.Introspection      as I
 
 import           System.Directory        (findExecutable, readable, writable)
 import           System.Exit
-import           System.FilePath
 
-import           XMonad.Core             (X, getXMonadDir)
+import           XMonad.Core             (X)
 import           XMonad.Internal.IO
 import           XMonad.Internal.Process
 import           XMonad.Internal.Shell
@@ -84,44 +75,38 @@ data Feature a b = Feature
   { ftrAction   :: a
   , ftrSilent   :: Bool
   , ftrChildren :: [Dependency b]
-  } | ConstFeature a
+  }
+  | ConstFeature a
+  | BlankFeature
 
--- data Chain a = Chain
+type FeatureX = Feature (X ()) (X ())
---   { chainAction   :: a
+
---   , chainChildren :: [Feature a a]
+type FeatureIO = Feature (IO ()) (IO ())
---   , chainCompose  :: a -> a -> a
+
---   }
+ioFeature :: (MonadIO m, MonadIO n) => Feature (IO a) (IO b) -> Feature (m a) (n b)
+ioFeature f@Feature { ftrAction = a, ftrChildren = ds } =
+  f { ftrAction = liftIO a, ftrChildren = fmap go ds }
+  where
+    go :: MonadIO o => Dependency (IO b) -> Dependency (o b)
+    go (SubFeature s) = SubFeature $ ioFeature s
+    go (Dependency d) = Dependency d
+ioFeature (ConstFeature f) = ConstFeature $ liftIO f
+ioFeature BlankFeature = BlankFeature
 
 evalFeature :: Feature a b -> IO (MaybeExe a)
 evalFeature (ConstFeature x) = return $ Right x
+evalFeature BlankFeature = return $ Left []
 evalFeature Feature { ftrAction = a, ftrSilent = s, ftrChildren = c } = do
   es <- mapM go c
   return $ case concat es of
     []  -> Right a
     es' -> Left (if s then [] else es')
-  -- return $ case foldl groupResult ([], []) c' of
-  --   ([], opt)  -> Installed a opt
-  --   (req, opt) -> if s then Ignore else Missing req opt
   where
     go (SubFeature Feature { ftrChildren = cs }) = concat <$> mapM go cs
-    go (SubFeature (ConstFeature _)) = return []
     go (Dependency d) = do
       e <- depInstalled d
       return $ maybeToList e
-    -- groupResult (x, y) (True, z)  = (z:x, y)
+    go (SubFeature _) = return []
-    -- groupResult (x, y) (False, z) = (x, z:y)
-
--- evalChain :: Chain a -> IO (MaybeExe a)
--- evalChain Chain { chainAction = a, chainChildren = cs , chainCompose = f } =
---   flip Installed [] <$> foldM go a cs
---   where
---     go acc child = do
---       c <- evalFeature child
---       -- TODO need a way to get error messages out of this for anything
---       -- that's missing
---       return $ case c of
---         (Installed x _) -> f x acc
---         _               -> acc
 
 exe :: String -> Dependency a
 exe = Dependency . Executable
@@ -149,19 +134,23 @@ userUnit = unit 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)
--- data MaybeExe a = Installed a [DependencyData]
---   | Missing [DependencyData] [DependencyData]
---   | Ignore
---   deriving (Foldable, Traversable)
--- data MaybeExe a = MaybeExe (Maybe a) [String]
 type MaybeExe a = Either [String] a
---   deriving (Foldable, Traversable)
-
--- instance Functor MaybeExe where
---   fmap f (MaybeExe x m)    = MaybeExe (f <$> x) m
 
 type MaybeX = MaybeExe (X ())
 
+featureRun :: [Dependency a] -> b -> Feature b a
+featureRun ds x = Feature
+  { ftrAction = x
+  , ftrSilent = False
+  , ftrChildren = ds
+  }
+
+featureSpawnCmd :: MonadIO m => String -> [String] -> Feature (m ()) (m ())
+featureSpawnCmd cmd args = featureRun [exe cmd] $ spawnCmd cmd args
+
+featureSpawn :: MonadIO m => String -> Feature (m ()) (m ())
+featureSpawn cmd = featureSpawnCmd cmd []
+
 exeInstalled :: String -> IO (Maybe String)
 exeInstalled x = do
   r <- findExecutable x
@@ -180,34 +169,22 @@ unitInstalled u x = do
     unitType SystemUnit = "system"
     unitType UserUnit   = "user"
 
--- pathAccessible :: FilePath -> Bool -> Bool -> IO (Maybe String)
 pathAccessible :: FilePath -> Bool -> Bool -> IO (Maybe String)
 pathAccessible p testread testwrite = do
   res <- getPermissionsSafe p
   let msg = permMsg res
   return msg
-  -- return $ fmap (\m -> m ++ ": " ++ p) msg
   where
     testPerm False _ _ = Nothing
     testPerm True f r  = Just $ f r
     permMsg NotFoundError            = Just "file not found"
     permMsg PermError                = Just "could not get permissions"
-    -- permMsg NotFoundError            = False
-    -- permMsg PermError                = False
     permMsg (PermResult r) =
       case (testPerm testread readable r, testPerm testwrite writable r) of
         (Just False, Just False) -> Just "file not readable or writable"
         (Just False, _)          -> Just "file not readable"
         (_, Just False)          -> Just "file not writable"
         _                        -> Nothing
-        -- (Just True, Just True)   -> True
-        -- (Just True, Nothing)     -> True
-        -- (Nothing, Just True)     -> True
-        -- _                        -> False
-        -- (Just False, Just False) -> Just "file not readable or writable"
-        -- (Just False, _)          -> Just "file not readable"
-        -- (_, Just False)          -> Just "file not writable"
-        -- _                        -> Nothing
 
 introspectInterface :: InterfaceName
 introspectInterface = interfaceName_ "org.freedesktop.DBus.Introspectable"
@@ -227,7 +204,6 @@ dbusInstalled bus usesystem objpath iface mem = do
   return $ case res of
     Just _ -> Nothing
     _      -> Just "some random dbus interface not found"
-  -- return $ fromMaybe False res
   where
     findMem obj = fmap (matchMem mem)
       $ find (\i -> I.interfaceName i == iface)
@@ -248,28 +224,6 @@ depInstalled DBusEndpoint { ddDbusBus = b
                           , ddDbusMember = m
                           } = dbusInstalled b s o i m
 
--- checkInstalled :: [Dependency a] -> IO ([DependencyData], [DependencyData])
--- checkInstalled = fmap go . filterMissing
---   where
---     go = join (***) (fmap depData) . partition depRequired
-
--- filterMissing :: [Dependency a] -> IO [Dependency a]
--- filterMissing = filterM (fmap not . depInstalled . depData)
-
-runIfInstalled :: [Dependency a] -> b -> IO (MaybeExe b)
-runIfInstalled ds x = evalFeature $
-  Feature
-  { ftrAction = x
-  , ftrSilent = False
-  , ftrChildren = ds
-  }
-
-spawnIfInstalled :: MonadIO m => String -> IO (MaybeExe (m ()))
-spawnIfInstalled n = runIfInstalled [exe n] $ spawn n
-
-spawnCmdIfInstalled :: MonadIO m => String -> [String] -> IO (MaybeExe (m ()))
-spawnCmdIfInstalled n args = runIfInstalled [exe n] $ spawnCmd n args
-
 whenInstalled :: Monad m => MaybeExe (m ()) -> m ()
 whenInstalled = flip ifInstalled skip
 
@@ -277,62 +231,5 @@ ifInstalled ::  MaybeExe a -> a -> a
 ifInstalled (Right x) _ = x
 ifInstalled _ alt       = alt
 
-noCheck :: Monad m => a () -> m (MaybeExe (a ()))
-noCheck = return . Right
-
--- not sure what to do with these
-
-soundDir :: FilePath
-soundDir = "sound"
-
-spawnSound :: MonadIO m => FilePath -> m () -> m () -> IO (MaybeExe (m ()))
-spawnSound file pre post = runIfInstalled [exe "paplay"]
-  $ pre >> playSound file >> post
-
-playSound :: MonadIO m => FilePath -> m ()
-playSound file = do
-  p <- (</> soundDir </> file) <$> getXMonadDir
-  -- paplay seems to have less latency than aplay
-  spawnCmd "paplay" [p]
-
--- partitionMissing :: [MaybeExe a] -> ([DependencyData], [DependencyData])
--- partitionMissing = foldl (\(a, b) -> ((a++) *** (b++)) . go) ([], [])
---   where
---     go (Installed _ opt) = ([], opt)
---     go (Missing req opt) = (req, opt)
---     go Ignore            = ([], [])
-
--- fmtMissing :: DependencyData -> String
--- -- TODO this error message is lame
--- fmtMissing (IOTest _) = "some random test failed"
--- fmtMissing DBusEndpoint {} = "some random dbus path is missing"
--- fmtMissing (AccessiblePath p True False) = "path '" ++ p ++ "' not readable"
--- fmtMissing (AccessiblePath p False True) = "path '" ++ p ++ "' not writable"
--- fmtMissing (AccessiblePath p True True) = "path '" ++ p ++ "' not readable/writable"
--- fmtMissing (AccessiblePath p _ _) = "path '" ++ p ++ "' not ...something"
--- fmtMissing (Executable n) = "executable '" ++ n ++ "' not found"
--- fmtMissing (Systemd st n) = "systemd " ++ unitType st ++ " unit '"
---   ++ n ++ "' not found"
---   where
---     unitType SystemUnit = "system"
---     unitType UserUnit   = "user"
-
--- fmtMsgs :: [DependencyData] -> [DependencyData] -> [String]
--- fmtMsgs req opt = ("[WARNING] "++)
---   <$> (("[REQUIRED DEP] "++) . fmtMissing <$> req)
---   ++ (("[OPTIONAL DEP] "++) . fmtMissing <$> opt)
-
--- warnMsg ::
--- warnMsg xs = mapM_ putStrLn
---   $ [ "[WARNING] " ++ m | (MaybeExe _ (Just m)) <- xs ]
-
 warnMissing :: [MaybeExe a] -> IO ()
 warnMissing xs = mapM_ putStrLn $ fmap ("[WARNING] "++) $ concat $ [ m | (Left m) <- xs ]
-
--- fmtType (AccessiblePath _ _ _) = undefined
-
--- splitDeps :: [MaybeExe a] -> ([a], [String])
--- splitDeps xs = undefined
-
--- splitDeps' :: [m (MaybeExe a)] -> ([m a], [String])
--- splitDeps' xs = undefined