{-# 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.Exit import System.Posix.Signals 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 { phiRootImage :: !Surface , phiPanels :: ![PanelState] , phiRepaint :: !Bool , phiShutdown :: !Bool , phiShutdownHold :: !Int } data PanelState = PanelState { panelWindow :: !Window , panelPixmap :: !Pixmap , panelArea :: !Rectangle , panelScreenArea :: !Rectangle , panelWidgetStates :: ![Widget.WidgetState] } data PhiConfig = PhiConfig { phiPhi :: !Phi , 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 installHandler sigTERM (termHandler phi) Nothing installHandler sigINT (termHandler phi) Nothing installHandler sigQUIT (termHandler phi) Nothing disp <- openDisplay [] atoms <- initAtoms disp selectInput disp (defaultRootWindow disp) $ propertyChangeMask.|.structureNotifyMask bg <- createImageSurface FormatRGB24 1 1 runPhiX PhiConfig { phiPhi = phi , phiXConfig = xconfig , phiPanelConfig = config , phiAtoms = atoms } PhiState { phiRootImage = bg , phiPanels = [] , phiRepaint = True , phiShutdown = False , phiShutdownHold = 0 } $ do updateRootImage disp screens <- liftIO $ phiXScreenInfo xconfig disp panelWindows <- mapM (createPanelWindow disp) screens dispmvar <- liftIO $ newMVar disp let screenPanels = zip screens panelWindows dispvar = Widget.Display dispmvar atoms screenPanels widgetStates <- liftIO $ mapM (Widget.createWidgetState phi dispvar) widgets Widget.withDisplay dispvar $ \disp -> do panels <- mapM (\(screen, window) -> createPanel disp window widgetStates screen) screenPanels forM_ panels $ \panel -> do setPanelProperties disp panel liftIO $ mapWindow disp (panelWindow panel) modify $ \state -> state { phiPanels = panels } liftIO $ forkIO $ receiveEvents phi dispvar forever $ do available <- messageAvailable phi unless available $ do repaint <- gets phiRepaint when repaint $ do updatePanels dispvar modify $ \state -> state {phiRepaint = False} message <- receiveMessage phi handleMessage dispvar message case (fromMessage message) of Just Shutdown -> modify $ \state -> state { phiShutdown = True } Just HoldShutdown -> modify $ \state -> state { phiShutdownHold = phiShutdownHold state + 1 } Just ReleaseShutdown -> modify $ \state -> state { phiShutdownHold = phiShutdownHold state - 1 } _ -> return () shutdown <- gets phiShutdown shutdownHold <- gets phiShutdownHold when (shutdown && (shutdownHold == 0)) $ liftIO $ exitSuccess return () termHandler :: Phi -> Handler termHandler phi = Catch $ sendMessage phi Shutdown 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 -> modify $ \state -> state {phiRepaint = True} _ -> case (fromMessage m) of Just event@PropertyEvent {} -> Widget.withDisplay dispvar $ flip handlePropertyUpdate 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 $ Util.getEvent disp xevent sendMessage phi event return True else return False when (not handled) $ threadWaitRead connection updatePanels :: Widget.Display -> PhiX () updatePanels dispvar = do rootImage <- gets phiRootImage panels <- gets phiPanels panels' <- forM panels $ \panel -> do let pixmap = panelPixmap panel area = panelArea panel let layoutedWidgets = (withDimension area $ Widget.layoutWidgets (panelWidgetStates panel) 0 0) $ panelScreenArea panel panel' = panel { panelWidgetStates = layoutedWidgets } Widget.withDisplay dispvar $ \disp -> do let screen = defaultScreen disp visual = defaultVisual disp screen buffer <- liftIO $ withDimension area $ Util.createXlibSurface disp pixmap visual renderWith buffer $ do withPatternForSurface rootImage $ \pattern -> do save translate (-(fromIntegral $ rect_x area)) (-(fromIntegral $ rect_y area)) setSource pattern paint restore Widget.renderWidgets layoutedWidgets $ panelScreenArea panel surfaceFinish buffer -- copy buffer to window liftIO $ do setWindowBackgroundPixmap disp (panelWindow panel') pixmap (withDimension area $ clearArea disp (panelWindow panel') 0 0) True sync disp False return panel' modify $ \state -> state { phiPanels = panels' } handlePropertyUpdate :: Display -> Event -> PhiX () handlePropertyUpdate disp PropertyEvent { ev_atom = atom } = do phi <- asks phiPhi atoms <- asks phiAtoms panels <- gets phiPanels when (atom == atom_XROOTPMAP_ID atoms || atom == atom_XROOTMAP_ID atoms) $ do updateRootImage disp sendMessage phi ResetBackground sendMessage phi Repaint 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 -> Window -> [Widget.WidgetState] -> Rectangle -> PhiX PanelState createPanel disp win widgets screenRect = do config <- asks phiPanelConfig let rect = panelBounds config screenRect let screen = defaultScreen disp depth = defaultDepth disp screen pixmap <- liftIO $ (withDimension rect $ createPixmap disp win) depth return PanelState { panelWindow = win , panelPixmap = pixmap , panelArea = rect , panelScreenArea = screenRect , panelWidgetStates = widgets } createPanelWindow :: Display -> Rectangle -> PhiX Window createPanelWindow disp screenRect = do config <- asks phiPanelConfig let rect = panelBounds config screenRect 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)