REF use common feature structure

This commit is contained in:
Nathan Dwarshuis 2022-07-03 18:23:32 -04:00
parent f82e1bd032
commit 05c0b6a116
6 changed files with 211 additions and 128 deletions

View File

@ -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-<End>" "power menu" $ Right runPowerPrompt
, KeyBinding "M-<End>" "power menu" $ Left runPowerPrompt
, KeyBinding "M-<Home>" "quit xmonad" $ Left runQuitPrompt
, KeyBinding "M-<Delete>" "lock screen" $ Left runScreenLock
-- M-<F1> 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

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -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)

View File

@ -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 }