ENH define deps in terms of 'features'

bin/xmobar.hs

@@ -232,7 +232,7 @@ dateCmd = CmdSpec
 -- toJust :: a -> Bool -> Maybe a
 -- toJust x b = if b then Just x else Nothing
 
-dbusDep :: Bool -> BusName -> ObjectPath -> InterfaceName -> DBusMember -> Dependency
+dbusDep :: Bool -> BusName -> ObjectPath -> InterfaceName -> DBusMember -> Dependency a
 dbusDep usesys bus obj iface mem =
   Dependency { depRequired = True, depData = d }
   where

lib/XMonad/Internal/Command/Desktop.hs

@@ -17,7 +17,7 @@ module XMonad.Internal.Command.Desktop
   , runVolumeUp
   , runVolumeMute
   , runToggleBluetooth
-  , runToggleDPMS
+  -- , runToggleDPMS
   , runToggleEthernet
   , runRestart
   , runRecompile
@@ -33,7 +33,7 @@ module XMonad.Internal.Command.Desktop
   , runNotificationContext
   ) where
 
-import           Control.Monad                    (void)
+import           Control.Monad              (void)
 
 import           System.Directory
     ( createDirectoryIfMissing
@@ -43,8 +43,8 @@ import           System.Environment
 import           System.FilePath
 
 import           XMonad.Actions.Volume
-import           XMonad.Core                      hiding (spawn)
-import           XMonad.Internal.DBus.Screensaver
+import           XMonad.Core                hiding (spawn)
+-- import           XMonad.Internal.DBus.Screensaver
 import           XMonad.Internal.Dependency
 import           XMonad.Internal.Notify
 import           XMonad.Internal.Process
@@ -93,7 +93,11 @@ runTerm :: IO MaybeX
 runTerm = spawnIfInstalled myTerm
 
 runTMux :: IO MaybeX
-runTMux = runIfInstalled [exe myTerm, exe "tmux", exe "bash"] cmd
+runTMux = evalFeature $ Feature
+  { ftrAction = cmd
+  , ftrSilent = False
+  , ftrChildren  = [exe myTerm, exe "tmux", exe "bash"]
+  }
   where
     cmd = spawn
       $ "tmux has-session"
@@ -171,8 +175,8 @@ runToggleBluetooth = runIfInstalled [exe myBluetooth] $ spawn
   #!>> fmtCmd myBluetooth ["power", "$a", ">", "/dev/null"]
   #!&& fmtNotifyCmd defNoteInfo { body = Just $ Text "bluetooth powered $a"  }
 
-runToggleDPMS :: X ()
-runToggleDPMS = io $ void callToggle
+-- runToggleDPMS :: IO MaybeX
+-- runToggleDPMS = io <$> evalFeature callToggle
 
 runToggleEthernet :: IO MaybeX
 runToggleEthernet = runIfInstalled [exe "nmcli"] $ spawn

lib/XMonad/Internal/Concurrent/Removable.hs

@@ -32,7 +32,7 @@ memAdded = memberName_ "InterfacesAdded"
 memRemoved :: MemberName
 memRemoved = memberName_ "InterfacesRemoved"
 
-dbusDep :: MemberName -> Dependency
+dbusDep :: MemberName -> Dependency (IO a)
 dbusDep m = Dependency { depRequired = True, depData = d }
   where
     d = DBusEndpoint
@@ -43,10 +43,10 @@ dbusDep m = Dependency { depRequired = True, depData = d }
       , ddDbusMember = Signal_ m
       }
 
-addedDep :: Dependency
+addedDep :: Dependency (IO a)
 addedDep = dbusDep memAdded
 
-removedDep :: Dependency
+removedDep :: Dependency (IO a)
 removedDep = dbusDep memRemoved
 
 driveInsertedSound :: FilePath

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

@@ -9,7 +9,7 @@ module XMonad.Internal.DBus.Brightness.Common
   , matchSignal
   ) where
 
-import           Control.Monad               (void, when)
+import           Control.Monad               (void)
 
 import           Data.Int                    (Int32)
 
