{-# 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 {Spawner -> [(ProcessID, ManageHook)]
pidsRef :: [(ProcessID, ManageHook)]} deriving Typeable
instance ExtensionClass Spawner where
initialValue :: Spawner
initialValue = [(ProcessID, ManageHook)] -> Spawner
Spawner []
getPPIDOf :: ProcessID -> Maybe ProcessID
getPPIDOf :: ProcessID -> Maybe ProcessID
getPPIDOf pid :: ProcessID
pid =
case IO (Either () String) -> Either () String
forall a. IO a -> a
unsafePerformIO (IO (Either () String) -> Either () String)
-> (Integer -> IO (Either () String))
-> Integer
-> Either () String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (IOError -> Maybe ()) -> IO String -> IO (Either () String)
forall e b a.
Exception e =>
(e -> Maybe b) -> IO a -> IO (Either b a)
tryJust (Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> (IOError -> Bool) -> IOError -> Maybe ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IOError -> Bool
isDoesNotExistError) (IO String -> IO (Either () String))
-> (Integer -> IO String) -> Integer -> IO (Either () String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO String
readFile (String -> IO String)
-> (Integer -> String) -> Integer -> IO String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Integer -> String
forall r. PrintfType r => String -> r
printf "/proc/%d/stat" (Integer -> Either () String) -> Integer -> Either () String
forall a b. (a -> b) -> a -> b
$ ProcessID -> Integer
forall a. Integral a => a -> Integer
toInteger ProcessID
pid of
Left _ -> Maybe ProcessID
forall a. Maybe a
Nothing
Right contents :: String
contents -> case String -> [String]
lines String
contents of
[] -> Maybe ProcessID
forall a. Maybe a
Nothing
first :: String
first : _ -> case String -> [String]
words String
first of
_ : _ : _ : ppid :: String
ppid : _ -> ProcessID -> Maybe ProcessID
forall a. a -> Maybe a
Just (ProcessID -> Maybe ProcessID) -> ProcessID -> Maybe ProcessID
forall a b. (a -> b) -> a -> b
$ Int -> ProcessID
forall a b. (Integral a, Num b) => a -> b
fromIntegral (String -> Int
forall a. Read a => String -> a
read String
ppid :: Int)
_ -> Maybe ProcessID
forall a. Maybe a
Nothing
getPPIDChain :: ProcessID -> [ProcessID]
getPPIDChain :: ProcessID -> [ProcessID]
getPPIDChain pid' :: ProcessID
pid' = ProcessID -> [ProcessID] -> [ProcessID]
ppid_chain ProcessID
pid' []
where ppid_chain :: ProcessID -> [ProcessID] -> [ProcessID]
ppid_chain pid :: ProcessID
pid acc :: [ProcessID]
acc =
if ProcessID
pid ProcessID -> ProcessID -> Bool
forall a. Eq a => a -> a -> Bool
== 0
then [ProcessID]
acc
else case ProcessID -> Maybe ProcessID
getPPIDOf ProcessID
pid of
Nothing -> [ProcessID]
acc
Just ppid :: ProcessID
ppid -> ProcessID -> [ProcessID] -> [ProcessID]
ppid_chain ProcessID
ppid (ProcessID
ppid ProcessID -> [ProcessID] -> [ProcessID]
forall a. a -> [a] -> [a]
: [ProcessID]
acc)
modifySpawner :: ([(ProcessID, ManageHook)] -> [(ProcessID, ManageHook)]) -> X ()
modifySpawner :: ([(ProcessID, ManageHook)] -> [(ProcessID, ManageHook)]) -> X ()
modifySpawner f :: [(ProcessID, ManageHook)] -> [(ProcessID, ManageHook)]
f = (Spawner -> Spawner) -> X ()
forall a (m :: * -> *).
(ExtensionClass a, XLike m) =>
(a -> a) -> m ()
XS.modify ([(ProcessID, ManageHook)] -> Spawner
Spawner ([(ProcessID, ManageHook)] -> Spawner)
-> (Spawner -> [(ProcessID, ManageHook)]) -> Spawner -> Spawner
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(ProcessID, ManageHook)] -> [(ProcessID, ManageHook)]
f ([(ProcessID, ManageHook)] -> [(ProcessID, ManageHook)])
-> (Spawner -> [(ProcessID, ManageHook)])
-> Spawner
-> [(ProcessID, ManageHook)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Spawner -> [(ProcessID, ManageHook)]
pidsRef)
manageSpawn :: ManageHook
manageSpawn :: ManageHook
manageSpawn = ([(ProcessID, ManageHook)] -> X [(ProcessID, ManageHook)])
-> ManageHook
manageSpawnWithGC ([(ProcessID, ManageHook)] -> X [(ProcessID, ManageHook)]
forall (m :: * -> *) a. Monad m => a -> m a
return ([(ProcessID, ManageHook)] -> X [(ProcessID, ManageHook)])
-> ([(ProcessID, ManageHook)] -> [(ProcessID, ManageHook)])
-> [(ProcessID, ManageHook)]
-> X [(ProcessID, ManageHook)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [(ProcessID, ManageHook)] -> [(ProcessID, ManageHook)]
forall a. Int -> [a] -> [a]
take 20)
manageSpawnWithGC :: ([(ProcessID, ManageHook)] -> X [(ProcessID, ManageHook)])
-> ManageHook
manageSpawnWithGC :: ([(ProcessID, ManageHook)] -> X [(ProcessID, ManageHook)])
-> ManageHook
manageSpawnWithGC garbageCollect :: [(ProcessID, ManageHook)] -> X [(ProcessID, ManageHook)]
garbageCollect = do
Spawner pids :: [(ProcessID, ManageHook)]
pids <- X Spawner -> Query Spawner
forall a. X a -> Query a
liftX X Spawner
forall a (m :: * -> *). (ExtensionClass a, XLike m) => m a
XS.get
Maybe ProcessID
mp <- Query (Maybe ProcessID)
pid
let ppid_chain :: [ProcessID]
ppid_chain = case Maybe ProcessID
mp of
Just winpid :: ProcessID
winpid -> ProcessID
winpid ProcessID -> [ProcessID] -> [ProcessID]
forall a. a -> [a] -> [a]
: ProcessID -> [ProcessID]
getPPIDChain ProcessID
winpid
Nothing -> []
known_window_handlers :: [ManageHook]
known_window_handlers = [ ManageHook
mh
| ProcessID
ppid <- [ProcessID]
ppid_chain
, let mpid :: Maybe ManageHook
mpid = ProcessID -> [(ProcessID, ManageHook)] -> Maybe ManageHook
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup ProcessID
ppid [(ProcessID, ManageHook)]
pids
, Maybe ManageHook -> Bool
forall a. Maybe a -> Bool
isJust Maybe ManageHook
mpid
, let (Just mh :: ManageHook
mh) = Maybe ManageHook
mpid ]
case [ManageHook]
known_window_handlers of
[] -> ManageHook
forall m. Monoid m => m
idHook
(mh :: ManageHook
mh:_) -> do
Maybe ProcessID -> (ProcessID -> Query ()) -> Query ()
forall (m :: * -> *) a. Monad m => Maybe a -> (a -> m ()) -> m ()
whenJust Maybe ProcessID
mp ((ProcessID -> Query ()) -> Query ())
-> (ProcessID -> Query ()) -> Query ()
forall a b. (a -> b) -> a -> b
$ \p :: ProcessID
p -> X () -> Query ()
forall a. X a -> Query a
liftX (X () -> Query ()) -> X () -> Query ()
forall a b. (a -> b) -> a -> b
$ do
[(ProcessID, ManageHook)]
ps <- (Spawner -> [(ProcessID, ManageHook)])
-> X [(ProcessID, ManageHook)]
forall a (m :: * -> *) b.
(ExtensionClass a, XLike m) =>
(a -> b) -> m b
XS.gets Spawner -> [(ProcessID, ManageHook)]
pidsRef
Spawner -> X ()
forall a (m :: * -> *). (ExtensionClass a, XLike m) => a -> m ()
XS.put (Spawner -> X ())
-> ([(ProcessID, ManageHook)] -> Spawner)
-> [(ProcessID, ManageHook)]
-> X ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(ProcessID, ManageHook)] -> Spawner
Spawner ([(ProcessID, ManageHook)] -> X ())
-> X [(ProcessID, ManageHook)] -> X ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [(ProcessID, ManageHook)] -> X [(ProcessID, ManageHook)]
garbageCollect (((ProcessID, ManageHook) -> Bool)
-> [(ProcessID, ManageHook)] -> [(ProcessID, ManageHook)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((ProcessID -> ProcessID -> Bool
forall a. Eq a => a -> a -> Bool
/= ProcessID
p) (ProcessID -> Bool)
-> ((ProcessID, ManageHook) -> ProcessID)
-> (ProcessID, ManageHook)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ProcessID, ManageHook) -> ProcessID
forall a b. (a, b) -> a
fst) [(ProcessID, ManageHook)]
ps)
ManageHook
mh
mkPrompt :: (String -> X ()) -> XPConfig -> X ()
mkPrompt :: (String -> X ()) -> XPConfig -> X ()
mkPrompt cb :: String -> X ()
cb c :: XPConfig
c = do
[String]
cmds <- IO [String] -> X [String]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO [String] -> X [String]) -> IO [String] -> X [String]
forall a b. (a -> b) -> a -> b
$ IO [String]
getCommands
Shell -> XPConfig -> ComplFunction -> (String -> X ()) -> X ()
forall p.
XPrompt p =>
p -> XPConfig -> ComplFunction -> (String -> X ()) -> X ()
mkXPrompt Shell
Shell XPConfig
c ([String] -> Predicate -> ComplFunction
getShellCompl [String]
cmds (Predicate -> ComplFunction) -> Predicate -> ComplFunction
forall a b. (a -> b) -> a -> b
$ XPConfig -> Predicate
searchPredicate XPConfig
c) String -> X ()
cb
shellPromptHere :: XPConfig -> X ()
shellPromptHere :: XPConfig -> X ()
shellPromptHere = (String -> X ()) -> XPConfig -> X ()
mkPrompt String -> X ()
spawnHere
shellPromptOn :: WorkspaceId -> XPConfig -> X ()
shellPromptOn :: String -> XPConfig -> X ()
shellPromptOn ws :: String
ws = (String -> X ()) -> XPConfig -> X ()
mkPrompt (String -> String -> X ()
spawnOn String
ws)
spawnHere :: String -> X ()
spawnHere :: String -> X ()
spawnHere cmd :: String
cmd = (WindowSet -> X ()) -> X ()
forall a. (WindowSet -> X a) -> X a
withWindowSet ((WindowSet -> X ()) -> X ()) -> (WindowSet -> X ()) -> X ()
forall a b. (a -> b) -> a -> b
$ \ws :: WindowSet
ws -> String -> String -> X ()
spawnOn (WindowSet -> String
forall i l a s sd. StackSet i l a s sd -> i
W.currentTag WindowSet
ws) String
cmd
spawnOn :: WorkspaceId -> String -> X ()
spawnOn :: String -> String -> X ()
spawnOn ws :: String
ws cmd :: String
cmd = ManageHook -> String -> X ()
spawnAndDo (String -> ManageHook
doShift String
ws) String
cmd
spawnAndDo :: ManageHook -> String -> X ()
spawnAndDo :: ManageHook -> String -> X ()
spawnAndDo mh :: ManageHook
mh cmd :: String
cmd = do
ProcessID
p <- String -> X ProcessID
forall (m :: * -> *). MonadIO m => String -> m ProcessID
spawnPID (String -> X ProcessID) -> String -> X ProcessID
forall a b. (a -> b) -> a -> b
$ String -> String
mangle String
cmd
([(ProcessID, ManageHook)] -> [(ProcessID, ManageHook)]) -> X ()
modifySpawner (([(ProcessID, ManageHook)] -> [(ProcessID, ManageHook)]) -> X ())
-> ([(ProcessID, ManageHook)] -> [(ProcessID, ManageHook)]) -> X ()
forall a b. (a -> b) -> a -> b
$ ((ProcessID
p,ManageHook
mh) (ProcessID, ManageHook)
-> [(ProcessID, ManageHook)] -> [(ProcessID, ManageHook)]
forall a. a -> [a] -> [a]
:)
where
mangle :: String -> String
mangle xs :: String
xs | (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
metaChars) String
xs Bool -> Bool -> Bool
|| "exec" Predicate
forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf` String
xs = String
xs
| Bool
otherwise = "exec " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
xs
metaChars :: String
metaChars = "&|;"