{-# 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 Data.Char import Control.Monad.State import Control.Monad.Reader import Control.Monad.Trans 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 { phiRootPixmap :: Pixmap , phiPanels :: [PanelState] } data PanelState = PanelState { panelWindow :: Window , panelGC :: GC , panelPixmap :: Pixmap , panelSurface :: Surface , panelArea :: Rectangle , panelScreenArea :: Rectangle , panelWidgetStates :: [Widget.WidgetState] } 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 -> [Widget.Widget] -> IO () initPhi xconfig config widgets = 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 widgets) 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 panels' <- forM panels $ \panel -> do newPanel <- if not redraw then return panel else do let surface = panelSurface panel area = panelArea panel layoutedWidgets = withDimension area $ Widget.layoutWidgets (panelWidgetStates panel) 0 0 panel' = panel { panelWidgetStates = layoutedWidgets } -- draw background liftIO $ withRectangle (panelArea panel) (copyArea disp rootPixmap (panelPixmap panel) (panelGC panel)) 0 0 surfaceMarkDirty surface renderWith surface $ Widget.renderWidgets layoutedWidgets surfaceFlush surface return panel' -- copy pixmap to window liftIO $ withDimension (panelArea panel) (copyArea disp (panelPixmap panel) (panelWindow panel) (panelGC panel) 0 0) 0 0 return newPanel modify $ \state -> state { phiPanels = panels' } 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 :: [Widget.Widget] -> Rectangle -> Phi PanelState createPanel widgets 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, panelWidgetStates = map Widget.createWidgetState widgets } 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" 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 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 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)