{-# LANGUAGE GeneralizedNewtypeDeriving #-} module Phi.X11 ( XConfig(..) , defaultXConfig , runPhi ) 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 Data.Char import Control.Concurrent import Control.Concurrent.MVar import Control.Monad.State import Control.Monad.Reader import Control.Monad.Trans import System.Posix.Types import Phi.Phi import qualified Phi.Types as Phi import qualified Phi.Panel as Panel import qualified Phi.Widget as Widget import Phi.X11.Atoms import qualified Phi.Bindings.Util as Util data XConfig = XConfig { phiXScreenInfo :: !(Display -> IO [Rectangle]) } data PhiState = PhiState { phiPhi :: !Phi , phiRootImage :: !Surface , phiPanels :: ![PanelState] } data PanelState = PanelState { panelWindow :: !Window , panelBuffer :: !Surface , panelArea :: !Rectangle , panelScreenArea :: !Rectangle , panelWidgetStates :: ![Widget.WidgetState] } data PhiConfig = PhiConfig { phiPanelConfig :: !Panel.PanelConfig , phiXConfig :: !XConfig , 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 PhiX a = PhiX (StateT PhiState PhiReader a) deriving (Monad, MonadState PhiState, MonadReader PhiConfig, MonadIO) runPhiX :: PhiConfig -> PhiState -> PhiX a -> IO (a, PhiState) runPhiX config st (PhiX a) = runPhiReader config $ runStateT a st defaultXConfig = XConfig { phiXScreenInfo = getScreenInfo } runPhi :: XConfig -> Panel.PanelConfig -> [Widget.Widget] -> IO () runPhi xconfig config widgets = do xSetErrorHandler phi <- initPhi disp <- openDisplay [] atoms <- initAtoms disp selectInput disp (defaultRootWindow disp) $ propertyChangeMask.|.structureNotifyMask bg <- createImageSurface FormatRGB24 1 1 runPhiX PhiConfig { phiXConfig = xconfig, phiPanelConfig = config, phiAtoms = atoms } PhiState { phiPhi = phi, phiRootImage = bg, phiPanels = [] } $ do updateRootImage disp screens <- liftIO $ phiXScreenInfo xconfig disp dispmvar <- liftIO $ newMVar disp let dispvar = Widget.Display dispmvar atoms widgetStates <- liftIO $ mapM (Widget.createWidgetState phi dispvar) widgets Widget.withDisplay dispvar $ \disp -> do panels <- mapM (createPanel disp widgetStates) screens forM_ panels $ \panel -> do setPanelProperties disp panel liftIO $ mapWindow disp (panelWindow panel) modify $ \state -> state { phiPanels = panels } updatePanels disp True liftIO $ forkIO $ receiveEvents phi dispvar forever $ do message <- receiveMessage phi handleMessage dispvar message return () handlePanel :: Message -> PanelState -> PanelState handlePanel message panel@PanelState {panelWidgetStates = widgets} = panel {panelWidgetStates = widgets'} where widgets' = Widget.handleMessageWidgets message widgets handleMessage :: Widget.Display -> Message -> PhiX () handleMessage dispvar m = do modify $ \state@PhiState {phiPanels = panels} -> state {phiPanels = map (handlePanel m) panels} case (fromMessage m) of Just Repaint -> Widget.withDisplay dispvar $ \disp -> updatePanels disp True _ -> case (fromMessage m) of Just ExposeEvent {} -> Widget.withDisplay dispvar $ \disp -> updatePanels disp False Just event@PropertyEvent {} -> Widget.withDisplay dispvar $ \disp -> handlePropertyUpdate disp event _ -> return () receiveEvents :: Phi -> Widget.Display -> IO () receiveEvents phi dispvar = do connection <- Widget.withDisplay dispvar $ return . Fd . connectionNumber allocaXEvent $ \xevent -> forever $ do handled <- Widget.withDisplay dispvar $ \disp -> do pend <- pending disp if pend /= 0 then do liftIO $ nextEvent disp xevent event <- liftIO $ getEvent xevent sendMessage phi event return True else return False when (not handled) $ threadWaitRead connection updatePanels :: Display -> Bool -> PhiX () updatePanels disp redraw = do rootImage <- gets phiRootImage panels <- gets phiPanels panels' <- forM panels $ \panel -> do let buffer = panelBuffer panel area = panelArea panel newPanel <- if not redraw then return panel else do let layoutedWidgets = withDimension area $ Widget.layoutWidgets (panelWidgetStates panel) 0 0 panel' = panel { panelWidgetStates = layoutedWidgets } renderWith buffer $ do withPatternForSurface rootImage $ \pattern -> do save translate (-(fromIntegral $ rect_x area)) (-(fromIntegral $ rect_y area)) setSource pattern paint restore Widget.renderWidgets layoutedWidgets return panel' let screen = defaultScreen disp visual = defaultVisual disp screen surface <- liftIO $ withDimension area $ Util.createXlibSurface disp (panelWindow newPanel) visual -- copy buffer to window renderWith surface $ withPatternForSurface buffer $ \pattern -> do setSource pattern paint surfaceFinish surface return newPanel modify $ \state -> state { phiPanels = panels' } handlePropertyUpdate :: Display -> Event -> PhiX () handlePropertyUpdate disp PropertyEvent { ev_atom = atom } = do atoms <- asks phiAtoms panels <- gets phiPanels when (atom == atom_XROOTPMAP_ID atoms || atom == atom_XROOTMAP_ID atoms) $ do updateRootImage disp updatePanels disp True updateRootImage :: Display -> PhiX () updateRootImage disp = do atoms <- asks phiAtoms let screen = defaultScreen disp visual = defaultVisual disp screen rootwin = defaultRootWindow disp pixmap <- liftM (fromIntegral . fromMaybe 0 . listToMaybe . join . catMaybes) $ forM [atom_XROOTPMAP_ID atoms, atom_XROOTMAP_ID atoms] $ \atom -> liftIO $ getWindowProperty32 disp atom rootwin (_, _, _, rootWidth, rootHeight, _, _) <- liftIO $ getGeometry disp rootwin -- update surface size oldBg <- gets phiRootImage imageWidth <- liftM fromIntegral $ imageSurfaceGetWidth oldBg imageHeight <- liftM fromIntegral $ imageSurfaceGetHeight oldBg when (imageWidth /= rootWidth || imageHeight /= rootHeight) $ do surfaceFinish oldBg newBg <- liftIO $ createImageSurface FormatRGB24 (fromIntegral rootWidth) (fromIntegral rootHeight) modify $ \state -> state { phiRootImage = newBg } bg <- gets phiRootImage rootSurface <- liftIO $ Util.createXlibSurface disp pixmap visual (fromIntegral rootWidth) (fromIntegral rootHeight) renderWith bg $ withPatternForSurface rootSurface $ \pattern -> do setSource pattern paint surfaceFinish rootSurface createPanel :: Display -> [Widget.WidgetState] -> Rectangle -> PhiX PanelState createPanel disp widgets screenRect = do phi <- gets phiPhi config <- asks phiPanelConfig let rect = panelBounds config screenRect win <- createPanelWindow disp rect buffer <- liftIO $ withDimension rect $ createImageSurface FormatRGB24 return PanelState { panelWindow = win , panelBuffer = buffer , panelArea = rect , panelScreenArea = screenRect , panelWidgetStates = widgets } createPanelWindow :: Display -> Rectangle -> PhiX Window createPanelWindow disp rect = do 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 :: Display -> PanelState -> PhiX () setPanelProperties disp panel = do atoms <- asks phiAtoms liftIO $ do storeName disp (panelWindow panel) "Phi" changeProperty8 disp (panelWindow panel) (atom_NET_WM_NAME atoms) (atomUTF8_STRING atoms) propModeReplace $ map (fromIntegral . ord) "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 disp panel setStruts :: Display -> PanelState -> PhiX () setStruts disp panel = do atoms <- asks phiAtoms 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 Phi.Top -> makeTopStruts Phi.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 Phi.Top -> screenBounds { rect_height = fromIntegral $ Panel.panelSize config } Phi.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)