diff --git a/bin/xmonad.hs b/bin/xmonad.hs index 81952e3..19e292a 100644 --- a/bin/xmonad.hs +++ b/bin/xmonad.hs @@ -22,6 +22,7 @@ import Graphics.X11.Xlib.Extras import RIO ( async + , bracket , handleIO ) import RIO.Process @@ -83,7 +84,7 @@ main = getArgs >>= parse parse :: [String] -> IO () parse [] = run parse ["--deps"] = withCache printDeps -parse ["--test"] = void $ withCache . evalConf =<< connectDBusX +-- parse ["--test"] = void $ withCache . evalConf =<< connectDBusX parse _ = usage run :: IO () @@ -101,12 +102,54 @@ run = do -- signal handlers to carry over to the top. uninstallSignalHandlers hSetBuffering stdout LineBuffering - db <- connectDBusX - conf <- withCache $ evalConf db - ds <- getCreateDirectories - -- IDK why this is necessary; nothing prior to this will print if missing - -- hFlush stdout - launch conf ds + withCache $ do + bracket (io connectDBusX) (io . disconnectDBus) $ \db -> do + -- conf <- evalConf db + -- ds <- io getCreateDirectories + -- io $ launch conf ds + let sys = dbSysClient db + let fs = features sys + startDBusInterfaces db fs + withXmobar $ \xmobarP -> do + withChildDaemons fs $ \ds -> do + let ts = ThreadState ds (Just xmobarP) + startRemovableMon db fs + startPowerMon fs + dws <- startDynWorkspaces fs + kbs <- filterExternal <$> evalExternal (fsKeys fs ts 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 ha + , startupHook = myStartupHook + , workspaces = myWorkspaces + , logHook = myLoghook xmobarP + , clickJustFocuses = False + , focusFollowsMouse = False + , normalBorderColor = T.unpack XT.bordersColor + , focusedBorderColor = T.unpack XT.selectedBordersColor + } + dirs <- io getCreateDirectories + io $ launch conf dirs + where + startRemovableMon db fs = void $ executeSometimes $ fsRemovableMon fs + $ dbSysClient db + startPowerMon fs = void $ async $ void $ executeSometimes $ fsPowerMon fs + startDynWorkspaces fs = do + dws <- catMaybes <$> mapM evalSometimes (fsDynWorkspaces fs) + void $ io $ async $ runWorkspaceMon dws + return dws + +startDBusInterfaces :: DBusState -> FeatureSet -> FIO () +startDBusInterfaces db fs = mapM_ (\f -> executeSometimes $ f $ dbSesClient db) + $ fsDBusExporters fs getCreateDirectories :: IO Directories getCreateDirectories = do @@ -153,52 +196,67 @@ features cl = FeatureSet , fsDaemons = [runNetAppDaemon cl, runAutolock] } -evalConf db@DBusState { dbSysClient = cl } = do - -- start DBus interfaces first since many features after this test these - -- interfaces as dependencies - let fs = features cl - tt <- evalAlways $ fsTabbedTheme fs - startDBusInterfaces fs - ts <- startChildDaemons fs - startRemovableMon fs - startPowerMon fs - dws <- startDynWorkspaces fs - -- fb <- evalAlways $ fsFontBuilder features - kbs <- filterExternal <$> evalExternal (fsKeys fs ts db) - sk <- evalAlways $ fsShowKeys fs - ha <- evalAlways $ fsACPIHandler fs - 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 = maybe logViewports myLoghook $ tsXmobar ts - , clickJustFocuses = False - , focusFollowsMouse = False - , normalBorderColor = T.unpack XT.bordersColor - , focusedBorderColor = T.unpack XT.selectedBordersColor - } - where - forkIO_ = void . async - startDBusInterfaces fs = mapM_ (\f -> executeSometimes $ f $ dbSesClient db) - $ fsDBusExporters fs - startChildDaemons fs = do - p <- proc "xmobar" [] (startProcess . setStdin createPipe) - io $ hSetBuffering (getStdin p) LineBuffering - ps <- catMaybes <$> mapM executeSometimes (fsDaemons fs) - return $ ThreadState ps $ Just p - startRemovableMon fs = void $ executeSometimes $ fsRemovableMon fs - $ dbSysClient db - startPowerMon fs = void $ async $ void $ executeSometimes $ fsPowerMon fs - startDynWorkspaces fs = do - dws <- catMaybes <$> mapM evalSometimes (fsDynWorkspaces fs) - io $ forkIO_ $ runWorkspaceMon dws - return dws +-- evalConf db@DBusState { dbSysClient = cl } = do +-- -- start DBus interfaces first since many features after this test these +-- -- interfaces as dependencies +-- let fs = features cl +-- tt <- evalAlways $ fsTabbedTheme fs +-- startDBusInterfaces fs +-- ts <- startChildDaemons fs +-- startRemovableMon fs +-- startPowerMon fs +-- dws <- startDynWorkspaces fs +-- -- fb <- evalAlways $ fsFontBuilder features +-- kbs <- filterExternal <$> evalExternal (fsKeys fs ts db) +-- sk <- evalAlways $ fsShowKeys fs +-- ha <- evalAlways $ fsACPIHandler fs +-- 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 = maybe logViewports myLoghook $ tsXmobar ts +-- , clickJustFocuses = False +-- , focusFollowsMouse = False +-- , normalBorderColor = T.unpack XT.bordersColor +-- , focusedBorderColor = T.unpack XT.selectedBordersColor +-- } +-- where +-- forkIO_ = void . async +-- startDBusInterfaces fs = mapM_ (\f -> executeSometimes $ f $ dbSesClient db) +-- $ fsDBusExporters fs +-- startChildDaemons fs = do +-- p <- proc "xmobar" [] (startProcess . setStdin createPipe) +-- io $ hSetBuffering (getStdin p) LineBuffering +-- ps <- catMaybes <$> mapM executeSometimes (fsDaemons fs) +-- return $ ThreadState ps $ Just p +-- startRemovableMon fs = void $ executeSometimes $ fsRemovableMon fs +-- $ dbSysClient db +-- startPowerMon fs = void $ async $ void $ executeSometimes $ fsPowerMon fs +-- startDynWorkspaces fs = do +-- dws <- catMaybes <$> mapM evalSometimes (fsDynWorkspaces fs) +-- io $ forkIO_ $ runWorkspaceMon dws +-- return dws + +startXmobar :: FIO (Process Handle () ()) +startXmobar = do + p <- proc "xmobar" [] (startProcess . setStdin createPipe) + io $ hSetBuffering (getStdin p) LineBuffering + return p + +startChildDaemons :: FeatureSet -> FIO [ProcessHandle] +startChildDaemons fs = catMaybes <$> mapM executeSometimes (fsDaemons fs) + +withChildDaemons :: FeatureSet -> ([ProcessHandle] -> FIO a) -> FIO a +withChildDaemons fs = bracket (startChildDaemons fs) (mapM_ (io . killHandle)) + +withXmobar :: (Process Handle () () -> FIO a) -> FIO a +withXmobar = bracket startXmobar stopProcess printDeps :: FIO () printDeps = do