262 lines
10 KiB
Haskell
262 lines
10 KiB
Haskell
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
|
|
|
module Phi.X11 ( XConfig(..)
|
|
, defaultXConfig
|
|
, initPhi
|
|
) where
|
|
|
|
import Graphics.X11.Xlib
|
|
import Graphics.X11.Xlib.Extras
|
|
import Graphics.X11.Xinerama
|
|
|
|
import Graphics.Rendering.Cairo
|
|
|
|
import Control.Monad
|
|
import Data.Maybe
|
|
import Data.Bits
|
|
|
|
import Control.Monad.State
|
|
import Control.Monad.Reader
|
|
import Control.Monad.Trans
|
|
|
|
import qualified Phi.Panel as Panel
|
|
import Phi.X11.Atoms
|
|
import qualified Phi.Bindings.Util as Util
|
|
|
|
data XConfig = XConfig { phiXScreenInfo :: Display -> IO [Rectangle]
|
|
}
|
|
|
|
data PhiState = PhiState { phiRootPixmap :: Pixmap
|
|
, phiPanels :: [PanelState]
|
|
}
|
|
|
|
data PanelState = PanelState { panelWindow :: Window
|
|
, panelGC :: GC
|
|
, panelPixmap :: Pixmap
|
|
, panelSurface :: Surface
|
|
, panelArea :: Rectangle
|
|
, panelScreenArea :: Rectangle
|
|
}
|
|
|
|
data PhiConfig = PhiConfig { phiPanelConfig :: Panel.PanelConfig
|
|
, phiXConfig :: XConfig
|
|
, phiDisplay :: Display
|
|
, phiAtoms :: Atoms
|
|
}
|
|
|
|
newtype PhiReader a = PhiReader (ReaderT PhiConfig IO a)
|
|
deriving (Monad, MonadReader PhiConfig, MonadIO)
|
|
|
|
runPhiReader :: PhiConfig -> PhiReader a -> IO a
|
|
runPhiReader config (PhiReader a) = runReaderT a config
|
|
|
|
newtype Phi a = Phi (StateT PhiState PhiReader a)
|
|
deriving (Monad, MonadState PhiState, MonadReader PhiConfig, MonadIO)
|
|
|
|
runPhi :: PhiConfig -> PhiState -> Phi a -> IO (a, PhiState)
|
|
runPhi config st (Phi a) = runPhiReader config $ runStateT a st
|
|
|
|
liftIOContToPhi :: ((a -> IO (b, PhiState)) -> IO (b, PhiState)) -> (a -> Phi b) -> Phi b
|
|
liftIOContToPhi f c = do
|
|
config <- ask
|
|
state <- get
|
|
(a, state') <- liftIO $ f $ runPhi config state . c
|
|
put state'
|
|
return a
|
|
|
|
|
|
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, phiDisplay = disp, phiAtoms = atoms } PhiState { phiRootPixmap = 0, phiPanels = [] } $ do
|
|
updateRootPixmap
|
|
|
|
screens <- liftIO $ phiXScreenInfo xconfig disp
|
|
panels <- mapM createPanel screens
|
|
forM_ panels $ \panel -> do
|
|
setPanelProperties panel
|
|
liftIO $ mapWindow disp (panelWindow panel)
|
|
|
|
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 False
|
|
PropertyEvent {} -> handlePropertyUpdate event
|
|
_ -> return ()
|
|
return ()
|
|
|
|
|
|
updatePanels :: Bool -> Phi ()
|
|
updatePanels redraw = do
|
|
disp <- asks phiDisplay
|
|
panelConfig <- asks phiPanelConfig
|
|
|
|
rootPixmap <- gets phiRootPixmap
|
|
panels <- gets phiPanels
|
|
|
|
forM_ panels $ \panel -> do
|
|
when redraw $ do
|
|
let surface = panelSurface panel
|
|
area = panelArea panel
|
|
-- draw background
|
|
liftIO $ withRectangle (panelArea panel) (copyArea disp rootPixmap (panelPixmap panel) (panelGC panel)) 0 0
|
|
surfaceMarkDirty surface
|
|
|
|
renderWith surface $ do
|
|
save
|
|
Panel.render (Panel.panelContent panelConfig) (fromIntegral $ rect_width area) (fromIntegral $ rect_height area)
|
|
restore
|
|
|
|
surfaceFlush surface
|
|
|
|
-- copy pixmap to window
|
|
liftIO $ withDimension (panelArea panel) (copyArea disp (panelPixmap panel) (panelWindow panel) (panelGC panel) 0 0) 0 0
|
|
|
|
|
|
handlePropertyUpdate :: Event -> Phi ()
|
|
handlePropertyUpdate PropertyEvent { ev_atom = atom } = do
|
|
atoms <- asks phiAtoms
|
|
panels <- gets phiPanels
|
|
|
|
when (atom == atom_XROOTPMAP_ID atoms || atom == atom_XROOTMAP_ID atoms) $ do
|
|
updateRootPixmap
|
|
updatePanels True
|
|
|
|
|
|
updateRootPixmap :: Phi ()
|
|
updateRootPixmap = do
|
|
disp <- asks phiDisplay
|
|
atoms <- asks phiAtoms
|
|
let screen = defaultScreen disp
|
|
rootwin = defaultRootWindow disp
|
|
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 screenRect = do
|
|
config <- asks phiPanelConfig
|
|
disp <- asks phiDisplay
|
|
let rect = panelBounds config screenRect
|
|
|
|
win <- createPanelWindow rect
|
|
gc <- liftIO $ createGC disp win
|
|
|
|
let screen = defaultScreen disp
|
|
depth = defaultDepth disp screen
|
|
visual = defaultVisual disp screen
|
|
|
|
pixmap <- liftIO $ withDimension rect (createPixmap disp win) depth
|
|
surface <- liftIO $ withDimension rect $ Util.createXlibSurface disp pixmap visual
|
|
|
|
return PanelState { panelWindow = win, panelGC = gc, panelPixmap = pixmap, panelSurface = surface, panelArea = rect, panelScreenArea = screenRect }
|
|
|
|
|
|
createPanelWindow :: Rectangle -> Phi Window
|
|
createPanelWindow rect = do
|
|
disp <- asks phiDisplay
|
|
let screen = defaultScreen disp
|
|
depth = defaultDepth disp screen
|
|
visual = defaultVisual disp screen
|
|
colormap = defaultColormap disp screen
|
|
rootwin = defaultRootWindow disp
|
|
mask = cWEventMask.|.cWColormap.|.cWBackPixel.|.cWBorderPixel
|
|
|
|
liftIO $ allocaSetWindowAttributes $ \attr -> do
|
|
set_colormap attr colormap
|
|
set_background_pixel attr 0
|
|
set_border_pixel attr 0
|
|
set_event_mask attr exposureMask
|
|
withRectangle rect (createWindow disp rootwin) 0 depth inputOutput visual mask attr
|
|
|
|
|
|
setPanelProperties :: PanelState -> Phi ()
|
|
setPanelProperties panel = do
|
|
disp <- asks phiDisplay
|
|
atoms <- asks phiAtoms
|
|
liftIO $ do
|
|
storeName disp (panelWindow panel) "Phi"
|
|
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
|
|
, wmh_icon_pixmap = 0
|
|
, wmh_icon_window = 0
|
|
, wmh_icon_x = 0
|
|
, wmh_icon_y = 0
|
|
, wmh_icon_mask = 0
|
|
, wmh_window_group = 0
|
|
}
|
|
changeProperty32 disp (panelWindow panel) (atom_MOTIF_WM_HINTS atoms) (atom_MOTIF_WM_HINTS atoms) propModeReplace [ 2, 0, 0, 0, 0 ]
|
|
|
|
Util.setClassHint disp (panelWindow panel) ClassHint { resName = "phi", resClass = "Phi" }
|
|
|
|
setStruts panel
|
|
|
|
|
|
setStruts :: PanelState -> Phi ()
|
|
setStruts panel = do
|
|
atoms <- asks phiAtoms
|
|
disp <- asks phiDisplay
|
|
config <- asks phiPanelConfig
|
|
let rootwin = defaultRootWindow disp
|
|
position = Panel.panelPosition config
|
|
area = panelArea panel
|
|
(_, _, _, _, rootHeight, _, _) <- liftIO $ getGeometry disp rootwin
|
|
|
|
let struts = [makeStruts i | i <- [0..11]]
|
|
where
|
|
makeTopStruts 2 = (fromIntegral $ rect_y area) + (fromIntegral $ rect_height area)
|
|
makeTopStruts 8 = (fromIntegral $ rect_x area)
|
|
makeTopStruts 9 = (fromIntegral $ rect_x area) + (fromIntegral $ rect_width area) - 1
|
|
makeTopStruts _ = 0
|
|
|
|
makeBottomStruts 3 = (fromIntegral rootHeight) - (fromIntegral $ rect_y area)
|
|
makeBottomStruts 10 = (fromIntegral $ rect_x area)
|
|
makeBottomStruts 11 = (fromIntegral $ rect_x area) + (fromIntegral $ rect_width area) - 1
|
|
makeBottomStruts _ = 0
|
|
|
|
makeStruts = case position of
|
|
Panel.Top -> makeTopStruts
|
|
Panel.Bottom -> makeBottomStruts
|
|
|
|
liftIO $ do
|
|
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
|
|
panelBounds config screenBounds = case Panel.panelPosition config of
|
|
Panel.Top -> screenBounds { rect_height = fromIntegral $ Panel.panelSize config }
|
|
Panel.Bottom -> screenBounds { rect_height = fromIntegral $ Panel.panelSize config,
|
|
rect_y = (rect_y screenBounds) + (fromIntegral $ rect_height screenBounds) - (fromIntegral $ Panel.panelSize config) }
|
|
|
|
withRectangle :: (Num x, Num y, Num w, Num h) => Rectangle -> (x -> y -> w -> h -> a) -> a
|
|
withRectangle r = withDimension r . withPosition r
|
|
|
|
withPosition :: (Num x, Num y) => Rectangle -> (x -> y -> a) -> a
|
|
withPosition r f = f (fromIntegral $ rect_x r) (fromIntegral $ rect_y r)
|
|
|
|
withDimension :: (Num w, Num h) => Rectangle -> (w -> h -> a) -> a
|
|
withDimension r f = f (fromIntegral $ rect_width r) (fromIntegral $ rect_height r)
|