@@ -45,19 +45,23 @@ data BrightnessControls = BrightnessControls
   , bctlDec :: MaybeExe (IO ())
   }
 
-exportBrightnessControls :: RealFrac b => [Dependency] -> BrightnessConfig a b
+exportBrightnessControls :: RealFrac b => [Dependency (IO ())] -> BrightnessConfig a b
   -> Client -> IO BrightnessControls
-exportBrightnessControls deps bc client = do
-  (req, opt) <- checkInstalled deps
-  let callBacklight' = createInstalled req opt . callBacklight bc
-  when (null req) $
-    exportBrightnessControls' bc client
-  return $ BrightnessControls
-    { bctlMax = callBacklight' memMax
-    , bctlMin = callBacklight' memMin
-    , bctlInc = callBacklight' memInc
-    , bctlDec = callBacklight' memDec
-    }
+exportBrightnessControls deps bc client =
+  initControls client (brightnessExporter deps bc) controls
+  where
+    controls exporter = do
+      let callBacklight' = evalFeature . callBacklight bc exporter
+      mx <- callBacklight' memMax
+      mn <- callBacklight' memMin
+      ic <- callBacklight' memInc
+      dc <- callBacklight' memDec
+      return $ BrightnessControls
+        { bctlMax = mx
+        , bctlMin = mn
+        , bctlInc = ic
+        , bctlDec = dc
+        }
 
 callGetBrightness :: Num c => BrightnessConfig a b -> IO (Maybe c)
 callGetBrightness BrightnessConfig { bcPath = p, bcInterface = i } = do
@@ -78,6 +82,30 @@ matchSignal BrightnessConfig { bcPath = p, bcInterface = i } cb = do
 --------------------------------------------------------------------------------
 -- | Internal DBus Crap
 
+-- exportBrightnessControls' :: RealFrac b => BrightnessConfig a b -> Client -> IO ()
+-- exportBrightnessControls' bc client = do
+--   maxval <- bcGetMax bc -- assume the max value will never change
+--   let autoMethod' m f = autoMethod m $ emitBrightness bc client =<< f bc maxval
+--   let funget = bcGet bc
+--   export client (bcPath bc) defaultInterface
+--     { interfaceName = bcInterface bc
+--     , interfaceMethods =
+--       [ autoMethod' memMax bcMax
+--       , autoMethod' memMin bcMin
+--       , autoMethod' memInc bcInc
+--       , autoMethod' memDec bcDec
+--       , autoMethod memGet (round <$> funget maxval :: IO Int32)
+--       ]
+--     }
+
+brightnessExporter :: RealFrac b => [Dependency (IO ())]
+  -> BrightnessConfig a b -> Client -> Feature (IO ()) (IO ())
+brightnessExporter deps bc client = Feature
+  { ftrAction = exportBrightnessControls' bc client
+  , ftrSilent = False
+  , ftrChildren = deps
+  }
+
 exportBrightnessControls' :: RealFrac b => BrightnessConfig a b -> Client -> IO ()
 exportBrightnessControls' bc client = do
   maxval <- bcGetMax bc -- assume the max value will never change
@@ -100,9 +128,18 @@ emitBrightness BrightnessConfig{ bcPath = p, bcInterface = i } client cur =
   where
     sig = signal p i memCur
 
-callBacklight :: BrightnessConfig a b -> MemberName -> IO ()
-callBacklight BrightnessConfig { bcPath = p, bcInterface = i } mem =
-  void $ callMethod $ methodCall p i mem
+-- callBacklight :: BrightnessConfig a b -> MemberName -> IO ()
+-- callBacklight BrightnessConfig { bcPath = p, bcInterface = i } mem =
+--   void $ callMethod $ methodCall p i mem
+
+callBacklight :: BrightnessConfig a b -> Feature (IO ()) (IO ()) -> MemberName
+  -> Feature (IO ()) (IO ())
+callBacklight BrightnessConfig { bcPath = p, bcInterface = i } exporter mem =
+  Feature
+  { ftrAction = void $ callMethod $ methodCall p i mem
+  , ftrSilent = False
+  , ftrChildren = [SubFeature exporter]
+  }
 
 bodyGetBrightness :: Num a => [Variant] -> Maybe a
 bodyGetBrightness [b] = fromIntegral <$> (fromVariant b :: Maybe Int32)

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

