Get rid of layout function
This commit is contained in:
parent
e48e3a6fe0
commit
7a87ba6f2e
7 changed files with 131 additions and 159 deletions
|
|
@ -79,17 +79,6 @@ instance Eq s => Widget (Border w s c) s (BorderCache w s c) where
|
|||
|
||||
weight (Border config _) = borderWeight config
|
||||
|
||||
layout (Border config w) s width height screen = case True of
|
||||
_ | width' > 0 -> layout w s width' height' screen
|
||||
| otherwise -> s
|
||||
where
|
||||
m = margin config
|
||||
bw = borderWidth config
|
||||
p = padding config
|
||||
|
||||
width' = width - borderH m - 2*bw - borderH p
|
||||
height' = height - borderV m - 2*bw - borderV p
|
||||
|
||||
render (Border config w) s x y width height screen = case () of
|
||||
_ | (width > borderH m - 2*bw - borderH p) -> do
|
||||
border <- liftIO $ createImageSurface FormatARGB32 width height
|
||||
|
|
@ -104,7 +93,7 @@ instance Eq s => Widget (Border w s c) s (BorderCache w s c) where
|
|||
let surfaces' = (True, 0, Nothing):(map (\(updated, SurfaceSlice x surf) -> (updated, x+dx, Just surf)) surfaces)++[(True, width-rightWidth, Nothing)]
|
||||
surfacesWidths = zipWith (\(updated, x, surf) (_, x', _) -> (updated, x, x'-x, surf)) surfaces' (tail surfaces' ++ [(False, width, Nothing)])
|
||||
forM surfacesWidths $ \(updated, x, surfWidth, surf) -> do
|
||||
surf' <- liftIO $ createImageSurface FormatARGB32 surfWidth height
|
||||
surf' <- liftIO $ createImageSurface FormatARGB32 surfWidth height
|
||||
renderWith surf' $ do
|
||||
setOperator OperatorClear
|
||||
paint
|
||||
|
|
|
|||
|
|
@ -1,10 +1,9 @@
|
|||
{-# LANGUAGE ExistentialQuantification, StandaloneDeriving, MultiParamTypeClasses, FunctionalDependencies, TypeSynonymInstances, FlexibleInstances #-}
|
||||
{-# LANGUAGE ExistentialQuantification, StandaloneDeriving, DeriveDataTypeable, MultiParamTypeClasses, FunctionalDependencies, TypeSynonymInstances, FlexibleInstances #-}
|
||||
|
||||
module Phi.Widget ( Display(..)
|
||||
, withDisplay
|
||||
, getAtoms
|
||||
, getScreenWindows
|
||||
, getScreens
|
||||
, XMessage(..)
|
||||
, unionArea
|
||||
, SurfaceSlice(..)
|
||||
, Widget(..)
|
||||
|
|
@ -29,6 +28,7 @@ import Control.Monad.State.Strict hiding (lift)
|
|||
import Control.Monad.IO.Class
|
||||
|
||||
import Data.Maybe
|
||||
import Data.Typeable
|
||||
|
||||
import qualified Graphics.X11.Xlib as Xlib
|
||||
import Graphics.Rendering.Cairo
|
||||
|
|
@ -37,23 +37,19 @@ import Phi.Phi
|
|||
import Phi.X11.Atoms
|
||||
|
||||
|
||||
data Display = Display !(MVar Xlib.Display) !Atoms ![(Xlib.Rectangle, Xlib.Window)]
|
||||
data Display = Display !(MVar Xlib.Display) !Atoms
|
||||
|
||||
withDisplay :: MonadIO m => Display -> (Xlib.Display -> m a) -> m a
|
||||
withDisplay (Display dispvar _ _) f = do
|
||||
withDisplay (Display dispvar _) f = do
|
||||
disp <- liftIO $ takeMVar dispvar
|
||||
a <- f disp
|
||||
liftIO $ putMVar dispvar disp
|
||||
return a
|
||||
|
||||
getAtoms :: Display -> Atoms
|
||||
getAtoms (Display _ atoms _) = atoms
|
||||
getAtoms (Display _ atoms) = atoms
|
||||
|
||||
getScreenWindows :: Display -> [(Xlib.Rectangle, Xlib.Window)]
|
||||
getScreenWindows (Display _ _ screenWindows) = screenWindows
|
||||
|
||||
getScreens :: Display -> [Xlib.Rectangle]
|
||||
getScreens = map fst . getScreenWindows
|
||||
data XMessage = UpdateScreens [(Xlib.Rectangle, Xlib.Window)] deriving (Show, Typeable)
|
||||
|
||||
|
||||
unionArea :: Xlib.Rectangle -> Xlib.Rectangle -> Int
|
||||
|
|
@ -75,7 +71,7 @@ unionArea a b = fromIntegral $ uw*uh
|
|||
data SurfaceSlice = SurfaceSlice !Int !Surface
|
||||
|
||||
class Eq s => Widget w s c | w -> s, w -> c where
|
||||
initWidget :: w -> Phi -> Display -> IO s
|
||||
initWidget :: w -> Phi -> Display -> [(Xlib.Rectangle, Xlib.Window)] -> IO s
|
||||
|
||||
initCache :: w -> c
|
||||
|
||||
|
|
@ -84,9 +80,6 @@ class Eq s => Widget w s c | w -> s, w -> c where
|
|||
weight :: w -> Float
|
||||
weight _ = 0
|
||||
|
||||
layout :: w -> s -> Int -> Int -> Xlib.Rectangle -> s
|
||||
layout _ priv _ _ _ = priv
|
||||
|
||||
render :: w -> s -> Int -> Int -> Int -> Int -> Xlib.Rectangle -> StateT c IO [(Bool, SurfaceSlice)]
|
||||
|
||||
handleMessage :: w -> s -> Message -> s
|
||||
|
|
@ -125,43 +118,36 @@ renderCached widget state x y w h screen = do
|
|||
|
||||
data CompoundWidget a sa ca b sb cb = (Widget a sa ca, Widget b sb cb) => CompoundWidget !a !b
|
||||
|
||||
data CompoundState a sa ca b sb cb = (Widget a sa ca, Widget b sb cb) => CompoundState !sa !sb !Int
|
||||
data CompoundState a sa ca b sb cb = (Widget a sa ca, Widget b sb cb) => CompoundState !sa !sb
|
||||
deriving instance Eq (CompoundState a sa ca b sb cb)
|
||||
|
||||
data CompoundCache a sa ca b sb cb = (Widget a sa ca, Widget b sb cb) => CompoundCache !ca !cb
|
||||
|
||||
|
||||
instance Widget (CompoundWidget a sa ca b sb cb) (CompoundState a sa ca b sb cb) (CompoundCache a sa ca b sb cb) where
|
||||
initWidget (CompoundWidget a b) phi disp = liftM3 CompoundState (initWidget a phi disp) (initWidget b phi disp) (return 0)
|
||||
initWidget (CompoundWidget a b) phi disp screens = liftM2 CompoundState (initWidget a phi disp screens) (initWidget b phi disp screens)
|
||||
|
||||
initCache (CompoundWidget a b) = CompoundCache (initCache a) (initCache b)
|
||||
|
||||
minSize (CompoundWidget a b) (CompoundState da db _) height screen = minSize a da height screen + minSize b db height screen
|
||||
minSize (CompoundWidget a b) (CompoundState da db) height screen = minSize a da height screen + minSize b db height screen
|
||||
|
||||
weight (CompoundWidget a b) = weight' a + weight' b
|
||||
|
||||
layout c@(CompoundWidget a b) s@(CompoundState sa sb _) width height screen = CompoundState sa' sb' xb
|
||||
where
|
||||
sizesum = minSize c s height screen
|
||||
wsum = let wsum = weight c
|
||||
in if wsum > 0 then wsum else 1
|
||||
render c@(CompoundWidget a b) s@(CompoundState sa sb) x y w h screen = do
|
||||
let sizesum = minSize c s h screen
|
||||
wsum = let wsum = weight c
|
||||
in if wsum > 0 then wsum else 1
|
||||
surplus = w - sizesum
|
||||
xb = floor $ (fromIntegral $ minSize a sa h screen) + (fromIntegral surplus)*(weight' a)/wsum
|
||||
|
||||
surplus = width - sizesum
|
||||
|
||||
(xb, sa') = layoutWidget a sa
|
||||
(_, sb') = layoutWidget b sb
|
||||
|
||||
layoutWidget w s = let wWidth = floor $ (fromIntegral $ minSize w s height screen) + (fromIntegral surplus)*(weight' w)/wsum
|
||||
in (wWidth, layout w s wWidth height screen)
|
||||
|
||||
render (CompoundWidget a b) (CompoundState sa sb xb) x y w h screen = do
|
||||
CompoundCache ca cb <- get
|
||||
|
||||
(surfacea, ca') <- liftIO $ flip runStateT ca $ render a sa x y xb h screen
|
||||
(surfaceb, cb') <- liftIO $ flip runStateT cb $ render b sb (x+xb) y (w-xb) h screen
|
||||
put $ CompoundCache ca' cb'
|
||||
return $ surfacea ++ map (\(updated, SurfaceSlice x surface) -> (updated, SurfaceSlice (x+xb) surface)) surfaceb
|
||||
|
||||
handleMessage (CompoundWidget a b) (CompoundState sa sb xb) message = CompoundState (handleMessage a sa message) (handleMessage b sb message) xb
|
||||
handleMessage (CompoundWidget a b) (CompoundState sa sb) message = CompoundState (handleMessage a sa message) (handleMessage b sb message)
|
||||
|
||||
weight' :: (Widget a sa ca) => a -> Float
|
||||
weight' = max 0 . weight
|
||||
|
|
@ -172,7 +158,7 @@ a <~> b = CompoundWidget a b
|
|||
data Separator = Separator !Int !Float deriving (Show, Eq)
|
||||
|
||||
instance Widget Separator () (RenderCache Separator ()) where
|
||||
initWidget _ _ _ = return ()
|
||||
initWidget _ _ _ _ = return ()
|
||||
initCache _ = createRenderCache $ \_ _ _ _ _ _ _ -> do
|
||||
setOperator OperatorClear
|
||||
paint
|
||||
|
|
|
|||
|
|
@ -25,8 +25,6 @@ instance Eq s => Widget (AlphaBox w s c) s (AlphaBoxCache w s c) where
|
|||
|
||||
weight (AlphaBox _ w) = weight w
|
||||
|
||||
layout (AlphaBox _ w) = layout w
|
||||
|
||||
render (AlphaBox alpha w) s x y width height screen = do
|
||||
AlphaBoxCache c <- get
|
||||
(surfaces, c') <- liftIO $ flip runStateT c $ render w s x y width height screen
|
||||
|
|
|
|||
|
|
@ -43,7 +43,7 @@ data ClockState = ClockState !ZonedTime deriving (Show, Eq)
|
|||
data ClockMessage = UpdateTime !ZonedTime deriving (Show, Typeable)
|
||||
|
||||
instance Widget Clock ClockState (RenderCache Clock ClockState) where
|
||||
initWidget (Clock _) phi _ = do
|
||||
initWidget (Clock _) phi _ _ = do
|
||||
forkIO $ forever $ do
|
||||
time <- getZonedTime
|
||||
sendMessage phi $ UpdateTime time
|
||||
|
|
|
|||
|
|
@ -49,11 +49,11 @@ data SystrayMessage = AddIcon !Window !Window | RemoveIcon !Window | RenderIcon
|
|||
|
||||
|
||||
instance Widget Systray SystrayState (RenderCache Systray SystrayState) where
|
||||
initWidget (Systray) phi dispvar = do
|
||||
initWidget (Systray) phi dispvar screens = do
|
||||
phi' <- dupPhi phi
|
||||
forkIO $ systrayRunner phi' dispvar
|
||||
forkIO $ systrayRunner phi' dispvar $ snd . head $ screens
|
||||
|
||||
return $ SystrayState phi (head . getScreens $ dispvar) 0 []
|
||||
return $ SystrayState phi (fst . head $ screens) 0 []
|
||||
|
||||
initCache _ = createRenderCache $ \Systray (SystrayState phi systrayScreen reset icons) x y w h screen -> do
|
||||
when (screen == systrayScreen) $ do
|
||||
|
|
@ -77,12 +77,14 @@ instance Widget Systray SystrayState (RenderCache Systray SystrayState) where
|
|||
Just (AddIcon midParent window) -> SystrayState phi screen reset ((SystrayIconState midParent window):icons)
|
||||
Just (RemoveIcon window) -> SystrayState phi screen reset $ filter (\(SystrayIconState _ stateWindow) -> stateWindow /= window) icons
|
||||
_ -> case (fromMessage m) of
|
||||
Just ResetBackground -> SystrayState phi screen (reset+1) icons
|
||||
_ -> priv
|
||||
Just (UpdateScreens screens) -> SystrayState phi (fst . head $ screens) reset icons
|
||||
_ -> case (fromMessage m) of
|
||||
Just ResetBackground -> SystrayState phi screen (reset+1) icons
|
||||
_ -> priv
|
||||
|
||||
|
||||
systrayRunner :: Phi -> Display -> IO ()
|
||||
systrayRunner phi dispvar = do
|
||||
systrayRunner :: Phi -> Display -> Window -> IO ()
|
||||
systrayRunner phi dispvar panelWindow = do
|
||||
let atoms = getAtoms dispvar
|
||||
initSuccess <- withDisplay dispvar $ flip initSystray atoms
|
||||
|
||||
|
|
@ -94,7 +96,7 @@ systrayRunner phi dispvar = do
|
|||
m <- receiveMessage phi
|
||||
case (fromMessage m) of
|
||||
Just event ->
|
||||
handleEvent event phi dispvar xembedWindow
|
||||
handleEvent event phi dispvar panelWindow xembedWindow
|
||||
_ ->
|
||||
case (fromMessage m) of
|
||||
Just (RenderIcon midParent window x y w h) -> do
|
||||
|
|
@ -188,16 +190,15 @@ sYSTEM_TRAY_CANCEL_MESSAGE = 2
|
|||
xEMBED_EMBEDDED_NOTIFY :: CInt
|
||||
xEMBED_EMBEDDED_NOTIFY = 0
|
||||
|
||||
handleEvent :: Event -> Phi -> Display -> Window -> StateT (M.Map Window Window) IO ()
|
||||
handleEvent message@ClientMessageEvent { ev_message_type = message_type, ev_data = messageData, ev_window = window } phi dispvar xembedWindow = do
|
||||
handleEvent :: Event -> Phi -> Display -> Window -> Window -> StateT (M.Map Window Window) IO ()
|
||||
handleEvent message@ClientMessageEvent { ev_message_type = message_type, ev_data = messageData, ev_window = window } phi dispvar panelWindow xembedWindow = do
|
||||
let atoms = getAtoms dispvar
|
||||
screenWindows = getScreenWindows dispvar
|
||||
when (window == xembedWindow && message_type == atom_NET_SYSTEM_TRAY_OPCODE atoms) $ do
|
||||
case messageData of
|
||||
_:opcode:iconID:_ -> do
|
||||
case True of
|
||||
_ | opcode == sYSTEM_TRAY_REQUEST_DOCK -> do
|
||||
when (iconID /= 0) $ withDisplay dispvar $ \disp -> addIcon phi disp (getAtoms dispvar) (snd . head $ screenWindows) $ fromIntegral iconID
|
||||
when (iconID /= 0) $ withDisplay dispvar $ \disp -> addIcon phi disp (getAtoms dispvar) panelWindow $ fromIntegral iconID
|
||||
|
||||
| opcode == sYSTEM_TRAY_BEGIN_MESSAGE || opcode == sYSTEM_TRAY_CANCEL_MESSAGE ->
|
||||
return ()
|
||||
|
|
@ -210,13 +211,13 @@ handleEvent message@ClientMessageEvent { ev_message_type = message_type, ev_data
|
|||
_ ->
|
||||
return ()
|
||||
|
||||
handleEvent message@UnmapEvent { ev_window = window } phi dispvar xembedWindow =
|
||||
handleEvent message@UnmapEvent { ev_window = window } phi dispvar panelWindow xembedWindow =
|
||||
withDisplay dispvar $ \disp -> removeIcon phi disp True window
|
||||
|
||||
handleEvent message@DestroyWindowEvent { ev_window = window } phi dispvar xembedWindow =
|
||||
handleEvent message@DestroyWindowEvent { ev_window = window } phi dispvar panelWindow xembedWindow =
|
||||
withDisplay dispvar $ \disp -> removeIcon phi disp False window
|
||||
|
||||
handleEvent message@AnyEvent { ev_window = window } phi dispvar xembedWindow | ev_event_type message == reparentNotify = do
|
||||
handleEvent message@AnyEvent { ev_window = window } phi dispvar panelWindow xembedWindow | ev_event_type message == reparentNotify = do
|
||||
parent <- liftIO $ alloca $ \rootPtr -> alloca $ \parentPtr -> alloca $ \childrenPtrPtr -> alloca $ \nChildrenPtr -> do
|
||||
status <- withDisplay dispvar $ \disp -> xQueryTree disp window rootPtr parentPtr childrenPtrPtr nChildrenPtr
|
||||
case status of
|
||||
|
|
@ -232,7 +233,7 @@ handleEvent message@AnyEvent { ev_window = window } phi dispvar xembedWindow | e
|
|||
withDisplay dispvar $ \disp -> removeIcon phi disp False window
|
||||
return ()
|
||||
|
||||
handleEvent _ _ _ _ = return ()
|
||||
handleEvent _ _ _ _ _ = return ()
|
||||
|
||||
|
||||
addIcon :: Phi -> Xlib.Display -> Atoms -> Window -> Window -> StateT (M.Map Window Window) IO ()
|
||||
|
|
|
|||
|
|
@ -137,7 +137,8 @@ defaultTaskbarConfig = TaskbarConfig { taskMaxSize = 200
|
|||
|
||||
data Taskbar = Taskbar TaskbarConfig
|
||||
|
||||
data TaskbarState = TaskbarState { taskbarActiveWindow :: !Window
|
||||
data TaskbarState = TaskbarState { taskbarScreens :: ![Xlib.Rectangle]
|
||||
, taskbarActiveWindow :: !Window
|
||||
, taskbarDesktopCount :: !Int
|
||||
, taskbarCurrentDesktop :: !Int
|
||||
, taskbarWindows :: ![Window]
|
||||
|
|
@ -154,11 +155,11 @@ createIcon size surface = do
|
|||
return $ Icon id size surface
|
||||
|
||||
|
||||
data WindowState = WindowState { windowTitle :: !String
|
||||
, windowDesktop :: !Int
|
||||
, windowVisible :: !Bool
|
||||
, windowIcons :: ![Icon]
|
||||
, windowScreen :: !Xlib.Rectangle
|
||||
data WindowState = WindowState { windowTitle :: !String
|
||||
, windowDesktop :: !Int
|
||||
, windowVisible :: !Bool
|
||||
, windowIcons :: ![Icon]
|
||||
, windowGeometry :: !Xlib.Rectangle
|
||||
} deriving (Eq, Show)
|
||||
|
||||
data WindowCache = WindowCache { createScaledIconCached :: !(IOCache ([Icon], Int) (Maybe Icon))
|
||||
|
|
@ -205,24 +206,26 @@ data TaskbarMessage = WindowListUpdate ![Xlib.Window] !(M.Map Window WindowState
|
|||
deriving (Typeable, Show)
|
||||
|
||||
instance Widget Taskbar TaskbarState (M.Map Window WindowCache) where
|
||||
initWidget (Taskbar _) phi dispvar = do
|
||||
initWidget (Taskbar _) phi dispvar screens = do
|
||||
phi' <- dupPhi phi
|
||||
forkIO $ taskbarRunner phi' dispvar
|
||||
|
||||
return $ TaskbarState 0 0 (-1) [] M.empty
|
||||
return $ TaskbarState (map fst screens) 0 0 (-1) [] M.empty
|
||||
|
||||
initCache _ = M.empty
|
||||
|
||||
minSize _ _ _ _ = 0
|
||||
weight _ = 1
|
||||
|
||||
render (Taskbar config) TaskbarState { taskbarActiveWindow = activeWindow
|
||||
render (Taskbar config) TaskbarState { taskbarScreens = screens
|
||||
, taskbarActiveWindow = activeWindow
|
||||
, taskbarDesktopCount = desktopCount
|
||||
, taskbarCurrentDesktop = currentDesktop
|
||||
, taskbarWindows = windows
|
||||
, taskbarWindowStates = windowStates
|
||||
} _ _ w h screen = do
|
||||
let screenWindows = filter ((== Just screen) . fmap windowScreen . flip M.lookup windowStates) windows
|
||||
let windowScreen w = maximumBy (compare `on` unionArea (windowGeometry w)) screens
|
||||
screenWindows = filter ((== Just screen) . fmap windowScreen . flip M.lookup windowStates) windows
|
||||
desktopNumbers = take desktopCount [0..]
|
||||
desktops = map (\desktop -> (desktop, filter (fromMaybe False . fmap (windowOnDesktop desktop) . flip M.lookup windowStates) screenWindows)) desktopNumbers
|
||||
|
||||
|
|
@ -301,7 +304,9 @@ instance Widget Taskbar TaskbarState (M.Map Window WindowCache) where
|
|||
Just (DesktopCountUpdate count) -> priv {taskbarDesktopCount = count}
|
||||
Just (CurrentDesktopUpdate current) -> priv {taskbarCurrentDesktop = current}
|
||||
Just (ActiveWindowUpdate window) -> priv {taskbarActiveWindow = window}
|
||||
_ -> priv
|
||||
_ -> case (fromMessage m) of
|
||||
Just (UpdateScreens screens) -> priv {taskbarScreens = map fst screens}
|
||||
_ -> priv
|
||||
|
||||
|
||||
renderText :: String -> Int -> Int -> Int -> Int -> String -> Render ()
|
||||
|
|
@ -390,9 +395,8 @@ windowOnDesktop desktop state = (windowVisible state) && (desktop == windowDeskt
|
|||
|
||||
taskbarRunner :: Phi -> Display -> IO ()
|
||||
taskbarRunner phi dispvar = do
|
||||
let screens = getScreens dispvar
|
||||
(windows, states) <- liftIO $ withDisplay dispvar $ \disp -> do
|
||||
(windows, states) <- getWindowStates disp screens (getAtoms dispvar) M.empty
|
||||
(windows, states) <- getWindowStates disp (getAtoms dispvar) M.empty
|
||||
desktopCount <- getDesktopCount disp (getAtoms dispvar)
|
||||
current <- getCurrentDesktop disp (getAtoms dispvar)
|
||||
activeWindow <- getActiveWindow disp (getAtoms dispvar)
|
||||
|
|
@ -414,7 +418,6 @@ taskbarRunner phi dispvar = do
|
|||
handleEvent :: Phi -> Display -> XExtras.Event -> StateT ([Window], M.Map Window WindowState) IO ()
|
||||
handleEvent phi dispvar XExtras.PropertyEvent {XExtras.ev_atom = atom, XExtras.ev_window = window} = do
|
||||
let atoms = getAtoms dispvar
|
||||
let screens = getScreens dispvar
|
||||
|
||||
when (elem atom $ Xlib.wM_NAME : map ($ atoms) [ atom_NET_ACTIVE_WINDOW
|
||||
, atom_NET_NUMBER_OF_DESKTOPS
|
||||
|
|
@ -442,7 +445,7 @@ handleEvent phi dispvar XExtras.PropertyEvent {XExtras.ev_atom = atom, XExtras.e
|
|||
sendMessage phi Repaint
|
||||
when (atom == atom_NET_CLIENT_LIST atoms) $ do
|
||||
(windows, windowStates) <- get
|
||||
(windows', windowStates') <- liftIO $ getWindowStates disp screens atoms windowStates
|
||||
(windows', windowStates') <- liftIO $ getWindowStates disp atoms windowStates
|
||||
|
||||
when (windows /= windows') $ do
|
||||
sendMessage phi $ WindowListUpdate windows' windowStates'
|
||||
|
|
@ -476,14 +479,12 @@ handleEvent phi dispvar XExtras.PropertyEvent {XExtras.ev_atom = atom, XExtras.e
|
|||
return ()
|
||||
|
||||
handleEvent phi dispvar XExtras.ConfigureEvent {XExtras.ev_window = window} = do
|
||||
let screens = getScreens dispvar
|
||||
|
||||
(windows, windowStates) <- get
|
||||
when (elem window windows) $ withDisplay dispvar $ \disp -> do
|
||||
let screen = fmap windowScreen . M.lookup window $ windowStates
|
||||
screen' <- liftIO $ getWindowScreen disp screens window
|
||||
when (screen /= (Just screen')) $ do
|
||||
let windowStates' = M.update (\state -> Just state {windowScreen = screen'}) window windowStates
|
||||
let geom = fmap windowGeometry . M.lookup window $ windowStates
|
||||
geom' <- liftIO $ getWindowGeometry disp window
|
||||
when (geom /= (Just geom')) $ do
|
||||
let windowStates' = M.update (\state -> Just state {windowGeometry = geom'}) window windowStates
|
||||
sendMessage phi $ WindowListUpdate windows windowStates'
|
||||
sendMessage phi Repaint
|
||||
put (windows, windowStates')
|
||||
|
|
@ -504,8 +505,8 @@ getActiveWindow :: Xlib.Display -> Atoms -> IO Window
|
|||
getActiveWindow disp atoms =
|
||||
liftM (fromIntegral . fromMaybe 0 . join . fmap listToMaybe) $ XExtras.getWindowProperty32 disp (atom_NET_ACTIVE_WINDOW atoms) $ Xlib.defaultRootWindow disp
|
||||
|
||||
getWindowStates :: Xlib.Display -> [Xlib.Rectangle] -> Atoms -> M.Map Window WindowState -> IO ([Window], M.Map Window WindowState)
|
||||
getWindowStates disp screens atoms windowStates = do
|
||||
getWindowStates :: Xlib.Display -> Atoms -> M.Map Window WindowState -> IO ([Window], M.Map Window WindowState)
|
||||
getWindowStates disp atoms windowStates = do
|
||||
windows <- getWindowList disp atoms
|
||||
|
||||
let windowStates' = map (\w -> (w, M.lookup w windowStates)) windows
|
||||
|
|
@ -517,20 +518,20 @@ getWindowStates disp screens atoms windowStates = do
|
|||
getWindowState' (window, Just windowState) = return (window, windowState)
|
||||
getWindowState' (window, Nothing) = do
|
||||
Xlib.selectInput disp window $ Xlib.propertyChangeMask .|. Xlib.structureNotifyMask
|
||||
windowState <- getWindowState disp screens atoms window
|
||||
windowState <- getWindowState disp atoms window
|
||||
return (window, windowState)
|
||||
|
||||
getWindowState :: Xlib.Display -> [Xlib.Rectangle] -> Atoms -> Window -> IO WindowState
|
||||
getWindowState disp screens atoms window = do
|
||||
getWindowState :: Xlib.Display -> Atoms -> Window -> IO WindowState
|
||||
getWindowState disp atoms window = do
|
||||
(name, workspace, visible) <- getWindowInfo disp atoms window
|
||||
icons <- getWindowIcons disp atoms window
|
||||
screen <- getWindowScreen disp screens window
|
||||
geom <- getWindowGeometry disp window
|
||||
|
||||
return $ WindowState { windowTitle = name
|
||||
, windowDesktop = workspace
|
||||
, windowVisible = visible
|
||||
, windowIcons = icons
|
||||
, windowScreen = screen
|
||||
, windowGeometry = geom
|
||||
}
|
||||
|
||||
getWindowInfo :: Xlib.Display -> Atoms -> Window -> IO (String, Int, Bool)
|
||||
|
|
@ -581,18 +582,12 @@ premultiply c = a .|. r .|. g .|. b
|
|||
b = pm bmask
|
||||
|
||||
|
||||
getWindowScreen :: Xlib.Display -> [Xlib.Rectangle] -> Window -> IO Xlib.Rectangle
|
||||
getWindowScreen disp screens window = flip catch (\_ -> return $ head screens) $ do
|
||||
getWindowGeometry :: Xlib.Display -> Window -> IO Xlib.Rectangle
|
||||
getWindowGeometry disp window = flip catch (\_ -> return $ Xlib.Rectangle 0 0 0 0) $ do
|
||||
(_, _, _, width, height, _, _) <- Xlib.getGeometry disp window
|
||||
(ret, x, y, _) <- Xlib.translateCoordinates disp window (Xlib.defaultRootWindow disp) 0 0
|
||||
|
||||
case ret of
|
||||
True -> do
|
||||
let windowRect = Xlib.Rectangle x y width height
|
||||
screen = maximumBy (compare `on` unionArea windowRect) screens
|
||||
return screen
|
||||
False ->
|
||||
return $ head screens
|
||||
return $ if ret then Xlib.Rectangle x y width height else Xlib.Rectangle 0 0 0 0
|
||||
|
||||
|
||||
showWindow :: Xlib.Display -> Atoms -> Window -> IO Bool
|
||||
|
|
|
|||
115
lib/Phi/X11.hs
115
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
|
||||
|
|
|
|||
Reference in a new issue