ENH clean up interfaces
This commit is contained in:
parent
2ef652ebe1
commit
e0a186dd18
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
Loading…
Reference in New Issue