Generalized XMonad.Hooks.ServerMode

Ignore-this: e58da3b168a1058f32982833ea25a739

darcs-hash:20131216025100-92c7a-150574b67a1becbb0e5a09a9b2193d3dee5722dd.gz

1 files changed, 108 insertions, 41 deletions

diff --git a/XMonad/Hooks/ServerMode.hs b/XMonad/Hooks/ServerMode.hs
index bbe1097..daff6df 100644
--- a/XMonad/Hooks/ServerMode.hs
+++ b/XMonad/Hooks/ServerMode.hs
@@ -1,10 +1,10 @@
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  XMonad.Hooks.ServerMode
--- Copyright   :  (c) Andrea Rossato and David Roundy 2007
+-- Copyright   :  (c) Peter Olson 2013 and Andrea Rossato and David Roundy 2007
 -- License     :  BSD-style (see xmonad/LICENSE)
 --
--- Maintainer  :  andrea.rossato@unibz.it
+-- Maintainer  :  polson2@hawk.iit.edu
 -- Stability   :  unstable
 -- Portability :  unportable
 --
@@ -16,54 +16,88 @@
 -- > import Graphics.X11.Xlib
 -- > import Graphics.X11.Xlib.Extras
 -- > import System.Environment
+-- > import System.IO
 -- > import Data.Char
--- >
--- > usage :: String -> String
--- > usage n = "Usage: " ++ n ++ " command number\nSend a command number to a running instance of XMonad"
--- >
+-- > 
 -- > main :: IO ()
--- > main = do
--- >   args <- getArgs
--- >   pn <- getProgName
--- >   let com = case args of
--- >               [] -> error $ usage pn
--- >               w -> (w !! 0)
--- >   sendCommand com
--- >
--- > sendCommand :: String -> IO ()
--- > sendCommand s = do
+-- > 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 "XMONAD_COMMAND" False
+-- >   a <- internAtom d addr False
+-- >   m <- internAtom d s False
 -- >   allocaXEvent $ \e -> do
 -- >                   setEventType e clientMessage
--- >                   setClientMessageEvent e rw a 32 (fromIntegral (read s)) currentTime
+-- >                   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 sendCommand.hs@
+--
+-- compile with: @ghc --make xmonadctl.hs@
 --
 -- run with
 --
--- > sendCommand command number
+-- > xmonadctl command
+--
+-- or with
 --
--- For instance:
+-- > $ xmonadctl
+-- > command1
+-- > command2
+-- > .
+-- > .
+-- > .
+-- > ^D
 --
--- > sendCommand 0
+-- Usage will change depending on which event hook(s) you use. More examples are shown below.
 --
---  will ask to xmonad to print the list of command numbers in
--- stderr (so you can read it in @~\/.xsession-errors@).
 -----------------------------------------------------------------------------
 
 module XMonad.Hooks.ServerMode
     ( -- * Usage
       -- $usage
-      ServerMode (..)
-    , serverModeEventHook
+      serverModeEventHook
     , serverModeEventHook'
+    , serverModeEventHookCmd
+    , serverModeEventHookCmd'
+    , serverModeEventHookF
     ) where
 
 import Control.Monad (when)
+import Data.Maybe
 import Data.Monoid
 import System.IO
 
@@ -75,31 +109,64 @@ import XMonad.Actions.Commands
 -- @~\/.xmonad\/xmonad.hs@:
 --
 -- > import XMonad.Hooks.ServerMode
--- > import XMonad.Actions.Commands
 --
--- Then edit your @handleEventHook@ by adding the 'serverModeEventHook':
+-- 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
 --
-
-data ServerMode = ServerMode deriving ( Show, Read )
-
--- | Executes a command of the list when receiving its index via a special ClientMessageEvent
--- (indexing starts at 1)
 serverModeEventHook :: Event -> X All
 serverModeEventHook = serverModeEventHook' defaultCommands
 
 -- | serverModeEventHook' additionally takes an action to generate the list of
 -- commands.
 serverModeEventHook' :: X [(String,X ())] -> Event -> X All
-serverModeEventHook' cmdAction (ClientMessageEvent {ev_message_type = mt, ev_data = dt}) = do
+serverModeEventHook' cmdAction ev = serverModeEventHookF "XMONAD_COMMAND" (sequence_ . map helper . words) ev
+        where helper cmd = do cl <- cmdAction
+                              case lookup cmd (zip (map show [1..]) cl) of
+                                Just (_,action) -> action
+                                Nothing         -> mapM_ (io . hPutStrLn stderr) . listOfCommands $ cl
+              listOfCommands cl = map (uncurry (++)) $ zip (map show ([1..] :: [Int])) $ map ((++) " - " . fst) 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 = serverModeEventHookCmd' defaultCommands
+
+-- | Additionally takes an action to generate the list of commands
+serverModeEventHookCmd' :: X [(String,X ())] -> Event -> X All
+serverModeEventHookCmd' cmdAction ev = serverModeEventHookF "XMONAD_COMMAND" (sequence_ . map helper . words) ev
+        where helper cmd = do cl <- cmdAction
+                              fromMaybe (io $ hPutStrLn stderr ("Couldn't find command " ++ cmd)) (lookup cmd 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 key func (ClientMessageEvent {ev_message_type = mt, ev_data = dt}) = do
         d <- asks display
-        a <- io $ internAtom d "XMONAD_COMMAND" False
+        a <- io $ internAtom d key False
         when (mt == a && dt /= []) $ do
-             cl <- cmdAction
-             let listOfCommands = map (uncurry (++)) . zip (map show ([1..] :: [Int])) . map ((++) " - " . fst)
-             case lookup (fromIntegral (head dt) :: Int) (zip [1..] cl) of
-                  Just (_,action) -> action
-                  Nothing         -> mapM_ (io . hPutStrLn stderr) . listOfCommands $ cl
+	     let atom = fromIntegral $ toInteger $ foldr1 (\a b -> a + (b*2^32)) dt
+	     cmd <- io $ getAtomName d atom
+	     case cmd of
+	          Just command -> func command
+		  Nothing -> io $ hPutStrLn stderr ("Couldn't retrieve atom " ++ (show atom))
         return (All True)
-serverModeEventHook' _ _ = return (All True)
+serverModeEventHookF _ _ _ = return (All True)