From 982bcffcfeb074b4c1beff64ca7361a9a66ed273 Mon Sep 17 00:00:00 2001
From: Matthias Schiffer <mschiffer@universe-factory.net>
Date: Tue, 12 Jul 2011 19:09:05 +0200
Subject: Preload atoms using template haskell

---
 lib/Phi/X11/AtomList.hs | 18 ++++++++++++++++++
 lib/Phi/X11/Atoms.hs    | 36 ++++++++++++++++++++++++++++++++++++
 2 files changed, 54 insertions(+)
 create mode 100644 lib/Phi/X11/AtomList.hs
 create mode 100644 lib/Phi/X11/Atoms.hs

(limited to 'lib/Phi/X11')

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]
+   )
-- 
cgit v1.2.3