-----------------------------------------------------------------------------
-- |
-- Module      :  XMonad.Hooks.ServerMode
-- Copyright   :  (c) Peter Olson 2013 and Andrea Rossato and David Roundy 2007
-- License     :  BSD-style (see xmonad/LICENSE)
--
-- Maintainer  :  polson2@hawk.iit.edu
-- Stability   :  unstable
-- Portability :  unportable
--
-- This is an 'EventHook' that will receive commands from an external
-- client. Also consider "XMonad.Hooks.EwmhDesktops" together with
-- @wmctrl@.
--
-- This is the example of a client:
--
-- > import Graphics.X11.Xlib
-- > import Graphics.X11.Xlib.Extras
-- > import System.Environment
-- > import System.IO
-- > import Data.Char
-- > 
-- > main :: IO ()
-- > main = parse True "XMONAD_COMMAND" =<< getArgs
-- > 
-- > parse :: Bool -> String -> [String] -> IO ()
-- > parse input addr args = case args of
-- >         ["--"] | input -> repl addr
-- >                | otherwise -> return ()
-- >         ("--":xs) -> sendAll addr xs
-- >         ("-a":a:xs) -> parse input a xs
-- >         ("-h":_) -> showHelp
-- >         ("--help":_) -> showHelp
-- >         ("-?":_) -> showHelp
-- >         (a@('-':_):_) -> hPutStrLn stderr ("Unknown option " ++ a)
-- > 
-- >         (x:xs) -> sendCommand addr x >> parse False addr xs
-- >         [] | input -> repl addr
-- >            | otherwise -> return ()
-- > 
-- > 
-- > repl :: String -> IO ()
-- > repl addr = do e <- isEOF
-- >                case e of
-- >                 True -> return ()
-- >                 False -> do l <- getLine
-- >                             sendCommand addr l
-- >                             repl addr
-- > 
-- > sendAll :: String -> [String] -> IO ()
-- > sendAll addr ss = foldr (\a b -> sendCommand addr a >> b) (return ()) ss
-- > 
-- > sendCommand :: String -> String -> IO ()
-- > sendCommand addr s = do
-- >   d   <- openDisplay ""
-- >   rw  <- rootWindow d $ defaultScreen d
-- >   a <- internAtom d addr False
-- >   m <- internAtom d s False
-- >   allocaXEvent $ \e -> do
-- >                   setEventType e clientMessage
-- >                   setClientMessageEvent e rw a 32 m currentTime
-- >                   sendEvent d rw False structureNotifyMask e
-- >                   sync d False
-- > 
-- > showHelp :: IO ()
-- > showHelp = do pn <- getProgName
-- >               putStrLn ("Send commands to a running instance of xmonad. xmonad.hs must be configured with XMonad.Hooks.ServerMode to work.\n-a atomname can be used at any point in the command line arguments to change which atom it is sending on.\nIf sent with no arguments or only -a atom arguments, it will read commands from stdin.\nEx:\n" ++ pn ++ " cmd1 cmd2\n" ++ pn ++ " -a XMONAD_COMMAND cmd1 cmd2 cmd3 -a XMONAD_PRINT hello world\n" ++ pn ++ " -a XMONAD_PRINT # will read data from stdin.\nThe atom defaults to XMONAD_COMMAND.")
--
--
-- compile with: @ghc --make xmonadctl.hs@
--
-- run with
--
-- > xmonadctl command
--
-- or with
--
-- > $ xmonadctl
-- > command1
-- > command2
-- > .
-- > .
-- > .
-- > ^D
--
-- Usage will change depending on which event hook(s) you use. More examples are shown below.
--
-----------------------------------------------------------------------------

module XMonad.Hooks.ServerMode
    ( -- * Usage
      -- $usage
      serverModeEventHook
    , serverModeEventHook'
    , serverModeEventHookCmd
    , serverModeEventHookCmd'
    , serverModeEventHookF
    ) where

import Control.Monad (when)
import Data.Maybe
import Data.Monoid
import System.IO

import XMonad
import XMonad.Actions.Commands

-- $usage
-- You can use this module with the following in your
-- @~\/.xmonad\/xmonad.hs@:
--
-- > import XMonad.Hooks.ServerMode
--
-- Then edit your @handleEventHook@ by adding the appropriate event hook from below

