summaryrefslogtreecommitdiffstats
path: root/src/Phi
diff options
context:
space:
mode:
Diffstat (limited to 'src/Phi')
-rw-r--r--src/Phi/Panel.hs40
-rw-r--r--src/Phi/X11.hs236
2 files changed, 0 insertions, 276 deletions
diff --git a/src/Phi/Panel.hs b/src/Phi/Panel.hs
deleted file mode 100644
index 23b022f..0000000
--- a/src/Phi/Panel.hs
+++ /dev/null
@@ -1,40 +0,0 @@
-{-# 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
deleted file mode 100644
index 06bebfa..0000000
--- a/src/Phi/X11.hs
+++ /dev/null
@@ -1,236 +0,0 @@
-{-# 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)