ENH print out deps (but better this time)

bin/xmobar.hs

@@ -291,71 +291,47 @@ rightPlugins sysClient sesClient = mapM evalFeature
   ]
 
 getWireless :: BarFeature
-getWireless = Feature
+getWireless = feature "wireless status indicator" Default
-  { ftrDepTree = GenTree (Double wirelessCmd $ readInterface isWireless) []
+  $ GenTree (Double wirelessCmd $ readInterface isWireless) []
-  , ftrName = "wireless status indicator"
-  , ftrWarning = Default
-  }
 
 getEthernet :: Maybe Client -> BarFeature
-getEthernet client = Feature
+getEthernet client = feature "ethernet status indicator" Default
-  { ftrDepTree = DBusTree action client [devDep] []
+  $ DBusTree action client [devDep] []
-  , ftrName = "ethernet status indicator"
-  , ftrWarning = Default
-  }
   where
     action = Double (\i _ -> ethernetCmd i) (readInterface isEthernet)
 
 getBattery :: BarFeature
-getBattery = Feature
+getBattery = feature "battery level indicator" Default
-  { ftrDepTree = GenTree (Single batteryCmd) [IOTest hasBattery]
+  $ GenTree (Single batteryCmd) [IOTest desc hasBattery]
-  , ftrName = "battery level indicator"
+  where
-  , ftrWarning = Default
+    desc = "Test if battery is present"
-  }
 
 getVPN :: Maybe Client -> BarFeature
-getVPN client = Feature
+getVPN client = feature "VPN status indicator" Default
-  { ftrDepTree = DBusTree (Single (const vpnCmd)) client [vpnDep] [dp]
+  $ DBusTree (Single (const vpnCmd)) client [vpnDep] [dp]
-  , ftrName = "VPN status indicator"
-  , ftrWarning = Default
-  }
   where
-    dp = IOTest vpnPresent
+    dp = IOTest desc vpnPresent
+    desc = "Use nmcli to test if VPN is present"
 
 getBt :: Maybe Client -> BarFeature
-getBt client = Feature
+getBt client = feature "bluetooth status indicator" Default
-  { ftrDepTree = DBusTree (Single (const btCmd)) client [btDep] []
+  $ DBusTree (Single (const btCmd)) client [btDep] []
-  , ftrName = "bluetooth status indicator"
-  , ftrWarning = Default
-  }
 
 getAlsa :: BarFeature
-getAlsa = Feature
+getAlsa = feature "volume level indicator" Default
-  { ftrDepTree = GenTree (Single alsaCmd) [Executable "alsactl"]
+  $ GenTree (Single alsaCmd) [Executable "alsactl"]
-  , ftrName = "volume level indicator"
-  , ftrWarning = Default
-  }
 
 getBl :: Maybe Client -> BarFeature
-getBl client = Feature
+getBl client = feature "Intel backlight indicator" Default
-  { ftrDepTree = DBusTree (Single (const blCmd)) client [intelBacklightSignalDep] []
+  $ DBusTree (Single (const blCmd)) client [intelBacklightSignalDep] []
-  , ftrName = "Intel backlight indicator"
-  , ftrWarning = Default
-  }
 
 getCk :: Maybe Client -> BarFeature
-getCk client = Feature
+getCk client = feature "Clevo keyboard indicator" Default
-  { ftrDepTree = DBusTree (Single (const ckCmd)) client [clevoKeyboardSignalDep] []
+  $ DBusTree (Single (const ckCmd)) client [clevoKeyboardSignalDep] []
-  , ftrName = "Clevo keyboard indicator"
-  , ftrWarning = Default
-  }
 
 getSs :: Maybe Client -> BarFeature
-getSs client = Feature
+getSs client = feature "screensaver indicator" Default
-  { ftrDepTree = DBusTree (Single (const ssCmd)) client [ssSignalDep] []
+  $ DBusTree (Single (const ssCmd)) client [ssSignalDep] []
-  , ftrName = "screensaver indicator"
-  , ftrWarning = Default
-  }
 
 getAllCommands :: [MaybeAction CmdSpec] -> IO BarRegions
 getAllCommands right = do

bin/xmonad.hs

@@ -86,7 +86,7 @@ parse _          = usage
 
 run :: IO ()
 run = do
-  db <- connectDBus
+  db <- connectXDBus
   (h, p) <- spawnPipe "xmobar"
   executeFeature_ $ runRemovableMon $ dbSystemClient db
   executeFeatureWith_ forkIO_ runPowermon
@@ -123,17 +123,31 @@ run = do
 
 printDeps :: IO ()
 printDeps = do