-- | Executes a command of the list when receiving its index via a special ClientMessageEvent
-- (indexing starts at 1). Sending index 0 will ask xmonad to print the list of command numbers
-- in stderr (so that you can read it in @~\/.xsession-errors@). Uses "XMonad.Actions.Commands#defaultCommands" as the default.
--
-- > main = xmonad def { handleEventHook = serverModeEventHook }
-- 
-- > xmonadctl 0 # tells xmonad to output command list
-- > xmonadctl 1 # tells xmonad to switch to workspace 1
--
serverModeEventHook :: Event -> X All
serverModeEventHook :: Event -> X All
serverModeEventHook = X [(String, X ())] -> Event -> X All
serverModeEventHook' X [(String, X ())]
defaultCommands

-- | serverModeEventHook' additionally takes an action to generate the list of
-- commands.
serverModeEventHook' :: X [(String,X ())] -> Event -> X All
serverModeEventHook' :: X [(String, X ())] -> Event -> X All
serverModeEventHook' cmdAction :: X [(String, X ())]
cmdAction ev :: Event
ev = String -> (String -> X ()) -> Event -> X All
serverModeEventHookF "XMONAD_COMMAND" ([X ()] -> X ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ ([X ()] -> X ()) -> (String -> [X ()]) -> String -> X ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> X ()) -> [String] -> [X ()]
forall a b. (a -> b) -> [a] -> [b]
map String -> X ()
helper ([String] -> [X ()]) -> (String -> [String]) -> String -> [X ()]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
words) Event
ev
        where helper :: String -> X ()
helper cmd :: String
cmd = do [(String, X ())]
cl <- X [(String, X ())]
cmdAction
                              case String -> [(String, (String, X ()))] -> Maybe (String, X ())
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
cmd ([String] -> [(String, X ())] -> [(String, (String, X ()))]
forall a b. [a] -> [b] -> [(a, b)]
zip ((Integer -> String) -> [Integer] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Integer -> String
forall a. Show a => a -> String
show [1 :: Integer ..]) [(String, X ())]
cl) of
                                Just (_,action :: X ()
action) -> X ()
action
                                Nothing         -> (String -> X ()) -> [String] -> X ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (IO () -> X ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> X ()) -> (String -> IO ()) -> String -> X ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handle -> String -> IO ()
hPutStrLn Handle
stderr) ([String] -> X ())
-> ([(String, X ())] -> [String]) -> [(String, X ())] -> X ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(String, X ())] -> [String]
forall b. [(String, b)] -> [String]
listOfCommands ([(String, X ())] -> X ()) -> [(String, X ())] -> X ()
forall a b. (a -> b) -> a -> b
$ [(String, X ())]
cl
              listOfCommands :: [(String, b)] -> [String]
listOfCommands cl :: [(String, b)]
cl = ((String, String) -> String) -> [(String, String)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ((String -> String -> String) -> (String, String) -> String
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry String -> String -> String
forall a. [a] -> [a] -> [a]
(++)) ([(String, String)] -> [String]) -> [(String, String)] -> [String]
forall a b. (a -> b) -> a -> b
$ [String] -> [String] -> [(String, String)]
forall a b. [a] -> [b] -> [(a, b)]
zip ((Int -> String) -> [Int] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Int -> String
forall a. Show a => a -> String
show ([1..] :: [Int])) ([String] -> [(String, String)]) -> [String] -> [(String, String)]
forall a b. (a -> b) -> a -> b
$ ((String, b) -> String) -> [(String, b)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String -> String -> String
forall a. [a] -> [a] -> [a]
(++) " - " (String -> String)
-> ((String, b) -> String) -> (String, b) -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, b) -> String
forall a b. (a, b) -> a
fst) [(String, b)]
cl


-- | Executes a command of the list when receiving its name via a special ClientMessageEvent.
-- Uses "XMonad.Actions.Commands#defaultCommands" as the default.
--
-- > main = xmonad def { handleEventHook = serverModeEventHookCmd }
--
-- > xmonadctl run # Tells xmonad to generate a run prompt
--
serverModeEventHookCmd :: Event -> X All
serverModeEventHookCmd :: Event -> X All
serverModeEventHookCmd = X [(String, X ())] -> Event -> X All
serverModeEventHookCmd' X [(String, X ())]
defaultCommands

