236 lines
9.5 KiB
Haskell
236 lines
9.5 KiB
Haskell
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
|
|
|
module Phi.X11 ( PanelPosition(..)
|
|
, PhiXConfig(..)
|
|
, phiDefaultXConfig
|
|
, initPhi
|
|
) where
|
|
|
|
import Graphics.X11.Xlib
|
|
import Graphics.X11.Xlib.Extras
|
|
import Graphics.X11.Xinerama
|
|
|
|
import Control.Monad
|
|
import Data.Maybe
|
|
import Data.Bits
|
|
|
|
import Control.Monad.State
|
|
import Control.Monad.Trans
|
|
|
|
data PanelPosition = PanelPositionTop | PanelPositionBottom
|
|
|
|
data PhiXConfig = PhiXConfig { phiXScreenInfo :: Display -> IO [Rectangle]
|
|
, phiPanelPosition :: PanelPosition
|
|
, phiPanelSize :: Int
|
|
}
|
|
|
|
data PhiState = PhiState { phiXConfig :: PhiXConfig
|
|
, phiDisplay :: Display
|
|
, phiRootPixmap :: Pixmap
|
|
, phiPanels :: [PanelState]
|
|
}
|
|
|
|
data PanelState = PanelState { panelWindow :: Window
|
|
, panelGC :: GC
|
|
, panelArea :: Rectangle
|
|
, panelScreenArea :: Rectangle
|
|
}
|
|
|
|
newtype Phi a = Phi (StateT PhiState IO a)
|
|
deriving (Monad, MonadState PhiState, MonadIO)
|
|
|
|
runPhi :: PhiState -> Phi a -> IO (a, PhiState)
|
|
runPhi st (Phi a) = runStateT a st
|
|
|
|
|
|
phiDefaultXConfig = PhiXConfig { phiXScreenInfo = getScreenInfo
|
|
, phiPanelPosition = PanelPositionTop
|
|
, phiPanelSize = 24
|
|
}
|
|
|
|
|
|
initPhi :: PhiXConfig -> IO ()
|
|
initPhi config = do
|
|
disp <- openDisplay []
|
|
selectInput disp (defaultRootWindow disp) $ propertyChangeMask.|.structureNotifyMask
|
|
|
|
runPhi PhiState { phiXConfig = config, phiDisplay = disp, phiRootPixmap = 0, phiPanels = [] } $ do
|
|
updateRootPixmap
|
|
|
|
screens <- liftIO $ phiXScreenInfo config disp
|
|
panels <- mapM createPanel screens
|
|
forM_ panels $ \panel -> do
|
|
setPanelProperties panel
|
|
liftIO $ mapWindow disp (panelWindow panel)
|
|
|
|
modify $ \state -> state { phiPanels = panels }
|
|
|
|
state <- get
|
|
liftIO $ allocaXEvent $ \xevent -> runPhi state $ do
|
|
forever $ do
|
|
liftIO $ nextEvent disp xevent
|
|
event <- liftIO $ getEvent xevent
|
|
|
|
case event of
|
|
ExposeEvent {} -> updatePanels
|
|
PropertyEvent {} -> handlePropertyUpdate event
|
|
_ -> return ()
|
|
return ()
|
|
|
|
|
|
updatePanels :: Phi ()
|
|
updatePanels = do
|
|
disp <- gets phiDisplay
|
|
rootPixmap <- gets phiRootPixmap
|
|
panels <- gets phiPanels
|
|
forM_ panels $ \panel -> liftIO $ withRectangle (panelArea panel) (copyArea disp rootPixmap (panelWindow panel) (panelGC panel)) 0 0
|
|
|
|
|
|
handlePropertyUpdate :: Event -> Phi ()
|
|
handlePropertyUpdate PropertyEvent { ev_atom = atom } = do
|
|
disp <- gets phiDisplay
|
|
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
|
|
updateRootPixmap
|
|
updatePanels
|
|
|
|
|
|
updateRootPixmap :: Phi ()
|
|
updateRootPixmap = do
|
|
disp <- gets phiDisplay
|
|
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
|
|
modify $ \state -> state { phiRootPixmap = pixmap }
|
|
|
|
|
|
createPanel :: Rectangle -> Phi PanelState
|
|
createPanel screen = do
|
|
config <- gets phiXConfig
|
|
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 }
|
|
|
|
|
|
createPanelWindow :: Rectangle -> Phi Window
|
|
createPanelWindow rect = do
|
|
disp <- gets 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 <- gets phiDisplay
|
|
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]
|
|
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 atom_MOTIF_WM_HINTS propModeReplace [ 2, 0, 0, 0, 0 ]
|
|
setStruts panel
|
|
|
|
|
|
setStruts :: PanelState -> Phi ()
|
|
setStruts panel = do
|
|
disp <- gets phiDisplay
|
|
config <- gets phiXConfig
|
|
let rootwin = defaultRootWindow disp
|
|
position = phiPanelPosition config
|
|
area = panelArea panel
|
|
(_, _, _, _, rootHeight, _, _) <- liftIO $ getGeometry disp rootwin
|
|
|
|
let struts = case position of
|
|
PanelPositionTop -> [ 0
|
|
, 0
|
|
, (fromIntegral $ rect_y area) + (fromIntegral $ rect_height area)
|
|
, 0
|
|
, 0
|
|
, 0
|
|
, 0
|
|
, 0
|
|
, (fromIntegral $ rect_x area)
|
|
, (fromIntegral $ rect_x area) + (fromIntegral $ rect_width area) - 1
|
|
, 0
|
|
, 0
|
|
]
|
|
PanelPositionBottom -> [ 0
|
|
, 0
|
|
, 0
|
|
, (fromIntegral rootHeight) - (fromIntegral $ rect_y area)
|
|
, 0
|
|
, 0
|
|
, 0
|
|
, 0
|
|
, 0
|
|
, 0
|
|
, (fromIntegral $ rect_x area)
|
|
, (fromIntegral $ rect_x area) + (fromIntegral $ rect_width area) - 1
|
|
]
|
|
|
|
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
|
|
|
|
|
|
panelBounds :: PhiXConfig -> Rectangle -> Rectangle
|
|
panelBounds config screenBounds = case phiPanelPosition config of
|
|
PanelPositionTop -> screenBounds { rect_height = fromIntegral $ phiPanelSize config }
|
|
PanelPositionBottom -> screenBounds { rect_height = fromIntegral $ phiPanelSize config,
|
|
rect_y = (rect_y screenBounds) + (fromIntegral $ rect_height screenBounds) - (fromIntegral $ phiPanelSize config) }
|
|
|
|
withRectangle :: Rectangle -> (Position -> Position -> Dimension -> Dimension -> a) -> a
|
|
withRectangle r = withDimension r . withPosition r
|
|
|
|
withPosition :: Rectangle -> (Position -> Position -> a) -> a
|
|
withPosition r f = f (rect_x r) (rect_y r)
|
|
|
|
withDimension :: Rectangle -> (Dimension -> Dimension -> a) -> a
|
|
withDimension r f = f (rect_width r) (rect_height r)
|