ENH use logger in disconnect
This commit is contained in:
parent
4206893967
commit
609048f6b6
|
@ -2,6 +2,7 @@
|
||||||
{-# LANGUAGE FlexibleInstances #-}
|
{-# LANGUAGE FlexibleInstances #-}
|
||||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
{-# LANGUAGE RankNTypes #-}
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- XMonad binary
|
-- XMonad binary
|
||||||
|
@ -98,7 +99,9 @@ run = do
|
||||||
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
|
||||||
kbs <- filterExternal <$> evalExternal (fsKeys fs ts db)
|
runIO <- askRunInIO
|
||||||
|
let cleanup = runCleanup runIO ts db
|
||||||
|
kbs <- filterExternal <$> evalExternal (fsKeys fs cleanup ts db)
|
||||||
sk <- evalAlways $ fsShowKeys fs
|
sk <- evalAlways $ fsShowKeys fs
|
||||||
ha <- evalAlways $ fsACPIHandler fs
|
ha <- evalAlways $ fsACPIHandler fs
|
||||||
tt <- evalAlways $ fsTabbedTheme fs
|
tt <- evalAlways $ fsTabbedTheme fs
|
||||||
|
@ -151,7 +154,7 @@ getCreateDirectories = do
|
||||||
_ -> return ()
|
_ -> return ()
|
||||||
|
|
||||||
data FeatureSet = FeatureSet
|
data FeatureSet = FeatureSet
|
||||||
{ fsKeys :: ThreadState -> DBusState -> [KeyGroup FeatureX]
|
{ fsKeys :: X () -> ThreadState -> DBusState -> [KeyGroup FeatureX]
|
||||||
, fsDBusExporters :: [Maybe SesClient -> SometimesIO]
|
, fsDBusExporters :: [Maybe SesClient -> SometimesIO]
|
||||||
, fsPowerMon :: SometimesIO
|
, fsPowerMon :: SometimesIO
|
||||||
, fsRemovableMon :: Maybe SysClient -> SometimesIO
|
, fsRemovableMon :: Maybe SysClient -> SometimesIO
|
||||||
|
@ -222,10 +225,11 @@ printDeps = withDBus_ $ \db -> do
|
||||||
fmap dumpFeature f ++ fmap dumpSometimes i ++ fmap dumpSometimes d
|
fmap dumpFeature f ++ fmap dumpSometimes i ++ fmap dumpSometimes d
|
||||||
|
|
||||||
allFeatures :: DBusState -> FIO ([SometimesIO], [FeatureX], [Sometimes DynWorkspace])
|
allFeatures :: DBusState -> FIO ([SometimesIO], [FeatureX], [Sometimes DynWorkspace])
|
||||||
allFeatures db = do
|
allFeatures db = withRunInIO $ \runIO -> do
|
||||||
|
let cleanup = runCleanup runIO ts db
|
||||||
let bfs =
|
let bfs =
|
||||||
concatMap (fmap kbMaybeAction . kgBindings) $
|
concatMap (fmap kbMaybeAction . kgBindings) $
|
||||||
externalBindings ts db
|
externalBindings cleanup ts db
|
||||||
let dbus = fmap (\f -> f $ dbSesClient db) dbusExporters
|
let dbus = fmap (\f -> f $ dbSesClient db) dbusExporters
|
||||||
let others = [runRemovableMon $ dbSysClient db, runPowermon]
|
let others = [runRemovableMon $ dbSysClient db, runPowermon]
|
||||||
return (dbus ++ others, Left runScreenLock : bfs, allDWs')
|
return (dbus ++ others, Left runScreenLock : bfs, allDWs')
|
||||||
|
@ -249,11 +253,16 @@ data ThreadState = ThreadState
|
||||||
, tsXmobar :: Maybe (Process Handle () ())
|
, tsXmobar :: Maybe (Process Handle () ())
|
||||||
}
|
}
|
||||||
|
|
||||||
runCleanup :: ThreadState -> DBusState -> X ()
|
runCleanup
|
||||||
runCleanup ts db = io $ do
|
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
||||||
|
=> (m () -> IO ())
|
||||||
|
-> ThreadState
|
||||||
|
-> DBusState
|
||||||
|
-> X ()
|
||||||
|
runCleanup runIO ts db = io $ do
|
||||||
mapM_ killNoWait $ tsXmobar ts
|
mapM_ killNoWait $ tsXmobar ts
|
||||||
mapM_ killNoWait $ tsChildPIDs ts
|
mapM_ killNoWait $ tsChildPIDs ts
|
||||||
disconnectDBusX db
|
liftIO $ runIO $ disconnectDBusX db
|
||||||
|
|
||||||
-- | Kill a process (group) after xmonad has already started
|
-- | Kill a process (group) after xmonad has already started
|
||||||
-- This is necessary (as opposed to 'stopProcess' from rio) because a) xmonad
|
-- This is necessary (as opposed to 'stopProcess' from rio) because a) xmonad
|
||||||
|
@ -739,8 +748,8 @@ filterExternal = fmap go
|
||||||
]
|
]
|
||||||
}
|
}
|
||||||
|
|
||||||
externalBindings :: ThreadState -> DBusState -> [KeyGroup FeatureX]
|
externalBindings :: X () -> ThreadState -> DBusState -> [KeyGroup FeatureX]
|
||||||
externalBindings ts db =
|
externalBindings cleanup _ db =
|
||||||
[ KeyGroup
|
[ KeyGroup
|
||||||
"Launchers"
|
"Launchers"
|
||||||
[ KeyBinding "<XF86Search>" "select/launch app" $ Left runAppMenu
|
[ KeyBinding "<XF86Search>" "select/launch app" $ Left runAppMenu
|
||||||
|
@ -816,7 +825,7 @@ externalBindings ts db =
|
||||||
ib = Left . brightessControls intelBacklightControls
|
ib = Left . brightessControls intelBacklightControls
|
||||||
ck = Left . brightessControls clevoKeyboardControls
|
ck = Left . brightessControls clevoKeyboardControls
|
||||||
ftrAlways n = Right . Always n . Always_ . FallbackAlone
|
ftrAlways n = Right . Always n . Always_ . FallbackAlone
|
||||||
restartf = ftrAlways "restart function" (runCleanup ts db >> runRestart)
|
restartf = ftrAlways "restart function" (cleanup >> runRestart)
|
||||||
recompilef = ftrAlways "recompile function" runRecompile
|
recompilef = ftrAlways "recompile function" runRecompile
|
||||||
|
|
||||||
type MaybeX = Maybe (X ())
|
type MaybeX = Maybe (X ())
|
||||||
|
|
|
@ -91,7 +91,10 @@ connectDBusX = do
|
||||||
return db
|
return db
|
||||||
|
|
||||||
-- | Disconnect from DBus and release the XMonad name
|
-- | Disconnect from DBus and release the XMonad name
|
||||||
disconnectDBusX :: MonadUnliftIO m => DBusState -> m ()
|
disconnectDBusX
|
||||||
|
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
||||||
|
=> DBusState
|
||||||
|
-> m ()
|
||||||
disconnectDBusX db = do
|
disconnectDBusX db = do
|
||||||
forM_ (dbSesClient db) releaseXMonadName
|
forM_ (dbSesClient db) releaseXMonadName
|
||||||
disconnectDBus db
|
disconnectDBus db
|
||||||
|
@ -100,8 +103,14 @@ disconnectDBusX db = do
|
||||||
dbusExporters :: [Maybe SesClient -> SometimesIO]
|
dbusExporters :: [Maybe SesClient -> SometimesIO]
|
||||||
dbusExporters = [exportScreensaver, exportIntelBacklight, exportClevoKeyboard]
|
dbusExporters = [exportScreensaver, exportIntelBacklight, exportClevoKeyboard]
|
||||||
|
|
||||||
releaseXMonadName :: MonadUnliftIO m => SesClient -> m ()
|
releaseXMonadName
|
||||||
releaseXMonadName ses = liftIO $ void $ releaseName (toClient ses) xmonadBusName
|
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
||||||
|
=> SesClient
|
||||||
|
-> m ()
|
||||||
|
releaseXMonadName ses = do
|
||||||
|
-- TODO this might error?
|
||||||
|
liftIO $ void $ releaseName (toClient ses) xmonadBusName
|
||||||
|
logInfo "released xmonad name"
|
||||||
|
|
||||||
requestXMonadName
|
requestXMonadName
|
||||||
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
||||||
|
|
Loading…
Reference in New Issue