First commit of a simple Haskell binding to XCB, including a demo app that

    interns a few atoms.

8 files changed, 82 insertions, 0 deletions

diff --git a/xhsb/.cvsignore b/xhsb/.cvsignore
new file mode 100644
index 0000000..7635e51
--- /dev/null
+++ b/xhsb/.cvsignore
@@ -0,0 +1,2 @@
+*.hi
+Main
diff --git a/xhsb/Main.hs b/xhsb/Main.hs
new file mode 100644
index 0000000..704fa15
--- /dev/null
+++ b/xhsb/Main.hs
@@ -0,0 +1,11 @@
+module Main where
+
+import XCB
+import XProto
+import Monad
+
+main = withConnection "" $ \c screen -> do
+        putStrLn $ "screen: " ++ (show screen)
+        atoms <- mapM (internAtom c True) names
+        zipWithM_ (\name atom-> putStrLn $ name ++ ": " ++ (show atom)) names atoms
+    where names = ["this atom name doesn't exist", "PRIMARY", "SECONDARY", "Public domain font.  Share and enjoy."]
diff --git a/xhsb/Makefile b/xhsb/Makefile
new file mode 100644
index 0000000..f07da10
--- /dev/null
+++ b/xhsb/Makefile
@@ -0,0 +1,10 @@
+XCB_CFLAGS = -lXCB
+
+all: XProto.glue.o
+	ghc --make $(XCB_CFLAGS) -o Main Main $^
+
+%.glue.o: %.glue.c %.glue.h
+	ghc -c $<
+
+clean:
+	-rm -f *.o *.hi Main
diff --git a/xhsb/XCB.hs b/xhsb/XCB.hs
new file mode 100644
index 0000000..b0ba7be
--- /dev/null
+++ b/xhsb/XCB.hs
@@ -0,0 +1,20 @@
+{-# OPTIONS -fglasgow-exts -ffi #-}
+module XCB(XCBConnection, XCBGenericError, connect, disconnect, withConnection) where
+
+import Control.Exception
+import CForeign
+import Foreign
+
+data XCBConnection
+data XCBGenericError
+
+foreign import ccall "X11/XCB/xcb.h XCBConnect" _connect :: CString -> Ptr CInt -> IO (Ptr XCBConnection)
+foreign import ccall "X11/XCB/xcb.h XCBDisconnect" disconnect :: Ptr XCBConnection -> IO ()
+
+connect display = withCString display (\displayPtr -> alloca (\screenPtr -> do
+    c <- throwIfNull "connect failed" $ _connect displayPtr screenPtr
+    screen <- peek screenPtr
+    return (c, fromEnum screen)
+    ))
+
+withConnection display = bracket (connect display) (disconnect . fst) . uncurry
diff --git a/xhsb/XCBExt.hs b/xhsb/XCBExt.hs
new file mode 100644
index 0000000..9e1322d
--- /dev/null
+++ b/xhsb/XCBExt.hs
@@ -0,0 +1,15 @@
+{-# OPTIONS -ffi #-}
+module XCBExt(request, requestWithReply) where
+
+import XCB
+import Control.Exception
+import System.IO.Unsafe(unsafeInterleaveIO)
+import Foreign
+
+foreign import ccall "X11/XCB/xcbext.h XCBWaitForReply" _waitForReply :: Ptr XCBConnection -> Word32 -> Ptr (Ptr XCBGenericError) -> IO (Ptr Word32)
+
+request = throwIf (== 0) (const "couldn't send request")
+
+requestWithReply c req = do
+    cookie <- request req
+    unsafeInterleaveIO $ throwIfNull "couldn't get reply" (_waitForReply c cookie nullPtr) >>= newForeignPtr finalizerFree
diff --git a/xhsb/XProto.glue.c b/xhsb/XProto.glue.c
new file mode 100644
index 0000000..ccb2ed9
--- /dev/null
+++ b/xhsb/XProto.glue.c
@@ -0,0 +1,7 @@
+#include "XProto.glue.h"
+
+CARD32 _internAtom(XCBConnection *c, BOOL onlyIfExists, CARD16 name_len, char *name)
+{
+	XCBInternAtomCookie cookie = XCBInternAtom(c, onlyIfExists, name_len, name);
+	return cookie.sequence;
+}
diff --git a/xhsb/XProto.glue.h b/xhsb/XProto.glue.h
new file mode 100644
index 0000000..a6f8b8a
--- /dev/null
+++ b/xhsb/XProto.glue.h
@@ -0,0 +1,3 @@
+#include <X11/XCB/xcb.h>
+
+CARD32 _internAtom(XCBConnection *c, BOOL onlyIfExists, CARD16 name_len, char *name);
diff --git a/xhsb/XProto.hs b/xhsb/XProto.hs
new file mode 100644
index 0000000..8bd25ae
--- /dev/null
+++ b/xhsb/XProto.hs
@@ -0,0 +1,14 @@
+{-# OPTIONS -ffi #-}
+module XProto(internAtom) where
+
+import XCB
+import XCBExt
+import CForeign
+import Foreign
+import System.IO.Unsafe(unsafeInterleaveIO)
+
+foreign import ccall "XProto.glue.h" _internAtom :: Ptr XCBConnection -> Word8 -> Word16 -> CString -> IO Word32
+
+internAtom c onlyIfExists name = do
+    reply <- requestWithReply c $ withCStringLen name (\(name, name_len)-> _internAtom c (if onlyIfExists then 1 else 0) (toEnum name_len) name)
+    unsafeInterleaveIO $ withForeignPtr reply (\replyPtr-> peekElemOff replyPtr 2)