From 05c0b6a1165ed8fa37598765ab7fc3a6bcd35e67 Mon Sep 17 00:00:00 2001 From: ndwarshuis Date: Sun, 3 Jul 2022 18:23:32 -0400 Subject: [PATCH] REF use common feature structure --- bin/xmonad.hs | 169 +++++++++++--------- lib/XMonad/Internal/Command/Power.hs | 18 +-- lib/XMonad/Internal/Concurrent/ACPIEvent.hs | 11 +- lib/XMonad/Internal/DBus/Control.hs | 58 +++++-- lib/XMonad/Internal/Dependency.hs | 37 +++-- lib/XMonad/Internal/Theme.hs | 46 +++++- 6 files changed, 211 insertions(+), 128 deletions(-) diff --git a/bin/xmonad.hs b/bin/xmonad.hs index abb3b1e..28eb80a 100644 --- a/bin/xmonad.hs +++ b/bin/xmonad.hs @@ -8,10 +8,6 @@ module Main (main) where import Control.Concurrent import Control.Monad - ( forM_ - , unless - , void - ) import Data.List ( intercalate @@ -85,70 +81,110 @@ parse _ = usage run :: IO () run = do - db <- connectXDBus - (h, p) <- spawnPipe "xmobar" - ps <- catMaybes <$> mapM executeSometimes [ runNetAppDaemon - , runFlameshotDaemon - , runNotificationDaemon - , runBwDaemon - , runClipManager - , runAutolock - ] - void $ executeSometimes $ runRemovableMon $ dbSystemClient db - dws <- allDWs - forkIO_ $ void $ executeSometimes runPowermon - forkIO_ $ runWorkspaceMon dws - let ts = ThreadState - { tsChildPIDs = p:ps - , tsChildHandles = [h] - } - fb <- evalAlways T.defFont - ext <- evalExternal $ externalBindings ts db - sk <- evalAlways runShowKeys - ha <- evalAlways runHandleACPI - -- IDK why this is necessary; nothing prior to this line will print if missing - hFlush stdout + conf <- evalConf =<< connectDBusX ds <- getDirectories - let conf = ewmh - $ addKeymap dws sk (filterExternal ext) - $ docks - $ def { terminal = myTerm - , modMask = myModMask - , layoutHook = myLayouts fb - , manageHook = myManageHook dws - , handleEventHook = myEventHook ha - , startupHook = myStartupHook - , workspaces = myWorkspaces - , logHook = myLoghook h - , clickJustFocuses = False - , focusFollowsMouse = False - , normalBorderColor = T.bordersColor - , focusedBorderColor = T.selectedBordersColor - } + -- IDK why this is necessary; nothing prior to this will print if missing + hFlush stdout launch conf ds + +data FeatureSet = FeatureSet + { fsKeys :: ThreadState -> DBusState -> [KeyGroup FeatureX] + , fsDBusExporters :: [Maybe Client -> SometimesIO] + , fsPowerMon :: SometimesIO + , fsRemovableMon :: Maybe Client -> SometimesIO + , fsDaemons :: [Sometimes (IO ProcessHandle)] + , fsACPIHandler :: Always (String -> X ()) + , fsTabbedTheme :: Always Theme + , fsDynWorkspaces :: [Sometimes DynWorkspace] + , fsShowKeys :: Always ([((KeyMask, KeySym), NamedAction)] -> X ()) + } + +features :: FeatureSet +features = FeatureSet + { fsKeys = externalBindings + , fsDBusExporters = dbusExporters + , fsPowerMon = runPowermon + , fsRemovableMon = runRemovableMon + , fsACPIHandler = runHandleACPI + , fsDynWorkspaces = allDWs' + , fsTabbedTheme = T.tabbedFeature + , fsShowKeys = runShowKeys + , fsDaemons = [ runNetAppDaemon + , runFlameshotDaemon + -- TODO the problem with launching + -- dunst here is that the history + -- will get nuked on each restart + , runNotificationDaemon + , runBwDaemon + -- TODO does this have a lag when + -- spawned within the WM? + , runClipManager + , runAutolock + ] + } + +evalConf db = do + -- start DBus interfaces first since many features after this test these + -- interfaces as dependencies + startDBusInterfaces + (xmobarHandle, ts) <- startChildDaemons + startRemovableMon + startPowerMon + dws <- startDynWorkspaces + tt <- evalAlways $ fsTabbedTheme features + -- fb <- evalAlways $ fsFontBuilder features + kbs <- filterExternal <$> evalExternal (fsKeys features ts db) + sk <- evalAlways $ fsShowKeys features + ha <- evalAlways $ fsACPIHandler features + return $ ewmh + $ addKeymap dws sk kbs + $ docks + $ def { terminal = myTerm + , modMask = myModMask + , layoutHook = myLayouts tt + , manageHook = myManageHook dws + , handleEventHook = myEventHook ha + , startupHook = myStartupHook + , workspaces = myWorkspaces + , logHook = myLoghook xmobarHandle + , clickJustFocuses = False + , focusFollowsMouse = False + , normalBorderColor = T.bordersColor + , focusedBorderColor = T.selectedBordersColor + } where forkIO_ = void . forkIO + startDBusInterfaces = mapM_ (\f -> executeSometimes $ f $ dbSesClient db) + $ fsDBusExporters features + startChildDaemons = do + (h, p) <- spawnPipe "xmobar" + ps <- catMaybes <$> mapM executeSometimes (fsDaemons features) + return (h, ThreadState (p:ps) [h]) + startRemovableMon = void $ executeSometimes $ fsRemovableMon features + $ dbSysClient db + startPowerMon = forkIO_ $ void $ executeSometimes $ fsPowerMon features + startDynWorkspaces = do + dws <- catMaybes <$> mapM evalSometimes (fsDynWorkspaces features) + forkIO_ $ runWorkspaceMon dws + return dws printDeps :: IO () printDeps = do - ses <- getDBusClient False - sys <- getDBusClient True - let db = DBusState ses sys + db <- connectDBus (i, f, d) <- allFeatures db is <- mapM dumpSometimes i fs <- mapM dumpFeature f ds <- mapM dumpSometimes d let (UQ u) = jsonArray $ fmap JSON_UQ $ is ++ fs ++ ds putStrLn u - forM_ ses disconnect - forM_ sys disconnect + disconnectDBus db allFeatures :: DBusState -> IO ([SometimesIO], [FeatureX], [Sometimes DynWorkspace]) allFeatures db = do let bfs = concatMap (fmap kbMaybeAction . kgBindings) $ externalBindings ts db - let dbus = fmap (\f -> f $ dbSessionClient db) dbusExporters - let others = [runRemovableMon $ dbSystemClient db, runPowermon] + let dbus = fmap (\f -> f $ dbSesClient db) dbusExporters + let others = [runRemovableMon $ dbSysClient db, runPowermon] return (dbus ++ others, Left runScreenLock:bfs, allDWs') where ts = ThreadState { tsChildPIDs = [], tsChildHandles = [] } @@ -159,26 +195,9 @@ usage = putStrLn $ intercalate "\n" , "xmonad --deps: print dependencies" ] -connectXDBus :: IO DBusState -connectXDBus = connectDBus_ startXMonadService - -connectDBus_ :: IO (Maybe Client) -> IO DBusState -connectDBus_ getSes = do - ses <- getSes - sys <- getDBusClient True - return DBusState - { dbSessionClient = ses - , dbSystemClient = sys - } - -------------------------------------------------------------------------------- -- | Concurrency configuration -data DBusState = DBusState - { dbSessionClient :: Maybe Client - , dbSystemClient :: Maybe Client - } - data ThreadState = ThreadState { tsChildPIDs :: [ProcessHandle] , tsChildHandles :: [Handle] @@ -188,8 +207,7 @@ data ThreadState = ThreadState runCleanup :: ThreadState -> DBusState -> X () runCleanup ts db = io $ do mapM_ killHandle $ tsChildPIDs ts - forM_ (dbSessionClient db) stopXMonadService - forM_ (dbSystemClient db) disconnect + disconnectDBusX db -------------------------------------------------------------------------------- -- | Startuphook configuration @@ -300,21 +318,18 @@ allDWs' = [xsaneDynamicWorkspace , f5vpnDynamicWorkspace ] -allDWs :: IO [DynWorkspace] -allDWs = catMaybes <$> mapM evalSometimes allDWs' - -------------------------------------------------------------------------------- -- | Layout configuration -- NOTE this will have all available layouts, even those that may be for -- features that failed. Trying to dynamically take out a layout seems to -- make a new type :/ -myLayouts fb = onWorkspace vmTag vmLayout +myLayouts tt = onWorkspace vmTag vmLayout $ onWorkspace gimpTag gimpLayout $ mkToggle (single HIDE) $ tall ||| fulltab ||| full where - addTopBar = noFrillsDeco shrinkText $ T.tabbedTheme fb + addTopBar = noFrillsDeco shrinkText tt tall = renamed [Replace "Tall"] $ avoidStruts $ addTopBar @@ -323,7 +338,7 @@ myLayouts fb = onWorkspace vmTag vmLayout fulltab = renamed [Replace "Tabbed"] $ avoidStruts $ noBorders - $ tabbedAlways shrinkText $ T.tabbedTheme fb + $ tabbedAlways shrinkText tt full = renamed [Replace "Full"] $ noBorders Full vmLayout = noBorders Full @@ -656,7 +671,7 @@ externalBindings ts db = , KeyBinding "M-S-," "keyboard down" $ ck bctlDec , KeyBinding "M-S-M1-," "keyboard min" $ ck bctlMin , KeyBinding "M-S-M1-." "keyboard max" $ ck bctlMax - , KeyBinding "M-" "power menu" $ Right runPowerPrompt + , KeyBinding "M-" "power menu" $ Left runPowerPrompt , KeyBinding "M-" "quit xmonad" $ Left runQuitPrompt , KeyBinding "M-" "lock screen" $ Left runScreenLock -- M- reserved for showing the keymap @@ -672,7 +687,7 @@ externalBindings ts db = ] ] where - cl = dbSessionClient db + cl = dbSesClient db brightessControls ctl getter = (ioSometimes . getter . ctl) cl ib = Left . brightessControls intelBacklightControls ck = Left . brightessControls clevoKeyboardControls diff --git a/lib/XMonad/Internal/Command/Power.hs b/lib/XMonad/Internal/Command/Power.hs index dee3667..86c8b15 100644 --- a/lib/XMonad/Internal/Command/Power.hs +++ b/lib/XMonad/Internal/Command/Power.hs @@ -96,8 +96,7 @@ quitPrompt :: T.FontBuilder -> X () quitPrompt = confirmPrompt' "quit?" $ io exitSuccess sometimesPrompt :: String -> (T.FontBuilder -> X ()) -> SometimesX -sometimesPrompt n = sometimesIO n (n ++ " command") - $ Only $ IOAlways T.defFont id +sometimesPrompt n = sometimesIO n (n ++ " command") T.defFontTree -- TODO doesn't this need to also lock the screen? runSuspendPrompt :: SometimesX @@ -141,7 +140,7 @@ runOptimusPrompt = Sometimes "graphics switcher" [s] where s = Subfeature { sfData = r, sfName = "optimus manager", sfLevel = Error } r = IORoot runOptimusPrompt' t - t = And1 (Only $ IOAlways T.defFont id) + t = And1 T.defFontTree $ And_ (Only_ $ sysExe myOptimusManager) (Only_ $ sysExe myPrimeOffload) -------------------------------------------------------------------------------- @@ -170,16 +169,13 @@ data PowerPrompt = PowerPrompt instance XPrompt PowerPrompt where showXPrompt PowerPrompt = "(P)oweroff (S)uspend (H)ibernate (R)eboot:" -runPowerPrompt :: AlwaysX -runPowerPrompt = Always "power prompt" $ Option sf fallback +runPowerPrompt :: SometimesX +runPowerPrompt = Sometimes "power prompt" [sf] where - sf = Subfeature withLock "lock-enabled prompt" Error + sf = Subfeature withLock "prompt with lock" Error withLock = IORoot (uncurry powerPrompt) tree - tree = And12 (,) (Only $ IOSometimes runScreenLock id) (Only $ IOAlways T.defFont id) - fallback = Always_ $ FallbackTree powerPromptNoLock $ FallbackBottom T.defFont - -powerPromptNoLock :: T.FontBuilder -> X () -powerPromptNoLock = powerPrompt skip + tree = And12 (,) lockTree T.defFontTree + lockTree = Or (Only $ IOSometimes runScreenLock id) (Only $ IOConst skip) powerPrompt :: X () -> T.FontBuilder -> X () powerPrompt lock fb = mkXPrompt PowerPrompt theme comp executeMaybeAction diff --git a/lib/XMonad/Internal/Concurrent/ACPIEvent.hs b/lib/XMonad/Internal/Concurrent/ACPIEvent.hs index f7afce7..ff52cf9 100644 --- a/lib/XMonad/Internal/Concurrent/ACPIEvent.hs +++ b/lib/XMonad/Internal/Concurrent/ACPIEvent.hs @@ -27,7 +27,10 @@ import XMonad.Internal.Command.Power import XMonad.Internal.Concurrent.ClientMessage import XMonad.Internal.Dependency import XMonad.Internal.Shell -import XMonad.Internal.Theme (FontBuilder, defFont) +import XMonad.Internal.Theme + ( FontBuilder + , defFontTree + ) -------------------------------------------------------------------------------- -- | Data structure to hold the ACPI events I care about @@ -120,6 +123,6 @@ runHandleACPI :: Always (String -> X ()) runHandleACPI = Always "ACPI event handler" $ Option sf fallback where sf = Subfeature withLock "acpid prompt" Error - withLock = IORoot (uncurry handleACPI) - $ And12 (,) (Only $ IOAlways defFont id) (Only $ IOSometimes runScreenLock id) - fallback = Always_ $ FallbackTree (`handleACPI` skip) $ FallbackBottom defFont + withLock = IORoot (uncurry handleACPI) $ And12 (,) defFontTree $ Only + $ IOSometimes runScreenLock id + fallback = Always_ $ FallbackAlone $ const skip diff --git a/lib/XMonad/Internal/DBus/Control.hs b/lib/XMonad/Internal/DBus/Control.hs index 8d74eca..406512d 100644 --- a/lib/XMonad/Internal/DBus/Control.hs +++ b/lib/XMonad/Internal/DBus/Control.hs @@ -5,16 +5,19 @@ module XMonad.Internal.DBus.Control ( Client - , startXMonadService + , DBusState(..) + , connectDBus + , connectDBusX + , disconnectDBus + , disconnectDBusX , getDBusClient , withDBusClient , withDBusClient_ - , stopXMonadService , disconnect , dbusExporters ) where -import Control.Monad (forM_, void) +import Control.Monad import DBus import DBus.Client @@ -26,17 +29,42 @@ import XMonad.Internal.DBus.Common import XMonad.Internal.DBus.Screensaver import XMonad.Internal.Dependency -startXMonadService :: IO (Maybe Client) -startXMonadService = do - client <- getDBusClient False - forM_ client requestXMonadName - mapM_ (\f -> executeSometimes $ f client) dbusExporters - return client +-- | Current connections to the DBus (session and system buses) +data DBusState = DBusState + { dbSesClient :: Maybe Client + , dbSysClient :: Maybe Client + } -stopXMonadService :: Client -> IO () -stopXMonadService client = do - void $ releaseName client xmonadBusName - disconnect client +-- | Connect to the DBus +connectDBus :: IO DBusState +connectDBus = do + ses <- getDBusClient False + sys <- getDBusClient True + return DBusState { dbSesClient = ses, dbSysClient = sys } + +-- | Disconnect from the DBus +disconnectDBus :: DBusState -> IO () +disconnectDBus db = forM_ (dbSysClient db) disconnect + +-- | Connect to the DBus and request the XMonad name +connectDBusX :: IO DBusState +connectDBusX = do + db <- connectDBus + forM_ (dbSesClient db) requestXMonadName + return db + +-- | Disconnect from DBus and release the XMonad name +disconnectDBusX :: DBusState -> IO () +disconnectDBusX db = do + forM_ (dbSesClient db) releaseXMonadName + disconnectDBus db + +-- | All exporter features to be assigned to the DBus +dbusExporters :: [Maybe Client -> SometimesIO] +dbusExporters = [exportScreensaver, exportIntelBacklight, exportClevoKeyboard] + +releaseXMonadName :: Client -> IO () +releaseXMonadName cl = void $ releaseName cl xmonadBusName requestXMonadName :: Client -> IO () requestXMonadName client = do @@ -51,5 +79,5 @@ requestXMonadName client = do where xn = "'" ++ formatBusName xmonadBusName ++ "'" -dbusExporters :: [Maybe Client -> SometimesIO] -dbusExporters = [exportScreensaver, exportIntelBacklight, exportClevoKeyboard] +-- executeExporters :: Maybe Client -> IO () +-- executeExporters cl = mapM_ (\f -> executeSometimes $ f cl) dbusExporters diff --git a/lib/XMonad/Internal/Dependency.hs b/lib/XMonad/Internal/Dependency.hs index c1c217e..b37e741 100644 --- a/lib/XMonad/Internal/Dependency.hs +++ b/lib/XMonad/Internal/Dependency.hs @@ -74,7 +74,6 @@ module XMonad.Internal.Dependency -- dependency construction , sysExe , localExe - , fontFam , sysdSystem , sysdUser , listToAnds @@ -83,6 +82,9 @@ module XMonad.Internal.Dependency , pathRW , pathW , sysTest + + -- misc + , shellTest ) where import Control.Monad.IO.Class @@ -255,9 +257,15 @@ type DBusTree p = Tree IODependency DBusDependency_ p type IOTree_ = Tree_ IODependency_ type DBusTree_ = Tree_ DBusDependency_ --- | A dependency that only requires IO to evaluate -data IODependency p = IORead String (IO (Result p)) +-- | A dependency that only requires IO to evaluate (with payload) +data IODependency p = + -- an IO action that yields a payload + IORead String (IO (Result p)) + -- always yields a payload + | IOConst p + -- an always that yields a payload | forall a. IOAlways (Always a) (a -> p) + -- a sometimes that yields a payload | forall a. IOSometimes (Sometimes a) (a -> p) -- | A dependency pertaining to the DBus @@ -269,8 +277,10 @@ data DBusDependency_ = Bus BusName data IODependency_ = IOSystem_ SystemDependency | forall a. IOSometimes_ (Sometimes a) -data SystemDependency = Executable Bool FilePath - | FontFamily String +-- | A system component to an IODependency +-- This name is dumb, but most constructors should be obvious +data SystemDependency = + Executable Bool FilePath | AccessiblePath FilePath Bool Bool | IOTest String (IO (Maybe String)) | Systemd UnitType String @@ -411,6 +421,7 @@ testTree test_ test = go testIODependency :: IODependency p -> IO (Result p) testIODependency (IORead _ t) = t +testIODependency (IOConst c) = return $ Right $ PostPass c [] -- TODO this is a bit odd because this is a dependency that will always -- succeed, which kinda makes this pointless. The only reason I would want this -- is if I want to have a built-in logic to "choose" a payload to use in @@ -445,10 +456,6 @@ testSysDependency (Executable sys bin) = maybe (Just msg) (const Nothing) where msg = unwords [e, "executable", singleQuote bin, "not found"] e = if sys then "system" else "local" -testSysDependency (FontFamily fam) = shellTest cmd msg - where - msg = unwords ["font family", singleQuote fam, "not found"] - cmd = fmtCmd "fc-list" ["-q", singleQuote fam] testSysDependency (Systemd t n) = shellTest cmd msg where msg = unwords ["systemd", unitType t, "unit", singleQuote n, "not found"] @@ -620,9 +627,6 @@ toAnd a b = And_ (Only_ a) (Only_ b) exe :: Bool -> String -> IODependency_ exe b = IOSystem_ . Executable b -fontFam :: String -> IODependency_ -fontFam = IOSystem_ . FontFamily - sysExe :: String -> IODependency_ sysExe = exe True @@ -749,10 +753,10 @@ dataTree_ f_ = go dataIODependency :: IODependency p -> DependencyData dataIODependency d = first Q $ case d of - (IORead n _) -> ("ioread", [("desc", JSON_Q $ Q n)]) - -- TODO make this actually useful (I actually need to name my features) - (IOSometimes _ _) -> ("sometimes", []) - (IOAlways _ _) -> ("always", []) + (IORead n _) -> ("ioread", [("desc", JSON_Q $ Q n)]) + (IOConst _) -> ("const", []) + (IOSometimes (Sometimes n _) _) -> ("sometimes", [("name", JSON_Q $ Q n)]) + (IOAlways (Always n _) _) -> ("always", [("name", JSON_Q $ Q n)]) dataIODependency_ :: IODependency_ -> DependencyData dataIODependency_ d = case d of @@ -766,7 +770,6 @@ dataSysDependency d = first Q $ , ("path", JSON_Q $ Q path) ]) (IOTest desc _) -> ("iotest", [("desc", JSON_Q $ Q desc)]) - (FontFamily fam) -> ("font", [("family", JSON_Q $ Q fam)]) (AccessiblePath p r w) -> ("path", [ ("path", JSON_Q $ Q p) , ("readable", JSON_UQ $ jsonBool r) , ("writable", JSON_UQ $ jsonBool w) diff --git a/lib/XMonad/Internal/Theme.hs b/lib/XMonad/Internal/Theme.hs index 7d21b38..b74bff9 100644 --- a/lib/XMonad/Internal/Theme.hs +++ b/lib/XMonad/Internal/Theme.hs @@ -22,9 +22,12 @@ module XMonad.Internal.Theme , FontBuilder , buildFont , defFontData - , defFont + , defFontDep + , defFontTree , fontFeature + , fontDependency , tabbedTheme + , tabbedFeature , promptTheme ) where @@ -33,7 +36,11 @@ import Data.Colour import Data.Colour.SRGB import Data.List +import System.Exit + import XMonad.Internal.Dependency +import XMonad.Internal.Process +import XMonad.Internal.Shell import qualified XMonad.Layout.Decoration as D import qualified XMonad.Prompt as P @@ -130,11 +137,32 @@ buildFont (Just fam) FontData { weight = w showLower :: Show a => Maybe a -> Maybe String showLower = fmap (fmap toLower . show) +fallbackFont :: FontBuilder +fallbackFont = buildFont Nothing + +testFont :: String -> IO (Result FontBuilder) +testFont fam = do + (rc, _, _) <- readCreateProcessWithExitCode' (shell cmd) "" + return $ case rc of + ExitSuccess -> Right $ PostPass (buildFont $ Just fam) [] + _ -> Left [msg] + where + msg = unwords ["font family", qFam, "not found"] + cmd = fmtCmd "fc-list" ["-q", qFam] + qFam = singleQuote fam + +fontDependency :: String -> IODependency FontBuilder +fontDependency fam = + IORead (unwords ["test if font", singleQuote fam, "exists"]) $ testFont fam + +fontTree :: String -> IOTree FontBuilder +fontTree fam = Or (Only $ fontDependency fam) (Only $ IOConst fallbackFont) + fontFeature :: String -> String -> Always FontBuilder fontFeature n fam = always1 n sfn root def where sfn = "Font family for " ++ fam - root = IORoot_ (buildFont $ Just fam) $ Only_ $ fontFam fam + root = IORoot id $ fontTree fam def = buildFont Nothing -------------------------------------------------------------------------------- @@ -149,8 +177,11 @@ defFontData = FontData , pixelsize = Nothing } -defFont :: Always FontBuilder -defFont = fontFeature "Default Font" "DejaVu Sans" +defFontDep :: IODependency FontBuilder +defFontDep = fontDependency "DejaVu Sans" + +defFontTree :: IOTree FontBuilder +defFontTree = fontTree "DejaVu Sans" -------------------------------------------------------------------------------- -- | Complete themes @@ -181,6 +212,13 @@ tabbedTheme fb = D.def , D.windowTitleIcons = [] } +tabbedFeature :: Always D.Theme +tabbedFeature = Always "theme for tabbed windows" $ Option sf fallback + where + sf = Subfeature niceTheme "theme with nice font" Error + niceTheme = IORoot tabbedTheme $ Only defFontDep + fallback = Always_ $ FallbackAlone $ tabbedTheme fallbackFont + promptTheme :: FontBuilder -> P.XPConfig promptTheme fb = P.def { P.font = fb $ defFontData { size = Just 12 }