From 4d519acbd48fa400f09e4705251a0dbf45c6876e Mon Sep 17 00:00:00 2001 From: Matthias Schiffer Date: Thu, 8 Sep 2011 19:15:23 +0200 Subject: Core is independent of X11 now --- lib/Phi/X11.hs | 308 ++++++++++++++++++++++++++++++++------------------------- 1 file changed, 172 insertions(+), 136 deletions(-) (limited to 'lib/Phi/X11.hs') diff --git a/lib/Phi/X11.hs b/lib/Phi/X11.hs index 7e0bfff..713b162 100644 --- a/lib/Phi/X11.hs +++ b/lib/Phi/X11.hs @@ -1,13 +1,17 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving, ExistentialQuantification #-} +{-# LANGUAGE GeneralizedNewtypeDeriving, ExistentialQuantification, TypeFamilies, FlexibleContexts, DeriveDataTypeable #-} -module Phi.X11 ( XConfig(..) +module Phi.X11 ( X11(..) + , XEvent(..) + , XMessage(..) + , XConfig(..) , defaultXConfig , runPhi ) where -import Graphics.XHB +import Graphics.XHB hiding (Window) +import qualified Graphics.XHB.Connection.Open as CO import Graphics.XHB.Gen.Xinerama -import Graphics.XHB.Gen.Xproto +import Graphics.XHB.Gen.Xproto hiding (Window) import Graphics.Rendering.Cairo @@ -36,33 +40,51 @@ import Phi.Phi import Phi.X11.Util import qualified Phi.Types as Phi import qualified Phi.Panel as Panel -import qualified Phi.Widget as Widget -import Phi.Widget hiding (Display, handleMessage) +import qualified Phi.Widget as Widget (handleMessage) +import Phi.Widget hiding (handleMessage) import Phi.X11.Atoms -data XConfig = XConfig { phiXScreenInfo :: !(Connection -> IO [RECTANGLE]) +data X11 = X11 { x11Connection :: !Connection + , x11Atoms :: !Atoms + , x11Screen :: !SCREEN + } + +instance Display X11 where + type Window X11 = WINDOW + + +newtype XEvent = XEvent SomeEvent deriving Typeable + +instance Show XEvent where + show _ = "XEvent (..)" + +data XMessage = UpdateScreens [(Rectangle, WINDOW)] deriving (Show, Typeable) + + +data XConfig = XConfig { phiXScreenInfo :: !(X11 -> IO [Rectangle]) } -data PhiState w s c = (Widget.Widget w s c) => PhiState { phiRootImage :: !Surface - , phiPanels :: ![PanelState w s c] - , phiRepaint :: !Bool - , phiShutdown :: !Bool - , phiShutdownHold :: !Int - , phiWidgetState :: !s - } - -data PanelState w s c = (Widget.Widget w s c) => PanelState { panelWindow :: !WINDOW - , panelPixmap :: !PIXMAP - , panelArea :: !RECTANGLE - , panelScreenArea :: !RECTANGLE - , panelWidgetCache :: !c - } +data PhiState w s c = (Widget w s c X11) => PhiState { phiRootImage :: !Surface + , phiPanels :: ![PanelState w s c] + , phiRepaint :: !Bool + , phiShutdown :: !Bool + , phiShutdownHold :: !Int + , phiWidgetState :: !s + } + +data PanelState w s c = (Widget w s c X11) => PanelState { panelWindow :: !WINDOW + , panelPixmap :: !PIXMAP + , panelArea :: !Rectangle + , panelScreenArea :: !Rectangle + , panelWidgetCache :: !c + } data PhiConfig w s c = PhiConfig { phiPhi :: !Phi , phiPanelConfig :: !Panel.PanelConfig , phiXConfig :: !XConfig - , phiAtoms :: !Atoms + , phiX11 :: !X11 + , phiXCB :: !XCB.Connection , phiWidget :: !w } @@ -81,17 +103,22 @@ runPhiX config st (PhiX a) = runPhiReader config $ runStateT a st defaultXConfig = XConfig { phiXScreenInfo = getScreenInfo } -getScreenInfo :: Connection -> IO [RECTANGLE] -getScreenInfo conn = do +getScreenInfo :: X11 -> IO [Rectangle] +getScreenInfo x11 = do + let conn = x11Connection x11 + screen = x11Screen x11 exs <- queryScreens conn >>= getReply case exs of Right xs -> return . map screenInfoToRect $ screen_info_QueryScreensReply xs - Left _ -> getGeometry conn (fromXid . toXid $ getRoot conn) >>= getReply' "getScreenInfo: getGeometry failed" >>= - return . (\(MkGetGeometryReply _ _ x y w h _) -> [MkRECTANGLE x y w h]) + Left _ -> getGeometry conn (fromXid . toXid $ root_SCREEN screen) >>= getReply' "getScreenInfo: getGeometry failed" >>= + return . (\(MkGetGeometryReply _ _ x y w h _) -> [Rectangle (fi x) (fi y) (fi w) (fi h)]) where - screenInfoToRect (MkScreenInfo x y w h) = MkRECTANGLE x y w h + screenInfoToRect (MkScreenInfo x y w h) = Rectangle (fi x) (fi y) (fi w) (fi h) + + fi :: (Integral a, Num b) => a -> b + fi = fromIntegral -runPhi :: (Widget.Widget w s c) => XConfig -> Panel.PanelConfig -> w -> IO () +runPhi :: (Widget w s c X11) => XConfig -> Panel.PanelConfig -> w -> IO () runPhi xconfig config widget = do phi <- initPhi @@ -102,24 +129,30 @@ runPhi xconfig config widget = do conn <- liftM fromJust connect xcb <- XCB.connect + let dispname = displayInfo conn + screen = (roots_Setup . connectionSetup $ conn) !! CO.screen dispname + atoms <- initAtoms conn - changeWindowAttributes conn (getRoot conn) $ toValueParam [(CWEventMask, toMask [EventMaskPropertyChange, EventMaskStructureNotify])] + changeWindowAttributes conn (root_SCREEN screen) $ toValueParam [(CWEventMask, toMask [EventMaskPropertyChange, EventMaskStructureNotify])] bg <- createImageSurface FormatRGB24 1 1 - screens <- liftIO $ phiXScreenInfo xconfig conn - panelWindows <- mapM (createPanelWindow conn config) screens - let dispvar = Widget.Display conn atoms - widget' = widget <~> separator 0 (if weight widget > 0 then 0 else 1) + let x11 = X11 conn atoms screen + + screens <- liftIO $ phiXScreenInfo xconfig x11 + panelWindows <- mapM (createPanelWindow conn screen config) screens + + let widget' = widget <~> separator 0 (if weight widget > 0 then 0 else 1) screenPanels = zip screens panelWindows - initialState <- Widget.initWidget widget' phi dispvar screenPanels + initialState <- initWidget widget' phi x11 screenPanels runPhiX PhiConfig { phiPhi = phi , phiXConfig = xconfig , phiPanelConfig = config - , phiAtoms = atoms + , phiX11 = x11 + , phiXCB = xcb , phiWidget = widget' } PhiState { phiRootImage = bg @@ -129,15 +162,15 @@ runPhi xconfig config widget = do , phiShutdownHold = 0 , phiWidgetState = initialState } $ do - updateRootImage conn xcb + updateRootImage - panels <- mapM (\(screen, window) -> createPanel conn window screen) screenPanels + panels <- mapM (\(screen, window) -> createPanel window screen) screenPanels - forM_ panels $ setPanelProperties conn + forM_ panels setPanelProperties modify $ \state -> state { phiPanels = panels } - updatePanels conn xcb + updatePanels forM_ panels $ liftIO . mapWindow conn . panelWindow @@ -150,11 +183,11 @@ runPhi xconfig config widget = do available <- messageAvailable phi when (not available && repaint) $ do - updatePanels conn xcb + updatePanels modify $ \state -> state {phiRepaint = False} message <- receiveMessage phi - handleMessage conn xcb message + handleMessage message case (fromMessage message) of Just Shutdown -> @@ -179,8 +212,8 @@ termHandler :: Phi -> Handler termHandler phi = Catch $ sendMessage phi Shutdown -handleMessage :: (Widget w s c) => Connection -> XCB.Connection -> Message -> PhiX w s c () -handleMessage conn xcb m = do +handleMessage :: (Widget w s c X11) => Message -> PhiX w s c () +handleMessage m = do w <- asks phiWidget modify $ \state -> state {phiWidgetState = Widget.handleMessage w (phiWidgetState state) m} @@ -190,81 +223,86 @@ handleMessage conn xcb m = do _ -> case (fromMessage m) of Just (XEvent event) -> - handleEvent conn xcb event + handleEvent event _ -> return () -handleEvent :: (Widget w s c) => Connection -> XCB.Connection -> SomeEvent -> PhiX w s c () -handleEvent conn xcb event = +handleEvent :: (Widget w s c X11) => SomeEvent -> PhiX w s c () +handleEvent event = case (fromEvent event) of - Just e -> handlePropertyNotifyEvent conn xcb e + Just e -> handlePropertyNotifyEvent e Nothing -> case (fromEvent event) of - Just e -> handleConfigureNotifyEvent conn e + Just e -> handleConfigureNotifyEvent e Nothing -> return () -handlePropertyNotifyEvent :: (Widget w s c) => Connection -> XCB.Connection -> PropertyNotifyEvent -> PhiX w s c () -handlePropertyNotifyEvent conn xcb MkPropertyNotifyEvent { atom_PropertyNotifyEvent = atom } = do +handlePropertyNotifyEvent :: (Widget w s c X11) => PropertyNotifyEvent -> PhiX w s c () +handlePropertyNotifyEvent MkPropertyNotifyEvent { atom_PropertyNotifyEvent = atom } = do phi <- asks phiPhi - atoms <- asks phiAtoms + atoms <- asks (x11Atoms . phiX11) panels <- gets phiPanels when (atom == atom_XROOTPMAP_ID atoms || atom == atom_XROOTMAP_ID atoms) $ do - updateRootImage conn xcb + updateRootImage sendMessage phi ResetBackground sendMessage phi Repaint -handleConfigureNotifyEvent :: (Widget w s c) => Connection -> ConfigureNotifyEvent -> PhiX w s c () -handleConfigureNotifyEvent conn MkConfigureNotifyEvent { window_ConfigureNotifyEvent = window } | window == getRoot conn = do - phi <- asks phiPhi - xconfig <- asks phiXConfig - config <- asks phiPanelConfig - panels <- gets phiPanels - let screens = map panelScreenArea panels - screens' <- liftIO $ phiXScreenInfo xconfig conn - - when (screens /= screens') $ do - liftIO $ do - mapM_ (freePixmap conn . panelPixmap) panels - mapM_ (destroyWindow conn . panelWindow) $ drop (length screens') panels - - let panelsScreens = zip screens' $ map Just panels ++ repeat Nothing - - panels' <- forM panelsScreens $ \(screen, mpanel) -> - case mpanel of - Just panel -> do - let rect = panelBounds config screen - win = panelWindow panel - - liftIO $ configureWindow conn win $ toValueParam [ (ConfigWindowX, fromIntegral $ x_RECTANGLE rect) - , (ConfigWindowY, fromIntegral $ y_RECTANGLE rect) - , (ConfigWindowWidth, fromIntegral $ width_RECTANGLE rect) - , (ConfigWindowHeight, fromIntegral $ height_RECTANGLE rect) - ] - - panel' <- createPanel conn win screen - setPanelProperties conn panel' - - return panel' - Nothing -> do - win <- liftIO $ createPanelWindow conn config screen - panel <- createPanel conn win screen - setPanelProperties conn panel - liftIO $ mapWindow conn $ panelWindow panel - return panel - - modify $ \state -> state { phiPanels = panels' } +handleConfigureNotifyEvent :: (Widget w s c X11) => ConfigureNotifyEvent -> PhiX w s c () +handleConfigureNotifyEvent MkConfigureNotifyEvent { window_ConfigureNotifyEvent = window } = do + x11 <- asks phiX11 + let conn = x11Connection x11 + screen = x11Screen x11 + rootWindow = root_SCREEN screen + when (window == rootWindow) $ do + phi <- asks phiPhi + xconfig <- asks phiXConfig + config <- asks phiPanelConfig + panels <- gets phiPanels + let screens = map panelScreenArea panels + screens' <- liftIO $ phiXScreenInfo xconfig x11 - sendMessage phi $ UpdateScreens $ map (panelScreenArea &&& panelWindow) panels' - sendMessage phi Repaint - -handleConfigureNotifyEvent _ _ = return () + when (screens /= screens') $ do + liftIO $ do + mapM_ (freePixmap conn . panelPixmap) panels + mapM_ (destroyWindow conn . panelWindow) $ drop (length screens') panels + + let panelsScreens = zip screens' $ map Just panels ++ repeat Nothing + + panels' <- forM panelsScreens $ \(screenarea, mpanel) -> + case mpanel of + Just panel -> do + let rect = panelBounds config screenarea + win = panelWindow panel + + liftIO $ configureWindow conn win $ toValueParam [ (ConfigWindowX, fromIntegral $ rect_x rect) + , (ConfigWindowY, fromIntegral $ rect_y rect) + , (ConfigWindowWidth, fromIntegral $ rect_width rect) + , (ConfigWindowHeight, fromIntegral $ rect_height rect) + ] + + panel' <- createPanel win screenarea + setPanelProperties panel' + + return panel' + Nothing -> do + win <- liftIO $ createPanelWindow conn screen config screenarea + panel <- createPanel win screenarea + setPanelProperties panel + liftIO $ mapWindow conn $ panelWindow panel + return panel + + modify $ \state -> state { phiPanels = panels' } + + sendMessage phi $ UpdateScreens $ map (panelScreenArea &&& panelWindow) panels' + sendMessage phi Repaint receiveEvents :: Phi -> Connection -> IO () receiveEvents phi conn = do forever $ waitForEvent conn >>= sendMessage phi . XEvent -updatePanels :: (Widget w s c) => Connection -> XCB.Connection -> PhiX w s c () -updatePanels conn xcb = do +updatePanels :: (Widget w s c X11) => PhiX w s c () +updatePanels = do + X11 conn _ screen <- asks phiX11 + xcb <- asks phiXCB w <- asks phiWidget s <- gets phiWidgetState rootImage <- gets phiRootImage @@ -275,17 +313,16 @@ updatePanels conn xcb = do area = panelArea panel (panelSurfaces, cache') <- liftIO $ flip runStateT (panelWidgetCache panel) $ - (withDimension area $ Widget.render w s 0 0) (panelScreenArea panel) + (withDimension area $ render w s 0 0) (panelScreenArea panel) - let screen = head . roots_Setup . connectionSetup $ conn - visualtype = fromJust $ findVisualtype screen (root_visual_SCREEN screen) + let visualtype = fromJust $ findVisualtype screen (root_visual_SCREEN screen) xbuffer <- liftIO $ withDimension area $ XCB.createXCBSurface xcb (fromXid . toXid $ pixmap) visualtype liftIO $ (withDimension area $ withSimilarSurface xbuffer ContentColor) $ \buffer -> do renderWith buffer $ do save - translate (-(fromIntegral $ x_RECTANGLE area)) (-(fromIntegral $ y_RECTANGLE area)) + translate (-(fromIntegral $ rect_x area)) (-(fromIntegral $ rect_y area)) withPatternForSurface rootImage $ \pattern -> do patternSetExtend pattern ExtendRepeat setSource pattern @@ -313,12 +350,12 @@ updatePanels conn xcb = do modify $ \state -> state { phiPanels = panels' } -updateRootImage :: Connection -> XCB.Connection -> PhiX w s c () -updateRootImage conn xcb = do - atoms <- asks phiAtoms +updateRootImage :: PhiX w s c () +updateRootImage = do + X11 conn atoms screen <- asks phiX11 + xcb <- asks phiXCB - let screen = head . roots_Setup . connectionSetup $ conn - visualtype = fromJust $ findVisualtype screen (root_visual_SCREEN screen) + let visualtype = fromJust $ findVisualtype screen (root_visual_SCREEN screen) rootwin = root_SCREEN screen pixmap <- liftM (fromXid . toXid . fromMaybe 0 . listToMaybe . join . catMaybes) $ forM [atom_XROOTPMAP_ID atoms, atom_XROOTMAP_ID atoms] $ @@ -355,12 +392,12 @@ updateRootImage conn xcb = do return () -createPanel :: (Widget w s c) => Connection -> WINDOW -> RECTANGLE -> PhiX w s c (PanelState w s c) -createPanel conn win screenRect = do +createPanel :: (Widget w s c X11) => WINDOW -> Rectangle -> PhiX w s c (PanelState w s c) +createPanel win screenRect = do + (conn, screen) <- asks $ (x11Connection &&& x11Screen) . phiX11 config <- asks phiPanelConfig w <- asks phiWidget let rect = panelBounds config screenRect - screen = head . roots_Setup . connectionSetup $ conn depth = root_depth_SCREEN screen pixmap <- liftIO $ newResource conn @@ -374,10 +411,9 @@ createPanel conn win screenRect = do , panelWidgetCache = initCache w } -createPanelWindow :: Connection -> Panel.PanelConfig -> RECTANGLE -> IO WINDOW -createPanelWindow conn config screenRect = do +createPanelWindow :: Connection -> SCREEN -> Panel.PanelConfig -> Rectangle -> IO WINDOW +createPanelWindow conn screen config screenRect = do let rect = panelBounds config screenRect - screen = head . roots_Setup . connectionSetup $ conn depth = root_depth_SCREEN screen rootwin = root_SCREEN screen visual = root_visual_SCREEN screen @@ -387,9 +423,9 @@ createPanelWindow conn config screenRect = do return win -setPanelProperties :: Connection -> PanelState w s c -> PhiX w s c () -setPanelProperties conn panel = do - atoms <- asks phiAtoms +setPanelProperties :: PanelState w s c -> PhiX w s c () +setPanelProperties panel = do + (conn, atoms) <- asks $ (x11Connection &&& x11Atoms) . phiX11 liftIO $ do let name = map (fromIntegral . ord) "Phi" changeProperty8 conn PropModeReplace (panelWindow panel) (atomWM_NAME atoms) (atomSTRING atoms) name @@ -408,28 +444,28 @@ setPanelProperties conn panel = do changeProperty8 conn PropModeReplace (panelWindow panel) (atomWM_CLASS atoms) (atomSTRING atoms) $ map (fromIntegral . ord) "phi\0Phi" - setStruts conn panel + setStruts panel -setStruts :: Connection -> PanelState w s c -> PhiX w s c () -setStruts conn panel = do - atoms <- asks phiAtoms +setStruts :: PanelState w s c -> PhiX w s c () +setStruts panel = do + X11 conn atoms screen <- asks phiX11 config <- asks phiPanelConfig - let rootwin = getRoot conn + let rootwin = root_SCREEN screen position = Panel.panelPosition config area = panelArea panel rootHeight <- liftIO $ getGeometry conn (fromXid . toXid $ rootwin) >>= getReply' "setStruts: getGeometry failed" >>= return . height_GetGeometryReply let struts = [makeStruts i | i <- [0..11]] where - makeTopStruts 2 = (fromIntegral $ y_RECTANGLE area) + (fromIntegral $ height_RECTANGLE area) - makeTopStruts 8 = (fromIntegral $ x_RECTANGLE area) - makeTopStruts 9 = (fromIntegral $ x_RECTANGLE area) + (fromIntegral $ width_RECTANGLE area) - 1 + 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 $ y_RECTANGLE area) - makeBottomStruts 10 = (fromIntegral $ x_RECTANGLE area) - makeBottomStruts 11 = (fromIntegral $ x_RECTANGLE area) + (fromIntegral $ width_RECTANGLE area) - 1 + 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 @@ -441,17 +477,17 @@ setStruts conn panel = do changeProperty32 conn PropModeReplace (panelWindow panel) (atom_NET_WM_STRUT_PARTIAL atoms) (atomCARDINAL atoms) struts -panelBounds :: Panel.PanelConfig -> RECTANGLE -> RECTANGLE +panelBounds :: Panel.PanelConfig -> Rectangle -> Rectangle panelBounds config screenBounds = case Panel.panelPosition config of - Phi.Top -> screenBounds { height_RECTANGLE = fromIntegral $ Panel.panelSize config } - Phi.Bottom -> screenBounds { height_RECTANGLE = fromIntegral $ Panel.panelSize config, - y_RECTANGLE = (y_RECTANGLE screenBounds) + (fromIntegral $ height_RECTANGLE screenBounds) - (fromIntegral $ Panel.panelSize config) } + Phi.Top -> screenBounds { rect_height = Panel.panelSize config } + Phi.Bottom -> screenBounds { rect_height = Panel.panelSize config, + rect_y = rect_y screenBounds + rect_height screenBounds - Panel.panelSize config } -withRectangle :: (Num x, Num y, Num w, Num h) => RECTANGLE -> (x -> y -> w -> h -> a) -> a +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 $ x_RECTANGLE r) (fromIntegral $ y_RECTANGLE 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 $ width_RECTANGLE r) (fromIntegral $ height_RECTANGLE r) +withDimension :: (Num w, Num h) => Rectangle -> (w -> h -> a) -> a +withDimension r f = f (fromIntegral $ rect_width r) (fromIntegral $ rect_height r) -- cgit v1.2.3