Preload atoms using template haskell

3 files changed, 89 insertions, 45 deletions

diff --git a/lib/Phi/X11.hs b/lib/Phi/X11.hs
index 53fed21..2645ac2 100644
--- a/lib/Phi/X11.hs
+++ b/lib/Phi/X11.hs
@@ -18,12 +18,12 @@ import Control.Monad.Reader
 import Control.Monad.Trans
 
 import qualified Phi.Panel as Panel
+import Phi.X11.Atoms
 
 data XConfig = XConfig { phiXScreenInfo :: Display -> IO [Rectangle]
                        }
 
-data PhiState = PhiState { phiDisplay    :: Display
-                         , phiRootPixmap :: Pixmap
+data PhiState = PhiState { phiRootPixmap :: Pixmap
                          , phiPanels     :: [PanelState]
                          }
 
@@ -35,6 +35,8 @@ data PanelState = PanelState { panelWindow     :: Window
 
 data PhiConfig = PhiConfig { phiPanelConfig :: Panel.PanelConfig
                            , phiXConfig     :: XConfig
+                           , phiDisplay     :: Display
+                           , phiAtoms       :: Atoms
                            }
 
 newtype PhiReader a = PhiReader (ReaderT PhiConfig IO a)
@@ -64,9 +66,10 @@ defaultXConfig = XConfig { phiXScreenInfo = getScreenInfo
 initPhi :: XConfig -> Panel.PanelConfig -> IO ()
 initPhi xconfig config = do
   disp <- openDisplay []
+  atoms <- initAtoms disp
   selectInput disp (defaultRootWindow disp) $ propertyChangeMask.|.structureNotifyMask
   
-  runPhi PhiConfig { phiXConfig = xconfig, phiPanelConfig = config } PhiState { phiDisplay = disp, phiRootPixmap = 0, phiPanels = [] } $ do
+  runPhi PhiConfig { phiXConfig = xconfig, phiPanelConfig = config, phiDisplay = disp, phiAtoms = atoms } PhiState { phiRootPixmap = 0, phiPanels = [] } $ do
     updateRootPixmap
     
     screens <- liftIO $ phiXScreenInfo xconfig disp
@@ -77,21 +80,23 @@ initPhi xconfig config = do
     
     modify $ \state -> state { phiPanels = panels }
     
+    updatePanels True
+
     liftIOContToPhi allocaXEvent $ \xevent -> do
       forever $ do
         liftIO $ nextEvent disp xevent
         event <- liftIO $ getEvent xevent
         
         case event of
-          ExposeEvent {} -> updatePanels
+          ExposeEvent {} -> updatePanels False
           PropertyEvent {} -> handlePropertyUpdate event
           _ -> return ()
   return ()
 
 
-updatePanels :: Phi ()
-updatePanels = do
-  disp <- gets phiDisplay
+updatePanels :: Bool -> Phi ()
+updatePanels redraw = do
+  disp <- asks phiDisplay
   rootPixmap <- gets phiRootPixmap
   panels <- gets phiPanels
   forM_ panels $ \panel -> liftIO $ withRectangle (panelArea panel) (copyArea disp rootPixmap (panelWindow panel) (panelGC panel)) 0 0
@@ -99,32 +104,30 @@ updatePanels = do
 
 handlePropertyUpdate :: Event -> Phi ()
 handlePropertyUpdate PropertyEvent { ev_atom = atom } = do
-  disp <- gets phiDisplay
+  atoms <- asks phiAtoms
   panels <- gets phiPanels
-  atom_XROOTPMAP_ID <- liftIO $ internAtom disp "_XROOTPMAP_ID" False
-  atom_XROOTMAP_ID <- liftIO $ internAtom disp "_XROOTMAP_ID" False
 
-  when (atom == atom_XROOTPMAP_ID || atom == atom_XROOTMAP_ID) $ do
+  when (atom == atom_XROOTPMAP_ID atoms || atom == atom_XROOTMAP_ID atoms) $ do
     updateRootPixmap
-    updatePanels
+    updatePanels True
   
 
 updateRootPixmap :: Phi ()
 updateRootPixmap = do
-  disp <- gets phiDisplay
+  disp <- asks phiDisplay
+  atoms <- asks phiAtoms
   let screen = defaultScreen disp
       rootwin = defaultRootWindow disp
-  atom_XROOTPMAP_ID <- liftIO $ internAtom disp "_XROOTPMAP_ID" False
-  atom_XROOTMAP_ID <- liftIO $ internAtom disp "_XROOTMAP_ID" False
-  pixmap <- liftM (fromMaybe 0 . listToMaybe . join . catMaybes) $ forM [atom_XROOTPMAP_ID, atom_XROOTMAP_ID] $ \atom -> liftIO $ rawGetWindowProperty 32 disp atom rootwin
+  pixmap <- liftM (fromMaybe 0 . listToMaybe . join . catMaybes) $ forM [atom_XROOTPMAP_ID atoms, atom_XROOTMAP_ID atoms] $
+            \atom -> liftIO $ rawGetWindowProperty 32 disp atom rootwin
   modify $ \state -> state { phiRootPixmap = pixmap }
 
 
 createPanel :: Rectangle -> Phi PanelState
 createPanel screen = do
   config <- asks phiPanelConfig
+  disp <- asks phiDisplay
   let rect = panelBounds config screen
-  disp <- gets phiDisplay
   win <- createPanelWindow rect
   gc <- liftIO $ createGC disp win
   return PanelState { panelWindow = win, panelGC = gc, panelArea = rect, panelScreenArea = screen }
@@ -132,7 +135,7 @@ createPanel screen = do
 
 createPanelWindow :: Rectangle -> Phi Window
 createPanelWindow rect = do
-  disp <- gets phiDisplay
+  disp <- asks phiDisplay
   let screen = defaultScreen disp
       depth = defaultDepth disp screen
       visual = defaultVisual disp screen
@@ -150,28 +153,17 @@ createPanelWindow rect = do
 
 setPanelProperties :: PanelState -> Phi ()
 setPanelProperties panel = do
-  disp <- gets phiDisplay
+  disp <- asks phiDisplay
+  atoms <- asks phiAtoms
   liftIO $ do
-    atom_NET_WM_WINDOW_TYPE <- internAtom disp "_NET_WM_WINDOW_TYPE" False
-    atom_NET_WM_WINDOW_TYPE_DOCK <- internAtom disp "_NET_WM_WINDOW_TYPE_DOCK" False
-    
-    atom_NET_WM_DESKTOP <- internAtom disp "_NET_WM_DESKTOP" False
-    
-    atom_NET_WM_STATE <- internAtom disp "_NET_WM_STATE" False
-    atom_NET_WM_STATE_SKIP_PAGER <- internAtom disp "_NET_WM_STATE_SKIP_PAGER" False
-    atom_NET_WM_STATE_SKIP_TASKBAR <- internAtom disp "_NET_WM_STATE_SKIP_TASKBAR" False
-    atom_NET_WM_STATE_STICKY <- internAtom disp "_NET_WM_STATE_STICKY" False
-    atom_NET_WM_STATE_BELOW <- internAtom disp "_NET_WM_STATE_BELOW" False
-    
-    atom_MOTIF_WM_HINTS <- internAtom disp "_MOTIF_WM_HINTS" False
-    
     storeName disp (panelWindow panel) "Phi"
-    changeProperty32 disp (panelWindow panel) atom_NET_WM_WINDOW_TYPE aTOM propModeReplace [fromIntegral atom_NET_WM_WINDOW_TYPE_DOCK]
-    changeProperty32 disp (panelWindow panel) atom_NET_WM_DESKTOP cARDINAL propModeReplace [0xFFFFFFFF]
-    changeProperty32 disp (panelWindow panel) atom_NET_WM_STATE aTOM propModeReplace [ fromIntegral atom_NET_WM_STATE_SKIP_PAGER
-                                                                                     , fromIntegral atom_NET_WM_STATE_SKIP_TASKBAR
-                                                                                     , fromIntegral atom_NET_WM_STATE_STICKY
-                                                                                     , fromIntegral atom_NET_WM_STATE_BELOW]
+    changeProperty32 disp (panelWindow panel) (atom_NET_WM_WINDOW_TYPE atoms) aTOM propModeReplace [fromIntegral (atom_NET_WM_WINDOW_TYPE_DOCK atoms)]
+    changeProperty32 disp (panelWindow panel) (atom_NET_WM_DESKTOP atoms) cARDINAL propModeReplace [0xFFFFFFFF]
+    changeProperty32 disp (panelWindow panel) (atom_NET_WM_STATE atoms) aTOM propModeReplace [ fromIntegral (atom_NET_WM_STATE_SKIP_PAGER atoms)
+                                                                                             , fromIntegral (atom_NET_WM_STATE_SKIP_TASKBAR atoms)
+                                                                                             , fromIntegral (atom_NET_WM_STATE_STICKY atoms)
+                                                                                             , fromIntegral (atom_NET_WM_STATE_BELOW atoms)
+                                                                                             ]
     setWMHints disp (panelWindow panel) WMHints { wmh_flags = fromIntegral inputHintBit
                                                 , wmh_input = False
                                                 , wmh_initial_state = 0
@@ -182,13 +174,14 @@ setPanelProperties panel = do
                                                 , wmh_icon_mask = 0
                                                 , wmh_window_group = 0
                                                 }
-    changeProperty32 disp (panelWindow panel) atom_MOTIF_WM_HINTS atom_MOTIF_WM_HINTS propModeReplace [ 2, 0, 0, 0, 0 ]
+    changeProperty32 disp (panelWindow panel) (atom_MOTIF_WM_HINTS atoms) (atom_MOTIF_WM_HINTS atoms) propModeReplace [ 2, 0, 0, 0, 0 ]
   setStruts panel
 
 
 setStruts :: PanelState -> Phi ()
 setStruts panel = do
-  disp <- gets phiDisplay
+  atoms <- asks phiAtoms
+  disp <- asks phiDisplay
   config <- asks phiPanelConfig
   let rootwin = defaultRootWindow disp
       position = Panel.panelPosition config
@@ -212,11 +205,8 @@ setStruts panel = do
               Panel.Bottom -> makeBottomStruts
   
   liftIO $ do
-    atom_NET_WM_STRUT <- internAtom disp "_NET_WM_STRUT" False
-    atom_NET_WM_STRUT_PARTIAL <- internAtom disp "_NET_WM_STRUT_PARTIAL" False
-    
-    changeProperty32 disp (panelWindow panel) atom_NET_WM_STRUT cARDINAL propModeReplace $ take 4 struts
-    changeProperty32 disp (panelWindow panel) atom_NET_WM_STRUT_PARTIAL cARDINAL propModeReplace struts
+    changeProperty32 disp (panelWindow panel) (atom_NET_WM_STRUT atoms) cARDINAL propModeReplace $ take 4 struts
+    changeProperty32 disp (panelWindow panel) (atom_NET_WM_STRUT_PARTIAL atoms) cARDINAL propModeReplace struts
 
 
 panelBounds :: Panel.PanelConfig -> Rectangle -> Rectangle
diff --git a/lib/Phi/X11/AtomList.hs b/lib/Phi/X11/AtomList.hs
new file mode 100644
index 0000000..60cd0c5
--- /dev/null
+++ b/lib/Phi/X11/AtomList.hs
@@ -0,0 +1,18 @@
+module Phi.X11.AtomList ( atoms
+                        ) where
+
+atoms = [ "_XROOTPMAP_ID"
+        , "_XROOTMAP_ID"
+        , "_NET_WM_WINDOW_TYPE"
+        , "_NET_WM_WINDOW_TYPE_DOCK"
+        , "_NET_WM_DESKTOP"
+        , "_NET_WM_STATE"
+        , "_NET_WM_STATE_SKIP_PAGER"
+        , "_NET_WM_STATE_SKIP_TASKBAR"
+        , "_NET_WM_STATE_STICKY"
+        , "_NET_WM_STATE_BELOW"
+        , "_MOTIF_WM_HINTS"
+        , "_NET_WM_STRUT"
+        , "_NET_WM_STRUT_PARTIAL"
+        ]
+
diff --git a/lib/Phi/X11/Atoms.hs b/lib/Phi/X11/Atoms.hs
new file mode 100644
index 0000000..a2708dd
--- /dev/null
+++ b/lib/Phi/X11/Atoms.hs
@@ -0,0 +1,36 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+module Phi.X11.Atoms ( Atoms(..)
+                     , initAtoms
+                     ) where
+
+import Control.Monad
+import Language.Haskell.TH
+import Graphics.X11
+
+import Phi.X11.AtomList
+
+
+$(do
+     let atomsName = mkName "Atoms"
+         atomNames = map (\atom -> (atom, mkName ("atom" ++ atom))) atoms
+         fields = map (\(_, name) -> (name, IsStrict, ConT ''Atom)) atomNames
+     return [DataD [] atomsName [] [RecC atomsName fields] []]
+ )
+
+initAtoms :: Display -> IO Atoms
+initAtoms display =
+  $(do
+       let atomsName = mkName "Atoms"
+       atomNames <- mapM (\atom -> do
+                             varName <- newName ('_':atom)
+                             return (atom, mkName ("atom" ++ atom), varName)
+                         ) atoms
+       atomInitializers <- forM atomNames $
+                           \(atom, _, varName) -> liftM (BindS (VarP varName)) [| internAtom display atom False |]
+           
+       let atomFieldExps = map (\(_, atomName, varName) -> (atomName, VarE varName)) atomNames
+           atomsContruction = NoBindS $ AppE (VarE 'return) $ RecConE atomsName atomFieldExps
+
+       return $ DoE $ atomInitializers ++ [atomsContruction]
+   )