ENH put entire runtime in rio
This commit is contained in:
parent
59c483785a
commit
87394dd6a9
160
bin/xmonad.hs
160
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
|
||||
-- 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
|
||||
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
|
||||
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
|
||||
|
|
|
|||
Loading…
Reference in New Issue