@@ -113,10 +113,10 @@ intelBacklightConfig = BrightnessConfig
 --------------------------------------------------------------------------------
 -- | Exported haskell API
 
-curFileDep :: Dependency
+curFileDep :: Dependency (IO a)
 curFileDep = pathRW curFile
 
-maxFileDep :: Dependency
+maxFileDep :: Dependency (IO a)
 maxFileDep = pathR maxFile
 
 exportIntelBacklight :: Client -> IO BrightnessControls

lib/XMonad/Internal/DBus/Common.hs

@@ -6,11 +6,14 @@ module XMonad.Internal.DBus.Common
   , callMethod'
   , addMatchCallback
   , xmonadBus
+  , initControls
   ) where
 
 import           DBus
 import           DBus.Client
 
+import           XMonad.Internal.Dependency
+
 xmonadBus :: BusName
 xmonadBus = busName_ "org.xmonad"
 
@@ -36,3 +39,13 @@ addMatchCallback :: MatchRule -> ([Variant] -> IO ()) -> IO SignalHandler
 addMatchCallback rule cb = do
   client <- connectSession
   addMatch client rule $ cb . signalBody
+
+initControls :: Client -> (Client -> Feature (IO ()) (IO ()))
+  -> (Feature (IO ()) (IO ()) -> IO a) -> IO a
+initControls client exporter controls = do
+  let x = exporter client
+  e <- evalFeature x
+  case e of
+    (Installed c _) -> c
+    _               -> return ()
+  controls x

lib/XMonad/Internal/DBus/Screensaver.hs

@@ -11,7 +11,7 @@ module XMonad.Internal.DBus.Screensaver
   , SSControls(..)
   ) where
 
-import           Control.Monad               (void, when)
+import           Control.Monad               (void)
 
 import           DBus
 import           DBus.Client
@@ -31,7 +31,7 @@ type SSState = Bool -- true is enabled
 ssExecutable :: String
 ssExecutable = "xset"
 
-ssDep :: Dependency
+ssDep :: Dependency (IO a)
 ssDep = exe ssExecutable
 
 toggle :: IO SSState
@@ -100,24 +100,35 @@ bodyGetCurrentState _   = Nothing
 newtype SSControls = SSControls { ssToggle :: MaybeExe (IO ()) }
 
 exportScreensaver :: Client -> IO SSControls
-exportScreensaver client = do
-  (req, opt) <- checkInstalled [ssDep]
-  when (null req) $
-    exportScreensaver' client
-  return $ SSControls { ssToggle = createInstalled req opt callToggle }
+exportScreensaver client = initControls client exportScreensaver' controls
+  where
+    controls exporter = do
+      t <- evalFeature $ callToggle exporter
+      return $ SSControls { ssToggle = t }
 
-exportScreensaver' :: Client -> IO ()
-exportScreensaver' client = do
-  export client ssPath defaultInterface
-    { interfaceName = interface
-    , interfaceMethods =
-      [ autoMethod memToggle $ emitState client =<< toggle
-      , autoMethod memQuery query
-      ]
-    }
+exportScreensaver' :: Client -> Feature (IO ()) (IO ())
+exportScreensaver' client = Feature
+  { ftrAction = cmd
+  , ftrSilent = False
+  , ftrChildren = [ssDep]
+  }
+  where
+    cmd = export client ssPath defaultInterface
+      { interfaceName = interface
+      , interfaceMethods =
+        [ autoMethod memToggle $ emitState client =<< toggle
+        , autoMethod memQuery query
+        ]
+      }
 
-callToggle :: IO ()
-callToggle = void $ callMethod $ methodCall ssPath interface memToggle
+callToggle :: Feature (IO ()) (IO ()) -> Feature (IO ()) (IO ())
+callToggle exporter = Feature
+  { ftrAction = cmd
+  , ftrSilent = False
+  , ftrChildren = [SubFeature exporter]
+  }
+  where
+    cmd = void $ callMethod $ methodCall ssPath interface memToggle
 
 callQuery :: IO (Maybe SSState)
 callQuery = do

