-----------------------------------------------------------------------------
-- |
-- Module       : XMonad.Actions.SpawnOn
-- Description  : Modify a window spawned by a command.
-- Copyright    : (c) Spencer Janssen
-- License      : BSD
--
-- Maintainer   : Spencer Janssen <spencerjanssen@gmail.com>
-- Stability    : unstable
-- Portability  : unportable
--
-- Provides a way to modify a window spawned by a command(e.g shift it to the workspace
-- it was launched on) by using the _NET_WM_PID property that most windows set on creation.
-- Hence this module won't work on applications that don't set this property.
--
-----------------------------------------------------------------------------

module XMonad.Actions.SpawnOn (
    -- * Usage
    -- $usage
    Spawner,
    manageSpawn,
    manageSpawnWithGC,
    spawnHere,
    spawnOn,
    spawnAndDo,
    shellPromptHere,
    shellPromptOn
) where

import Control.Exception (tryJust)
import System.IO.Error (isDoesNotExistError)
import System.IO.Unsafe (unsafePerformIO)
import System.Posix.Types (ProcessID)
import Text.Printf (printf)

import XMonad
import XMonad.Prelude
import qualified XMonad.StackSet as W

import XMonad.Hooks.ManageHelpers
import XMonad.Prompt
import XMonad.Prompt.Shell
import qualified XMonad.Util.ExtensibleState as XS

-- $usage
-- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@:
--
-- >    import XMonad.Actions.SpawnOn
--
-- >    main = do
-- >      xmonad def {
-- >         ...
-- >         manageHook = manageSpawn <+> manageHook def
-- >         ...
-- >      }
--
-- To ensure that application appears on a workspace it was launched at, add keybindings like:
--
-- >  , ((mod1Mask,xK_o), spawnHere "urxvt")
-- >  , ((mod1Mask,xK_s), shellPromptHere def)
--
-- The module can also be used to apply other manage hooks to the window of
-- the spawned application(e.g. float or resize it).
--
-- For detailed instructions on editing your key bindings, see
-- "XMonad.Doc.Extending#Editing_key_bindings".

newtype Spawner = Spawner {Spawner -> [(ProcessID, Query (Endo WindowSet))]
pidsRef :: [(ProcessID, ManageHook)]}

instance ExtensionClass Spawner where
    initialValue :: Spawner
initialValue = [(ProcessID, Query (Endo WindowSet))] -> Spawner
Spawner []


getPPIDOf :: ProcessID -> Maybe ProcessID
getPPIDOf :: ProcessID -> Maybe ProcessID
getPPIDOf ProcessID
thisPid =
    case IO (Either () FilePath) -> Either () FilePath
forall a. IO a -> a
unsafePerformIO (IO (Either () FilePath) -> Either () FilePath)
-> (Integer -> IO (Either () FilePath))
-> Integer
-> Either () FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (IOError -> Maybe ()) -> IO FilePath -> IO (Either () FilePath)
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 FilePath -> IO (Either () FilePath))
-> (Integer -> IO FilePath) -> Integer -> IO (Either () FilePath)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> IO FilePath
readFile (FilePath -> IO FilePath)
-> (Integer -> FilePath) -> Integer -> IO FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Integer -> FilePath
forall r. PrintfType r => FilePath -> r
printf FilePath
"/proc/%d/stat" (Integer -> Either () FilePath) -> Integer -> Either () FilePath
forall a b. (a -> b) -> a -> b
$ ProcessID -> Integer
forall a. Integral a => a -> Integer
toInteger ProcessID
thisPid of
      Left ()
_         -> Maybe ProcessID
forall a. Maybe a
Nothing
      Right FilePath
contents -> case FilePath -> [FilePath]
lines FilePath
contents of
                          []        -> Maybe ProcessID
forall a. Maybe a
Nothing
                          FilePath
first : [FilePath]
_ -> case FilePath -> [FilePath]
words FilePath
first of
                                         FilePath
