Some initial systray code

2 files changed, 27 insertions, 5 deletions

diff --git a/lib/Phi/X11/AtomList.hs b/lib/Phi/X11/AtomList.hs
index d18be71..b91ae3e 100644
--- a/lib/Phi/X11/AtomList.hs
+++ b/lib/Phi/X11/AtomList.hs
@@ -1,8 +1,16 @@
+{-# LANGUAGE TemplateHaskell #-}
+
 module Phi.X11.AtomList ( atoms
+                        , specialAtoms
                         ) where
 
+import Language.Haskell.TH
+
+import Graphics.X11.Xlib
+
+atoms :: [String]
 atoms = [ "UTF8_STRING"
-        , "WM_NAME"
+        , "MANAGER"
         , "_NET_WM_NAME"
         , "_NET_WM_WINDOW_TYPE"
         , "_NET_WM_WINDOW_TYPE_NORMAL"
@@ -20,6 +28,10 @@ atoms = [ "UTF8_STRING"
         , "_NET_WM_STATE_BELOW"
         , "_NET_WM_STRUT"
         , "_NET_WM_STRUT_PARTIAL"
+        , "_NET_WM_PID"
+        , "_NET_SYSTEM_TRAY_OPCODE"
+        , "_NET_SYSTEM_TRAY_ORIENTATION"
+        , "_NET_SYSTEM_TRAY_VISUAL"
         , "_NET_ACTIVE_WINDOW"
         , "_NET_NUMBER_OF_DESKTOPS"
         , "_NET_CURRENT_DESKTOP"
@@ -28,3 +40,8 @@ atoms = [ "UTF8_STRING"
         , "_XROOTPMAP_ID"
         , "_XROOTMAP_ID"
         ]
+
+-- the expression must have the type (Display -> String)
+specialAtoms :: [(String, Q Exp)]
+specialAtoms = [ ("_NET_SYSTEM_TRAY_SCREEN", [|("_NET_SYSTEM_TRAY_S" ++) . show . defaultScreen|])
+               ]
\ No newline at end of file
diff --git a/lib/Phi/X11/Atoms.hs b/lib/Phi/X11/Atoms.hs
index 38f8f3c..acbae64 100644
--- a/lib/Phi/X11/Atoms.hs
+++ b/lib/Phi/X11/Atoms.hs
@@ -12,7 +12,7 @@ import Phi.X11.AtomList
 
 
 $(let atomsName = mkName "Atoms"
-      atomNames = map (\atom -> (atom, mkName ("atom" ++ atom))) atoms
+      atomNames = map (\atom -> (atom, mkName ("atom" ++ atom))) $ atoms ++ (map fst specialAtoms)
       fields = map (\(_, name) -> (name, IsStrict, ConT ''Atom)) atomNames
   in return [DataD [] atomsName [] [RecC atomsName fields] []]
  )
@@ -20,12 +20,17 @@ $(let atomsName = mkName "Atoms"
 initAtoms :: Display -> IO Atoms
 initAtoms display =
   $(do
-       atomNames <- mapM (\atom -> do
+       normalAtomNames <- mapM (\atom -> do
                              varName <- newName ('_':atom)
-                             return (atom, mkName ("atom" ++ atom), varName)
+                             return ([|const atom|], mkName ("atom" ++ atom), varName)
                          ) atoms
+       specialAtomNames <- mapM (\(name, atomgen) -> do
+                             varName <- newName ('_':name)
+                             return (atomgen, mkName ("atom" ++ name), varName)
+                         ) specialAtoms
+       let atomNames = normalAtomNames ++ specialAtomNames
        atomInitializers <- forM atomNames $
-                           \(atom, _, varName) -> liftM (BindS (VarP varName)) [| internAtom display atom False |]
+                           \(atomgen, _, varName) -> liftM (BindS (VarP varName)) [| internAtom display ($atomgen display) False |]
            
        let atomFieldExps = map (\(_, atomName, varName) -> (atomName, VarE varName)) atomNames
            atomsName = mkName "Atoms"