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

Preload atoms using template haskell

Browse source
This commit is contained in:
Matthias Schiffer 2011-07-12 19:09:05 +02:00
parent 19378fdcf1
commit 982bcffcfe
4 changed files with 91 additions and 46 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

80
lib/Phi/X11.hs
View file

@ -18,12 +18,12 @@ import Control.Monad.Reader
import Control.Monad.Trans import Control.Monad.Trans
import qualified Phi.Panel as Panel import qualified Phi.Panel as Panel
import Phi.X11.Atoms
data XConfig = XConfig { phiXScreenInfo :: Display -> IO [Rectangle] data XConfig = XConfig { phiXScreenInfo :: Display -> IO [Rectangle]
} }
data PhiState = PhiState { phiDisplay :: Display data PhiState = PhiState { phiRootPixmap :: Pixmap
, phiRootPixmap :: Pixmap
, phiPanels :: [PanelState] , phiPanels :: [PanelState]
} }
@ -35,6 +35,8 @@ data PanelState = PanelState { panelWindow :: Window
data PhiConfig = PhiConfig { phiPanelConfig :: Panel.PanelConfig data PhiConfig = PhiConfig { phiPanelConfig :: Panel.PanelConfig
, phiXConfig :: XConfig , phiXConfig :: XConfig
, phiDisplay :: Display
, phiAtoms :: Atoms
} }
newtype PhiReader a = PhiReader (ReaderT PhiConfig IO a) newtype PhiReader a = PhiReader (ReaderT PhiConfig IO a)
@ -64,9 +66,10 @@ defaultXConfig = XConfig { phiXScreenInfo = getScreenInfo
initPhi :: XConfig -> Panel.PanelConfig -> IO () initPhi :: XConfig -> Panel.PanelConfig -> IO ()
initPhi xconfig config = do initPhi xconfig config = do
disp <- openDisplay [] disp <- openDisplay []
atoms <- initAtoms disp
selectInput disp (defaultRootWindow disp) $ propertyChangeMask.|.structureNotifyMask 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 updateRootPixmap
screens <- liftIO $ phiXScreenInfo xconfig disp screens <- liftIO $ phiXScreenInfo xconfig disp
@ -77,21 +80,23 @@ initPhi xconfig config = do
modify $ \state -> state { phiPanels = panels } modify $ \state -> state { phiPanels = panels }
updatePanels True
liftIOContToPhi allocaXEvent $ \xevent -> do liftIOContToPhi allocaXEvent $ \xevent -> do
forever $ do forever $ do
liftIO $ nextEvent disp xevent liftIO $ nextEvent disp xevent
event <- liftIO $ getEvent xevent event <- liftIO $ getEvent xevent
case event of case event of
ExposeEvent {} -> updatePanels ExposeEvent {} -> updatePanels False
PropertyEvent {} -> handlePropertyUpdate event PropertyEvent {} -> handlePropertyUpdate event
_ -> return () _ -> return ()
return () return ()
updatePanels :: Phi () updatePanels :: Bool -> Phi ()
updatePanels = do updatePanels redraw = do
disp <- gets phiDisplay disp <- asks phiDisplay
rootPixmap <- gets phiRootPixmap rootPixmap <- gets phiRootPixmap
panels <- gets phiPanels panels <- gets phiPanels
forM_ panels $ \panel -> liftIO $ withRectangle (panelArea panel) (copyArea disp rootPixmap (panelWindow panel) (panelGC panel)) 0 0 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 :: Event -> Phi ()
handlePropertyUpdate PropertyEvent { ev_atom = atom } = do handlePropertyUpdate PropertyEvent { ev_atom = atom } = do
disp <- gets phiDisplay atoms <- asks phiAtoms
panels <- gets phiPanels 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 updateRootPixmap
updatePanels updatePanels True
updateRootPixmap :: Phi () updateRootPixmap :: Phi ()
updateRootPixmap = do updateRootPixmap = do
disp <- gets phiDisplay disp <- asks phiDisplay
atoms <- asks phiAtoms
let screen = defaultScreen disp let screen = defaultScreen disp
rootwin = defaultRootWindow disp rootwin = defaultRootWindow disp
atom_XROOTPMAP_ID <- liftIO $ internAtom disp "_XROOTPMAP_ID" False pixmap <- liftM (fromMaybe 0 . listToMaybe . join . catMaybes) $ forM [atom_XROOTPMAP_ID atoms, atom_XROOTMAP_ID atoms] $
atom_XROOTMAP_ID <- liftIO $ internAtom disp "_XROOTMAP_ID" False \atom -> liftIO $ rawGetWindowProperty 32 disp atom rootwin
pixmap <- liftM (fromMaybe 0 . listToMaybe . join . catMaybes) $ forM [atom_XROOTPMAP_ID, atom_XROOTMAP_ID] $ \atom -> liftIO $ rawGetWindowProperty 32 disp atom rootwin
modify $ \state -> state { phiRootPixmap = pixmap } modify $ \state -> state { phiRootPixmap = pixmap }
createPanel :: Rectangle -> Phi PanelState createPanel :: Rectangle -> Phi PanelState
createPanel screen = do createPanel screen = do
config <- asks phiPanelConfig config <- asks phiPanelConfig
disp <- asks phiDisplay
let rect = panelBounds config screen let rect = panelBounds config screen
disp <- gets phiDisplay
win <- createPanelWindow rect win <- createPanelWindow rect
gc <- liftIO $ createGC disp win gc <- liftIO $ createGC disp win
return PanelState { panelWindow = win, panelGC = gc, panelArea = rect, panelScreenArea = screen } return PanelState { panelWindow = win, panelGC = gc, panelArea = rect, panelScreenArea = screen }
@ -132,7 +135,7 @@ createPanel screen = do
createPanelWindow :: Rectangle -> Phi Window createPanelWindow :: Rectangle -> Phi Window
createPanelWindow rect = do createPanelWindow rect = do
disp <- gets phiDisplay disp <- asks phiDisplay
let screen = defaultScreen disp let screen = defaultScreen disp
depth = defaultDepth disp screen depth = defaultDepth disp screen
visual = defaultVisual disp screen visual = defaultVisual disp screen
@ -150,28 +153,17 @@ createPanelWindow rect = do
setPanelProperties :: PanelState -> Phi () setPanelProperties :: PanelState -> Phi ()
setPanelProperties panel = do setPanelProperties panel = do
disp <- gets phiDisplay disp <- asks phiDisplay
atoms <- asks phiAtoms
liftIO $ do 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" 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_WINDOW_TYPE atoms) aTOM propModeReplace [fromIntegral (atom_NET_WM_WINDOW_TYPE_DOCK atoms)]
changeProperty32 disp (panelWindow panel) atom_NET_WM_DESKTOP cARDINAL propModeReplace [0xFFFFFFFF] changeProperty32 disp (panelWindow panel) (atom_NET_WM_DESKTOP atoms) cARDINAL propModeReplace [0xFFFFFFFF]
changeProperty32 disp (panelWindow panel) atom_NET_WM_STATE aTOM propModeReplace [ fromIntegral atom_NET_WM_STATE_SKIP_PAGER 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 , fromIntegral (atom_NET_WM_STATE_SKIP_TASKBAR atoms)
, fromIntegral atom_NET_WM_STATE_STICKY , fromIntegral (atom_NET_WM_STATE_STICKY atoms)
, fromIntegral atom_NET_WM_STATE_BELOW] , fromIntegral (atom_NET_WM_STATE_BELOW atoms)
]
setWMHints disp (panelWindow panel) WMHints { wmh_flags = fromIntegral inputHintBit setWMHints disp (panelWindow panel) WMHints { wmh_flags = fromIntegral inputHintBit
, wmh_input = False , wmh_input = False
, wmh_initial_state = 0 , wmh_initial_state = 0
@ -182,13 +174,14 @@ setPanelProperties panel = do
, wmh_icon_mask = 0 , wmh_icon_mask = 0
, wmh_window_group = 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 panel
setStruts :: PanelState -> Phi () setStruts :: PanelState -> Phi ()
setStruts panel = do setStruts panel = do
disp <- gets phiDisplay atoms <- asks phiAtoms
disp <- asks phiDisplay
config <- asks phiPanelConfig config <- asks phiPanelConfig
let rootwin = defaultRootWindow disp let rootwin = defaultRootWindow disp
position = Panel.panelPosition config position = Panel.panelPosition config
@ -212,11 +205,8 @@ setStruts panel = do
Panel.Bottom -> makeBottomStruts Panel.Bottom -> makeBottomStruts
liftIO $ do liftIO $ do
atom_NET_WM_STRUT <- internAtom disp "_NET_WM_STRUT" False changeProperty32 disp (panelWindow panel) (atom_NET_WM_STRUT atoms) cARDINAL propModeReplace $ take 4 struts
atom_NET_WM_STRUT_PARTIAL <- internAtom disp "_NET_WM_STRUT_PARTIAL" False changeProperty32 disp (panelWindow panel) (atom_NET_WM_STRUT_PARTIAL atoms) cARDINAL propModeReplace struts
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
panelBounds :: Panel.PanelConfig -> Rectangle -> Rectangle panelBounds :: Panel.PanelConfig -> Rectangle -> Rectangle

18
lib/Phi/X11/AtomList.hs Normal file
View file

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

36
lib/Phi/X11/Atoms.hs Normal file
View file

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

3
phi.cabal
View file

@ -11,8 +11,9 @@ maintainer: mschiffer@universe-factory.net
build-type: Simple build-type: Simple
library library
build-depends: base >= 4, mtl, cairo, X11 build-depends: base >= 4, template-haskell, mtl, cairo, X11
exposed-modules: Phi.Panel, Phi.X11 exposed-modules: Phi.Panel, Phi.X11
other-modules: Phi.X11.Atoms, Phi.X11.AtomList
hs-source-dirs: lib hs-source-dirs: lib
executable Phi executable Phi