diff options
Diffstat (limited to 'src/Phi')
| -rw-r--r-- | src/Phi/Panel.hs | 40 | ||||
| -rw-r--r-- | src/Phi/X11.hs | 236 |
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) |