Converted core to XHB/XCB
This commit is contained in:
parent
42d5f27d32
commit
15d9304e05
11 changed files with 433 additions and 368 deletions
|
|
@ -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|])
|
||||
]
|
||||
|
|
@ -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
89
lib/Phi/X11/Util.hs
Normal 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
|
||||
Reference in a new issue