Use a Reader monad instead of passing the ForeignPtr down through all the

    calls.

1 files changed, 21 insertions, 17 deletions

diff --git a/xhsb/XCBExt.hs b/xhsb/XCBExt.hs
index e8dd9ea..3d4c3ee 100644
--- a/xhsb/XCBExt.hs
+++ b/xhsb/XCBExt.hs
@@ -6,38 +6,42 @@ import Control.Exception
 import System.IO.Unsafe(unsafeInterleaveIO)
 import Foreign
 
+import Control.Monad.Reader
 import Control.Monad.State
 import Data.Generics
 
-readSize :: Storable a => Int -> ForeignPtr p -> StateT Int IO a
-readSize size p = do
+type ReplyReader a = StateT Int (ReaderT (ForeignPtr Word32) IO) a
+
+readSize :: Storable a => Int -> ReplyReader a
+readSize size = do
     last <- get
     let cur = (last + size - 1) .&. (-size)
     put $ cur + size
-    liftIO $ unsafeInterleaveIO $ withForeignPtr p $ \p'-> peek $ plusPtr p' cur
+    p <- ask
+    liftIO $ 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
+readGenericM :: Storable a => ReplyReader a
+readGenericM = action
+    where action = readSize (sizeOf $ retTypeM action)
 
-readBoolM :: ForeignPtr p -> StateT Int IO Bool
-readBoolM p = do
-    v <- readSize 1 p
+readBoolM :: ReplyReader Bool
+readBoolM = do
+    v <- readSize 1
     return $ (v :: Word8) /= 0
 
-readReply :: Data reply => ForeignPtr p -> IO reply
-readReply p = ret
+readReply :: Data reply => ReaderT (ForeignPtr Word32) IO reply
+readReply = ret
     where
         ret = evalStateT (fromConstrM reader c) 0
-        reader :: Typeable a => StateT Int IO a
+        reader :: Typeable a => ReplyReader 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)
+            `extR` (readBoolM)
+            `extR` (readGenericM :: ReplyReader Word8)
+            `extR` (readGenericM :: ReplyReader Word16)
+            `extR` (readGenericM :: ReplyReader 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)
@@ -47,4 +51,4 @@ 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 >>= readReply
+    unsafeInterleaveIO $ throwIfNull "couldn't get reply" (_waitForReply c cookie nullPtr) >>= newForeignPtr finalizerFree >>= runReaderT readReply