summaryrefslogtreecommitdiffstats
path: root/lib
diff options
context:
space:
mode:
Diffstat (limited to 'lib')
-rw-r--r--lib/Phi/X11.hs80
-rw-r--r--lib/Phi/X11/AtomList.hs18
-rw-r--r--lib/Phi/X11/Atoms.hs36
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]
+ )