diff --git a/bin/xmonad.hs b/bin/xmonad.hs index 1ee95a2..9234c21 100644 --- a/bin/xmonad.hs +++ b/bin/xmonad.hs @@ -114,38 +114,39 @@ run = do hSetBuffering stdout LineBuffering withDBusX_ $ \db -> do let fs = features $ dbSysClient db - startDBusInterfaces db fs - withXmobar $ \xmobarP -> do - withChildDaemons fs $ \ds -> do - let ts = ThreadState ds (Just xmobarP) - void $ executeSometimes $ fsRemovableMon fs $ dbSysClient db - void $ async $ void $ executeSometimes $ fsPowerMon fs - dws <- startDynWorkspaces fs - runIO <- askRunInIO - let cleanup = runCleanup runIO ts db - kbs <- filterExternal <$> evalExternal (fsKeys fs cleanup db) - sk <- evalAlways $ fsShowKeys fs - ha <- evalAlways $ fsACPIHandler fs - tt <- evalAlways $ fsTabbedTheme fs - let conf = - ewmh $ - addKeymap dws sk kbs $ - docks $ - def - { terminal = myTerm - , modMask = myModMask - , layoutHook = myLayouts tt - , manageHook = myManageHook dws - , handleEventHook = myEventHook runIO ha - , startupHook = myStartupHook - , workspaces = myWorkspaces - , logHook = myLoghook xmobarP - , clickJustFocuses = False - , focusFollowsMouse = False - , normalBorderColor = T.unpack XT.bordersColor - , focusedBorderColor = T.unpack XT.selectedBordersColor - } - io $ runXMonad conf + -- startDBusInterfaces db fs + withDBusInterfaces db $ \_ -> do + withXmobar $ \xmobarP -> do + withChildDaemons fs $ \ds -> do + let ts = ThreadState ds (Just xmobarP) + void $ executeSometimes $ fsRemovableMon fs $ dbSysClient db + void $ async $ void $ executeSometimes $ fsPowerMon fs + dws <- startDynWorkspaces fs + runIO <- askRunInIO + let cleanup = runCleanup runIO ts db + kbs <- filterExternal <$> evalExternal (fsKeys fs cleanup db) + sk <- evalAlways $ fsShowKeys fs + ha <- evalAlways $ fsACPIHandler fs + tt <- evalAlways $ fsTabbedTheme fs + let conf = + ewmh $ + addKeymap dws sk kbs $ + docks $ + def + { terminal = myTerm + , modMask = myModMask + , layoutHook = myLayouts tt + , manageHook = myManageHook dws + , handleEventHook = myEventHook runIO ha + , startupHook = myStartupHook + , workspaces = myWorkspaces + , logHook = myLoghook xmobarP + , clickJustFocuses = False + , focusFollowsMouse = False + , normalBorderColor = T.unpack XT.bordersColor + , focusedBorderColor = T.unpack XT.selectedBordersColor + } + io $ runXMonad conf where startDynWorkspaces fs = do dws <- catMaybes <$> mapM evalSometimes (fsDynWorkspaces fs) @@ -157,10 +158,8 @@ runXMonad conf = do dirs <- getCreateDirectories launch conf dirs -startDBusInterfaces :: DBusState -> FeatureSet -> FIO () -startDBusInterfaces db fs = - mapM_ (\f -> executeSometimes $ f $ dbSesClient db) $ - fsDBusExporters fs +-- startDBusInterfaces :: DBusState -> [Maybe SesClient -> SometimesIO] -> FIO () +-- startDBusInterfaces db = mapM_ (\f -> executeSometimes $ f $ dbSesClient db) getCreateDirectories :: IO Directories getCreateDirectories = do @@ -177,7 +176,7 @@ getCreateDirectories = do data FeatureSet = FeatureSet { fsKeys :: X () -> DBusState -> [KeyGroup FeatureX] - , fsDBusExporters :: [Maybe SesClient -> SometimesIO] + , fsDBusExporters :: [Maybe SesClient -> Sometimes (IO (), IO ())] , fsPowerMon :: SometimesIO , fsRemovableMon :: Maybe SysClient -> SometimesIO , fsDaemons :: [Sometimes (FIO (Process () () ()))] @@ -246,16 +245,21 @@ stopChildDaemons ps = do printDeps :: FIO () printDeps = withDBus_ $ \db -> do - (i, f, d) <- allFeatures db + (u, i, f, d) <- allFeatures db -- TODO might be better to use glog for this? mapM_ logInfo $ fmap showFulfillment $ sort $ nub $ concat $ - fmap dumpFeature f ++ fmap dumpSometimes i ++ fmap dumpSometimes d + fmap dumpSometimes u + ++ fmap dumpFeature f + ++ fmap dumpSometimes i + ++ fmap dumpSometimes d -allFeatures :: DBusState -> FIO ([SometimesIO], [FeatureX], [Sometimes DynWorkspace]) +allFeatures + :: DBusState + -> FIO ([Sometimes (IO (), IO ())], [SometimesIO], [FeatureX], [Sometimes DynWorkspace]) allFeatures db = withRunInIO $ \runIO -> do let cleanup = runCleanup runIO ts db let bfs = @@ -263,7 +267,7 @@ allFeatures db = withRunInIO $ \runIO -> do externalBindings cleanup db let dbus = fmap (\f -> f $ dbSesClient db) dbusExporters let others = [runRemovableMon $ dbSysClient db, runPowermon] - return (dbus ++ others, Left runScreenLock : bfs, allDWs') + return (dbus, others, Left runScreenLock : bfs, allDWs') where ts = ThreadState {tsChildPIDs = [], tsXmobar = Nothing} diff --git a/lib/XMonad/Internal/DBus/Brightness/ClevoKeyboard.hs b/lib/XMonad/Internal/DBus/Brightness/ClevoKeyboard.hs index 8352949..75bd291 100644 --- a/lib/XMonad/Internal/DBus/Brightness/ClevoKeyboard.hs +++ b/lib/XMonad/Internal/DBus/Brightness/ClevoKeyboard.hs @@ -115,7 +115,7 @@ brightnessFileDep = pathR brightnessFile [Package AUR "tuxedo-keyboard"] clevoKeyboardSignalDep :: DBusDependency_ SesClient clevoKeyboardSignalDep = signalDep clevoKeyboardConfig -exportClevoKeyboard :: Maybe SesClient -> SometimesIO +exportClevoKeyboard :: MonadUnliftIO m => Maybe SesClient -> Sometimes (m (), m ()) exportClevoKeyboard = brightnessExporter xpfClevoBacklight diff --git a/lib/XMonad/Internal/DBus/Brightness/Common.hs b/lib/XMonad/Internal/DBus/Brightness/Common.hs index 7f336f4..29d844f 100644 --- a/lib/XMonad/Internal/DBus/Brightness/Common.hs +++ b/lib/XMonad/Internal/DBus/Brightness/Common.hs @@ -101,45 +101,47 @@ matchSignal BrightnessConfig {bcPath = p, bcInterface = i} cb = -- Internal DBus Crap brightnessExporter - :: RealFrac b + :: (MonadUnliftIO m, RealFrac b) => XPQuery -> [Fulfillment] -> [IODependency_] -> BrightnessConfig a b -> Maybe SesClient - -> SometimesIO + -> Sometimes (m (), m ()) brightnessExporter q ful deps bc@BrightnessConfig {bcName = n} cl = Sometimes (T.append n " DBus Interface") q [Subfeature root "exporter"] where - root = DBusRoot_ (exportBrightnessControls' bc) tree cl + root = DBusRoot_ (exportBrightnessControlsInner bc) tree cl tree = listToAnds (Bus ful xmonadBusName) $ fmap DBusIO deps -exportBrightnessControls' +exportBrightnessControlsInner :: (MonadUnliftIO m, RealFrac b) => BrightnessConfig a b -> SesClient - -> m () -exportBrightnessControls' bc cl = io $ do - let ses = toClient cl - maxval <- bcGetMax bc -- assume the max value will never change - let bounds = (bcMinRaw bc, maxval) - let autoMethod' m f = autoMethod m $ emitBrightness bc ses =<< f bc bounds - let funget = bcGet bc - export - ses - (bcPath bc) - defaultInterface - { interfaceName = bcInterface bc - , interfaceMethods = - [ autoMethod' memMax bcMax - , autoMethod' memMin bcMin - , autoMethod' memInc bcInc - , autoMethod' memDec bcDec - , autoMethod memGet (round <$> funget bounds :: IO Int32) - ] - , interfaceSignals = [sig] - } + -> (m (), m ()) +exportBrightnessControlsInner bc cl = (up, down) where + up = liftIO $ do + let ses = toClient cl + maxval <- bcGetMax bc -- assume the max value will never change + let bounds = (bcMinRaw bc, maxval) + let autoMethod' m f = autoMethod m $ emitBrightness bc ses =<< f bc bounds + let funget = bcGet bc + export + ses + (bcPath bc) + defaultInterface + { interfaceName = bcInterface bc + , interfaceMethods = + [ autoMethod' memMax bcMax + , autoMethod' memMin bcMin + , autoMethod' memInc bcInc + , autoMethod' memDec bcDec + , autoMethod memGet (round <$> funget bounds :: IO Int32) + ] + , interfaceSignals = [sig] + } + down = liftIO $ unexport (toClient cl) (bcPath bc) sig = I.Signal { I.signalName = memCur diff --git a/lib/XMonad/Internal/DBus/Brightness/IntelBacklight.hs b/lib/XMonad/Internal/DBus/Brightness/IntelBacklight.hs index 0858fed..53dbdcd 100644 --- a/lib/XMonad/Internal/DBus/Brightness/IntelBacklight.hs +++ b/lib/XMonad/Internal/DBus/Brightness/IntelBacklight.hs @@ -99,7 +99,7 @@ maxFileDep = pathR maxFile [] intelBacklightSignalDep :: DBusDependency_ SesClient intelBacklightSignalDep = signalDep intelBacklightConfig -exportIntelBacklight :: Maybe SesClient -> SometimesIO +exportIntelBacklight :: MonadUnliftIO m => Maybe SesClient -> Sometimes (m (), m ()) exportIntelBacklight = brightnessExporter xpfIntelBacklight diff --git a/lib/XMonad/Internal/DBus/Control.hs b/lib/XMonad/Internal/DBus/Control.hs index 50c2baa..4c7791b 100644 --- a/lib/XMonad/Internal/DBus/Control.hs +++ b/lib/XMonad/Internal/DBus/Control.hs @@ -7,6 +7,7 @@ module XMonad.Internal.DBus.Control ( Client , DBusState (..) + , withDBusInterfaces , withDBusX , withDBusX_ , withDBus @@ -99,8 +100,16 @@ disconnectDBusX db = do forM_ (dbSesClient db) releaseXMonadName disconnectDBus db +withDBusInterfaces :: DBusState -> ([FIO ()] -> FIO a) -> FIO a +withDBusInterfaces db = bracket up sequence + where + up = do + pairs <- catMaybes <$> mapM (\f -> evalSometimes $ f $ dbSesClient db) dbusExporters + mapM_ fst pairs + return $ snd <$> pairs + -- | All exporter features to be assigned to the DBus -dbusExporters :: [Maybe SesClient -> SometimesIO] +dbusExporters :: MonadUnliftIO m => [Maybe SesClient -> Sometimes (m (), m ())] dbusExporters = [exportScreensaver, exportIntelBacklight, exportClevoKeyboard] releaseXMonadName diff --git a/lib/XMonad/Internal/DBus/Screensaver.hs b/lib/XMonad/Internal/DBus/Screensaver.hs index 59cda53..cfd20ce 100644 --- a/lib/XMonad/Internal/DBus/Screensaver.hs +++ b/lib/XMonad/Internal/DBus/Screensaver.hs @@ -93,13 +93,13 @@ bodyGetCurrentState _ = Nothing -------------------------------------------------------------------------------- -- Exported haskell API -exportScreensaver :: Maybe SesClient -> SometimesIO +exportScreensaver :: MonadUnliftIO m => Maybe SesClient -> Sometimes (m (), m ()) exportScreensaver ses = - sometimesDBus ses "screensaver toggle" "xset" (toAnd_ bus ssx) cmd + sometimesDBus ses "screensaver toggle" "xset" (toAnd_ bus ssx) $ \cl -> (up cl, down cl) where - cmd cl = + up cl = let cl' = toClient cl - in withRunInIO $ \run -> + in liftIO $ withRunInIO $ \run -> export cl' ssPath @@ -111,6 +111,7 @@ exportScreensaver ses = ] , interfaceSignals = [sig] } + down cl = liftIO $ unexport (toClient cl) ssPath sig = I.Signal { I.signalName = memState