ENH clean up interfaces

This commit is contained in:
Nathan Dwarshuis 2023-01-01 13:07:10 -05:00
parent 2ef652ebe1
commit e0a186dd18
3 changed files with 36 additions and 32 deletions

View File

@ -114,15 +114,15 @@ run = do
hSetBuffering stdout LineBuffering hSetBuffering stdout LineBuffering
withDBusX_ $ \db -> do withDBusX_ $ \db -> do
let fs = features $ dbSysClient db let fs = features $ dbSysClient db
withDBusInterfaces db (fsDBusExporters fs) $ \_ -> do withDBusInterfaces db (fsDBusExporters fs) $ \unexporters -> do
withXmobar $ \xmobarP -> do withXmobar $ \xmobarP -> do
withChildDaemons fs $ \ds -> do withChildDaemons fs $ \ds -> do
let ts = ThreadState ds (Just xmobarP) let toClean = Cleanup ds (Just xmobarP) unexporters
void $ executeSometimes $ fsRemovableMon fs $ dbSysClient db void $ executeSometimes $ fsRemovableMon fs $ dbSysClient db
void $ async $ void $ executeSometimes $ fsPowerMon fs void $ async $ void $ executeSometimes $ fsPowerMon fs
dws <- startDynWorkspaces fs dws <- startDynWorkspaces fs
runIO <- askRunInIO runIO <- askRunInIO
let cleanup = runCleanup runIO ts db let cleanup = runCleanup runIO toClean db
kbs <- filterExternal <$> evalExternal (fsKeys fs cleanup db) kbs <- filterExternal <$> evalExternal (fsKeys fs cleanup db)
sk <- evalAlways $ fsShowKeys fs sk <- evalAlways $ fsShowKeys fs
ha <- evalAlways $ fsACPIHandler fs ha <- evalAlways $ fsACPIHandler fs
@ -241,49 +241,46 @@ stopChildDaemons ps = do
printDeps :: FIO () printDeps :: FIO ()
printDeps = withDBus_ $ \db -> do printDeps = withDBus_ $ \db -> do
(u, i, f, d) <- allFeatures db runIO <- askRunInIO
let mockCleanup = runCleanup runIO mockClean db
let bfs =
concatMap (fmap kbMaybeAction . kgBindings) $
externalBindings mockCleanup db
let dbus =
fmap (\f -> f $ dbSesClient db) dbusExporters
:: [Sometimes (FIO (), FIO ())]
let others = [runRemovableMon $ dbSysClient db, runPowermon]
-- TODO might be better to use glog for this? -- TODO might be better to use glog for this?
mapM_ logInfo $ mapM_ logInfo $
fmap showFulfillment $ fmap showFulfillment $
sort $ sort $
nub $ nub $
concat $ concat $
fmap dumpSometimes u fmap dumpSometimes dbus
++ fmap dumpFeature f ++ fmap dumpSometimes others
++ fmap dumpSometimes i ++ fmap dumpSometimes allDWs'
++ fmap dumpSometimes d ++ fmap dumpFeature bfs
allFeatures
:: DBusState
-> FIO ([Sometimes (IO (), IO ())], [SometimesIO], [FeatureX], [Sometimes DynWorkspace])
allFeatures db = withRunInIO $ \runIO -> do
let cleanup = runCleanup runIO ts db
let bfs =
concatMap (fmap kbMaybeAction . kgBindings) $
externalBindings cleanup db
let dbus = fmap (\f -> f $ dbSesClient db) dbusExporters
let others = [runRemovableMon $ dbSysClient db, runPowermon]
return (dbus, others, Left runScreenLock : bfs, allDWs')
where where
ts = ThreadState {tsChildPIDs = [], tsXmobar = Nothing} mockClean = Cleanup {clChildren = [], clXmobar = Nothing, clDBusUnexporters = []}
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- Concurrency configuration -- Concurrency configuration
data ThreadState = ThreadState data Cleanup = Cleanup
{ tsChildPIDs :: [Process () () ()] { clChildren :: [Process () () ()]
, tsXmobar :: Maybe (Process Handle () ()) , clXmobar :: Maybe (Process Handle () ())
, clDBusUnexporters :: [FIO ()]
} }
runCleanup runCleanup
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m) :: (FIO () -> IO ())
=> (m () -> IO ()) -> Cleanup
-> ThreadState
-> DBusState -> DBusState
-> X () -> X ()
runCleanup runIO ts db = liftIO $ runIO $ do runCleanup runIO ts db = liftIO $ runIO $ do
mapM_ stopXmobar $ tsXmobar ts mapM_ stopXmobar $ clXmobar ts
stopChildDaemons $ tsChildPIDs ts stopChildDaemons $ clChildren ts
sequence_ $ clDBusUnexporters ts
disconnectDBusX db disconnectDBusX db
-- | Kill a process (group) after xmonad has already started -- | Kill a process (group) after xmonad has already started

View File

@ -113,7 +113,9 @@ withDBusInterfaces db interfaces = bracket up sequence
return $ snd <$> pairs return $ snd <$> pairs
-- | All exporter features to be assigned to the DBus -- | All exporter features to be assigned to the DBus
dbusExporters :: MonadUnliftIO m => [Maybe SesClient -> Sometimes (m (), m ())] dbusExporters
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
=> [Maybe SesClient -> Sometimes (m (), m ())]
dbusExporters = [exportScreensaver, exportIntelBacklight, exportClevoKeyboard] dbusExporters = [exportScreensaver, exportIntelBacklight, exportClevoKeyboard]
releaseXMonadName releaseXMonadName

View File

@ -93,7 +93,10 @@ bodyGetCurrentState _ = Nothing
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- Exported haskell API -- Exported haskell API
exportScreensaver :: MonadUnliftIO m => Maybe SesClient -> Sometimes (m (), m ()) exportScreensaver
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
=> Maybe SesClient
-> Sometimes (m (), m ())
exportScreensaver ses = exportScreensaver ses =
sometimesDBus ses "screensaver toggle" "xset" (toAnd_ bus ssx) $ \cl -> (up cl, down cl) sometimesDBus ses "screensaver toggle" "xset" (toAnd_ bus ssx) $ \cl -> (up cl, down cl)
where where
@ -111,7 +114,9 @@ exportScreensaver ses =
] ]
, interfaceSignals = [sig] , interfaceSignals = [sig]
} }
down cl = liftIO $ unexport (toClient cl) ssPath down cl = do
logInfo "removing screensaver interface"
liftIO $ unexport (toClient cl) ssPath
sig = sig =
I.Signal I.Signal
{ I.signalName = memState { I.signalName = memState