{-# 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)