[Xcb-commit] xhsb Main.hs, 1.1, 1.2 XCBExt.hs, 1.1, 1.2 XProto.hs, 1.1, 1.2

[Jamey Sharp]

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

Modified Files:
	Main.hs XCBExt.hs XProto.hs 
Log Message:
Rewrite reply handling using "Scrap Your Boilerplate"-style generics so the Haskell type of the reply directs how the bytes are interpreted off the wire.

Index: XProto.hs
===================================================================
RCS file: /cvs/xcb/xhsb/XProto.hs,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -d -r1.1 -r1.2
--- XProto.hs	10 Jan 2006 08:25:25 -0000	1.1
+++ XProto.hs	10 Jan 2006 11:55:42 -0000	1.2
@@ -1,14 +1,19 @@
-{-# OPTIONS -ffi #-}
-module XProto(internAtom) where
+{-# OPTIONS -fglasgow-exts -ffi #-}
+module XProto(internAtom, Atom, InternAtomReply(..)) where
 
 import XCB
 import XCBExt
 import CForeign
 import Foreign
-import System.IO.Unsafe(unsafeInterleaveIO)
+import Data.Generics
 
 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)
+type Atom = Word32
+
+data InternAtomReply = InternAtomReply { internAtomResponseType :: Word8, internAtomSequence :: Word16, internAtomLength :: Word32, internAtomAtom :: Atom }
+    deriving (Typeable, Data)
+
+internAtom :: Ptr XCBConnection -> Bool -> String -> IO InternAtomReply
+internAtom c onlyIfExists name =
+    requestWithReply c $ withCStringLen name (\(name, name_len)-> _internAtom c (if onlyIfExists then 1 else 0) (toEnum name_len) name)

Index: XCBExt.hs
===================================================================
RCS file: /cvs/xcb/xhsb/XCBExt.hs,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -d -r1.1 -r1.2
--- XCBExt.hs	10 Jan 2006 08:25:25 -0000	1.1
+++ XCBExt.hs	10 Jan 2006 11:55:42 -0000	1.2
@@ -6,10 +6,45 @@
 import System.IO.Unsafe(unsafeInterleaveIO)
 import Foreign
 
+import Control.Monad.State
+import Data.Generics
+
+readSize :: Storable a => Int -> ForeignPtr p -> StateT Int IO a
+readSize size p = do
+    last <- get
+    let cur = (last + size - 1) .&. (-size)
+    put $ cur + size
+    liftIO $ unsafeInterleaveIO $ withForeignPtr p $ \p'-> peek $ plusPtr p' cur
+
+retTypeM :: Monad m => m a -> a
+retTypeM _ = undefined
+
+readGenericM :: Storable a => ForeignPtr p -> StateT Int IO a
+readGenericM p = action
+    where action = readSize (sizeOf $ retTypeM action) p
+
+readBoolM :: ForeignPtr p -> StateT Int IO Bool
+readBoolM p = do
+    v <- readSize 1 p
+    return $ (v :: Word8) /= 0
+
+readReply :: Data reply => ForeignPtr p -> IO reply
+readReply p = ret
+    where
+        ret = evalStateT (fromConstrM reader c) 0
+        reader :: Typeable a => StateT Int IO a
+        reader = fail "no reader for this type"
+            `extR` (readBoolM p)
+            `extR` (readGenericM p :: StateT Int IO Word8)
+            `extR` (readGenericM p :: StateT Int IO Word16)
+            `extR` (readGenericM p :: StateT Int IO Word32)
+        c = indexConstr (dataTypeOf $ retTypeM ret) 1
+
 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 :: Data reply => Ptr XCBConnection -> IO Word32 -> IO reply
 requestWithReply c req = do
     cookie <- request req
-    unsafeInterleaveIO $ throwIfNull "couldn't get reply" (_waitForReply c cookie nullPtr) >>= newForeignPtr finalizerFree
+    unsafeInterleaveIO $ throwIfNull "couldn't get reply" (_waitForReply c cookie nullPtr) >>= newForeignPtr finalizerFree >>= readReply

Index: Main.hs
===================================================================
RCS file: /cvs/xcb/xhsb/Main.hs,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -d -r1.1 -r1.2
--- Main.hs	10 Jan 2006 08:25:25 -0000	1.1
+++ Main.hs	10 Jan 2006 11:55:42 -0000	1.2
@@ -7,5 +7,5 @@
 main = withConnection "" $ \c screen -> do
         putStrLn $ "screen: " ++ (show screen)
         atoms <- mapM (internAtom c True) names
-        zipWithM_ (\name atom-> putStrLn $ name ++ ": " ++ (show atom)) names atoms
+        zipWithM_ (\name atom-> putStrLn $ name ++ ": " ++ (show $ internAtomAtom atom)) names atoms
     where names = ["this atom name doesn't exist", "PRIMARY", "SECONDARY", "Public domain font.  Share and enjoy."]