[Xcb-commit] xhsb .cvsignore, NONE, 1.1 Main.hs, NONE, 1.1 Makefile, NONE, 1.1 XCB.hs, NONE, 1.1 XCBExt.hs, NONE, 1.1 XProto.glue.c, NONE, 1.1 XProto.glue.h, NONE, 1.1 XProto.hs, NONE, 1.1

[Jamey Sharp]

Update of /cvs/xcb/xhsb
In directory gabe:/tmp/cvs-serv23149

Added Files:
	.cvsignore Main.hs Makefile XCB.hs XCBExt.hs XProto.glue.c 
	XProto.glue.h XProto.hs 
Log Message:
First commit of a simple Haskell binding to XCB, including a demo app that interns a few atoms.

--- NEW FILE: .cvsignore ---
*.hi
Main

--- NEW FILE: XCB.hs ---
{-# 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

--- NEW FILE: XProto.glue.c ---
#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;
}

--- NEW FILE: XProto.glue.h ---
#include <X11/XCB/xcb.h>

CARD32 _internAtom(XCBConnection *c, BOOL onlyIfExists, CARD16 name_len, char *name);

--- NEW FILE: Main.hs ---
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."]

--- NEW FILE: Makefile ---
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

--- NEW FILE: XProto.hs ---
{-# 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)

--- NEW FILE: XCBExt.hs ---
{-# 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