summaryrefslogtreecommitdiffstats
path: root/lib/Phi/X11.hs
diff options
context:
space:
mode:
Diffstat (limited to 'lib/Phi/X11.hs')
-rw-r--r--lib/Phi/X11.hs115
1 files changed, 59 insertions, 56 deletions
diff --git a/lib/Phi/X11.hs b/lib/Phi/X11.hs
index 971be37..dbaaf28 100644
--- a/lib/Phi/X11.hs
+++ b/lib/Phi/X11.hs
@@ -43,33 +43,33 @@ data PhiState w s c = (Widget.Widget w s c) => PhiState { phiRootImage :: !Su
, phiRepaint :: !Bool
, phiShutdown :: !Bool
, phiShutdownHold :: !Int
+ , phiWidgetState :: !s
}
data PanelState w s c = (Widget.Widget w s c) => PanelState { panelWindow :: !Window
, panelPixmap :: !Pixmap
, panelArea :: !Rectangle
, panelScreenArea :: !Rectangle
- , panelWidget :: !w
- , panelWidgetState :: !s
, panelWidgetCache :: !c
}
-data PhiConfig = PhiConfig { phiPhi :: !Phi
- , phiPanelConfig :: !Panel.PanelConfig
- , phiXConfig :: !XConfig
- , phiAtoms :: !Atoms
- }
+data PhiConfig w s c = PhiConfig { phiPhi :: !Phi
+ , phiPanelConfig :: !Panel.PanelConfig
+ , phiXConfig :: !XConfig
+ , phiAtoms :: !Atoms
+ , phiWidget :: !w
+ }
-newtype PhiReader a = PhiReader (ReaderT PhiConfig IO a)
- deriving (Monad, MonadReader PhiConfig, MonadIO)
+newtype PhiReader w s c a = PhiReader (ReaderT (PhiConfig w s c) IO a)
+ deriving (Monad, MonadReader (PhiConfig w s c), MonadIO)
-runPhiReader :: PhiConfig -> PhiReader a -> IO a
+runPhiReader :: PhiConfig w s c -> PhiReader w s c a -> IO a
runPhiReader config (PhiReader a) = runReaderT a config
-newtype PhiX w s c a = PhiX (StateT (PhiState w s c) PhiReader a)
- deriving (Monad, MonadState (PhiState w s c), MonadReader PhiConfig, MonadIO)
+newtype PhiX w s c a = PhiX (StateT (PhiState w s c) (PhiReader w s c) a)
+ deriving (Monad, MonadState (PhiState w s c), MonadReader (PhiConfig w s c), MonadIO)
-runPhiX :: PhiConfig -> PhiState w s c -> PhiX w s c a -> IO (a, PhiState w s c)
+runPhiX :: PhiConfig w s c -> PhiState w s c -> PhiX w s c a -> IO (a, PhiState w s c)
runPhiX config st (PhiX a) = runPhiReader config $ runStateT a st
defaultXConfig = XConfig { phiXScreenInfo = getScreenInfo
@@ -91,30 +91,34 @@ runPhi xconfig config widget = do
selectInput disp (defaultRootWindow disp) $ propertyChangeMask.|.structureNotifyMask
bg <- createImageSurface FormatRGB24 1 1
- runPhiX PhiConfig { phiPhi = phi
- , phiXConfig = xconfig
- , phiPanelConfig = config
- , phiAtoms = atoms
- } PhiState { phiRootImage = bg
- , phiPanels = []
- , phiRepaint = True
- , phiShutdown = False
- , phiShutdownHold = 0
- } $ do
+
+ dispmvar <- newMVar disp
+ screens <- liftIO $ phiXScreenInfo xconfig disp
+ panelWindows <- mapM (createPanelWindow disp config) screens
+ let dispvar = Widget.Display dispmvar atoms
+ widget' = widget <~> separator 0 (if weight widget > 0 then 0 else 1)
+ screenPanels = zip screens panelWindows
+
+ initialState <- Widget.initWidget widget' phi dispvar screenPanels
+
+ runPhiX
+ PhiConfig { phiPhi = phi
+ , phiXConfig = xconfig
+ , phiPanelConfig = config
+ , phiAtoms = atoms
+ , phiWidget = widget'
+ }
+ PhiState { phiRootImage = bg
+ , phiPanels = []
+ , phiRepaint = True
+ , phiShutdown = False
+ , phiShutdownHold = 0
+ , phiWidgetState = initialState
+ } $ do
updateRootImage disp
- screens <- liftIO $ phiXScreenInfo xconfig disp
-
- panelWindows <- mapM (createPanelWindow disp) screens
-
- dispmvar <- liftIO $ newMVar disp
- let screenPanels = zip screens panelWindows
- dispvar = Widget.Display dispmvar atoms screenPanels
- widget' = widget <~> separator 0 (if weight widget > 0 then 0 else 1)
- widgetState <- liftIO $ Widget.initWidget widget' phi dispvar
-
Widget.withDisplay dispvar $ \disp -> do
- panels <- mapM (\(screen, window) -> createPanel disp window widget' widgetState screen) screenPanels
+ panels <- mapM (\(screen, window) -> createPanel disp window screen) screenPanels
forM_ panels $ \panel -> do
setPanelProperties disp panel
@@ -158,14 +162,10 @@ termHandler :: Phi -> Handler
termHandler phi = Catch $ sendMessage phi Shutdown
-handlePanel :: Message -> PanelState w s c -> PanelState w s c
-handlePanel message panel@PanelState {panelWidget = widget, panelWidgetState = state} = panel {panelWidgetState = state'}
- where
- state' = Widget.handleMessage widget state message
-
-handleMessage :: Widget.Display -> Message -> PhiX w s c ()
+handleMessage :: (Widget w s c) => Widget.Display -> Message -> PhiX w s c ()
handleMessage dispvar m = do
- modify $ \state@PhiState {phiPanels = panels} -> state {phiPanels = map (handlePanel m) panels}
+ w <- asks phiWidget
+ modify $ \state -> state {phiWidgetState = Widget.handleMessage w (phiWidgetState state) m}
case (fromMessage m) of
Just Repaint ->
@@ -193,10 +193,13 @@ receiveEvents phi dispvar = do
return True
else return False
- when (not handled) $ threadWaitRead connection
+ --when (not handled) $ threadWaitRead connection
+ when (not handled) $ threadDelay 40000
updatePanels :: (Widget w s c) => Widget.Display -> PhiX w s c ()
updatePanels dispvar = do
+ w <- asks phiWidget
+ s <- gets phiWidgetState
rootImage <- gets phiRootImage
panels <- gets phiPanels
@@ -204,9 +207,8 @@ updatePanels dispvar = do
let pixmap = panelPixmap panel
area = panelArea panel
- let layoutedWidget = (withDimension area $ Widget.layout (panelWidget panel) (panelWidgetState panel)) $ panelScreenArea panel
(panelSurfaces, cache') <- liftIO $ flip runStateT (panelWidgetCache panel) $
- (withDimension area $ Widget.render (panelWidget panel) layoutedWidget 0 0) (panelScreenArea panel)
+ (withDimension area $ Widget.render w s 0 0) (panelScreenArea panel)
Widget.withDisplay dispvar $ \disp -> do
let screen = defaultScreen disp
@@ -237,14 +239,13 @@ updatePanels dispvar = do
surfaceFinish xbuffer
- -- copy buffer to window
+ -- update window
liftIO $ do
(withDimension area $ clearArea disp (panelWindow panel) 0 0) True
--(withDimension area $ copyArea disp (panelPixmap panel) (panelWindow panel) (defaultGC disp $ defaultScreen disp) 0 0) 0 0
sync disp False
- return $ panel { panelWidgetState = layoutedWidget, panelWidgetCache = cache' }
-
+ return $ panel { panelWidgetCache = cache' }
modify $ \state -> state { phiPanels = panels' }
@@ -271,7 +272,11 @@ updateRootImage disp = do
pixmap <- liftM (fromIntegral . fromMaybe 0 . listToMaybe . join . catMaybes) $ forM [atom_XROOTPMAP_ID atoms, atom_XROOTMAP_ID atoms] $
\atom -> liftIO $ getWindowProperty32 disp atom rootwin
- (_, _, _, pixmapWidth, pixmapHeight, _, _) <- liftIO $ getGeometry disp pixmap
+ (pixmapWidth, pixmapHeight) <- case pixmap of
+ 0 -> return (1, 1)
+ _ -> do
+ (_, _, _, pixmapWidth, pixmapHeight, _, _) <- liftIO $ getGeometry disp pixmap
+ return (pixmapWidth, pixmapHeight)
-- update surface size
oldBg <- gets phiRootImage
@@ -299,11 +304,12 @@ updateRootImage disp = do
surfaceFinish rootSurface
-createPanel :: (Widget w s c) => Display -> Window -> w -> s -> Rectangle -> PhiX w s c (PanelState w s c)
-createPanel disp win w s screenRect = do
+createPanel :: (Widget w s c) => Display -> Window -> Rectangle -> PhiX w s c (PanelState w s c)
+createPanel disp win screenRect = do
config <- asks phiPanelConfig
+ w <- asks phiWidget
let rect = panelBounds config screenRect
- let screen = defaultScreen disp
+ screen = defaultScreen disp
depth = defaultDepth disp screen
pixmap <- liftIO $ (withDimension rect $ createPixmap disp win) depth
@@ -313,14 +319,11 @@ createPanel disp win w s screenRect = do
, panelPixmap = pixmap
, panelArea = rect
, panelScreenArea = screenRect
- , panelWidget = w
- , panelWidgetState = s
, panelWidgetCache = initCache w
}
-createPanelWindow :: Display -> Rectangle -> PhiX w s c Window
-createPanelWindow disp screenRect = do
- config <- asks phiPanelConfig
+createPanelWindow :: Display -> Panel.PanelConfig -> Rectangle -> IO Window
+createPanelWindow disp config screenRect = do
let rect = panelBounds config screenRect
screen = defaultScreen disp
depth = defaultDepth disp screen
generated by cgit v1.2.3 (git 2.25.1) at 2024-05-03 05:47:08 +0200