REF move DMenu to separate module and clean up main function code

This commit is contained in:
Nathan Dwarshuis 2020-03-28 14:44:50 -04:00
parent 012798c85f
commit 68d83d859f
5 changed files with 211 additions and 174 deletions

View File

@ -3,6 +3,8 @@
module Main (main) where module Main (main) where
import Internal.DMenu
import ACPI import ACPI
import DBus.Common import DBus.Common
import DBus.IntelBacklight import DBus.IntelBacklight
@ -17,37 +19,27 @@ import WorkspaceMon
import Control.Arrow (first) import Control.Arrow (first)
import Control.Concurrent import Control.Concurrent
import Control.Monad import Control.Monad
( forM ( forM_
, forM_
, liftM2 , liftM2
, mapM_ , mapM_
, void , void
, when , when
) )
import Data.List import Data.List (isPrefixOf, sortBy, sortOn)
( find
, isPrefixOf
, sortBy
, sortOn
)
import qualified Data.Map.Lazy as M import qualified Data.Map.Lazy as M
import Data.Maybe (catMaybes, isJust) import Data.Maybe (isJust)
import Data.Monoid (All (..)) import Data.Monoid (All (..))
import DBus.Client (Client)
import Graphics.X11.Types import Graphics.X11.Types
import Graphics.X11.Xlib.Atom import Graphics.X11.Xlib.Atom
import Graphics.X11.Xlib.Extras import Graphics.X11.Xlib.Extras
import Graphics.X11.Xrandr
import System.Directory import System.Directory
import System.Exit import System.Exit
import System.IO import System.IO
import System.Posix.IO import System.Process
import System.Posix.Process
import System.Posix.Types
import Text.Read (readMaybe) import Text.Read (readMaybe)
@ -63,36 +55,38 @@ import XMonad.Actions.Warp
import XMonad.Hooks.EwmhDesktops import XMonad.Hooks.EwmhDesktops
import XMonad.Hooks.ManageDocks import XMonad.Hooks.ManageDocks
import XMonad.Hooks.ManageHelpers import XMonad.Hooks.ManageHelpers
-- import XMonad.Layout.LayoutCombinators hiding ((|||))
-- import XMonad.Layout.Master
import XMonad.Layout.NoBorders import XMonad.Layout.NoBorders
import XMonad.Layout.NoFrillsDecoration import XMonad.Layout.NoFrillsDecoration
import XMonad.Layout.PerWorkspace import XMonad.Layout.PerWorkspace
import XMonad.Layout.Renamed import XMonad.Layout.Renamed
-- import XMonad.Layout.Simplest
import XMonad.Layout.Tabbed import XMonad.Layout.Tabbed
import XMonad.Prompt import XMonad.Prompt
import XMonad.Prompt.ConfirmPrompt import XMonad.Prompt.ConfirmPrompt
import qualified XMonad.StackSet as W import qualified XMonad.StackSet as W
import XMonad.Util.EZConfig import XMonad.Util.EZConfig
import XMonad.Util.NamedActions import XMonad.Util.NamedActions
import XMonad.Util.Run
main :: IO () main :: IO ()
main = do main = do
dbClient <- startXMonadService cl <- startXMonadService
(barPID, h) <- spawnPipe' "xmobar" (p, h) <- spawnPipe' "xmobar"
_ <- forkIO runPowermon _ <- forkIO runPowermon
_ <- forkIO runWorkspaceMon' _ <- forkIO $ runWorkspaceMon matchPatterns
let ts = ThreadState
{ client = cl
, childPIDs = [p]
, childHandles = [h]
}
launch launch
$ ewmh $ ewmh
$ addDescrKeys' ((myModMask, xK_F1), showKeybindings) (mkKeys [barPID] dbClient) $ addKeymap ts
$ def { terminal = myTerm $ def { terminal = myTerm
, modMask = myModMask , modMask = myModMask
, layoutHook = myLayouts , layoutHook = myLayouts
, manageHook = myManageHook <+> manageDocks <+> manageHook def , manageHook = myManageHook
, handleEventHook = myEventHook <+> docksEventHook <+> handleEventHook def , handleEventHook = myEventHook
, startupHook = docksStartupHook <+> startupHook def , startupHook = myStartupHook
, workspaces = myWorkspaces , workspaces = myWorkspaces
, logHook = myLoghook h , logHook = myLoghook h
, clickJustFocuses = False , clickJustFocuses = False
@ -101,24 +95,21 @@ main = do
, focusedBorderColor = T.selectedBordersColor , focusedBorderColor = T.selectedBordersColor
} }
runWorkspaceMon' :: IO () myStartupHook :: X ()
runWorkspaceMon' = runWorkspaceMon myStartupHook = docksStartupHook <+> startupHook def
$ fromList [ (myGimpClass, myGimpWorkspace)
, (myVMClass, myVMWorkspace)
, (myXSaneClass, myXSaneWorkspace)
]
spawnPipe' :: MonadIO m => String -> m (ProcessID, Handle) data ThreadState = ThreadState
spawnPipe' x = io $ do { client :: Client
(rd, wr) <- createPipe , childPIDs :: [Pid]
setFdOption wr CloseOnExec True , childHandles :: [Handle]
h <- fdToHandle wr }
hSetBuffering h LineBuffering
p <- xfork $ do matchPatterns :: M.Map String String
_ <- dupTo rd stdInput matchPatterns = fromList
executeFile "/bin/sh" False ["-c", x] Nothing [ (myGimpClass, myGimpWorkspace)
closeFd rd , (myVMClass, myVMWorkspace)
return (p, h) , (myXSaneClass, myXSaneWorkspace)
]
myWorkspaces :: [String] myWorkspaces :: [String]
myWorkspaces = map show [1..10 :: Int] myWorkspaces = map show [1..10 :: Int]
@ -201,7 +192,10 @@ moveBottom :: W.StackSet i l a s sd -> W.StackSet i l a s sd
moveBottom = W.modify' $ \(W.Stack f t b) -> W.Stack f (reverse b ++ t) [] moveBottom = W.modify' $ \(W.Stack f t b) -> W.Stack f (reverse b ++ t) []
myManageHook :: ManageHook myManageHook :: ManageHook
myManageHook = composeOne myManageHook = manageApps <+> manageDocks <+> manageHook def
manageApps :: ManageHook
manageApps = composeOne
[ isDialog -?> doCenterFloat [ isDialog -?> doCenterFloat
-- VM window -- VM window
, className =? myVMClass -?> appendViewShift myVMWorkspace , className =? myVMClass -?> appendViewShift myVMWorkspace
@ -228,7 +222,10 @@ myManageHook = composeOne
] ]
myEventHook :: Event -> X All myEventHook :: Event -> X All
myEventHook ClientMessageEvent { ev_message_type = t, ev_data = d } myEventHook = monitorEventHook <+> docksEventHook <+> handleEventHook def
monitorEventHook :: Event -> X All
monitorEventHook ClientMessageEvent { ev_message_type = t, ev_data = d }
| t == bITMAP = do | t == bITMAP = do
let (xtype, tag) = splitXMsg d let (xtype, tag) = splitXMsg d
case xtype of case xtype of
@ -242,7 +239,7 @@ myEventHook ClientMessageEvent { ev_message_type = t, ev_data = d }
status <- io isDischarging status <- io isDischarging
forM_ status $ \s -> runScreenLock >> when s runSuspend forM_ status $ \s -> runScreenLock >> when s runSuspend
return (All True) return (All True)
myEventHook _ = return (All True) monitorEventHook _ = return (All True)
data PowerPrompt = PowerPrompt data PowerPrompt = PowerPrompt
@ -335,85 +332,6 @@ runTerm = spawn myTerm
runCalc :: X () runCalc :: X ()
runCalc = spawnCmd myTerm ["-e", "R"] runCalc = spawnCmd myTerm ["-e", "R"]
myDmenuCmd :: String
myDmenuCmd = "rofi"
-- | Focus rofi on the current workspace always
-- Apparently xrandr and xinerama order monitors differently, which
-- means they have different indices. Since rofi uses the former and
-- xmonad uses the latter, this function is to figure out the xrandr
-- screen name based on the xinerama screen that is currently in
-- focus. The steps to do this:
-- 1) get the coordinates of the currently focuses xinerama screen
-- 2) get list of Xrandr outputs and filter which ones are connected
-- 3) match the coordinates of the xinerama screen with the xrandr
-- output and return the latter's name (eg "DP-0") which can be
-- fed to Rofi
getMonitorName :: X (Maybe String)
getMonitorName = do
dpy <- asks display
root <- asks theRoot
-- these are the focused screen coordinates according to xinerama
(sx, sy) <- getCoords
io $ do
res <- xrrGetScreenResourcesCurrent dpy root
outputs <- forM res $ \res' ->
forM (xrr_sr_outputs res') $ \output -> do
oi <- xrrGetOutputInfo dpy res' output
case oi of
-- connection: 0 == connected, 1 == disconnected
Just XRROutputInfo { xrr_oi_connection = 0
, xrr_oi_name = name
, xrr_oi_crtc = crtc
} -> do
ci <- xrrGetCrtcInfo dpy res' crtc
return $ (\ci' -> Just (name, xrr_ci_x ci', xrr_ci_y ci'))
=<< ci
_ -> return Nothing
return $ (\(name, _, _) -> Just name)
=<< find (\(_, x, y) -> x == sx && y == sy) . catMaybes
=<< outputs
where
getCoords = do
(Rectangle x y _ _) <- getFocusedScreen
return (fromIntegral x, fromIntegral y)
getFocusedScreen :: X Rectangle
getFocusedScreen = withWindowSet $ return . screenRect . W.screenDetail . W.current
spawnDmenuCmd :: String -> [String] -> X ()
spawnDmenuCmd cmd args = do
name <- getMonitorName
case name of
Just n -> spawnCmd cmd $ ["-m", n] ++ args
Nothing -> io $ putStrLn "fail"
spawnDmenuCmd' :: [String] -> X ()
spawnDmenuCmd' = spawnDmenuCmd myDmenuCmd
runCmdMenu :: X ()
runCmdMenu = spawnDmenuCmd' ["-show", "run"]
runAppMenu :: X ()
runAppMenu = spawnDmenuCmd' ["-show", "drun"]
runClipMenu :: X ()
runClipMenu = spawnDmenuCmd'
[ "-modi", "\"clipboard:greenclip print\""
, "-show", "clipboard"
, "-run-command", "'{cmd}'"
, "-theme-str", "'#element.selected.normal { background-color: #00c44e; }'"
]
runWinMenu :: X ()
runWinMenu = spawnDmenuCmd' ["-show", "window"]
runNetMenu :: X ()
runNetMenu = spawnDmenuCmd "networkmanager_dmenu" []
runDevMenu :: X ()
runDevMenu = spawnDmenuCmd "rofi-devices" []
runBrowser :: X () runBrowser :: X ()
runBrowser = spawn "brave" runBrowser = spawn "brave"
@ -447,10 +365,10 @@ runScreenCapture = runFlameshot "screen"
runDesktopCapture :: X () runDesktopCapture :: X ()
runDesktopCapture = runFlameshot "full" runDesktopCapture = runFlameshot "full"
runCleanup :: [ProcessID] -> Client -> X () runCleanup :: ThreadState -> X ()
runCleanup ps client = io $ do runCleanup ts = io $ do
mapM_ killPID ps mapM_ killPID $ childPIDs ts
stopXMonadService client stopXMonadService $ client ts
runRestart :: X () runRestart :: X ()
runRestart = restart "xmonad" True runRestart = restart "xmonad" True
@ -516,26 +434,6 @@ runToggleDPMS = io $ void callToggle
-- keybindings -- keybindings
showKeybindings :: [((KeyMask, KeySym), NamedAction)] -> NamedAction
showKeybindings x = addName "Show Keybindings" $ do
name <- getMonitorName
case name of
Just n -> do
h <- spawnPipe $ cmd n
io $ hPutStr h (unlines $ showKm x)
io $ hClose h
return ()
Nothing -> io $ putStrLn "fail"
where cmd name = fmtCmd myDmenuCmd
[ "-dmenu"
, "-m"
, name
, "-p"
, "commands"
, "-theme-str"
, "'#element.selected.normal { background-color: #a200ff; }'"
]
myVMWorkspace :: String myVMWorkspace :: String
myVMWorkspace = "VM" myVMWorkspace = "VM"
@ -578,18 +476,12 @@ runXSane = spawnOrSwitch myXSaneWorkspace $ spawnCmd "xsane" []
myModMask :: KeyMask myModMask :: KeyMask
myModMask = mod4Mask myModMask = mod4Mask
mkNamedSubmap addKeymap :: ThreadState -> XConfig l -> XConfig l
:: XConfig l addKeymap ts = addDescrKeys' ((myModMask, xK_F1), runShowKeys) (mkKeys ts)
-> String
-> [(String, String, X ())]
-> [((KeyMask, KeySym), NamedAction)]
mkNamedSubmap c sectionName bindings =
(subtitle sectionName:) $ mkNamedKeymap c
$ map (\(key, name, cmd) -> (key, addName name cmd)) bindings
mkKeys :: [ProcessID] -> Client -> XConfig Layout -> [((KeyMask, KeySym), NamedAction)] mkKeys :: ThreadState -> XConfig Layout -> [((KeyMask, KeySym), NamedAction)]
mkKeys hs client c = mkKeys ts c =
mkNamedSubmap c "Window Layouts" mkNamedSubmap "Window Layouts"
[ ("M-j", "focus down", windows W.focusDown) [ ("M-j", "focus down", windows W.focusDown)
, ("M-k", "focus up", windows W.focusUp) , ("M-k", "focus up", windows W.focusUp)
, ("M-m", "focus master", windows W.focusMaster) , ("M-m", "focus master", windows W.focusMaster)
@ -605,7 +497,7 @@ mkKeys hs client c =
, ("M-S-=", "add master window", sendMessage $ IncMasterN 1) , ("M-S-=", "add master window", sendMessage $ IncMasterN 1)
] ++ ] ++
mkNamedSubmap c "Workspaces" mkNamedSubmap "Workspaces"
-- ASSUME standard workspaces only use numbers 0-9 (otherwise we won't get -- ASSUME standard workspaces only use numbers 0-9 (otherwise we won't get
-- valid keysyms) -- valid keysyms)
([ (mods ++ n, msg ++ n, f n) | n <- myWorkspaces ([ (mods ++ n, msg ++ n, f n) | n <- myWorkspaces
@ -621,7 +513,7 @@ mkKeys hs client c =
, ("M-M1-h", "move down workspace", moveTo Prev HiddenNonEmptyWS) , ("M-M1-h", "move down workspace", moveTo Prev HiddenNonEmptyWS)
]) ++ ]) ++
mkNamedSubmap c "Screens" mkNamedSubmap "Screens"
[ ("M-l", "move up screen", nextScreen) [ ("M-l", "move up screen", nextScreen)
, ("M-h", "move down screen", prevScreen) , ("M-h", "move down screen", prevScreen)
, ("M-C-l", "follow client up screen", shiftNextScreen >> nextScreen) , ("M-C-l", "follow client up screen", shiftNextScreen >> nextScreen)
@ -630,7 +522,7 @@ mkKeys hs client c =
, ("M-S-h", "shift workspace down screen", swapPrevScreen >> prevScreen) , ("M-S-h", "shift workspace down screen", swapPrevScreen >> prevScreen)
] ++ ] ++
mkNamedSubmap c "Actions" mkNamedSubmap "Actions"
[ ("M-q", "close window", kill1) [ ("M-q", "close window", kill1)
, ("M-r", "run program", runCmdMenu) , ("M-r", "run program", runCmdMenu)
, ("M-<Space>", "warp pointer", warpToWindow 0.5 0.5) , ("M-<Space>", "warp pointer", warpToWindow 0.5 0.5)
@ -640,7 +532,7 @@ mkKeys hs client c =
-- , ("M-C-S-s", "capture focused window", spawn myWindowCap) -- , ("M-C-S-s", "capture focused window", spawn myWindowCap)
] ++ ] ++
mkNamedSubmap c "Launchers" mkNamedSubmap "Launchers"
[ ("<XF86Search>", "select/launch app", runAppMenu) [ ("<XF86Search>", "select/launch app", runAppMenu)
, ("M-g", "launch clipboard manager", runClipMenu) , ("M-g", "launch clipboard manager", runClipMenu)
, ("M-a", "launch network selector", runNetMenu) , ("M-a", "launch network selector", runNetMenu)
@ -656,7 +548,7 @@ mkKeys hs client c =
, ("M-C-x", "launch XSane", runXSane) , ("M-C-x", "launch XSane", runXSane)
] ++ ] ++
mkNamedSubmap c "Multimedia" mkNamedSubmap "Multimedia"
[ ("<XF86AudioPlay>", "toggle play/pause", runTogglePlay) [ ("<XF86AudioPlay>", "toggle play/pause", runTogglePlay)
, ("<XF86AudioPrev>", "previous track", runPrevTrack) , ("<XF86AudioPrev>", "previous track", runPrevTrack)
, ("<XF86AudioNext>", "next track", runNextTrack) , ("<XF86AudioNext>", "next track", runNextTrack)
@ -668,14 +560,14 @@ mkKeys hs client c =
-- dummy map for dunst commands (defined separately but this makes them show -- dummy map for dunst commands (defined separately but this makes them show
-- up in the help menu) -- up in the help menu)
mkNamedSubmap c "Dunst" mkNamedSubmap "Dunst"
[ ("M-`", "dunst history", return ()) [ ("M-`", "dunst history", return ())
, ("M-S-`", "dunst close", return ()) , ("M-S-`", "dunst close", return ())
, ("M-M1-`", "dunst context menu", return ()) , ("M-M1-`", "dunst context menu", return ())
, ("M-C-`", "dunst close all", return ()) , ("M-C-`", "dunst close all", return ())
] ++ ] ++
mkNamedSubmap c "System" mkNamedSubmap "System"
[ ("M-.", "backlight up", runIncBacklight) [ ("M-.", "backlight up", runIncBacklight)
, ("M-,", "backlight down", runDecBacklight) , ("M-,", "backlight down", runDecBacklight)
, ("M-M1-,", "backlight min", runMinBacklight) , ("M-M1-,", "backlight min", runMinBacklight)
@ -684,9 +576,12 @@ mkKeys hs client c =
, ("M-<Home>", "quit xmonad", runQuitPrompt) , ("M-<Home>", "quit xmonad", runQuitPrompt)
, ("M-<Delete>", "lock screen", runScreenLock) , ("M-<Delete>", "lock screen", runScreenLock)
-- M-<F1> reserved for showing the keymap -- M-<F1> reserved for showing the keymap
, ("M-<F2>", "restart xmonad", runCleanup hs client >> runRestart) , ("M-<F2>", "restart xmonad", runCleanup ts >> runRestart)
, ("M-<F3>", "recompile xmonad", runRecompile) , ("M-<F3>", "recompile xmonad", runRecompile)
, ("M-<F10>", "toggle bluetooth", runToggleBluetooth) , ("M-<F10>", "toggle bluetooth", runToggleBluetooth)
, ("M-<F11>", "toggle screensaver", runToggleDPMS) , ("M-<F11>", "toggle screensaver", runToggleDPMS)
, ("M-<F12>", "switch gpu", runOptimusPrompt) , ("M-<F12>", "switch gpu", runOptimusPrompt)
] ]
where
mkNamedSubmap header bindings = (subtitle header:) $ mkNamedKeymap c
$ map (\(key, name, cmd) -> (key, addName name cmd)) bindings

View File

@ -1,11 +1,15 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
module DBus.Common where module DBus.Common
( Client
, startXMonadService
, stopXMonadService)
where
import DBus.IntelBacklight import DBus.IntelBacklight
import DBus.Screensaver import DBus.Screensaver
import DBus.Client import DBus.Client
startXMonadService :: IO Client startXMonadService :: IO Client
startXMonadService = do startXMonadService = do

119
lib/Internal/DMenu.hs Normal file
View File

@ -0,0 +1,119 @@
module Internal.DMenu where
import Shell
import Control.Monad.Reader
import Data.List
import Data.Maybe
import Graphics.X11.Types
import Graphics.X11.Xlib
import Graphics.X11.Xrandr
import System.IO
import XMonad.Core
import XMonad.StackSet
import XMonad.Util.NamedActions
import XMonad.Util.Run
-- | Focus rofi on the current workspace always
-- Apparently xrandr and xinerama order monitors differently, which
-- means they have different indices. Since rofi uses the former and
-- xmonad uses the latter, this function is to figure out the xrandr
-- screen name based on the xinerama screen that is currently in
-- focus. The steps to do this:
-- 1) get the coordinates of the currently focuses xinerama screen
-- 2) get list of Xrandr outputs and filter which ones are connected
-- 3) match the coordinates of the xinerama screen with the xrandr
-- output and return the latter's name (eg "DP-0") which can be
-- fed to Rofi
getMonitorName :: X (Maybe String)
getMonitorName = do
dpy <- asks display
root <- asks theRoot
-- these are the focused screen coordinates according to xinerama
(sx, sy) <- getCoords
io $ do
res <- xrrGetScreenResourcesCurrent dpy root
outputs <- forM res $ \res' ->
forM (xrr_sr_outputs res') $ \output -> do
oi <- xrrGetOutputInfo dpy res' output
case oi of
-- connection: 0 == connected, 1 == disconnected
Just XRROutputInfo { xrr_oi_connection = 0
, xrr_oi_name = name
, xrr_oi_crtc = crtc
} -> do
ci <- xrrGetCrtcInfo dpy res' crtc
return $ (\ci' -> Just (name, xrr_ci_x ci', xrr_ci_y ci'))
=<< ci
_ -> return Nothing
return $ (\(name, _, _) -> Just name)
=<< find (\(_, x, y) -> x == sx && y == sy) . catMaybes
=<< outputs
where
getCoords = do
(Rectangle x y _ _) <- getFocusedScreen
return (fromIntegral x, fromIntegral y)
getFocusedScreen :: X Rectangle
getFocusedScreen = withWindowSet $ return . screenRect . screenDetail . current
myDmenuCmd :: String
myDmenuCmd = "rofi"
runShowKeys :: [((KeyMask, KeySym), NamedAction)] -> NamedAction
runShowKeys x = addName "Show Keybindings" $ do
name <- getMonitorName
case name of
Just n -> do
h <- spawnPipe $ cmd n
io $ hPutStr h (unlines $ showKm x)
io $ hClose h
return ()
-- TODO put better error message here
Nothing -> io $ putStrLn "fail"
where cmd name = fmtCmd myDmenuCmd
[ "-dmenu"
, "-m"
, name
, "-p"
, "commands"
, "-theme-str"
, "'#element.selected.normal { background-color: #a200ff; }'"
]
spawnDmenuCmd :: String -> [String] -> X ()
spawnDmenuCmd cmd args = do
name <- getMonitorName
case name of
Just n -> spawnCmd cmd $ ["-m", n] ++ args
Nothing -> io $ putStrLn "fail"
spawnDmenuCmd' :: [String] -> X ()
spawnDmenuCmd' = spawnDmenuCmd myDmenuCmd
runCmdMenu :: X ()
runCmdMenu = spawnDmenuCmd' ["-show", "run"]
runAppMenu :: X ()
runAppMenu = spawnDmenuCmd' ["-show", "drun"]
runClipMenu :: X ()
runClipMenu = spawnDmenuCmd'
[ "-modi", "\"clipboard:greenclip print\""
, "-show", "clipboard"
, "-run-command", "'{cmd}'"
, "-theme-str", "'#element.selected.normal { background-color: #00c44e; }'"
]
runWinMenu :: X ()
runWinMenu = spawnDmenuCmd' ["-show", "window"]
runNetMenu :: X ()
runNetMenu = spawnDmenuCmd "networkmanager_dmenu" []
runDevMenu :: X ()
runDevMenu = spawnDmenuCmd "rofi-devices" []

View File

@ -5,18 +5,24 @@ module Process where
import Control.Concurrent import Control.Concurrent
import Control.Exception import Control.Exception
import Control.Monad import Control.Monad
import Control.Monad.IO.Class
import System.Directory import System.Directory
import System.Exit import System.Exit
import System.IO
import System.Posix.IO
import System.Posix.Process
import System.Posix.Signals import System.Posix.Signals
import System.Posix.Types import System.Posix.Types
import System.Process (waitForProcess) import System.Process hiding (createPipe)
import System.Process.Internals import System.Process.Internals
( ProcessHandle__ (ClosedHandle, OpenHandle) ( ProcessHandle__ (ClosedHandle, OpenHandle)
, mkProcessHandle , mkProcessHandle
, withProcessHandle , withProcessHandle
) )
import XMonad.Core
-- | Block until a PID has exited (in any form) -- | Block until a PID has exited (in any form)
-- ASSUMPTION on linux PIDs will always increase until they overflow, in which -- ASSUMPTION on linux PIDs will always increase until they overflow, in which
-- case they will start to recycle. Barring any fork bombs, this code should -- case they will start to recycle. Barring any fork bombs, this code should
@ -42,3 +48,15 @@ killPID pid = do
OpenHandle _ -> signalProcess sigTERM pid OpenHandle _ -> signalProcess sigTERM pid
ClosedHandle _ -> return () ClosedHandle _ -> return ()
_ -> return () -- this should never happen _ -> return () -- this should never happen
spawnPipe' :: MonadIO m => String -> m (ProcessID, Handle)
spawnPipe' x = liftIO $ do
(rd, wr) <- createPipe
setFdOption wr CloseOnExec True
h <- fdToHandle wr
hSetBuffering h LineBuffering
p <- xfork $ do
_ <- dupTo rd stdInput
executeFile "/bin/sh" False ["-c", x] Nothing
closeFd rd
return (p, h)

View File

@ -11,6 +11,7 @@ library
, Notify , Notify
, Shell , Shell
, WorkspaceMon , WorkspaceMon
, Internal.DMenu
, DBus.Common , DBus.Common
, DBus.IntelBacklight , DBus.IntelBacklight
, DBus.Internal , DBus.Internal
@ -46,8 +47,8 @@ executable xmonad
build-depends: X11 >= 1.9.1 build-depends: X11 >= 1.9.1
, base , base
, containers >= 0.6.0.1 , containers >= 0.6.0.1
, dbus >= 1.2.7
, directory >= 1.3.3.0 , directory >= 1.3.3.0
, process >= 1.6.5.0
, my-xmonad , my-xmonad
, unix >= 2.7.2.2 , unix >= 2.7.2.2
, xmonad >= 0.13 , xmonad >= 0.13