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.

3 files changed, 48 insertions, 8 deletions

diff --git a/xhsb/Main.hs b/xhsb/Main.hs
index 704fa15..f73c2a5 100644
--- a/xhsb/Main.hs
+++ b/xhsb/Main.hs
@@ -7,5 +7,5 @@ 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
+        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."]
diff --git a/xhsb/XCBExt.hs b/xhsb/XCBExt.hs
index 9e1322d..e8dd9ea 100644
--- a/xhsb/XCBExt.hs
+++ b/xhsb/XCBExt.hs
@@ -6,10 +6,45 @@ import Control.Exception
 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
diff --git a/xhsb/XProto.hs b/xhsb/XProto.hs
index 8bd25ae..982b285 100644
--- a/xhsb/XProto.hs
+++ b/xhsb/XProto.hs
@@ -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)