{-# LANGUAGE GeneralizedNewtypeDeriving #-} module Phi.X11 ( XConfig(..) , defaultXConfig , 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.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 { phiRootPixmap :: Pixmap , phiPanels :: [PanelState] } data PanelState = PanelState { panelWindow :: Window , panelGC :: GC , 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 $ \x -> runPhi config state $ c x 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 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 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 screen = do config <- asks phiPanelConfig disp <- asks phiDisplay let rect = panelBounds config screen 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 <- 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 ] 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 :: 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)