_ : FilePath
_ : FilePath
_ : FilePath
ppid : [FilePath]
_ -> 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 (FilePath -> Int
forall a. Read a => FilePath -> a
read FilePath
ppid :: Int)
                                         [FilePath]
_                    -> Maybe ProcessID
forall a. Maybe a
Nothing

getPPIDChain :: ProcessID -> [ProcessID]
getPPIDChain :: ProcessID -> [ProcessID]
getPPIDChain ProcessID
thisPid = ProcessID -> [ProcessID] -> [ProcessID]
ppid_chain ProcessID
thisPid []
    where ppid_chain :: ProcessID -> [ProcessID] -> [ProcessID]
ppid_chain ProcessID
pid' [ProcessID]
acc =
              if ProcessID
pid' ProcessID -> ProcessID -> Bool
forall a. Eq a => a -> a -> Bool
== ProcessID
0
              then [ProcessID]
acc
              else case ProcessID -> Maybe ProcessID
getPPIDOf ProcessID
pid' of
                     Maybe ProcessID
Nothing   -> [ProcessID]
acc
                     Just ProcessID
ppid -> ProcessID -> [ProcessID] -> [ProcessID]
ppid_chain ProcessID
ppid (ProcessID
ppid ProcessID -> [ProcessID] -> [ProcessID]
forall a. a -> [a] -> [a]
: [ProcessID]
acc)

-- | Get the current Spawner or create one if it doesn't exist.
modifySpawner :: ([(ProcessID, ManageHook)] -> [(ProcessID, ManageHook)]) -> X ()
modifySpawner :: ([(ProcessID, Query (Endo WindowSet))]
 -> [(ProcessID, Query (Endo WindowSet))])
-> X ()
modifySpawner [(ProcessID, Query (Endo WindowSet))]
-> [(ProcessID, Query (Endo WindowSet))]
f = (Spawner -> Spawner) -> X ()
forall a (m :: * -> *).
(ExtensionClass a, XLike m) =>
(a -> a) -> m ()
XS.modify ([(ProcessID, Query (Endo WindowSet))] -> Spawner
Spawner ([(ProcessID, Query (Endo WindowSet))] -> Spawner)
-> (Spawner -> [(ProcessID, Query (Endo WindowSet))])
-> Spawner
-> Spawner
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(ProcessID, Query (Endo WindowSet))]
-> [(ProcessID, Query (Endo WindowSet))]
f ([(ProcessID, Query (Endo WindowSet))]
 -> [(ProcessID, Query (Endo WindowSet))])
-> (Spawner -> [(ProcessID, Query (Endo WindowSet))])
-> Spawner
-> [(ProcessID, Query (Endo WindowSet))]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Spawner -> [(ProcessID, Query (Endo WindowSet))]
pidsRef)

-- | Provides a manage hook to react on process spawned with
-- 'spawnOn', 'spawnHere' etc.
manageSpawn :: ManageHook
manageSpawn :: Query (Endo WindowSet)
manageSpawn = ([(ProcessID, Query (Endo WindowSet))]
 -> X [(ProcessID, Query (Endo WindowSet))])
-> Query (Endo WindowSet)
manageSpawnWithGC ([(ProcessID, Query (Endo WindowSet))]
-> X [(ProcessID, Query (Endo WindowSet))]
forall (m :: * -> *) a. Monad m => a -> m a
return ([(ProcessID, Query (Endo WindowSet))]
 -> X [(ProcessID, Query (Endo WindowSet))])
-> ([(ProcessID, Query (Endo WindowSet))]
    -> [(ProcessID, Query (Endo WindowSet))])
-> [(ProcessID, Query (Endo WindowSet))]
-> X [(ProcessID, Query (Endo WindowSet))]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int
-> [(ProcessID, Query (Endo WindowSet))]
-> [(ProcessID, Query (Endo WindowSet))]
forall a. Int -> [a] -> [a]
take Int
20)