-  db <- connectDBus
+  (i, x) <- allFeatures
-  lockRes <- evalFeature runScreenLock
+  mapM_ printDep $ concatMap extractFeatures i ++ concatMap extractFeatures x
-  let lock = whenSatisfied lockRes
-  mapM_ printDep $ concatMap flatten $ externalBindings ts db lock
   where
-    ts = ThreadState { tsChildPIDs = [], tsChildHandles = [] }
+    extractFeatures (Feature f)      = dtDeps $ ftrDepTree f
-    flatten = concatMap (dtDeps . ftrDepTree . kbMaybeAction) . kgBindings
+    extractFeatures (ConstFeature _) = []
     dtDeps (GenTree _ ds)      = ds
     dtDeps (DBusTree _ _ _ ds) = ds
-    printDep (Executable s) = putStrLn s
+    printDep = putStrLn . depName
-    printDep _              = skip
+
+allFeatures :: IO ([FeatureIO], [FeatureX])
+allFeatures = do
+  ses <- getDBusClient False
+  sys <- getDBusClient True
+  let db = DBusState ses sys
+  lockRes <- evalFeature runScreenLock
+  let lock = whenSatisfied lockRes
+  let bfs = concatMap (fmap kbMaybeAction . kgBindings)
+            $ externalBindings ts db lock
+  let dbus = fmap (\f -> f ses) dbusExporters
+  let others =  [runRemovableMon sys, runPowermon]
+  forM_ ses disconnect
+  forM_ sys disconnect
+  return (dbus ++ others, bfs)
+  where
+    ts = ThreadState { tsChildPIDs = [], tsChildHandles = [] }
 
 usage :: IO ()
 usage = putStrLn $ intercalate "\n"
@@ -141,13 +155,16 @@ usage = putStrLn $ intercalate "\n"
   , "xmonad --deps: print dependencies"
   ]
 
-connectDBus :: IO DBusState
+connectXDBus :: IO DBusState
-connectDBus = do
+connectXDBus = connectDBus_ startXMonadService
-  sesClient <- startXMonadService
+
-  sysClient <- getDBusClient True
+connectDBus_ :: IO (Maybe Client) -> IO DBusState
+connectDBus_ getSes = do
+  ses <- getSes
+  sys <- getDBusClient True
   return DBusState
