neocturne/phi
Archived
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Some initial systray code

Browse source
This commit is contained in:
Matthias Schiffer 2011-07-17 19:20:19 +02:00
parent b66d6690d8
commit 0fefcaa35f
10 changed files with 213 additions and 32 deletions
Download patch file Download diff file Expand all files Collapse all files

19
lib/Phi/X11/AtomList.hs
View file

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

13
lib/Phi/X11/Atoms.hs
View file

@ -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"