Implemented basic panel windows with pseudo-transparency

.gitignore

@@ -0,0 +1,2 @@
+*~
+dist

LICENSE

@@ -0,0 +1,24 @@
+Copyright (c) 2011, Matthias Schiffer <mschiffer@universe-factory.net>
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+    * Redistributions of source code must retain the above copyright
+      notice, this list of conditions and the following disclaimer.
+    * Redistributions in binary form must reproduce the above copyright
+      notice, this list of conditions and the following disclaimer in the
+      documentation and/or other materials provided with the distribution.
+    * Neither the name of the <organization> nor the
+      names of its contributors may be used to endorse or promote products
+      derived from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
+DISCLAIMED. IN NO EVENT SHALL <COPYRIGHT HOLDER> BE LIABLE FOR ANY
+DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
+(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
+LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
+ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

Setup.lhs

@@ -0,0 +1,3 @@
+#!/usr/bin/env runhaskell
+> import Distribution.Simple
+> main = defaultMain

phi.cabal

@@ -0,0 +1,21 @@
+cabal-version:       >= 1.2
+name:                phi
+version:             0.1
+synopsis:            An X panel
+description:         An X panel
+category:            X11
+license:             BSD3
+license-file:        LICENSE
+author:              Matthias Schiffer
+maintainer:          mschiffer@universe-factory.net
+build-type:          Simple
+
+library
+  build-depends:     base >= 4, mtl, cairo, X11
+  exposed-modules:   Phi.Panel
+  hs-source-dirs:    src
+
+executable Phi
+  build-depends:       base >= 4
+  hs-source-dirs:      src
+  main-is:             Phi.hs

src/Phi.hs

@@ -0,0 +1,6 @@
+import Phi.Panel
+import Phi.X11
+
+main :: IO ()
+main = do
+  initPhi phiDefaultXConfig { phiPanelPosition = PanelPositionBottom }

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

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)