Remove xcl and CVSROOT.

8 files changed, 205 insertions, 0 deletions

diff --git a/.cvsignore b/.cvsignore
new file mode 100644
index 0000000..7635e51
--- /dev/null
+++ b/.cvsignore
@@ -0,0 +1,2 @@
+*.hi
+Main
diff --git a/Main.hs b/Main.hs
new file mode 100644
index 0000000..2dbecb2
--- /dev/null
+++ b/Main.hs
@@ -0,0 +1,13 @@
+module Main where
+
+import XCB
+import XProto
+import Monad
+
+main = withConnection "" $ \c screen -> do
+        putStrLn $ "screen: " ++ (show screen)
+        atoms <- mapM (internAtom c True) names
+        fonts <- listFontsWithInfo c 5 "-daewoo-*"
+        zipWithM_ (\name atom-> putStrLn $ name ++ ": " ++ (show $ internAtomAtom atom)) names atoms
+        mapM (print . name) fonts
+    where names = ["this atom name doesn't exist", "PRIMARY", "SECONDARY", "Public domain font.  Share and enjoy."]
diff --git a/Makefile b/Makefile
new file mode 100644
index 0000000..f07da10
--- /dev/null
+++ b/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/XCB.hs b/XCB.hs
new file mode 100644
index 0000000..b0ba7be
--- /dev/null
+++ b/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/XCBExt.hs b/XCBExt.hs
new file mode 100644
index 0000000..9834562
--- /dev/null
+++ b/XCBExt.hs
@@ -0,0 +1,66 @@
+{-# OPTIONS -ffi #-}
+module XCBExt(Readable(..), ReplyReader, readSize, readString, request, requestWithReply) where
+
+import XCB
+import Control.Exception
+import System.IO.Unsafe(unsafeInterleaveIO)
+import Foreign
+import CForeign
+import Control.Monad.Reader
+import Control.Monad.State
+import Debug.Trace
+
+trace' s = trace $ " * " ++ s
+
+type ReplyReader a = StateT Int (ReaderT (ForeignPtr Word32) IO) a
+
+class Readable a where
+    replyRead :: ReplyReader a
+    replyReadLen :: Enum n => n -> ReplyReader [a]
+    replyReadLen n = sequence $ replicate (fromEnum n) $ replyRead
+
+instance Readable Bool where replyRead = readBool
+instance Readable Word8 where replyRead = readStorable
+instance Readable Word16 where replyRead = readStorable
+instance Readable Word32 where replyRead = readStorable
+instance Readable Int8 where replyRead = readStorable
+instance Readable Int16 where replyRead = readStorable
+instance Readable Int32 where replyRead = readStorable
+
+readSize :: Storable a => Int -> ReplyReader a
+readSize size = do
+    last <- get
+    let cur = (last + size - 1) .&. (-size)
+    put $ cur + size
+    p <- return . trace' "read pointer" =<< ask
+    liftIO $ liftIO $ unsafeInterleaveIO $ withForeignPtr p $ \p'-> trace' "peek" $ peek $ plusPtr p' cur
+
+retTypeM :: Monad m => m a -> a
+retTypeM _ = undefined
+
+readStorable :: Storable a => ReplyReader a
+readStorable = action
+    where action = readSize (sizeOf $ retTypeM action)
+
+readBool :: ReplyReader Bool
+readBool = (replyRead :: ReplyReader Word8) >>= return . toBool
+
+readString :: Enum n => n -> ReplyReader String
+readString n = do
+    cur <- get
+    put $ cur + fromEnum n
+    p <- ask
+    liftIO $ liftIO $ unsafeInterleaveIO $ withForeignPtr p $ \p'-> peekCStringLen (plusPtr p' cur, fromEnum n)
+
+foreign import ccall "X11/XCB/xcbext.h XCBWaitForReply" _waitForReply :: Ptr XCBConnection -> Word32 -> Ptr (Ptr XCBGenericError) -> IO (Ptr Word32)
+
+request :: IO Word32 -> IO Word32
+request = return . trace' "sent request" =<< throwIf (== 0) (const "couldn't send request")
+
+repeatIO :: IO a -> IO [a]
+repeatIO f = unsafeInterleaveIO $ do x <- f; xs <- repeatIO f; return (x:xs)
+
+requestWithReply :: Ptr XCBConnection -> ReplyReader reply -> IO Word32 -> IO [reply]
+requestWithReply c readReply req = do
+    cookie <- request req
+    repeatIO $ throwIfNull "couldn't get reply" (_waitForReply c cookie nullPtr) >>= newForeignPtr finalizerFree >>= runReaderT (evalStateT readReply 0) >>= return . trace' "got reply"
diff --git a/XProto.glue.c b/XProto.glue.c
new file mode 100644
index 0000000..6d74111
--- /dev/null
+++ b/XProto.glue.c
@@ -0,0 +1,13 @@
+#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;
+}
+
+CARD32 _ListFontsWithInfo(XCBConnection *c, CARD16 max_names, CARD16 pattern_len, char *pattern)
+{
+	XCBListFontsWithInfoCookie cookie = XCBListFontsWithInfo(c, max_names, pattern_len, pattern);
+	return cookie.sequence;
+}
diff --git a/XProto.glue.h b/XProto.glue.h
new file mode 100644
index 0000000..f9055ae
--- /dev/null
+++ b/XProto.glue.h
@@ -0,0 +1,4 @@
+#include <X11/XCB/xcb.h>
+
+CARD32 _internAtom(XCBConnection *c, BOOL onlyIfExists, CARD16 name_len, char *name);
+CARD32 _ListFontsWithInfo(XCBConnection *c, CARD16 max_names, CARD16 pattern_len, char *pattern);
diff --git a/XProto.hs b/XProto.hs
new file mode 100644
index 0000000..2c51ba4
--- /dev/null
+++ b/XProto.hs
@@ -0,0 +1,77 @@
+{-# OPTIONS -fglasgow-exts -ffi #-}
+module XProto(internAtom, Atom, InternAtomReply(..), listFontsWithInfo, ListFontsWithInfoReply(..)) where
+
+import XCB
+import XCBExt
+import CForeign
+import Foreign
+import Control.Monad.State
+
+type Atom = Word32
+
+data CharInfo = CharInfo Int16 Int16 Int16 Int16 Int16 Word16
+    deriving Show
+
+instance Readable CharInfo where
+    replyRead = do
+        left_side_bearing <- replyRead
+        right_side_bearing <- replyRead
+        character_width <- replyRead
+        ascent <- replyRead
+        descent <- replyRead
+        attributes <- replyRead
+        return $ CharInfo left_side_bearing right_side_bearing character_width ascent descent attributes
+
+data FontProp = FontProp Atom Word32
+    deriving Show
+
+instance Readable FontProp where
+    replyRead = do
+        name <- replyRead
+        value <- replyRead
+        return $ FontProp name value
+
+foreign import ccall "XProto.glue.h" _internAtom :: Ptr XCBConnection -> Word8 -> Word16 -> CString -> IO Word32
+data InternAtomReply = InternAtomReply { internAtomResponseType :: Word8, internAtomSequence :: Word16, internAtomLength :: Word32, internAtomAtom :: Atom }
+internAtom :: Ptr XCBConnection -> Bool -> String -> IO InternAtomReply
+internAtom c onlyIfExists name =
+        (requestWithReply c reader $ withCStringLen name (\(name, name_len)-> _internAtom c (fromBool onlyIfExists) (toEnum name_len) name))
+        >>= return . head
+    where reader = do
+            responseType <- replyRead
+            sequence <- replyRead
+            length <- replyRead
+            atom <- replyRead
+            return $ InternAtomReply responseType sequence length atom
+
+foreign import ccall "XProto.glue.h" _ListFontsWithInfo :: Ptr XCBConnection -> Word16 -> Word16 -> CString -> IO Word32
+data ListFontsWithInfoReply = ListFontsWithInfoReply { min_bounds :: CharInfo, max_bounds :: CharInfo, min_char_or_byte2 :: Word16, max_char_or_byte2 :: Word16, default_char :: Word16, draw_direction :: Word8, min_byte1 :: Word8, max_byte1 :: Word8, all_chars_exist :: Bool, font_ascent :: Int16, font_descent :: Int16, replies_hint :: Word32, properties :: [FontProp], name :: String }
+    deriving Show
+listFontsWithInfo :: Ptr XCBConnection -> Word16 -> String -> IO [ListFontsWithInfoReply]
+listFontsWithInfo c max_names pattern =
+        (requestWithReply c reader $ withCStringLen pattern $ \(pattern, pattern_len)-> _ListFontsWithInfo c max_names (toEnum pattern_len) pattern)
+        >>= return . takeWhile (\f-> name f /= "")
+    where
+        reader = do
+            modify (+ 1)
+            name_len <- replyRead :: ReplyReader Word8
+            modify (+ 6)
+            min_bounds <- replyRead
+            modify (+ 4)
+            max_bounds <- replyRead
+            modify (+ 4)
+            min_char_or_byte2 <- replyRead
+            max_char_or_byte2 <- replyRead
+            default_char <- replyRead
+            properties_len <- replyRead :: ReplyReader Word16
+            draw_direction <- replyRead
+            min_byte1 <- replyRead
+            max_byte1 <- replyRead
+            all_chars_exist <- replyRead
+            font_ascent <- replyRead
+            font_descent <- replyRead
+            replies_hint <- replyRead
+            properties <- replyReadLen properties_len
+            modify (\n-> (n + 3) .&. (-4))
+            name <- readString name_len
+            return $ ListFontsWithInfoReply min_bounds max_bounds min_char_or_byte2 max_char_or_byte2 default_char draw_direction min_byte1 max_byte1 all_chars_exist font_ascent font_descent replies_hint properties name