manageSpawnWithGC :: ([(ProcessID, ManageHook)] -> X [(ProcessID, ManageHook)])
        -- ^ function to stop accumulation of entries for windows that never set @_NET_WM_PID@
       -> ManageHook
manageSpawnWithGC :: ([(ProcessID, Query (Endo WindowSet))]
 -> X [(ProcessID, Query (Endo WindowSet))])
-> Query (Endo WindowSet)
manageSpawnWithGC [(ProcessID, Query (Endo WindowSet))]
-> X [(ProcessID, Query (Endo WindowSet))]
garbageCollect = do
    Spawner [(ProcessID, Query (Endo WindowSet))]
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 ProcessID
winpid -> ProcessID
winpid ProcessID -> [ProcessID] -> [ProcessID]
forall a. a -> [a] -> [a]
: ProcessID -> [ProcessID]
getPPIDChain ProcessID
winpid
                       Maybe ProcessID
Nothing     -> []
        known_window_handlers :: [Query (Endo WindowSet)]
known_window_handlers = [ Query (Endo WindowSet)
mh
                                | ProcessID
ppid <- [ProcessID]
ppid_chain
                                , let mpid :: Maybe (Query (Endo WindowSet))
mpid = ProcessID
-> [(ProcessID, Query (Endo WindowSet))]
-> Maybe (Query (Endo WindowSet))
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup ProcessID
ppid [(ProcessID, Query (Endo WindowSet))]
pids
                                , Maybe (Query (Endo WindowSet)) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (Query (Endo WindowSet))
mpid
                                , let (Just Query (Endo WindowSet)
mh) = Maybe (Query (Endo WindowSet))
mpid ]
    case [Query (Endo WindowSet)]
known_window_handlers of
        [] -> Query (Endo WindowSet)
forall m. Monoid m => m
idHook
        (Query (Endo WindowSet)
mh:[Query (Endo WindowSet)]
_)  -> 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
$ \ProcessID
p -> X () -> Query ()
forall a. X a -> Query a
liftX (X () -> Query ()) -> X () -> Query ()
forall a b. (a -> b) -> a -> b
$ do
                [(ProcessID, Query (Endo WindowSet))]
ps <- (Spawner -> [(ProcessID, Query (Endo WindowSet))])
-> X [(ProcessID, Query (Endo WindowSet))]
forall a (m :: * -> *) b.
(ExtensionClass a, XLike m) =>
(a -> b) -> m b
XS.gets Spawner -> [(ProcessID, Query (Endo WindowSet))]
pidsRef
                Spawner -> X ()
forall a (m :: * -> *). (ExtensionClass a, XLike m) => a -> m ()
XS.put (Spawner -> X ())
-> ([(ProcessID, Query (Endo WindowSet))] -> Spawner)
-> [(ProcessID, Query (Endo WindowSet))]
-> X ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(ProcessID, Query (Endo WindowSet))] -> Spawner
Spawner ([(ProcessID, Query (Endo WindowSet))] -> X ())
-> X [(ProcessID, Query (Endo WindowSet))] -> X ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [(ProcessID, Query (Endo WindowSet))]
-> X [(ProcessID, Query (Endo WindowSet))]
garbageCollect (((ProcessID, Query (Endo WindowSet)) -> Bool)
-> [(ProcessID, Query (Endo WindowSet))]
-> [(ProcessID, Query (Endo WindowSet))]
forall a. (a -> Bool) -> [a] -> [a]
filter ((ProcessID -> ProcessID -> Bool
forall a. Eq a => a -> a -> Bool
/= ProcessID
p) (ProcessID -> Bool)
-> ((ProcessID, Query (Endo WindowSet)) -> ProcessID)
-> (ProcessID, Query (Endo WindowSet))
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ProcessID, Query (Endo WindowSet)) -> ProcessID
forall a b. (a, b) -> a
fst) [(ProcessID, Query (Endo WindowSet))]
ps)
            Query (Endo WindowSet)
mh