-- | Additionally takes an action to generate the list of commands
serverModeEventHookCmd' :: X [(String,X ())] -> Event -> X All
serverModeEventHookCmd' :: X [(String, X ())] -> Event -> X All
serverModeEventHookCmd' cmdAction :: X [(String, X ())]
cmdAction ev :: Event
ev = String -> (String -> X ()) -> Event -> X All
serverModeEventHookF "XMONAD_COMMAND" ([X ()] -> X ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ ([X ()] -> X ()) -> (String -> [X ()]) -> String -> X ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> X ()) -> [String] -> [X ()]
forall a b. (a -> b) -> [a] -> [b]
map String -> X ()
helper ([String] -> [X ()]) -> (String -> [String]) -> String -> [X ()]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
words) Event
ev
        where helper :: String -> X ()
helper cmd :: String
cmd = do [(String, X ())]
cl <- X [(String, X ())]
cmdAction
                              X () -> Maybe (X ()) -> X ()
forall a. a -> Maybe a -> a
fromMaybe (IO () -> X ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> X ()) -> IO () -> X ()
forall a b. (a -> b) -> a -> b
$ Handle -> String -> IO ()
hPutStrLn Handle
stderr ("Couldn't find command " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
cmd)) (String -> [(String, X ())] -> Maybe (X ())
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
cmd [(String, X ())]
cl)

-- | Listens for an atom, then executes a callback function whenever it hears it.
-- A trivial example that prints everything supplied to it on xmonad's standard out:
--
-- > main = xmonad def { handleEventHook = serverModeEventHookF "XMONAD_PRINT" (io . putStrLn) }
--
-- > xmonadctl -a XMONAD_PRINT "hello world"
--
serverModeEventHookF :: String -> (String -> X ()) -> Event -> X All
serverModeEventHookF :: String -> (String -> X ()) -> Event -> X All
serverModeEventHookF key :: String
key func :: String -> X ()
func (ClientMessageEvent {ev_message_type :: Event -> Atom
ev_message_type = Atom
mt, ev_data :: Event -> [CInt]
ev_data = [CInt]
dt}) = do
        Display
d <- (XConf -> Display) -> X Display
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks XConf -> Display
display
        Atom
atm <- IO Atom -> X Atom
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO Atom -> X Atom) -> IO Atom -> X Atom
forall a b. (a -> b) -> a -> b
$ Display -> String -> Bool -> IO Atom
internAtom Display
d String
key Bool
False
        Bool -> X () -> X ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Atom
mt Atom -> Atom -> Bool
forall a. Eq a => a -> a -> Bool
== Atom
atm Bool -> Bool -> Bool
&& [CInt]
dt [CInt] -> [CInt] -> Bool
forall a. Eq a => a -> a -> Bool
/= []) (X () -> X ()) -> X () -> X ()
forall a b. (a -> b) -> a -> b
$ do
         let atom :: Atom
atom = Integer -> Atom
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Atom) -> Integer -> Atom
forall a b. (a -> b) -> a -> b
$ CInt -> Integer
forall a. Integral a => a -> Integer
toInteger (CInt -> Integer) -> CInt -> Integer
forall a b. (a -> b) -> a -> b
$ (CInt -> CInt -> CInt) -> [CInt] -> CInt
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 (\a :: CInt
a b :: CInt
b -> CInt
a CInt -> CInt -> CInt
forall a. Num a => a -> a -> a
+ (CInt
bCInt -> CInt -> CInt
forall a. Num a => a -> a -> a
*2CInt -> Int -> CInt
forall a b. (Num a, Integral b) => a -> b -> a
^(32::Int))) [CInt]
dt
         Maybe String
cmd <- IO (Maybe String) -> X (Maybe String)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO (Maybe String) -> X (Maybe String))
-> IO (Maybe String) -> X (Maybe String)
forall a b. (a -> b) -> a -> b
$ Display -> Atom -> IO (Maybe String)
getAtomName Display
d Atom
atom
         case Maybe String
cmd of
              Just command :: String
command -> String -> X ()
func String
command
              Nothing -> IO () -> X ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> X ()) -> IO () -> X ()
forall a b. (a -> b) -> a -> b
$ Handle -> String -> IO ()
hPutStrLn Handle
stderr ("Couldn't retrieve atom " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Atom -> String
forall a. Show a => a -> String
show Atom
atom))
        All -> X All
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> All
All Bool
True)
serverModeEventHookF _ _ _ = All -> X All
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> All
All Bool
True)