-    { dbSessionClient = sesClient
+    { dbSessionClient = ses
-    , dbSystemClient = sysClient
+    , dbSystemClient = sys
     }
 
 --------------------------------------------------------------------------------

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

@@ -87,11 +87,9 @@ matchSignal BrightnessConfig { bcPath = p, bcInterface = i } cb =
 
 brightnessExporter :: RealFrac b => [Dependency] -> BrightnessConfig a b
   -> Maybe Client -> FeatureIO
-brightnessExporter deps bc@BrightnessConfig { bcName = n } client = Feature
+brightnessExporter deps bc@BrightnessConfig { bcName = n } client = feature
-  { ftrDepTree = DBusTree (Single (exportBrightnessControls' bc)) client [Bus xmonadBusName] deps
+  (n ++ " exporter") Default
-  , ftrName = n ++ " exporter"
+  $ DBusTree (Single (exportBrightnessControls' bc)) client [Bus xmonadBusName] deps
-  , ftrWarning = Default
-  }
 
 exportBrightnessControls' :: RealFrac b => BrightnessConfig a b -> Client -> IO ()
 exportBrightnessControls' bc client = do

lib/XMonad/Internal/DBus/Control.hs

@@ -11,6 +11,7 @@ module XMonad.Internal.DBus.Control
   , withDBusClient_
   , stopXMonadService
   , disconnect
+  , dbusExporters
   ) where
 
 import           Control.Monad                                  (forM_, void)
@@ -29,10 +30,8 @@ startXMonadService :: IO (Maybe Client)
 startXMonadService = do
   client <- getDBusClient False
   forM_ client requestXMonadName
-  mapM_ (\f -> executeFeature_ $ f client) exporters
+  mapM_ (\f -> executeFeature_ $ f client) dbusExporters
   return client
-  where
-    exporters = [exportScreensaver, exportIntelBacklight, exportClevoKeyboard]
 
 stopXMonadService :: Client -> IO ()
 stopXMonadService client = do
@@ -51,3 +50,6 @@ requestXMonadName client = do
   forM_ msg putStrLn
   where
     xn = "'" ++ formatBusName xmonadBusName ++ "'"
+
+dbusExporters :: [Maybe Client -> FeatureIO]
+dbusExporters = [exportScreensaver, exportIntelBacklight, exportClevoKeyboard]

lib/XMonad/Internal/DBus/Removable.hs

@@ -82,8 +82,5 @@ listenDevices client = do
       $ playSoundMaybe p . f . signalBody
 
 runRemovableMon :: Maybe Client -> FeatureIO
-runRemovableMon client = Feature
+runRemovableMon client = feature "removeable device monitor" Default
-  { ftrDepTree = DBusTree (Single listenDevices) client [addedDep, removedDep] []
+  $ DBusTree (Single listenDevices) client [addedDep, removedDep] []
-  , ftrName = "removeable device monitor"
-  , ftrWarning = Default
-  }

lib/XMonad/Internal/DBus/Screensaver.hs

@@ -95,7 +95,7 @@ bodyGetCurrentState _   = Nothing
 -- | Exported haskell API
 
 exportScreensaver :: Maybe Client -> FeatureIO
-exportScreensaver client = Feature
+exportScreensaver client = Feature $ Feature_
   { ftrDepTree = DBusTree (Single cmd) client [Bus xmonadBusName] [Executable ssExecutable]
   , ftrName = "screensaver interface"
   , ftrWarning = Default

lib/XMonad/Internal/Dependency.hs

@@ -1,5 +1,5 @@
-{-# LANGUAGE GADTs           #-}
+{-# LANGUAGE GADTs             #-}
-{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE OverloadedStrings #-}
 
 --------------------------------------------------------------------------------
 -- | Functions for handling dependencies
@@ -13,10 +13,12 @@ module XMonad.Internal.Dependency
   , FeatureX
   , FeatureIO
   , Feature(..)
+  , Feature_(..)
   , Warning(..)
   , Dependency(..)
   , UnitType(..)
   , DBusMember(..)
+  , feature
   , ioFeature
   , evalFeature
   , systemUnit
@@ -34,13 +36,16 @@ module XMonad.Internal.Dependency
   , executeFeature_
   , executeFeatureWith
   , executeFeatureWith_
+  , depName
   ) where
 
 import           Control.Monad.IO.Class
 import           Control.Monad.Identity
 
+-- import           Data.Aeson
 import           Data.List               (find)
 import           Data.Maybe              (catMaybes, fromMaybe, listToMaybe)
+-- import qualified Data.Text               as T
 
 import           DBus
 import           DBus.Client
@@ -68,12 +73,24 @@ import           XMonad.Internal.Shell
 -- 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
+-- TODO some things to add to make this more feature-ful (lol)
+-- - use AndOr types to encode alternative dependencies into the tree
+-- - use an Alt data constructor for Features (which will mean "try A before B"
+-- - add an Either String Bool to dependency nodes that encodes testing status
+--   (where Right False means untested)
+-- - add a lens/functor mapper thingy to walk down the tree and update testing
+--   status fields
+-- - print to JSON
+-- - make sum type to hold all type instances of Feature blabla (eg IO and X)
+-- - figure out how to make features a dependency of another feature
+
+data Feature_ a = Feature_
   { ftrDepTree :: DepTree a
   , ftrName    :: String
   , ftrWarning :: Warning
   }
-  | ConstFeature a
+
+data Feature a = Feature (Feature_ a) | ConstFeature a
 
 -- TODO this is silly as is, and could be made more useful by representing
 -- loglevels
@@ -83,20 +100,19 @@ type FeatureX = Feature (X ())
 
 type FeatureIO = Feature (IO ())
 
+feature :: String -> Warning -> DepTree a -> Feature a
+feature n w t = Feature $ Feature_
+  { ftrDepTree = t
+  , ftrName = n
+  , ftrWarning = w
+  }
+
 ioFeature :: MonadIO m => Feature (IO b) -> Feature (m b)
 ioFeature (ConstFeature a) = ConstFeature $ liftIO a
-ioFeature Feature {..} =
+ioFeature (Feature f)      = Feature $ f {ftrDepTree = liftIO <$> ftrDepTree f}
-  -- HACK just doing a normal record update here will make GHC complain about
-  -- an 'insufficiently polymorphic record update' ...I guess because my
-  -- GADT isn't polymorphic enough (which is obviously BS)
-  Feature {ftrDepTree = liftIO <$> ftrDepTree, ..}
 
 featureDefault :: String -> [Dependency] -> a -> Feature a
-featureDefault n ds x = Feature
+featureDefault n ds x = feature n Default $ GenTree (Single x) ds
-  { ftrDepTree = GenTree (Single x) ds
-  , ftrName = n
-  , ftrWarning = Default
-  }
 
 featureExe :: MonadIO m => String -> String -> Feature (m ())
 featureExe n cmd = featureExeArgs n cmd []
@@ -105,13 +121,10 @@ featureExeArgs :: MonadIO m => String -> String -> [String] -> Feature (m ())
 featureExeArgs n cmd args =
   featureDefault n [Executable cmd] $ spawnCmd cmd args
 
-featureEndpoint :: String -> BusName -> ObjectPath -> InterfaceName -> MemberName
+featureEndpoint :: String -> BusName -> ObjectPath -> InterfaceName
-  -> Maybe Client -> FeatureIO
+  -> MemberName -> Maybe Client -> FeatureIO
-featureEndpoint name busname path iface mem client = Feature
+featureEndpoint name busname path iface mem client = feature name Default
-  { ftrDepTree = DBusTree (Single cmd) client deps []
+  $ DBusTree (Single cmd) client deps []
-  , ftrName = name
-  , ftrWarning = Default
-  }
   where
     cmd c = void $ callMethod c busname path iface mem
     deps = [Endpoint busname path iface $ Method_ mem]
@@ -156,11 +169,7 @@ type MaybeX = MaybeAction (X ())
 
 evalFeature :: Feature a -> IO (MaybeAction a)
 evalFeature (ConstFeature x) = return $ Just x
-evalFeature Feature
+evalFeature (Feature (Feature_{ftrDepTree = a, ftrName = n, ftrWarning = w})) = do
-  { ftrDepTree = a
-  , ftrName = n
-  , ftrWarning = w
-  } = do
   procName <- getProgName
   res <- evalTree a
   either (printWarnings procName) (return . Just) res
@@ -229,7 +238,7 @@ ifSatisfied _ alt      = alt
 
 data Dependency = Executable String
   | AccessiblePath FilePath Bool Bool
-  | IOTest (IO (Maybe String))
+  | IOTest String (IO (Maybe String))
   | Systemd UnitType String
 
 data UnitType = SystemUnit | UserUnit deriving (Eq, Show)
@@ -270,7 +279,7 @@ data DBusDep =
 
 evalDependency :: Dependency -> IO (Maybe String)
 evalDependency (Executable n)         = exeSatisfied n
-evalDependency (IOTest t)             = t
+evalDependency (IOTest _ t)           = t
 evalDependency (Systemd t n)          = unitSatisfied t n
 evalDependency (AccessiblePath p r w) = pathSatisfied p r w
 
@@ -365,3 +374,40 @@ dbusDepSatisfied client (Endpoint busname objpath iface mem) = do
       , formatBusName busname
       ]
 
+--------------------------------------------------------------------------------
+-- | Printing dependencies
+
+-- instance ToJSON (DepTree a) where
+--   toJSON (GenTree _) = undefined
+
+-- instance ToJSON Dependency where
+--   toJSON (Executable n)         = depValue "executable" Nothing n
+--   toJSON (IOTest d _)           = depValue "internal" Nothing d
+--   toJSON (Systemd t n)          = depValue "systemd" (Just $ tp t) n
+--     where
+--       tp SystemUnit = "sys"
+--       tp UserUnit   = "user"
+--   toJSON (AccessiblePath p r w) = depValue "path" perms p
+--     where
+--       perms = case (r, w) of
+--         (True, True)  -> Just "readwrite"
+--         (True, False) -> Just "read"
+--         (False, True) -> Just "write"
+--         _             -> Nothing
+
+-- depValue :: String -> Maybe String -> String -> Value
+-- depValue t s n = object
+--   [ "type" .= t
+--   , "name" .= n
+--   , "subtype" .= maybe Null (String . T.pack) s
+--   ]
+
+depName :: Dependency -> String
+depName (Executable n)         = "executable: " ++ n
+depName (IOTest d _)           = "internal: " ++ d
+depName (Systemd t n)          = "systemd (" ++ tp t ++ "): "  ++ n
+  where
+    tp SystemUnit = "sys"
+    tp UserUnit   = "user"
+depName (AccessiblePath p _ _) = "path: " ++ p
+

my-xmonad.cabal

@@ -53,7 +53,8 @@ library
                  , xmonad-extras >= 0.15.2
                  , xmonad >= 0.13
                  , xmonad-contrib >= 0.13
-    ghc-options: -Wall -Werror -fno-warn-missing-signatures
+                 , aeson >= 2.0.3.0
+    ghc-options: -Wall -Werror -Wpartial-fields -fno-warn-missing-signatures
     default-language: Haskell2010
 
 executable xmonad
@@ -65,7 +66,7 @@ executable xmonad
                  , xmonad >= 0.13
                  , xmonad-contrib >= 0.13
     default-language: Haskell2010
-    ghc-options: -Wall -Werror -fno-warn-missing-signatures -threaded
+    ghc-options: -Wall -Werror -Wpartial-fields -fno-warn-missing-signatures -threaded
 
 executable xmobar
     main-is: bin/xmobar.hs
@@ -79,4 +80,4 @@ executable xmobar
                  , xmonad-contrib >= 0.13
                  , directory >= 1.3.3.0
     default-language: Haskell2010
-    ghc-options: -Wall -Werror -fno-warn-missing-signatures -threaded
+    ghc-options: -Wall -Werror -Wpartial-fields -fno-warn-missing-signatures -threaded