lib/XMonad/Internal/Dependency.hs

@@ -10,6 +10,8 @@ module XMonad.Internal.Dependency
   , DependencyData(..)
   , DBusMember(..)
   , MaybeX
+  , Feature(..)
+  , evalFeature
   , exe
   , systemUnit
   , userUnit
@@ -80,43 +82,69 @@ data DependencyData = Executable String
   | Systemd UnitType String
   deriving (Eq, Show)
 
-data Dependency = Dependency
+-- data Dependency = Dependency
+--   { depRequired :: Bool
+--   , depData     :: DependencyData
+--   }
+--   deriving (Eq, Show)
+
+data Dependency a = SubFeature (Feature a a)
+  | Dependency
   { depRequired :: Bool
   , depData     :: DependencyData
-  }
-  deriving (Eq, Show)
+  } deriving (Eq, Show)
 
-exe :: String -> Dependency
+data Feature a b = Feature
+  { ftrAction   :: a
+  , ftrSilent   :: Bool
+  , ftrChildren :: [Dependency b]
+  } deriving (Eq, Show)
+
+evalFeature :: Feature a b -> IO (MaybeExe a)
+evalFeature Feature { ftrAction = a, ftrSilent = s, ftrChildren = c } = do
+  c' <- concat <$> mapM go c
+  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 Dependency { depRequired = r, depData = d } = do
+      i <- depInstalled d
+      return [(r, d) | not i ]
+    groupResult (x, y) (True, z)  = (z:x, y)
+    groupResult (x, y) (False, z) = (x, z:y)
+
+exe :: String -> Dependency a
 exe n = Dependency
   { depRequired = True
   , depData = Executable n
   }
 
-unit :: UnitType -> String -> Dependency
+unit :: UnitType -> String -> Dependency a
 unit t n = Dependency
   { depRequired = True
   , depData = Systemd t n
   }
 
-path :: Bool -> Bool -> String -> Dependency
+path :: Bool -> Bool -> String -> Dependency a
 path r w n = Dependency
   { depRequired = True
   , depData = AccessiblePath n r w
   }
 
-pathR :: String -> Dependency
+pathR :: String -> Dependency a
 pathR = path True False
 
-pathW :: String -> Dependency
+pathW :: String -> Dependency a
 pathW = path False True
 
-pathRW :: String -> Dependency
+pathRW :: String -> Dependency a
 pathRW = path True True
 
-systemUnit :: String -> Dependency
+systemUnit :: String -> Dependency a
 systemUnit = unit SystemUnit
 
-userUnit :: String -> Dependency
+userUnit :: String -> Dependency a
 userUnit = unit UserUnit
 
 -- TODO this is poorly named. This actually represents an action that has
@@ -210,7 +238,7 @@ depInstalled DBusEndpoint { ddDbusBus = b
                           , ddDbusMember = m
                           } = dbusInstalled b s o i m
 
-checkInstalled :: [Dependency] -> IO ([DependencyData], [DependencyData])
+checkInstalled :: [Dependency a] -> IO ([DependencyData], [DependencyData])
 checkInstalled = fmap go . filterMissing
   where
     go = join (***) (fmap depData) . partition depRequired
@@ -218,14 +246,16 @@ checkInstalled = fmap go . filterMissing
 createInstalled :: [DependencyData] -> [DependencyData] -> a -> MaybeExe a
 createInstalled req opt x = if null req then Installed x opt else Missing req opt
 
-filterMissing :: [Dependency] -> IO [Dependency]
+filterMissing :: [Dependency a] -> IO [Dependency a]
 filterMissing = filterM (fmap not . depInstalled . depData)
 
--- runIfInstalled :: MonadIO m => [Dependency] -> m a -> IO (MaybeExe (m a))
-runIfInstalled :: [Dependency] -> a -> IO (MaybeExe a)
-runIfInstalled ds x = do
-  (req, opt) <- checkInstalled ds
-  return $ createInstalled req opt x
+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