Converted core to XHB/XCB

This commit is contained in:
Matthias Schiffer 2011-09-07 16:38:36 +02:00
parent 42d5f27d32
commit 15d9304e05
11 changed files with 433 additions and 368 deletions

View file

@ -6,10 +6,16 @@ module Phi.X11.AtomList ( atoms
import Language.Haskell.TH
import Graphics.X11.Xlib
import Graphics.XHB
import Graphics.XHB.Connection.Open
atoms :: [String]
atoms = [ "UTF8_STRING"
atoms = [ "ATOM"
, "CARDINAL"
, "STRING"
, "UTF8_STRING"
, "WM_NAME"
, "WM_CLASS"
, "MANAGER"
, "_NET_WM_NAME"
, "_NET_WM_WINDOW_TYPE"
@ -43,7 +49,7 @@ atoms = [ "UTF8_STRING"
, "_XROOTMAP_ID"
]
-- the expression must have the type (Display -> String)
-- the expression must have the type (Connection -> String)
specialAtoms :: [(String, Q Exp)]
specialAtoms = [ ("_NET_SYSTEM_TRAY_SCREEN", [|("_NET_SYSTEM_TRAY_S" ++) . show . defaultScreen|])
specialAtoms = [ ("_NET_SYSTEM_TRAY_SCREEN", [|("_NET_SYSTEM_TRAY_S" ++) . show . screen . displayInfo|])
]

View file

@ -5,36 +5,48 @@ module Phi.X11.Atoms ( Atoms(..)
) where
import Control.Monad
import Data.Char
import Data.List
import Language.Haskell.TH
import Graphics.X11
import Graphics.XHB
import Graphics.XHB.Gen.Xproto
import Phi.X11.AtomList
$(let atomsName = mkName "Atoms"
atomNames = map (\atom -> (atom, mkName ("atom" ++ atom))) $ atoms ++ (map fst specialAtoms)
fields = map (\(_, name) -> (name, IsStrict, ConT ''Atom)) atomNames
fields = map (\(_, name) -> (name, IsStrict, ConT ''ATOM)) atomNames
in return [DataD [] atomsName [] [RecC atomsName fields] []]
)
initAtoms :: Display -> IO Atoms
initAtoms display =
initAtoms :: Connection -> IO Atoms
initAtoms conn =
$(do
normalAtomNames <- mapM (\atom -> do
receiptName <- newName ('_':atom)
varName <- newName ('_':atom)
return ([|const atom|], mkName ("atom" ++ atom), varName)
return ([|const atom|], mkName ("atom" ++ atom), receiptName, varName)
) atoms
specialAtomNames <- mapM (\(name, atomgen) -> do
receiptName <- newName ('_':name)
varName <- newName ('_':name)
return (atomgen, mkName ("atom" ++ name), varName)
return (atomgen, mkName ("atom" ++ name), receiptName, varName)
) specialAtoms
let atomNames = normalAtomNames ++ specialAtomNames
atomReceipts <- forM atomNames $
\(atomgen, _, receiptName, _) -> liftM (BindS (VarP receiptName))
[|let name = ($atomgen conn)
in internAtom conn $ MkInternAtom False (genericLength name) $ map (fromIntegral . ord) name|]
atomInitializers <- forM atomNames $
\(atomgen, _, varName) -> liftM (BindS (VarP varName)) [| internAtom display ($atomgen display) False |]
let atomFieldExps = map (\(_, atomName, varName) -> (atomName, VarE varName)) atomNames
\(_, _, receiptName, varName) -> liftM (BindS (VarP varName))
[|liftM (\(Right a) -> a) $ getReply $(return $ VarE receiptName)|]
let atomFieldExps = map (\(_, atomName, _, varName) -> (atomName, VarE varName)) atomNames
atomsName = mkName "Atoms"
atomsContruction = NoBindS $ AppE (VarE 'return) $ RecConE atomsName atomFieldExps
return $ DoE $ atomInitializers ++ [atomsContruction]
return $ DoE $ atomReceipts ++ atomInitializers ++ [atomsContruction]
)

89
lib/Phi/X11/Util.hs Normal file
View file

@ -0,0 +1,89 @@
module Phi.X11.Util ( getReply'
, changeProperty8
, changeProperty16
, changeProperty32
, getProperty8
, getProperty16
, getProperty32
, findVisualtype
) where
import Control.Monad
import Data.Int
import Data.List
import Data.Maybe
import Data.Word
import Foreign.Marshal.Array
import Foreign.Ptr
import Graphics.XHB
import Graphics.XHB.Gen.Xproto
import System.IO.Unsafe
getReply' :: String -> Receipt a -> IO a
getReply' m = getReply >=> return . fromRight
where
fromRight (Left _) = error m
fromRight (Right a) = a
castWord16to8 :: [Word16] -> [Word8]
castWord16to8 input = unsafePerformIO $
withArray input $ \ptr ->
peekArray (2 * length input) (castPtr ptr)
castWord32to8 :: [Word32] -> [Word8]
castWord32to8 input = unsafePerformIO $
withArray input $ \ptr ->
peekArray (4 * length input) (castPtr ptr)
castWord8to16 :: [Word8] -> [Word16]
castWord8to16 input = unsafePerformIO $
withArray input $ \ptr ->
peekArray (length input `div` 2) (castPtr ptr)
castWord8to32 :: [Word8] -> [Word32]
castWord8to32 input = unsafePerformIO $
withArray input $ \ptr ->
peekArray (length input `div` 4) (castPtr ptr)
changeProperty8 :: Connection -> PropMode -> WINDOW -> ATOM -> ATOM -> [Word8] -> IO ()
changeProperty8 conn mode win prop proptype propdata = changeProperty conn $ MkChangeProperty mode win prop proptype 8 (genericLength propdata) propdata
changeProperty16 :: Connection -> PropMode -> WINDOW -> ATOM -> ATOM -> [Word16] -> IO ()
changeProperty16 conn mode win prop proptype propdata = changeProperty conn $ MkChangeProperty mode win prop proptype 16 (genericLength propdata) (castWord16to8 propdata)
changeProperty32 :: Connection -> PropMode -> WINDOW -> ATOM -> ATOM -> [Word32] -> IO ()
changeProperty32 conn mode win prop proptype propdata = changeProperty conn $ MkChangeProperty mode win prop proptype 32 (genericLength propdata) (castWord32to8 propdata)
getProperty' :: Word8 -> Connection -> WINDOW -> ATOM -> IO (Maybe [Word8])
getProperty' format conn win prop = do
reply <- getProperty conn (MkGetProperty False win prop (fromXid xidNone) 0 4) >>= getReply
case reply of
Left _ -> return Nothing
Right (MkGetPropertyReply {format_GetPropertyReply = format'}) | format' /= format -> return Nothing
Right (MkGetPropertyReply {bytes_after_GetPropertyReply = 0, value_GetPropertyReply = value}) -> return $ Just value
Right (MkGetPropertyReply {bytes_after_GetPropertyReply = bytes_after}) -> do
reply' <- getProperty conn (MkGetProperty False win prop (fromXid xidNone) 0 (4+bytes_after)) >>= getReply
case reply' of
Left _ -> return Nothing
Right (MkGetPropertyReply {format_GetPropertyReply = format'}) | format' /= format -> return Nothing
Right (MkGetPropertyReply {value_GetPropertyReply = value}) -> return $ Just value
getProperty8 :: Connection -> WINDOW -> ATOM -> IO (Maybe [Word8])
getProperty8 = getProperty' 8
getProperty16 :: Connection -> WINDOW -> ATOM -> IO (Maybe [Word16])
getProperty16 conn win prop = getProperty' 16 conn win prop >>= return . fmap castWord8to16
getProperty32 :: Connection -> WINDOW -> ATOM -> IO (Maybe [Word32])
getProperty32 conn win prop = getProperty' 32 conn win prop >>= return . fmap castWord8to32
findVisualtype :: SCREEN -> VISUALID -> Maybe VISUALTYPE
findVisualtype screen id = listToMaybe . filter ((== id) . visual_id_VISUALTYPE) . join . map visuals_DEPTH . allowed_depths_SCREEN $ screen