Converted core to XHB/XCB

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