diff options
Diffstat (limited to 'lib')
| -rw-r--r-- | lib/Phi/X11.hs | 80 | ||||
| -rw-r--r-- | lib/Phi/X11/AtomList.hs | 18 | ||||
| -rw-r--r-- | lib/Phi/X11/Atoms.hs | 36 |
3 files changed, 89 insertions, 45 deletions
diff --git a/lib/Phi/X11.hs b/lib/Phi/X11.hs index 53fed21..2645ac2 100644 --- a/lib/Phi/X11.hs +++ b/lib/Phi/X11.hs @@ -18,12 +18,12 @@ import Control.Monad.Reader import Control.Monad.Trans import qualified Phi.Panel as Panel +import Phi.X11.Atoms data XConfig = XConfig { phiXScreenInfo :: Display -> IO [Rectangle] } -data PhiState = PhiState { phiDisplay :: Display - , phiRootPixmap :: Pixmap +data PhiState = PhiState { phiRootPixmap :: Pixmap , phiPanels :: [PanelState] } @@ -35,6 +35,8 @@ data PanelState = PanelState { panelWindow :: Window data PhiConfig = PhiConfig { phiPanelConfig :: Panel.PanelConfig , phiXConfig :: XConfig + , phiDisplay :: Display + , phiAtoms :: Atoms } newtype PhiReader a = PhiReader (ReaderT PhiConfig IO a) @@ -64,9 +66,10 @@ defaultXConfig = XConfig { phiXScreenInfo = getScreenInfo initPhi :: XConfig -> Panel.PanelConfig -> IO () initPhi xconfig config = do disp <- openDisplay [] + atoms <- initAtoms disp selectInput disp (defaultRootWindow disp) $ propertyChangeMask.|.structureNotifyMask - runPhi PhiConfig { phiXConfig = xconfig, phiPanelConfig = config } PhiState { phiDisplay = disp, phiRootPixmap = 0, phiPanels = [] } $ do + runPhi PhiConfig { phiXConfig = xconfig, phiPanelConfig = config, phiDisplay = disp, phiAtoms = atoms } PhiState { phiRootPixmap = 0, phiPanels = [] } $ do updateRootPixmap screens <- liftIO $ phiXScreenInfo xconfig disp @@ -77,21 +80,23 @@ initPhi xconfig config = do modify $ \state -> state { phiPanels = panels } + updatePanels True + liftIOContToPhi allocaXEvent $ \xevent -> do forever $ do liftIO $ nextEvent disp xevent event <- liftIO $ getEvent xevent case event of - ExposeEvent {} -> updatePanels + ExposeEvent {} -> updatePanels False PropertyEvent {} -> handlePropertyUpdate event _ -> return () return () -updatePanels :: Phi () -updatePanels = do - disp <- gets phiDisplay +updatePanels :: Bool -> Phi () +updatePanels redraw = do + disp <- asks phiDisplay rootPixmap <- gets phiRootPixmap panels <- gets phiPanels forM_ panels $ \panel -> liftIO $ withRectangle (panelArea panel) (copyArea disp rootPixmap (panelWindow panel) (panelGC panel)) 0 0 @@ -99,32 +104,30 @@ updatePanels = do handlePropertyUpdate :: Event -> Phi () handlePropertyUpdate PropertyEvent { ev_atom = atom } = do - disp <- gets phiDisplay + atoms <- asks phiAtoms 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 + when (atom == atom_XROOTPMAP_ID atoms || atom == atom_XROOTMAP_ID atoms) $ do updateRootPixmap - updatePanels + updatePanels True updateRootPixmap :: Phi () updateRootPixmap = do - disp <- gets phiDisplay + disp <- asks phiDisplay + atoms <- asks phiAtoms 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 + pixmap <- liftM (fromMaybe 0 . listToMaybe . join . catMaybes) $ forM [atom_XROOTPMAP_ID atoms, atom_XROOTMAP_ID atoms] $ + \atom -> liftIO $ rawGetWindowProperty 32 disp atom rootwin modify $ \state -> state { phiRootPixmap = pixmap } createPanel :: Rectangle -> Phi PanelState createPanel screen = do config <- asks phiPanelConfig + disp <- asks phiDisplay 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 } @@ -132,7 +135,7 @@ createPanel screen = do createPanelWindow :: Rectangle -> Phi Window createPanelWindow rect = do - disp <- gets phiDisplay + disp <- asks phiDisplay let screen = defaultScreen disp depth = defaultDepth disp screen visual = defaultVisual disp screen @@ -150,28 +153,17 @@ createPanelWindow rect = do setPanelProperties :: PanelState -> Phi () setPanelProperties panel = do - disp <- gets phiDisplay + disp <- asks phiDisplay + atoms <- asks phiAtoms 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] + changeProperty32 disp (panelWindow panel) (atom_NET_WM_WINDOW_TYPE atoms) aTOM propModeReplace [fromIntegral (atom_NET_WM_WINDOW_TYPE_DOCK atoms)] + changeProperty32 disp (panelWindow panel) (atom_NET_WM_DESKTOP atoms) cARDINAL propModeReplace [0xFFFFFFFF] + changeProperty32 disp (panelWindow panel) (atom_NET_WM_STATE atoms) aTOM propModeReplace [ fromIntegral (atom_NET_WM_STATE_SKIP_PAGER atoms) + , fromIntegral (atom_NET_WM_STATE_SKIP_TASKBAR atoms) + , fromIntegral (atom_NET_WM_STATE_STICKY atoms) + , fromIntegral (atom_NET_WM_STATE_BELOW atoms) + ] setWMHints disp (panelWindow panel) WMHints { wmh_flags = fromIntegral inputHintBit , wmh_input = False , wmh_initial_state = 0 @@ -182,13 +174,14 @@ setPanelProperties panel = do , 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 ] + changeProperty32 disp (panelWindow panel) (atom_MOTIF_WM_HINTS atoms) (atom_MOTIF_WM_HINTS atoms) propModeReplace [ 2, 0, 0, 0, 0 ] setStruts panel setStruts :: PanelState -> Phi () setStruts panel = do - disp <- gets phiDisplay + atoms <- asks phiAtoms + disp <- asks phiDisplay config <- asks phiPanelConfig let rootwin = defaultRootWindow disp position = Panel.panelPosition config @@ -212,11 +205,8 @@ setStruts panel = do Panel.Bottom -> makeBottomStruts 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 + changeProperty32 disp (panelWindow panel) (atom_NET_WM_STRUT atoms) cARDINAL propModeReplace $ take 4 struts + changeProperty32 disp (panelWindow panel) (atom_NET_WM_STRUT_PARTIAL atoms) cARDINAL propModeReplace struts panelBounds :: Panel.PanelConfig -> Rectangle -> Rectangle diff --git a/lib/Phi/X11/AtomList.hs b/lib/Phi/X11/AtomList.hs new file mode 100644 index 0000000..60cd0c5 --- /dev/null +++ b/lib/Phi/X11/AtomList.hs @@ -0,0 +1,18 @@ +module Phi.X11.AtomList ( atoms + ) where + +atoms = [ "_XROOTPMAP_ID" + , "_XROOTMAP_ID" + , "_NET_WM_WINDOW_TYPE" + , "_NET_WM_WINDOW_TYPE_DOCK" + , "_NET_WM_DESKTOP" + , "_NET_WM_STATE" + , "_NET_WM_STATE_SKIP_PAGER" + , "_NET_WM_STATE_SKIP_TASKBAR" + , "_NET_WM_STATE_STICKY" + , "_NET_WM_STATE_BELOW" + , "_MOTIF_WM_HINTS" + , "_NET_WM_STRUT" + , "_NET_WM_STRUT_PARTIAL" + ] + diff --git a/lib/Phi/X11/Atoms.hs b/lib/Phi/X11/Atoms.hs new file mode 100644 index 0000000..a2708dd --- /dev/null +++ b/lib/Phi/X11/Atoms.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Phi.X11.Atoms ( Atoms(..) + , initAtoms + ) where + +import Control.Monad +import Language.Haskell.TH +import Graphics.X11 + +import Phi.X11.AtomList + + +$(do + let atomsName = mkName "Atoms" + atomNames = map (\atom -> (atom, mkName ("atom" ++ atom))) atoms + fields = map (\(_, name) -> (name, IsStrict, ConT ''Atom)) atomNames + return [DataD [] atomsName [] [RecC atomsName fields] []] + ) + +initAtoms :: Display -> IO Atoms +initAtoms display = + $(do + let atomsName = mkName "Atoms" + atomNames <- mapM (\atom -> do + varName <- newName ('_':atom) + return (atom, mkName ("atom" ++ atom), varName) + ) atoms + atomInitializers <- forM atomNames $ + \(atom, _, varName) -> liftM (BindS (VarP varName)) [| internAtom display atom False |] + + let atomFieldExps = map (\(_, atomName, varName) -> (atomName, VarE varName)) atomNames + atomsContruction = NoBindS $ AppE (VarE 'return) $ RecConE atomsName atomFieldExps + + return $ DoE $ atomInitializers ++ [atomsContruction] + ) |