Preload atoms using template haskell

2 files changed, 54 insertions, 0 deletions

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]
+   )