[Xcb-commit] xhsb Main.hs, 1.2, 1.3 XCBExt.hs, 1.7,
1.8 XProto.glue.c, 1.1, 1.2 XProto.glue.h, 1.1, 1.2 XProto.hs,
1.4, 1.5
Jamey Sharp
xcb-commit at lists.freedesktop.org
Tue Jan 10 21:32:49 PST 2006
Update of /cvs/xcb/xhsb
In directory gabe:/tmp/cvs-serv24594
Modified Files:
Main.hs XCBExt.hs XProto.glue.c XProto.glue.h XProto.hs
Log Message:
Add support for requests with multiple replies, and somewhat generic reply parsing. Implement ListFontsWithInfo on the result.
Index: XCBExt.hs
===================================================================
RCS file: /cvs/xcb/xhsb/XCBExt.hs,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -d -r1.7 -r1.8
--- XCBExt.hs 10 Jan 2006 23:44:43 -0000 1.7
+++ XCBExt.hs 11 Jan 2006 05:32:47 -0000 1.8
@@ -1,10 +1,11 @@
{-# OPTIONS -ffi #-}
-module XCBExt(ReplyReader, readSize, readStorable, readBool, request, requestWithReply) where
+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
@@ -13,6 +14,19 @@
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
@@ -29,16 +43,24 @@
where action = readSize (sizeOf $ retTypeM action)
readBool :: ReplyReader Bool
-readBool = do
- v <- readSize 1
- return $ (v :: Word8) /= 0
+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")
-requestWithReply :: Ptr XCBConnection -> ReplyReader reply -> IO Word32 -> IO reply
+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
- unsafeInterleaveIO $ trace' "got reply" $ throwIfNull "couldn't get reply" (_waitForReply c cookie nullPtr) >>= newForeignPtr finalizerFree >>= runReaderT (evalStateT readReply 0)
+ repeatIO $ throwIfNull "couldn't get reply" (_waitForReply c cookie nullPtr) >>= newForeignPtr finalizerFree >>= runReaderT (evalStateT readReply 0) >>= return . trace' "got reply"
Index: XProto.hs
===================================================================
RCS file: /cvs/xcb/xhsb/XProto.hs,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -d -r1.4 -r1.5
--- XProto.hs 10 Jan 2006 23:44:43 -0000 1.4
+++ XProto.hs 11 Jan 2006 05:32:47 -0000 1.5
@@ -1,25 +1,77 @@
{-# OPTIONS -fglasgow-exts -ffi #-}
-module XProto(internAtom, Atom, InternAtomReply(..)) where
+module XProto(internAtom, Atom, InternAtomReply(..), listFontsWithInfo, ListFontsWithInfoReply(..)) where
import XCB
import XCBExt
import CForeign
import Foreign
-import Data.Generics
-
-foreign import ccall "XProto.glue.h" _internAtom :: Ptr XCBConnection -> Word8 -> Word16 -> CString -> IO Word32
+import Control.Monad.State
type Atom = Word32
-data InternAtomReply = InternAtomReply { internAtomResponseType :: Word8, internAtomSequence :: Word16, internAtomLength :: Word32, internAtomAtom :: Atom }
- deriving (Typeable, Data)
+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)
+ (requestWithReply c reader $ withCStringLen name (\(name, name_len)-> _internAtom c (fromBool onlyIfExists) (toEnum name_len) name))
+ >>= return . head
where reader = do
- responseType <- readStorable
- sequence <- readStorable
- length <- readStorable
- atom <- readStorable
+ 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
Index: Main.hs
===================================================================
RCS file: /cvs/xcb/xhsb/Main.hs,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -d -r1.2 -r1.3
--- Main.hs 10 Jan 2006 11:55:42 -0000 1.2
+++ Main.hs 11 Jan 2006 05:32:47 -0000 1.3
@@ -7,5 +7,7 @@
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."]
Index: XProto.glue.h
===================================================================
RCS file: /cvs/xcb/xhsb/XProto.glue.h,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -d -r1.1 -r1.2
--- XProto.glue.h 10 Jan 2006 08:25:25 -0000 1.1
+++ XProto.glue.h 11 Jan 2006 05:32:47 -0000 1.2
@@ -1,3 +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);
Index: XProto.glue.c
===================================================================
RCS file: /cvs/xcb/xhsb/XProto.glue.c,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -d -r1.1 -r1.2
--- XProto.glue.c 10 Jan 2006 08:25:25 -0000 1.1
+++ XProto.glue.c 11 Jan 2006 05:32:47 -0000 1.2
@@ -5,3 +5,9 @@
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;
+}
More information about the xcb-commit
mailing list