summaryrefslogtreecommitdiffstats
path: root/lib/Phi
diff options
context:
space:
mode:
authorMatthias Schiffer <mschiffer@universe-factory.net>2011-07-12 03:08:19 +0200
committerMatthias Schiffer <mschiffer@universe-factory.net>2011-07-12 03:08:19 +0200
commitc918dde366a02ed4de26ea0c5e07a153d8f902bb (patch)
treece8a24f997f1981d236bc7abc0227d6b0b997736 /lib/Phi
parentade33320e5ea201a847bb9ee5522ee58b1cd8cb6 (diff)
downloadphi-c918dde366a02ed4de26ea0c5e07a153d8f902bb.tar
phi-c918dde366a02ed4de26ea0c5e07a153d8f902bb.zip
Correctly divide into library and executable
Diffstat (limited to 'lib/Phi')
-rw-r--r--lib/Phi/Panel.hs40
-rw-r--r--lib/Phi/X11.hs236
2 files changed, 276 insertions, 0 deletions
diff --git a/lib/Phi/Panel.hs b/lib/Phi/Panel.hs
new file mode 100644
index 0000000..23b022f
--- /dev/null
+++ b/lib/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/lib/Phi/X11.hs b/lib/Phi/X11.hs
new file mode 100644
index 0000000..06bebfa
--- /dev/null
+++ b/lib/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)