From ade33320e5ea201a847bb9ee5522ee58b1cd8cb6 Mon Sep 17 00:00:00 2001 From: Matthias Schiffer Date: Tue, 12 Jul 2011 02:56:30 +0200 Subject: Implemented basic panel windows with pseudo-transparency --- src/Phi.hs | 6 ++ src/Phi/Panel.hs | 40 ++++++++++ src/Phi/X11.hs | 236 +++++++++++++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 282 insertions(+) create mode 100644 src/Phi.hs create mode 100644 src/Phi/Panel.hs create mode 100644 src/Phi/X11.hs (limited to 'src') diff --git a/src/Phi.hs b/src/Phi.hs new file mode 100644 index 0000000..9aa6ad0 --- /dev/null +++ b/src/Phi.hs @@ -0,0 +1,6 @@ +import Phi.Panel +import Phi.X11 + +main :: IO () +main = do + initPhi phiDefaultXConfig { phiPanelPosition = PanelPositionBottom } \ No newline at end of file diff --git a/src/Phi/Panel.hs b/src/Phi/Panel.hs new file mode 100644 index 0000000..23b022f --- /dev/null +++ b/src/Phi/Panel.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE ExistentialQuantification #-} + +module Phi.Panel ( Panel(..) + , PanelClass(..) + , (<~>) + , separator + ) where + +import Data.Function + +class PanelClass a where + minSize :: a -> Int + + weight :: a -> Float + weight _ = 0 + +data Panel = forall a. PanelClass a => Panel a + +instance PanelClass Panel where + minSize (Panel p) = minSize p + weight (Panel p) = weight p + +data CompoundPanel = CompoundPanel Panel Panel + +instance PanelClass CompoundPanel where + minSize (CompoundPanel a b) = ((+) `on` minSize) a b + weight (CompoundPanel a b) = ((+) `on` weight) a b + +(<~>) :: Panel -> Panel -> Panel +a <~> b = Panel $ CompoundPanel a b + + +data Separator = Separator Int Float + +instance PanelClass Separator where + minSize (Separator s _) = s + weight (Separator _ w) = w + +separator :: Int -> Float -> Panel +separator s w = Panel $ Separator s w diff --git a/src/Phi/X11.hs b/src/Phi/X11.hs new file mode 100644 index 0000000..06bebfa --- /dev/null +++ b/src/Phi/X11.hs @@ -0,0 +1,236 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module Phi.X11 ( PanelPosition(..) + , PhiXConfig(..) + , phiDefaultXConfig + , 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.Trans + +data PanelPosition = PanelPositionTop | PanelPositionBottom + +data PhiXConfig = PhiXConfig { phiXScreenInfo :: Display -> IO [Rectangle] + , phiPanelPosition :: PanelPosition + , phiPanelSize :: Int + } + +data PhiState = PhiState { phiXConfig :: PhiXConfig + , phiDisplay :: Display + , phiRootPixmap :: Pixmap + , phiPanels :: [PanelState] + } + +data PanelState = PanelState { panelWindow :: Window + , panelGC :: GC + , panelArea :: Rectangle + , panelScreenArea :: Rectangle + } + +newtype Phi a = Phi (StateT PhiState IO a) + deriving (Monad, MonadState PhiState, MonadIO) + +runPhi :: PhiState -> Phi a -> IO (a, PhiState) +runPhi st (Phi a) = runStateT a st + + +phiDefaultXConfig = PhiXConfig { phiXScreenInfo = getScreenInfo + , phiPanelPosition = PanelPositionTop + , phiPanelSize = 24 + } + + +initPhi :: PhiXConfig -> IO () +initPhi config = do + disp <- openDisplay [] + selectInput disp (defaultRootWindow disp) $ propertyChangeMask.|.structureNotifyMask + + runPhi PhiState { phiXConfig = config, phiDisplay = disp, phiRootPixmap = 0, phiPanels = [] } $ do + updateRootPixmap + + screens <- liftIO $ phiXScreenInfo config disp + panels <- mapM createPanel screens + forM_ panels $ \panel -> do + setPanelProperties panel + liftIO $ mapWindow disp (panelWindow panel) + + modify $ \state -> state { phiPanels = panels } + + state <- get + liftIO $ allocaXEvent $ \xevent -> runPhi state $ do + forever $ do + liftIO $ nextEvent disp xevent + event <- liftIO $ getEvent xevent + + case event of + ExposeEvent {} -> updatePanels + PropertyEvent {} -> handlePropertyUpdate event + _ -> return () + return () + + +updatePanels :: Phi () +updatePanels = do + disp <- gets 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 + disp <- gets phiDisplay + panels <- gets phiPanels + atom_XROOTPMAP_ID <- liftIO $ internAtom disp "_XROOTPMAP_ID" False + atom_XROOTMAP_ID <- liftIO $ internAtom disp "_XROOTMAP_ID" False + + when (atom == atom_XROOTPMAP_ID || atom == atom_XROOTMAP_ID) $ do + updateRootPixmap + updatePanels + + +updateRootPixmap :: Phi () +updateRootPixmap = do + disp <- gets phiDisplay + let screen = defaultScreen disp + rootwin = defaultRootWindow disp + atom_XROOTPMAP_ID <- liftIO $ internAtom disp "_XROOTPMAP_ID" False + atom_XROOTMAP_ID <- liftIO $ internAtom disp "_XROOTMAP_ID" False + pixmap <- liftM (fromMaybe 0 . listToMaybe . join . catMaybes) $ forM [atom_XROOTPMAP_ID, atom_XROOTMAP_ID] $ \atom -> liftIO $ rawGetWindowProperty 32 disp atom rootwin + modify $ \state -> state { phiRootPixmap = pixmap } + + +createPanel :: Rectangle -> Phi PanelState +createPanel screen = do + config <- gets phiXConfig + let rect = panelBounds config screen + disp <- gets phiDisplay + 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 <- gets 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 <- gets phiDisplay + liftIO $ do + atom_NET_WM_WINDOW_TYPE <- internAtom disp "_NET_WM_WINDOW_TYPE" False + atom_NET_WM_WINDOW_TYPE_DOCK <- internAtom disp "_NET_WM_WINDOW_TYPE_DOCK" False + + atom_NET_WM_DESKTOP <- internAtom disp "_NET_WM_DESKTOP" False + + atom_NET_WM_STATE <- internAtom disp "_NET_WM_STATE" False + atom_NET_WM_STATE_SKIP_PAGER <- internAtom disp "_NET_WM_STATE_SKIP_PAGER" False + atom_NET_WM_STATE_SKIP_TASKBAR <- internAtom disp "_NET_WM_STATE_SKIP_TASKBAR" False + atom_NET_WM_STATE_STICKY <- internAtom disp "_NET_WM_STATE_STICKY" False + atom_NET_WM_STATE_BELOW <- internAtom disp "_NET_WM_STATE_BELOW" False + + atom_MOTIF_WM_HINTS <- internAtom disp "_MOTIF_WM_HINTS" False + + storeName disp (panelWindow panel) "Phi" + changeProperty32 disp (panelWindow panel) atom_NET_WM_WINDOW_TYPE aTOM propModeReplace [fromIntegral atom_NET_WM_WINDOW_TYPE_DOCK] + changeProperty32 disp (panelWindow panel) atom_NET_WM_DESKTOP cARDINAL propModeReplace [0xFFFFFFFF] + changeProperty32 disp (panelWindow panel) atom_NET_WM_STATE aTOM propModeReplace [ fromIntegral atom_NET_WM_STATE_SKIP_PAGER + , fromIntegral atom_NET_WM_STATE_SKIP_TASKBAR + , fromIntegral atom_NET_WM_STATE_STICKY + , fromIntegral atom_NET_WM_STATE_BELOW] + 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 atom_MOTIF_WM_HINTS propModeReplace [ 2, 0, 0, 0, 0 ] + setStruts panel + + +setStruts :: PanelState -> Phi () +setStruts panel = do + disp <- gets phiDisplay + config <- gets phiXConfig + let rootwin = defaultRootWindow disp + position = phiPanelPosition config + area = panelArea panel + (_, _, _, _, rootHeight, _, _) <- liftIO $ getGeometry disp rootwin + + let struts = case position of + PanelPositionTop -> [ 0 + , 0 + , (fromIntegral $ rect_y area) + (fromIntegral $ rect_height area) + , 0 + , 0 + , 0 + , 0 + , 0 + , (fromIntegral $ rect_x area) + , (fromIntegral $ rect_x area) + (fromIntegral $ rect_width area) - 1 + , 0 + , 0 + ] + PanelPositionBottom -> [ 0 + , 0 + , 0 + , (fromIntegral rootHeight) - (fromIntegral $ rect_y area) + , 0 + , 0 + , 0 + , 0 + , 0 + , 0 + , (fromIntegral $ rect_x area) + , (fromIntegral $ rect_x area) + (fromIntegral $ rect_width area) - 1 + ] + + liftIO $ do + atom_NET_WM_STRUT <- internAtom disp "_NET_WM_STRUT" False + atom_NET_WM_STRUT_PARTIAL <- internAtom disp "_NET_WM_STRUT_PARTIAL" False + + changeProperty32 disp (panelWindow panel) atom_NET_WM_STRUT cARDINAL propModeReplace $ take 4 struts + changeProperty32 disp (panelWindow panel) atom_NET_WM_STRUT_PARTIAL cARDINAL propModeReplace struts + + +panelBounds :: PhiXConfig -> Rectangle -> Rectangle +panelBounds config screenBounds = case phiPanelPosition config of + PanelPositionTop -> screenBounds { rect_height = fromIntegral $ phiPanelSize config } + PanelPositionBottom -> screenBounds { rect_height = fromIntegral $ phiPanelSize config, + rect_y = (rect_y screenBounds) + (fromIntegral $ rect_height screenBounds) - (fromIntegral $ phiPanelSize 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) -- cgit v1.2.3