summaryrefslogtreecommitdiffstats
path: root/lib/Phi/X11
diff options
context:
space:
mode:
authorMatthias Schiffer <mschiffer@universe-factory.net>2011-07-12 19:09:05 +0200
committerMatthias Schiffer <mschiffer@universe-factory.net>2011-07-12 19:09:05 +0200
commit982bcffcfeb074b4c1beff64ca7361a9a66ed273 (patch)
tree176299794f94b55ed0d8c7b83ed2c54ef468b129 /lib/Phi/X11
parent19378fdcf11af2ef78d1b7e6cbda06952bb4e692 (diff)
downloadphi-982bcffcfeb074b4c1beff64ca7361a9a66ed273.tar
phi-982bcffcfeb074b4c1beff64ca7361a9a66ed273.zip
Preload atoms using template haskell
Diffstat (limited to 'lib/Phi/X11')
-rw-r--r--lib/Phi/X11/AtomList.hs18
-rw-r--r--lib/Phi/X11/Atoms.hs36
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]
+ )