Permalink
Browse files

add the send control routine

very difficult to make work
final logic is:

wait for GTK plug event
delay for 1000ms
open display
repeat
  send key
  flush the event queue
  delay 100us (long enough?)
close display

Signed-off-by: Christopher Hall <hsw@ms2.hinet.net>
  • Loading branch information...
1 parent 4eb3c4a commit d1bdcd55f272a9953c960ce2b43ff374beecc3ac @hxw committed Jun 24, 2012
Showing with 116 additions and 5 deletions.
  1. +2 −2 Makefile
  2. +1 −1 README.md
  3. +90 −0 SendControl.hs
  4. +20 −0 TerminalUI.hs
  5. +3 −2 config.rc
View
@@ -2,9 +2,9 @@
.PHONY: all
-all: conlecterm
+all: conlecterm run
-conlecterm: Main.hs ConfigurationParser.hs TerminalUI.hs ProcessRunner.hs
+conlecterm: $(wildcard *.hs)
ghc -o "$@" --make Main.hs
.PHONY: run
View
@@ -52,7 +52,7 @@ the configuration file has three kinds of configuration elements
# Compiling
-The program is written in Haskell and requires GTK (Ubuntu: libghc-gtk-dev).
+The program is written in Haskell and requires GTK and X11 (Ubuntu: libghc-gtk-dev, libghc-x11-de).
A simple Makefile is provided.
View
@@ -0,0 +1,90 @@
+-- Copyright (c) 2012, Christopher Hall <hsw@ms2.hinet.net>
+-- Licence BSD see LICENSE.text
+
+module SendControl where
+
+--import Data.Maybe
+import Foreign.C
+import Data.Char( isUpper )
+import qualified Graphics.X11 as X
+import qualified Graphics.X11.Xlib.Extras as XE
+import qualified Graphics.UI.Gtk as GTK
+import Control.Exception( bracket )
+import Control.Concurrent( threadDelay )
+
+-- ***FIX*** why is this missing?
+-- it was in the docs on the web site
+-- just Ubuntu not up to date?
+-- remove this and convert noModMask to X.noModMask
+noModMask :: X.KeyMask
+noModMask = 0
+
+eol :: X.KeySym
+--eol = X.xK_Return
+eol = X.xK_Linefeed
+
+
+-- group together the low leve X related items
+-- needed to send a key event
+type NativeAccess = (X.Display, X.Window, X.Window)
+
+
+-- send a list of keys
+-- ***TODO*** allow shift, control
+-- ***UNTESTED***
+send :: GTK.Socket -> [String] -> IO ()
+send socket keyList = withNative socket $ \native -> do
+ mapM_ (\k -> sendKey native noModMask (sym k)) keyList
+ where
+ sym = X.stringToKeysym
+
+
+-- send a line ended by newline
+-- each character of the string is treated as a separate keysym
+sendLine :: GTK.Socket -> String -> IO ()
+sendLine socket str = withNative socket $ \native -> do
+ mapM_ (\ch -> sendKey native (shift ch) (sym ch)) str
+ sendKey native noModMask eol
+ where
+ shift ch = if isUpper ch then X.shiftMask else noModMask
+ sym ' ' = X.stringToKeysym "space"
+ sym ch = X.stringToKeysym [ch]
+
+
+-- bracket all the messy details of accessing Xlib
+-- opens and closes the display, gets root window
+-- finds the X window ID corresponding to the "plug" in the GTK socket
+withNative :: GTK.Socket -> (NativeAccess -> IO ()) -> IO ()
+withNative socket run =
+ bracket setup final run
+ where
+ setup :: IO NativeAccess
+ setup = do
+ putStrLn $ "setup"
+ plugWindow <- GTK.socketGetPlugWindow socket
+ window <- GTK.drawableGetID plugWindow
+ let nativeWindow = GTK.fromNativeWindowId window
+ display <- X.openDisplay ""
+ let root = X.defaultRootWindow display
+ return (display, root, nativeWindow)
+ final :: NativeAccess -> IO ()
+ final (display, _root, _window) = do
+ putStrLn $ "final"
+ X.closeDisplay display
+
+
+-- send the key event
+-- needs flush and delay to ensure that the event actually gets sent
+-- delay appears to be required or the event queue is overloaded
+-- and the urxvt ceases to respond to normal key presses
+sendKey :: NativeAccess -> X.KeyMask -> X.KeySym -> IO ()
+sendKey (display, root, window) shift keysym = do
+ keycode <- X.keysymToKeycode display keysym
+ X.allocaXEvent $ \ke -> do
+ XE.setEventType ke X.keyPress
+ XE.setKeyEvent ke window root XE.none shift keycode True
+ X.sendEvent display window True X.keyPressMask ke
+ XE.setEventType ke X.keyRelease
+ X.sendEvent display window True X.keyReleaseMask ke
+ X.flush display -- ensure the key is sent immediately
+ threadDelay 100 -- must delay otherwise the event queue fails
View
@@ -11,6 +11,7 @@ import qualified Text.Read as TR
import qualified ConfigurationParser as CP
import qualified ProcessRunner as PR
+import qualified SendControl as SC
orientation :: CP.Orientation -> GTK.PositionType
@@ -82,13 +83,32 @@ addPane notebook title dir commandList = do
let run = CP.expandCommand commandList windowID title
GTK.on socket GTK.socketPlugRemoved $ unplug socket page dir run
+ GTK.on socket GTK.socketPlugAdded $ plug socket
putStrLn $ "RUN: " ++ (show run)
PR.run dir run
return page
+-- detect the program creating its main window
+-- delay inorder to give it tiome to set itself up
+-- send too quickly and the event queue locks up
+plug :: GTK.Socket -> IO ()
+plug socket = do
+ putStrLn $ "plug "
+ h <- GTK.timeoutAdd (delayedSend socket >> return False) 1000
+ return ()
+
+
+-- dummy routine to send a couple of test lines
+delayedSend socket = do
+ putStrLn "plug--delay"
+
+ SC.sendLine socket "ls"
+ SC.sendLine socket "echo the quick brown fox jumps over the lazy dog"
+
+
-- dialog to decide whether to restart the command
unplug :: GTK.Socket -> Int -> Maybe String -> [String] -> IO Bool
unplug socket page dir run = do
View
@@ -93,8 +93,9 @@ pane gvim "Vi IMprove" {
# the default session
session default left {
#tab emacs
- tab * 3 p1
- tab * 2 p2
+ tab p1
+# tab * 3 p1
+# tab * 2 p2
button p1
button p2
}

0 comments on commit d1bdcd5

Please sign in to comment.