mkPrompt :: (String -> X ()) -> XPConfig -> X ()
mkPrompt :: (FilePath -> X ()) -> XPConfig -> X ()
mkPrompt FilePath -> X ()
cb XPConfig
c = do
    [FilePath]
cmds <- IO [FilePath] -> X [FilePath]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io IO [FilePath]
getCommands
    Shell -> XPConfig -> ComplFunction -> (FilePath -> X ()) -> X ()
forall p.
XPrompt p =>
p -> XPConfig -> ComplFunction -> (FilePath -> X ()) -> X ()
mkXPrompt Shell
Shell XPConfig
c ([FilePath] -> Predicate -> ComplFunction
getShellCompl [FilePath]
cmds (Predicate -> ComplFunction) -> Predicate -> ComplFunction
forall a b. (a -> b) -> a -> b
$ XPConfig -> Predicate
searchPredicate XPConfig
c) FilePath -> X ()
cb

-- | Replacement for Shell prompt ("XMonad.Prompt.Shell") which launches
-- application on current workspace.
shellPromptHere :: XPConfig -> X ()
shellPromptHere :: XPConfig -> X ()
shellPromptHere = (FilePath -> X ()) -> XPConfig -> X ()
mkPrompt FilePath -> X ()
spawnHere

-- | Replacement for Shell prompt ("XMonad.Prompt.Shell") which launches
-- application on given workspace.
shellPromptOn :: WorkspaceId -> XPConfig -> X ()
shellPromptOn :: FilePath -> XPConfig -> X ()
shellPromptOn FilePath
ws = (FilePath -> X ()) -> XPConfig -> X ()
mkPrompt (FilePath -> FilePath -> X ()
spawnOn FilePath
ws)

-- | Replacement for 'spawn' which launches
-- application on current workspace.
spawnHere :: String -> X ()
spawnHere :: FilePath -> X ()
spawnHere FilePath
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
$ \WindowSet
ws -> FilePath -> FilePath -> X ()
spawnOn (WindowSet -> FilePath
forall i l a s sd. StackSet i l a s sd -> i
W.currentTag WindowSet
ws) FilePath
cmd

-- | Replacement for 'spawn' which launches
-- application on given workspace.
spawnOn :: WorkspaceId -> String -> X ()
spawnOn :: FilePath -> FilePath -> X ()
spawnOn FilePath
ws = Query (Endo WindowSet) -> FilePath -> X ()
spawnAndDo (FilePath -> Query (Endo WindowSet)
doShift FilePath
ws)

-- | Spawn an application and apply the manage hook when it opens.
spawnAndDo :: ManageHook -> String -> X ()
spawnAndDo :: Query (Endo WindowSet) -> FilePath -> X ()
spawnAndDo Query (Endo WindowSet)
mh FilePath
cmd = do
    ProcessID
p <- FilePath -> X ProcessID
forall (m :: * -> *). MonadIO m => FilePath -> m ProcessID
spawnPID (FilePath -> X ProcessID) -> FilePath -> X ProcessID
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
mangle FilePath
cmd
    ([(ProcessID, Query (Endo WindowSet))]
 -> [(ProcessID, Query (Endo WindowSet))])
-> X ()
modifySpawner ((ProcessID
p,Query (Endo WindowSet)
mh) (ProcessID, Query (Endo WindowSet))
-> [(ProcessID, Query (Endo WindowSet))]
-> [(ProcessID, Query (Endo WindowSet))]
forall a. a -> [a] -> [a]
:)
 where
    -- TODO this is silly, search for a better solution
    mangle :: FilePath -> FilePath
mangle FilePath
xs | (Char -> Bool) -> FilePath -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Char -> FilePath -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` FilePath
metaChars) FilePath
xs Bool -> Bool -> Bool
|| FilePath
"exec" Predicate
forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf` FilePath
xs = FilePath
xs
              | Bool
otherwise = FilePath
"exec " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
xs
    metaChars :: FilePath
metaChars = FilePath
"&|;"