{-# LANGUAGE DeriveDataTypeable #-}
module XMonad.Actions.SpawnOn (
Spawner,
manageSpawn,
manageSpawnWithGC,
spawnHere,
spawnOn,
spawnAndDo,
shellPromptHere,
shellPromptOn
) where
import Control.Exception (tryJust)
import Control.Monad (guard)
import Data.List (isInfixOf)
import Data.Maybe (isJust)
import System.IO.Error (isDoesNotExistError)
import System.IO.Unsafe (unsafePerformIO)
import System.Posix.Types (ProcessID)
import Text.Printf (printf)
import XMonad
import qualified XMonad.StackSet as W
import XMonad.Hooks.ManageHelpers
import XMonad.Prompt
import XMonad.Prompt.Shell
import qualified XMonad.Util.ExtensibleState as XS
newtype Spawner = Spawner {pidsRef :: [(ProcessID, ManageHook)]} deriving Typeable
instance ExtensionClass Spawner where
initialValue = Spawner []
getPPIDOf :: ProcessID -> Maybe ProcessID
getPPIDOf pid =
case unsafePerformIO . tryJust (guard . isDoesNotExistError) . readFile . printf "/proc/%d/stat" $ toInteger pid of
Left _ -> Nothing
Right contents -> case lines contents of
[] -> Nothing
first : _ -> case words first of
_ : _ : _ : ppid : _ -> Just $ fromIntegral (read ppid :: Int)
_ -> Nothing
getPPIDChain :: ProcessID -> [ProcessID]
getPPIDChain pid' = ppid_chain pid' []
where ppid_chain pid acc =
if pid == 0
then acc
else case getPPIDOf pid of
Nothing -> acc
Just ppid -> ppid_chain ppid (ppid : acc)
modifySpawner :: ([(ProcessID, ManageHook)] -> [(ProcessID, ManageHook)]) -> X ()
modifySpawner f = XS.modify (Spawner . f . pidsRef)
manageSpawn :: ManageHook
manageSpawn = manageSpawnWithGC (return . take 20)
manageSpawnWithGC :: ([(ProcessID, ManageHook)] -> X [(ProcessID, ManageHook)])
-> ManageHook
manageSpawnWithGC garbageCollect = do
Spawner pids <- liftX XS.get
mp <- pid
let ppid_chain = case mp of
Just winpid -> winpid : getPPIDChain winpid
Nothing -> []
known_window_handlers = [ mh
| ppid <- ppid_chain
, let mpid = lookup ppid pids
, isJust mpid
, let (Just mh) = mpid ]
case known_window_handlers of
[] -> idHook
(mh:_) -> do
whenJust mp $ \p -> liftX $ do
ps <- XS.gets pidsRef
XS.put . Spawner =<< garbageCollect (filter ((/= p) . fst) ps)
mh
mkPrompt :: (String -> X ()) -> XPConfig -> X ()
mkPrompt cb c = do
cmds <- io $ getCommands
mkXPrompt Shell c (getShellCompl cmds $ searchPredicate c) cb
shellPromptHere :: XPConfig -> X ()
shellPromptHere = mkPrompt spawnHere
shellPromptOn :: WorkspaceId -> XPConfig -> X ()
shellPromptOn ws = mkPrompt (spawnOn ws)
spawnHere :: String -> X ()
spawnHere cmd = withWindowSet $ \ws -> spawnOn (W.currentTag ws) cmd
spawnOn :: WorkspaceId -> String -> X ()
spawnOn ws cmd = spawnAndDo (doShift ws) cmd
spawnAndDo :: ManageHook -> String -> X ()
spawnAndDo mh cmd = do
p <- spawnPID $ mangle cmd
modifySpawner $ ((p,mh) :)
where
mangle xs | any (`elem` metaChars) xs || "exec" `isInfixOf` xs = xs
| otherwise = "exec " ++ xs
metaChars = "&|;"