diff --git a/bin/xmobar.hs b/bin/xmobar.hs index 4190560..1f20b4c 100644 --- a/bin/xmobar.hs +++ b/bin/xmobar.hs @@ -291,71 +291,47 @@ rightPlugins sysClient sesClient = mapM evalFeature ] getWireless :: BarFeature -getWireless = Feature - { ftrDepTree = GenTree (Double wirelessCmd $ readInterface isWireless) [] - , ftrName = "wireless status indicator" - , ftrWarning = Default - } +getWireless = feature "wireless status indicator" Default + $ GenTree (Double wirelessCmd $ readInterface isWireless) [] getEthernet :: Maybe Client -> BarFeature -getEthernet client = Feature - { ftrDepTree = DBusTree action client [devDep] [] - , ftrName = "ethernet status indicator" - , ftrWarning = Default - } +getEthernet client = feature "ethernet status indicator" Default + $ DBusTree action client [devDep] [] where action = Double (\i _ -> ethernetCmd i) (readInterface isEthernet) getBattery :: BarFeature -getBattery = Feature - { ftrDepTree = GenTree (Single batteryCmd) [IOTest hasBattery] - , ftrName = "battery level indicator" - , ftrWarning = Default - } +getBattery = feature "battery level indicator" Default + $ GenTree (Single batteryCmd) [IOTest desc hasBattery] + where + desc = "Test if battery is present" getVPN :: Maybe Client -> BarFeature -getVPN client = Feature - { ftrDepTree = DBusTree (Single (const vpnCmd)) client [vpnDep] [dp] - , ftrName = "VPN status indicator" - , ftrWarning = Default - } +getVPN client = feature "VPN status indicator" Default + $ DBusTree (Single (const vpnCmd)) client [vpnDep] [dp] where - dp = IOTest vpnPresent + dp = IOTest desc vpnPresent + desc = "Use nmcli to test if VPN is present" getBt :: Maybe Client -> BarFeature -getBt client = Feature - { ftrDepTree = DBusTree (Single (const btCmd)) client [btDep] [] - , ftrName = "bluetooth status indicator" - , ftrWarning = Default - } +getBt client = feature "bluetooth status indicator" Default + $ DBusTree (Single (const btCmd)) client [btDep] [] getAlsa :: BarFeature -getAlsa = Feature - { ftrDepTree = GenTree (Single alsaCmd) [Executable "alsactl"] - , ftrName = "volume level indicator" - , ftrWarning = Default - } +getAlsa = feature "volume level indicator" Default + $ GenTree (Single alsaCmd) [Executable "alsactl"] getBl :: Maybe Client -> BarFeature -getBl client = Feature - { ftrDepTree = DBusTree (Single (const blCmd)) client [intelBacklightSignalDep] [] - , ftrName = "Intel backlight indicator" - , ftrWarning = Default - } +getBl client = feature "Intel backlight indicator" Default + $ DBusTree (Single (const blCmd)) client [intelBacklightSignalDep] [] getCk :: Maybe Client -> BarFeature -getCk client = Feature - { ftrDepTree = DBusTree (Single (const ckCmd)) client [clevoKeyboardSignalDep] [] - , ftrName = "Clevo keyboard indicator" - , ftrWarning = Default - } +getCk client = feature "Clevo keyboard indicator" Default + $ DBusTree (Single (const ckCmd)) client [clevoKeyboardSignalDep] [] getSs :: Maybe Client -> BarFeature -getSs client = Feature - { ftrDepTree = DBusTree (Single (const ssCmd)) client [ssSignalDep] [] - , ftrName = "screensaver indicator" - , ftrWarning = Default - } +getSs client = feature "screensaver indicator" Default + $ DBusTree (Single (const ssCmd)) client [ssSignalDep] [] getAllCommands :: [MaybeAction CmdSpec] -> IO BarRegions getAllCommands right = do diff --git a/bin/xmonad.hs b/bin/xmonad.hs index 805fd40..cbc4cd3 100644 --- a/bin/xmonad.hs +++ b/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 - lockRes <- evalFeature runScreenLock - let lock = whenSatisfied lockRes - mapM_ printDep $ concatMap flatten $ externalBindings ts db lock + (i, x) <- allFeatures + mapM_ printDep $ concatMap extractFeatures i ++ concatMap extractFeatures x where - ts = ThreadState { tsChildPIDs = [], tsChildHandles = [] } - flatten = concatMap (dtDeps . ftrDepTree . kbMaybeAction) . kgBindings + extractFeatures (Feature f) = dtDeps $ ftrDepTree f + extractFeatures (ConstFeature _) = [] dtDeps (GenTree _ ds) = ds dtDeps (DBusTree _ _ _ ds) = ds - printDep (Executable s) = putStrLn s - printDep _ = skip + printDep = putStrLn . depName + +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 -connectDBus = do - sesClient <- startXMonadService - sysClient <- getDBusClient True +connectXDBus :: IO DBusState +connectXDBus = connectDBus_ startXMonadService + +connectDBus_ :: IO (Maybe Client) -> IO DBusState +connectDBus_ getSes = do + ses <- getSes + sys <- getDBusClient True return DBusState - { dbSessionClient = sesClient - , dbSystemClient = sysClient + { dbSessionClient = ses + , dbSystemClient = sys } -------------------------------------------------------------------------------- diff --git a/lib/XMonad/Internal/DBus/Brightness/Common.hs b/lib/XMonad/Internal/DBus/Brightness/Common.hs index 93f046a..edc309d 100644 --- a/lib/XMonad/Internal/DBus/Brightness/Common.hs +++ b/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 - { ftrDepTree = DBusTree (Single (exportBrightnessControls' bc)) client [Bus xmonadBusName] deps - , ftrName = n ++ " exporter" - , ftrWarning = Default - } +brightnessExporter deps bc@BrightnessConfig { bcName = n } client = feature + (n ++ " exporter") Default + $ DBusTree (Single (exportBrightnessControls' bc)) client [Bus xmonadBusName] deps exportBrightnessControls' :: RealFrac b => BrightnessConfig a b -> Client -> IO () exportBrightnessControls' bc client = do diff --git a/lib/XMonad/Internal/DBus/Control.hs b/lib/XMonad/Internal/DBus/Control.hs index 570f5c9..5637ec0 100644 --- a/lib/XMonad/Internal/DBus/Control.hs +++ b/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] diff --git a/lib/XMonad/Internal/DBus/Removable.hs b/lib/XMonad/Internal/DBus/Removable.hs index d59d178..9b6c670 100644 --- a/lib/XMonad/Internal/DBus/Removable.hs +++ b/lib/XMonad/Internal/DBus/Removable.hs @@ -82,8 +82,5 @@ listenDevices client = do $ playSoundMaybe p . f . signalBody runRemovableMon :: Maybe Client -> FeatureIO -runRemovableMon client = Feature - { ftrDepTree = DBusTree (Single listenDevices) client [addedDep, removedDep] [] - , ftrName = "removeable device monitor" - , ftrWarning = Default - } +runRemovableMon client = feature "removeable device monitor" Default + $ DBusTree (Single listenDevices) client [addedDep, removedDep] [] diff --git a/lib/XMonad/Internal/DBus/Screensaver.hs b/lib/XMonad/Internal/DBus/Screensaver.hs index 4a7e900..38afca7 100644 --- a/lib/XMonad/Internal/DBus/Screensaver.hs +++ b/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 diff --git a/lib/XMonad/Internal/Dependency.hs b/lib/XMonad/Internal/Dependency.hs index 133c062..45fa88c 100644 --- a/lib/XMonad/Internal/Dependency.hs +++ b/lib/XMonad/Internal/Dependency.hs @@ -1,5 +1,5 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE GADTs #-} +{-# 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 {..} = - -- 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, ..} +ioFeature (Feature f) = Feature $ f {ftrDepTree = liftIO <$> ftrDepTree f} featureDefault :: String -> [Dependency] -> a -> Feature a -featureDefault n ds x = Feature - { ftrDepTree = GenTree (Single x) ds - , ftrName = n - , ftrWarning = Default - } +featureDefault n ds x = feature n Default $ GenTree (Single x) ds 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 - -> Maybe Client -> FeatureIO -featureEndpoint name busname path iface mem client = Feature - { ftrDepTree = DBusTree (Single cmd) client deps [] - , ftrName = name - , ftrWarning = Default - } +featureEndpoint :: String -> BusName -> ObjectPath -> InterfaceName + -> MemberName -> Maybe Client -> FeatureIO +featureEndpoint name busname path iface mem client = feature name Default + $ DBusTree (Single cmd) client deps [] 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 - { ftrDepTree = a - , ftrName = n - , ftrWarning = w - } = do +evalFeature (Feature (Feature_{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 + diff --git a/my-xmonad.cabal b/my-xmonad.cabal index 6ecde78..a33d6a2 100644 --- a/my-xmonad.cabal +++ b/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