Implemented basic panel windows with pseudo-transparency
This commit is contained in:
commit
ade33320e5
7 changed files with 332 additions and 0 deletions
2
.gitignore
vendored
Normal file
2
.gitignore
vendored
Normal file
|
|
@ -0,0 +1,2 @@
|
|||
*~
|
||||
dist
|
||||
24
LICENSE
Normal file
24
LICENSE
Normal file
|
|
@ -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.
|
||||
3
Setup.lhs
Normal file
3
Setup.lhs
Normal file
|
|
@ -0,0 +1,3 @@
|
|||
#!/usr/bin/env runhaskell
|
||||
> import Distribution.Simple
|
||||
> main = defaultMain
|
||||
21
phi.cabal
Normal file
21
phi.cabal
Normal file
|
|
@ -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
|
||||
6
src/Phi.hs
Normal file
6
src/Phi.hs
Normal file
|
|
@ -0,0 +1,6 @@
|
|||
import Phi.Panel
|
||||
import Phi.X11
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
initPhi phiDefaultXConfig { phiPanelPosition = PanelPositionBottom }
|
||||
40
src/Phi/Panel.hs
Normal file
40
src/Phi/Panel.hs
Normal file
|
|
@ -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
|
||||
236
src/Phi/X11.hs
Normal file
236
src/Phi/X11.hs
Normal file
|
|
@ -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)
|
||||
Reference in a new issue