summaryrefslogtreecommitdiffstats
path: root/lib/Phi/X11
diff options
context:
space:
mode:
Diffstat (limited to 'lib/Phi/X11')
-rw-r--r--lib/Phi/X11/AtomList.hs14
-rw-r--r--lib/Phi/X11/Atoms.hs32
-rw-r--r--lib/Phi/X11/Util.hs89
3 files changed, 121 insertions, 14 deletions
diff --git a/lib/Phi/X11/AtomList.hs b/lib/Phi/X11/AtomList.hs
index dbd6fc5..d05bad2 100644
--- a/lib/Phi/X11/AtomList.hs
+++ b/lib/Phi/X11/AtomList.hs
@@ -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|])
] \ No newline at end of file
diff --git a/lib/Phi/X11/Atoms.hs b/lib/Phi/X11/Atoms.hs
index acbae64..0a8f66a 100644
--- a/lib/Phi/X11/Atoms.hs
+++ b/lib/Phi/X11/Atoms.hs
@@ -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]
)
diff --git a/lib/Phi/X11/Util.hs b/lib/Phi/X11/Util.hs
new file mode 100644
index 0000000..cadceeb
--- /dev/null
+++ b/lib/Phi/X11/Util.hs
@@ -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 \ No newline at end of file
generated by cgit v1.2.3 (git 2.25.1) at 2024-05-17 05:47:04 +0200