From 4d519acbd48fa400f09e4705251a0dbf45c6876e Mon Sep 17 00:00:00 2001 From: Matthias Schiffer Date: Thu, 8 Sep 2011 19:15:23 +0200 Subject: Core is independent of X11 now --- lib/Phi/Border.hs | 8 +- lib/Phi/Widget.hs | 86 +++--- lib/Phi/Widgets/AlphaBox.hs | 8 +- lib/Phi/Widgets/Clock.hs | 8 +- lib/Phi/Widgets/Systray.hs | 294 ------------------- lib/Phi/Widgets/Taskbar.hs | 641 ---------------------------------------- lib/Phi/Widgets/X11/Systray.hs | 294 +++++++++++++++++++ lib/Phi/Widgets/X11/Taskbar.hs | 649 +++++++++++++++++++++++++++++++++++++++++ lib/Phi/X11.hs | 308 ++++++++++--------- lib/Phi/X11/AtomList.hs | 2 +- 10 files changed, 1164 insertions(+), 1134 deletions(-) delete mode 100644 lib/Phi/Widgets/Systray.hs delete mode 100644 lib/Phi/Widgets/Taskbar.hs create mode 100644 lib/Phi/Widgets/X11/Systray.hs create mode 100644 lib/Phi/Widgets/X11/Taskbar.hs (limited to 'lib') diff --git a/lib/Phi/Border.hs b/lib/Phi/Border.hs index ca5e515..2e1e008 100644 --- a/lib/Phi/Border.hs +++ b/lib/Phi/Border.hs @@ -56,11 +56,11 @@ defaultBorderConfig = BorderConfig { margin = simpleBorderWidth 0 , borderWeight = 1 } -data Border w s c = (Widget w s c) => Border !BorderConfig !w +data Border w s c d = (Widget w s c d) => Border !BorderConfig !w -data BorderCache w s c = (Widget w s c) => BorderCache !c +data BorderCache w s c d = (Widget w s c d) => BorderCache !c -instance Eq s => Widget (Border w s c) s (BorderCache w s c) where +instance (Eq s, Display d) => Widget (Border w s c d) s (BorderCache w s c d) d where initWidget (Border _ w) = initWidget w initCache (Border _ w) = BorderCache $ initCache w @@ -165,5 +165,5 @@ roundRectangle x y width height radius = do arc (x + radius) (y + radius) radius pi (pi*3/2) closePath -border :: (Widget w s c) => BorderConfig -> w -> Border w s c +border :: (Widget w s c d) => BorderConfig -> w -> Border w s c d border = Border diff --git a/lib/Phi/Widget.hs b/lib/Phi/Widget.hs index a598887..3687630 100644 --- a/lib/Phi/Widget.hs +++ b/lib/Phi/Widget.hs @@ -1,10 +1,7 @@ -{-# LANGUAGE ExistentialQuantification, StandaloneDeriving, DeriveDataTypeable, MultiParamTypeClasses, FunctionalDependencies, TypeSynonymInstances, FlexibleInstances #-} +{-# LANGUAGE ExistentialQuantification, StandaloneDeriving, MultiParamTypeClasses, FunctionalDependencies, TypeSynonymInstances, FlexibleInstances, TypeFamilies #-} -module Phi.Widget ( XEvent(..) +module Phi.Widget ( Rectangle(..) , Display(..) - , withDisplay - , getAtoms - , XMessage(..) , unionArea , SurfaceSlice(..) , Widget(..) @@ -23,7 +20,6 @@ module Phi.Widget ( XEvent(..) import Control.Arrow import Control.Arrow.Transformer import Control.CacheArrow -import Control.Concurrent.MVar import Control.Monad import Control.Monad.State.Strict hiding (lift) import Control.Monad.IO.Class @@ -31,67 +27,57 @@ import Control.Monad.IO.Class import Data.Maybe import Data.Typeable -import Graphics.XHB import Graphics.Rendering.Cairo import Phi.Phi import Phi.X11.Atoms -data Display = Display !Connection !Atoms +data Rectangle = Rectangle { rect_x :: !Int + , rect_y :: !Int + , rect_width :: !Int + , rect_height :: !Int + } deriving (Show, Eq) -newtype XEvent = XEvent SomeEvent deriving Typeable +class Display d where + type Window d :: * -instance Show XEvent where - show _ = "XEvent (..)" - -withDisplay :: MonadIO m => Display -> (Connection -> m a) -> m a -withDisplay (Display conn _) f = f conn - -getAtoms :: Display -> Atoms -getAtoms (Display _ atoms) = atoms - -data XMessage = UpdateScreens [(RECTANGLE, WINDOW)] deriving (Show, Typeable) - - -unionArea :: RECTANGLE -> RECTANGLE -> Int +unionArea :: Rectangle -> Rectangle -> Int unionArea a b = uw*uh where - uw = max 0 $ (min ax2 bx2) - fromIntegral (max ax1 bx1) - uh = max 0 $ (min ay2 by2) - fromIntegral (max ay1 by1) + uw = max 0 $ (min ax2 bx2) - (max ax1 bx1) + uh = max 0 $ (min ay2 by2) - (max ay1 by1) - MkRECTANGLE ax1 ay1 aw ah = a - MkRECTANGLE bx1 by1 bw bh = b + Rectangle ax1 ay1 aw ah = a + Rectangle bx1 by1 bw bh = b - ax2 = fromIntegral ax1 + fromIntegral aw - ay2 = fromIntegral ay1 + fromIntegral ah + ax2 = ax1 + aw + ay2 = ay1 + ah - bx2 = fromIntegral bx1 + fromIntegral bw - by2 = fromIntegral by1 + fromIntegral bh + bx2 = bx1 + bw + by2 = by1 + bh data SurfaceSlice = SurfaceSlice !Int !Surface -class Eq s => Widget w s c | w -> s, w -> c where - initWidget :: w -> Phi -> Display -> [(RECTANGLE, WINDOW)] -> IO s +class (Eq s, Display d) => Widget w s c d | w -> s, w -> c, w -> d where + initWidget :: w -> Phi -> d -> [(Rectangle, Window d)] -> IO s initCache :: w -> c - minSize :: w -> s -> Int -> RECTANGLE -> Int + minSize :: w -> s -> Int -> Rectangle -> Int weight :: w -> Float weight _ = 0 - render :: w -> s -> Int -> Int -> Int -> Int -> RECTANGLE -> StateT c IO [(Bool, SurfaceSlice)] + render :: w -> s -> Int -> Int -> Int -> Int -> Rectangle -> StateT c IO [(Bool, SurfaceSlice)] handleMessage :: w -> s -> Message -> s handleMessage _ priv _ = priv -deriving instance Eq RECTANGLE - type IOCache = CacheArrow (Kleisli IO) -type RenderCache s = IOCache (s, Int, Int, Int, Int, RECTANGLE) Surface +type RenderCache s = IOCache (s, Int, Int, Int, Int, Rectangle) Surface createIOCache :: Eq a => (a -> IO b) -> IOCache a b createIOCache = lift . Kleisli @@ -103,8 +89,8 @@ runIOCache a = do put cache' return b -createRenderCache :: (s -> Int -> Int -> Int -> Int -> RECTANGLE -> Render ()) - -> CacheArrow (Kleisli IO) (s, Int, Int, Int, Int, RECTANGLE) Surface +createRenderCache :: (s -> Int -> Int -> Int -> Int -> Rectangle -> Render ()) + -> CacheArrow (Kleisli IO) (s, Int, Int, Int, Int, Rectangle) Surface createRenderCache f = lift . Kleisli $ \(state, x, y, w, h, screen) -> do surface <- createImageSurface FormatARGB32 w h renderWith surface $ do @@ -114,22 +100,22 @@ createRenderCache f = lift . Kleisli $ \(state, x, y, w, h, screen) -> do f state x y w h screen return surface -renderCached :: Eq s => s -> Int -> Int -> Int -> Int -> RECTANGLE -> StateT (RenderCache s) IO [(Bool, SurfaceSlice)] +renderCached :: Eq s => s -> Int -> Int -> Int -> Int -> Rectangle -> StateT (RenderCache s) IO [(Bool, SurfaceSlice)] renderCached state x y w h screen = do cache <- get (surf, updated, cache') <- liftIO $ runKleisli (runCache' cache) (state, x, y, w, h, screen) put cache' return [(updated, SurfaceSlice 0 surf)] -data CompoundWidget a sa ca b sb cb = (Widget a sa ca, Widget b sb cb) => CompoundWidget !a !b +data CompoundWidget a sa ca b sb cb d = (Widget a sa ca d, Widget b sb cb d) => CompoundWidget !a !b -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 CompoundState a sa ca b sb cb d = (Widget a sa ca d, Widget b sb cb d) => CompoundState !sa !sb +deriving instance Eq (CompoundState a sa ca b sb cb d) -data CompoundCache a sa ca b sb cb = (Widget a sa ca, Widget b sb cb) => CompoundCache !ca !cb +data CompoundCache a sa ca b sb cb d = (Widget a sa ca d, Widget b sb cb d) => 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 +instance Display d => Widget (CompoundWidget a sa ca b sb cb d) (CompoundState a sa ca b sb cb d) (CompoundCache a sa ca b sb cb d) d where 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) @@ -154,15 +140,15 @@ instance Widget (CompoundWidget a sa ca b sb cb) (CompoundState a sa ca b sb cb) 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' :: (Widget a sa ca d) => a -> Float weight' = max 0 . weight -(<~>) :: (Widget a sa ca, Widget b sb cb) => a -> b -> CompoundWidget a sa ca b sb cb +(<~>) :: (Widget a sa ca d, Widget b sb cb d) => a -> b -> CompoundWidget a sa ca b sb cb d a <~> b = CompoundWidget a b -data Separator = Separator !Int !Float deriving (Show, Eq) +data Separator d = Separator !Int !Float deriving (Show, Eq) -instance Widget Separator () (RenderCache ()) where +instance Display d => Widget (Separator d) () (RenderCache ()) d where initWidget _ _ _ _ = return () initCache _ = createRenderCache $ \_ _ _ _ _ _ -> do setOperator OperatorClear @@ -173,5 +159,5 @@ instance Widget Separator () (RenderCache ()) where render _ = renderCached -separator :: Int -> Float -> Separator +separator :: Int -> Float -> Separator d separator = Separator diff --git a/lib/Phi/Widgets/AlphaBox.hs b/lib/Phi/Widgets/AlphaBox.hs index 6f989ea..59f8aea 100644 --- a/lib/Phi/Widgets/AlphaBox.hs +++ b/lib/Phi/Widgets/AlphaBox.hs @@ -13,11 +13,11 @@ import Control.Monad.State.Strict import Graphics.Rendering.Cairo -data AlphaBox w s c = (Widget w s c) => AlphaBox !Double !w +data AlphaBox w s c d = (Widget w s c d) => AlphaBox !Double !w -data AlphaBoxCache w s c = (Widget w s c) => AlphaBoxCache !c +data AlphaBoxCache w s c d = (Widget w s c d) => AlphaBoxCache !c -instance Eq s => Widget (AlphaBox w s c) s (AlphaBoxCache w s c) where +instance (Eq s, Display d) => Widget (AlphaBox w s c d) s (AlphaBoxCache w s c d) d where initWidget (AlphaBox _ w) = initWidget w initCache (AlphaBox _ w) = AlphaBoxCache $ initCache w @@ -47,6 +47,6 @@ instance Eq s => Widget (AlphaBox w s c) s (AlphaBoxCache w s c) where handleMessage (AlphaBox _ w) = handleMessage w -alphaBox :: (Widget w s c) => Double -> w -> AlphaBox w s c +alphaBox :: (Widget w s c d) => Double -> w -> AlphaBox w s c d alphaBox = AlphaBox diff --git a/lib/Phi/Widgets/Clock.hs b/lib/Phi/Widgets/Clock.hs index 9282432..26b777f 100644 --- a/lib/Phi/Widgets/Clock.hs +++ b/lib/Phi/Widgets/Clock.hs @@ -34,7 +34,7 @@ data ClockConfig = ClockConfig { clockFormat :: !String defaultClockConfig :: ClockConfig defaultClockConfig = ClockConfig "%R" (0, 0, 0, 1) 0 50 -data Clock = Clock !ClockConfig deriving (Show, Eq) +data Clock d = Clock !ClockConfig deriving (Show, Eq) deriving instance Eq ZonedTime @@ -42,7 +42,7 @@ data ClockState = ClockState !ZonedTime deriving (Show, Eq) data ClockMessage = UpdateTime !ZonedTime deriving (Show, Typeable) -instance Widget Clock ClockState (RenderCache ClockState) where +instance Display d => Widget (Clock d) ClockState (RenderCache ClockState) d where initWidget (Clock _) phi _ _ = do forkIO $ forever $ do time <- getZonedTime @@ -85,6 +85,6 @@ instance Widget Clock ClockState (RenderCache ClockState) where _ -> priv -clock :: ClockConfig -> Clock +clock :: ClockConfig -> Clock d clock config = do - Clock config \ No newline at end of file + Clock config diff --git a/lib/Phi/Widgets/Systray.hs b/lib/Phi/Widgets/Systray.hs deleted file mode 100644 index 27a5e34..0000000 --- a/lib/Phi/Widgets/Systray.hs +++ /dev/null @@ -1,294 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses, DeriveDataTypeable, TypeSynonymInstances, FlexibleInstances #-} - -module Phi.Widgets.Systray ( systray - ) where - -import Control.Concurrent -import Control.Monad -import Control.Monad.State -import Control.Monad.Trans - -import Data.Bits -import Data.IORef -import Data.Maybe -import Data.Typeable -import qualified Data.Map as M - -import Foreign.C.Types -import Foreign.Marshal -import Foreign.Ptr -import Foreign.Storable - -import Graphics.Rendering.Cairo -import Graphics.Rendering.Cairo.Types - -import Graphics.X11.Xlib hiding (Display) -import qualified Graphics.X11.Xlib as Xlib -import Graphics.X11.Xlib.Extras - -import Phi.Bindings.Util -import Phi.Bindings.SystrayErrorHandler - -import Phi.Phi -import Phi.Types -import Phi.Widget -import Phi.X11.Atoms - - -data SystrayIconState = SystrayIconState !Window !Window deriving (Show, Eq) - -instance Eq Phi where - _ == _ = True - -data SystrayState = SystrayState !Phi !Rectangle !Int ![SystrayIconState] deriving Eq - -data Systray = Systray deriving (Show, Eq) - -data SystrayMessage = AddIcon !Window !Window | RemoveIcon !Window | RenderIcon !Window !Window !Int !Int !Int !Int - deriving (Show, Typeable) - - -instance Widget Systray SystrayState (RenderCache SystrayState) where - initWidget (Systray) phi dispvar screens = do - phi' <- dupPhi phi - forkIO $ systrayRunner phi' dispvar $ snd . head $ screens - - return $ SystrayState phi (fst . head $ screens) 0 [] - - initCache _ = createRenderCache $ \(SystrayState phi systrayScreen reset icons) x y w h screen -> do - when (screen == systrayScreen) $ do - forM_ (zip [0..] icons) $ \(i, SystrayIconState midParent window) -> do - let x' = x + i*(h+2) - sendMessage phi $ RenderIcon midParent window x' y h h - - setOperator OperatorClear - paint - - minSize _ (SystrayState _ systrayScreen _ icons) height screen = case True of - _ | screen == systrayScreen -> max 0 $ (length icons)*(height+2)-1 - | otherwise -> 0 - - weight _ = 0 - - render _ = renderCached - - - handleMessage _ priv@(SystrayState phi screen reset icons) m = case (fromMessage m) of - 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 (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 -> Window -> IO () -systrayRunner phi dispvar panelWindow = do - let atoms = getAtoms dispvar - initSuccess <- withDisplay dispvar $ flip initSystray atoms - - case initSuccess of - Just xembedWindow -> flip evalStateT M.empty $ do - sendMessage phi HoldShutdown - - forever $ do - m <- receiveMessage phi - case (fromMessage m) of - Just event -> - handleEvent event phi dispvar panelWindow xembedWindow - _ -> - case (fromMessage m) of - Just (RenderIcon midParent window x y w h) -> do - withDisplay dispvar $ \disp -> do - liftIO $ flip catch (\_ -> return ()) $ do - sync disp False - setSystrayErrorHandler - - (_, x', y', w', h', _, _) <- getGeometry disp midParent - (_, x'', y'', w'', h'', _, _) <- getGeometry disp window - let resize = (fromIntegral x) /= x' || (fromIntegral y) /= y' || (fromIntegral w) /= w' || (fromIntegral h) /= h' - || 0 /= x'' || 0 /= y'' || (fromIntegral w) /= w'' || (fromIntegral h) /= h'' - - when resize $ do - moveResizeWindow disp midParent (fromIntegral x) (fromIntegral y) (fromIntegral w) (fromIntegral h) - moveResizeWindow disp window 0 0 (fromIntegral w) (fromIntegral h) - sync disp False - - clearArea disp window 0 0 (fromIntegral w) (fromIntegral h) True - - sync disp False - xSetErrorHandler - - lastErrorWindow <- liftIO $ getLastErrorWindow - when (lastErrorWindow == window) $ do - removeIcon phi disp True window - _ -> - case (fromMessage m) of - Just Shutdown -> do - windows <- gets M.keys - withDisplay dispvar $ \disp -> do - mapM_ (removeIcon phi disp True) windows - liftIO $ do - destroyWindow disp xembedWindow - sync disp False - sendMessage phi ReleaseShutdown - _ -> - return () - Nothing -> - return () - - -initSystray :: Xlib.Display -> Atoms -> IO (Maybe Window) -initSystray disp atoms = do - currentSystrayWin <- xGetSelectionOwner disp $ atom_NET_SYSTEM_TRAY_SCREEN atoms - - if currentSystrayWin /= 0 then do - pid <- liftM (fromMaybe "" . fmap (\pid -> " (pid" ++ show (fromIntegral pid :: CUShort) ++ ")") . join . fmap listToMaybe) $ - getWindowProperty16 disp (atom_NET_WM_PID atoms) currentSystrayWin - - putStrLn $ "Phi: another systray is running." ++ pid - - return Nothing - else do - xembedWin <- createSimpleWindow disp (defaultRootWindow disp) (-1) (-1) 1 1 0 0 0 - - -- orient horizontally - changeProperty32 disp xembedWin (atom_NET_SYSTEM_TRAY_ORIENTATION atoms) cARDINAL propModeReplace [0] - - -- set visual - let rootwin = defaultRootWindow disp - screen = defaultScreen disp - visual = defaultVisual disp screen - visualID = visualIDFromVisual visual - changeProperty32 disp xembedWin (atom_NET_SYSTEM_TRAY_VISUAL atoms) vISUALID propModeReplace [fromIntegral visualID] - - xSetSelectionOwner disp (atom_NET_SYSTEM_TRAY_SCREEN atoms) xembedWin currentTime - systrayWin <- xGetSelectionOwner disp $ atom_NET_SYSTEM_TRAY_SCREEN atoms - if systrayWin /= xembedWin then do - destroyWindow disp xembedWin - putStrLn $ "Phi: can't initialize systray." - return Nothing - - else do - allocaXEvent $ \event -> do - putClientMessage event rootwin (atomMANAGER atoms) [fromIntegral currentTime, fromIntegral (atom_NET_SYSTEM_TRAY_SCREEN atoms), fromIntegral xembedWin, 0, 0] - sendEvent disp rootwin False structureNotifyMask event - - return $ Just xembedWin - - -sYSTEM_TRAY_REQUEST_DOCK :: CInt -sYSTEM_TRAY_REQUEST_DOCK = 0 - -sYSTEM_TRAY_BEGIN_MESSAGE :: CInt -sYSTEM_TRAY_BEGIN_MESSAGE = 1 - -sYSTEM_TRAY_CANCEL_MESSAGE :: CInt -sYSTEM_TRAY_CANCEL_MESSAGE = 2 - -xEMBED_EMBEDDED_NOTIFY :: CInt -xEMBED_EMBEDDED_NOTIFY = 0 - -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 - 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) panelWindow $ fromIntegral iconID - - | opcode == sYSTEM_TRAY_BEGIN_MESSAGE || opcode == sYSTEM_TRAY_CANCEL_MESSAGE -> - return () - - | otherwise -> do - liftIO $ putStrLn "Phi: unknown tray message" - return () - - - _ -> - return () - -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 panelWindow xembedWindow = - withDisplay dispvar $ \disp -> removeIcon phi disp False window - -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 - 0 -> - return 0 - _ -> do - childrenPtr <- peek childrenPtrPtr - when (childrenPtr /= nullPtr) $ - xFree childrenPtr >> return () - peek parentPtr - midParent <- gets $ M.lookup window - when (midParent /= Just parent) $ - withDisplay dispvar $ \disp -> removeIcon phi disp False window - return () - -handleEvent _ _ _ _ _ = return () - - -addIcon :: Phi -> Xlib.Display -> Atoms -> Window -> Window -> StateT (M.Map Window Window) IO () -addIcon phi disp atoms panelWindow window = do - removeIcon phi disp False window - - liftIO $ selectInput disp window $ structureNotifyMask .|. propertyChangeMask - - midParent <- liftIO $ createSimpleWindow disp panelWindow (-16) (-16) 16 16 0 0 0 - - liftIO $ do - setWindowBackgroundPixmap disp midParent 1 -- ParentRelative - - sync disp False - setSystrayErrorHandler - - reparentWindow disp window midParent 0 0 - - mapRaised disp midParent - mapWindow disp window - - allocaXEvent $ \event -> do - putClientMessage event window (atom_XEMBED atoms) [fromIntegral currentTime, fromIntegral xEMBED_EMBEDDED_NOTIFY, 0, fromIntegral midParent, 0] - sendEvent disp window False 0xFFFFFF event - - sync disp False - xSetErrorHandler - - errorWindow <- liftIO $ getLastErrorWindow - case True of - _ | errorWindow /= window -> do - sendMessage phi $ AddIcon midParent window - sendMessage phi Repaint - modify $ M.insert window midParent - | otherwise -> - liftIO $ destroyWindow disp midParent - - -removeIcon :: Phi -> Xlib.Display -> Bool -> Window -> StateT (M.Map Window Window) IO () -removeIcon phi disp reparent window = do - mmidParent <- gets $ M.lookup window - case mmidParent of - Just midParent -> do - sendMessage phi $ RemoveIcon window - sendMessage phi Repaint - liftIO $ do - selectInput disp window $ noEventMask - when reparent $ - reparentWindow disp window (defaultRootWindow disp) 0 0 - destroyWindow disp midParent - sync disp False - modify $ M.delete window - _ -> - return () - - -systray :: Systray -systray = Systray diff --git a/lib/Phi/Widgets/Taskbar.hs b/lib/Phi/Widgets/Taskbar.hs deleted file mode 100644 index f0a8196..0000000 --- a/lib/Phi/Widgets/Taskbar.hs +++ /dev/null @@ -1,641 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses, DeriveDataTypeable, TypeSynonymInstances, FlexibleInstances #-} - -module Phi.Widgets.Taskbar ( IconStyle - , idIconStyle - , desaturateIconStyle - , TaskStyle(..) - , DesktopStyle(..) - , TaskbarConfig(..) - , defaultTaskbarConfig - , Taskbar - , taskbar - ) where - -import Control.Arrow -import Control.Concurrent -import Control.Monad -import Control.Monad.State.Strict -import Control.Monad.Trans - -import Data.Array.MArray -import Data.Bits -import Data.Char -import Data.Function -import Data.IORef -import Data.List -import Data.Maybe -import Data.Typeable -import Data.Unique -import Data.Word -import qualified Data.Accessor.Basic as A -import qualified Data.Accessor.Container as AC -import qualified Data.Map as M - -import Foreign.C.Types - -import Graphics.Rendering.Cairo -import Graphics.Rendering.Pango.Cairo -import Graphics.Rendering.Pango.Enums (PangoRectangle(..)) -import Graphics.Rendering.Pango.Layout -import Graphics.Rendering.Pango.Font - -import Graphics.XHB -import Graphics.XHB.Gen.Xproto - -import Codec.Binary.UTF8.String - -import Phi.Phi -import Phi.Types -import Phi.Border -import Phi.Widget -import Phi.X11.Atoms -import Phi.X11.Util - - -newtype IconStyle = IconStyle { withIconStyle :: Surface -> Render () } -instance Eq IconStyle where - _ == _ = True - -idIconStyle :: IconStyle -idIconStyle = IconStyle $ flip withPatternForSurface setSource - -desaturateIconStyle :: Double -> IconStyle -desaturateIconStyle v = IconStyle $ \icon -> do - w <- imageSurfaceGetWidth icon - h <- imageSurfaceGetHeight icon - - renderWithSimilarSurface ContentColorAlpha w h $ \surface -> do - renderWith surface $ do - setOperator OperatorAdd - withPatternForSurface icon setSource - paint - - setSourceRGB 0 0 0 - paint - - setOperator OperatorHslSaturation - setSourceRGBA 0 0 0 (1-v) - paint - - setOperator OperatorDestIn - withPatternForSurface icon setSource - paint - - withPatternForSurface surface setSource - - -downscaled :: Double -> Surface -> Render () -downscaled s surface = do - case True of - _ | s < 0.5 -> do - w <- imageSurfaceGetWidth surface - h <- imageSurfaceGetHeight surface - - renderWithSimilarSurface ContentColorAlpha (ceiling (fromIntegral w*s)) (ceiling (fromIntegral h*s)) $ \surface' -> do - renderWith surface' $ do - scale 0.5 0.5 - downscaled (2*s) surface - paint - withPatternForSurface surface' setSource - - | otherwise -> do - scale s s - withPatternForSurface surface setSource - - -data TaskStyle = TaskStyle { taskFont :: !String - , taskColor :: !Color - , taskBorder :: !BorderConfig - , taskIconStyle :: !IconStyle - } deriving Eq - -data DesktopStyle = DesktopStyle { desktopFont :: !String - , desktopLabelWidth :: !Int - , desktopLabelGap :: !Int - , desktopColor :: !Color - , desktopBorder :: !BorderConfig - } - -data TaskbarConfig = TaskbarConfig { taskMaxSize :: !Int - , normalTaskStyle :: !TaskStyle - , activeTaskStyle :: !TaskStyle - , desktopStyle :: !(Maybe (DesktopStyle, DesktopStyle)) - } - -defaultStyle :: TaskStyle -defaultStyle = TaskStyle { taskFont = "Sans 8" - , taskColor = (0, 0, 0, 1) - , taskBorder = defaultBorderConfig { backgroundColor = (0.75, 0.75, 0.75, 1) } - , taskIconStyle = idIconStyle - } - -defaultTaskbarConfig :: TaskbarConfig -defaultTaskbarConfig = TaskbarConfig { taskMaxSize = 200 - , normalTaskStyle = defaultStyle - , activeTaskStyle = defaultStyle {taskBorder = defaultBorderConfig { borderColor = (1, 1, 1, 1) }} - , desktopStyle = Nothing - } - -data Taskbar = Taskbar TaskbarConfig - -data TaskbarState = TaskbarState { taskbarScreens :: ![RECTANGLE] - , taskbarActiveWindow :: !WINDOW - , taskbarDesktopCount :: !Int - , taskbarCurrentDesktop :: !Int - , taskbarDesktopNames :: ![String] - , taskbarWindows :: ![WINDOW] - , taskbarWindowStates :: !(M.Map WINDOW WindowState) - } deriving Eq - -data Icon = Icon !Unique !Int !Surface -instance Eq Icon where (Icon a _ _) == (Icon b _ _) = a == b -instance Show Icon where show (Icon _ size _) = "Icon { size = " ++ (show size) ++ " }" - -createIcon :: Int -> Surface -> IO Icon -createIcon size surface = do - id <- newUnique - return $ Icon id size surface - - -data WindowState = WindowState { windowTitle :: !String - , windowDesktop :: !Int - , windowVisible :: !Bool - , windowIcons :: ![Icon] - , windowGeometry :: !RECTANGLE - } deriving (Eq, Show) - -data WindowCache = WindowCache { createScaledIconCached :: !(IOCache ([Icon], Int) (Maybe Icon)) - , renderWindowCached :: !(IOCache (String, Maybe Icon, TaskStyle, Int, Int) Surface) - } - -createScaledIconCached' = A.fromSetGet (\a cache -> cache {createScaledIconCached = a}) createScaledIconCached -renderWindowCached' = A.fromSetGet (\a cache -> cache {renderWindowCached = a}) renderWindowCached - - -newtype DesktopCache = DesktopCache (IOCache () ()) - -emptyWindowCache :: WindowCache -emptyWindowCache = WindowCache { createScaledIconCached = createIOCache createScaledIcon - , renderWindowCached = createIOCache doRenderWindow - } - -data TaskbarCache = TaskbarCache { desktopCaches :: !(M.Map Int DesktopCache) - , windowCaches :: !(M.Map WINDOW WindowCache) - } - --- substitute for the liftT function in Data.Accessor.MonadState that uses the strict StateT variant -liftT :: (Monad m) => A.T r s -> StateT s m a -> StateT r m a -liftT f m = do - s0 <- gets $ A.get f - (a,s1) <- lift $ runStateT m s0 - modify $ A.set f s1 - return a - -liftIOStateT :: (MonadIO m) => StateT s IO a -> StateT s m a -liftIOStateT m = do - s0 <- get - (a,s1) <- liftIO $ runStateT m s0 - put s1 - return a - -cached :: (MonadIO m, Eq a) => A.T s (IOCache a b) -> a -> StateT s m b -cached t = liftT t . liftIOStateT . runIOCache - -data TaskbarMessage = WindowListUpdate ![WINDOW] !(M.Map WINDOW WindowState) - | DesktopCountUpdate !Int - | CurrentDesktopUpdate !Int - | DesktopNamesUpdate ![String] - | ActiveWindowUpdate !WINDOW - deriving (Typeable, Show) - -instance Widget Taskbar TaskbarState (M.Map WINDOW WindowCache) where - initWidget (Taskbar _) phi dispvar screens = do - phi' <- dupPhi phi - forkIO $ taskbarRunner phi' dispvar - - return $ TaskbarState (map fst screens) (fromXid xidNone) 0 (-1) [] [] M.empty - - initCache _ = M.empty - - minSize _ _ _ _ = 0 - weight _ = 1 - - render (Taskbar config) TaskbarState { taskbarScreens = screens - , taskbarActiveWindow = activeWindow - , taskbarDesktopCount = desktopCount - , taskbarCurrentDesktop = currentDesktop - , taskbarDesktopNames = desktopNames - , taskbarWindows = windows - , taskbarWindowStates = windowStates - } _ _ w h screen = do - let windowScreen w = maximumBy (compare `on` unionArea (windowGeometry w)) screens - screenWindows = filter ((== Just screen) . fmap windowScreen . flip M.lookup windowStates) windows - desktopNumbers = take desktopCount $ zip [0..] (desktopNames ++ repeat "") - desktops = map (\desktop -> (desktop, filter (fromMaybe False . fmap (windowOnDesktop . fst $ desktop) . flip M.lookup windowStates) screenWindows)) desktopNumbers - - windowCount = sum $ map (length . snd) $ desktops - - dstyle d = fmap (if d == currentDesktop then snd else fst) $ desktopStyle config - dlabelwidth d = fromMaybe 0 $ fmap desktopLabelWidth $ dstyle d - gap d ds = if null (snd $ desktops !! d) then 0 else desktopLabelGap ds - dleftwidth d = fromMaybe 0 $ fmap (\ds@DesktopStyle {desktopBorder = border} - -> (borderLeft $ margin border) + (borderWidth border) + (borderLeft $ padding border) - + dlabelwidth d + gap d ds) $ dstyle d - dwidth d = fromMaybe 0 $ fmap (\ds@DesktopStyle {desktopBorder = border} - -> (borderH $ margin border) + 2*(borderWidth border) + (borderH $ padding border) - + dlabelwidth d + gap d ds) $ dstyle d - - desktopsWidth = sum $ map (dwidth . fst) desktopNumbers - windowWidth = if windowCount == 0 then 0 else min (taskMaxSize config) ((w - desktopsWidth) `div` windowCount) - - surface <- liftIO $ createImageSurface FormatARGB32 w h - cache <- liftM (M.filterWithKey $ \w _ -> elem w windows) get - cache' <- renderWith surface $ flip execStateT cache $ do - lift $ do - setOperator OperatorClear - paint - - setOperator OperatorOver - - flip (flip foldM_ 0) desktops $ \nwindows (desktop, desktopWindows) -> do - let dstyle' = dstyle (fst desktop) - dx = dleftwidth (fst desktop) + (sum $ map dwidth $ take (fst desktop) [0..]) + nwindows*windowWidth - - case dstyle' of - Just ds -> do - let (r, g, b, a) = desktopColor ds - lift $ do - save - drawBorder (desktopBorder ds) (dx - dleftwidth (fst desktop)) 0 (dwidth (fst desktop) + windowWidth * length desktopWindows) h - clip - - setSourceRGBA r g b a - renderText (desktopFont ds) (fromIntegral (dx - dlabelwidth (fst desktop) - gap (fst desktop) ds)) 0 (dlabelwidth (fst desktop)) h $ snd desktop - - restore - - forM_ (zip [0..] desktopWindows) $ \(i, window) -> do - let style = (if window == activeWindow then activeTaskStyle else normalTaskStyle) config - h' = h - (borderV $ margin $ desktopBorder ds) - 2*(borderWidth $ desktopBorder ds) - (borderV $ padding $ desktopBorder ds) - mstate = M.lookup window windowStates - x = dx + i*windowWidth - y = (borderTop $ margin $ desktopBorder ds) + (borderWidth $ desktopBorder ds) + (borderTop $ padding $ desktopBorder ds) - - case mstate of - Just state -> do - windowSurface <- liftT (AC.mapDefault emptyWindowCache window) . liftIOStateT $ renderWindow state style windowWidth h' - lift $ do - save - translate (fromIntegral $ x - 5) (fromIntegral $ y - 5) - withPatternForSurface windowSurface setSource - paint - restore - - Nothing -> return () - - _ -> return () - - return $ nwindows + length desktopWindows - put cache' - - return [(True, SurfaceSlice 0 surface)] - - - handleMessage _ priv m = case (fromMessage m) of - Just (WindowListUpdate windows windowStates) -> priv { taskbarWindows = windows - , taskbarWindowStates = windowStates - } - Just (DesktopCountUpdate count) -> priv {taskbarDesktopCount = count} - Just (CurrentDesktopUpdate current) -> priv {taskbarCurrentDesktop = current} - Just (DesktopNamesUpdate names) -> priv {taskbarDesktopNames = names} - Just (ActiveWindowUpdate window) -> priv {taskbarActiveWindow = window} - _ -> case (fromMessage m) of - Just (UpdateScreens screens) -> priv {taskbarScreens = map fst screens} - _ -> priv - - -renderText :: String -> Int -> Int -> Int -> Int -> String -> Render () -renderText font x y w h text = do - layout <- createLayout "" - (_, PangoRectangle _ _ textWidth textHeight) <- liftIO $ do - layoutSetMarkup layout $ "" ++ (escapeMarkup text) ++ "" - layoutSetWidth layout $ Just $ fromIntegral w - layoutSetEllipsize layout EllipsizeEnd - - layoutGetExtents layout - - - moveTo ((fromIntegral x) + ((fromIntegral w) - textWidth)/2) ((fromIntegral y) + ((fromIntegral h) - textHeight)/2) - showLayout layout - -renderWindow :: WindowState -> TaskStyle -> Int -> Int -> StateT WindowCache IO Surface -renderWindow state style w h = do - let h' = h - (borderV $ margin $ taskBorder style) - - scaledIcon <- cached createScaledIconCached' (windowIcons state, h') - cached renderWindowCached' (windowTitle state, scaledIcon, style, w, h) - -doRenderWindow :: (String, Maybe Icon, TaskStyle, Int, Int) -> IO Surface -doRenderWindow (title, scaledIcon, style, w, h) = do - let (r, g, b, a) = taskColor style - leftBorder = (borderLeft $ margin $ taskBorder style) + (borderWidth $ taskBorder style) + (borderLeft $ padding $ taskBorder style) - rightBorder = (borderRight $ margin $ taskBorder style) + (borderWidth $ taskBorder style) + (borderRight $ padding $ taskBorder style) - h' = h - (borderV $ margin $ taskBorder style) - - surface <- createImageSurface FormatARGB32 (w+10) (h+10) - renderWith surface $ do - translate 5 5 - - save - drawBorder (taskBorder style) 0 0 w h - clip - - setSourceRGBA r g b a - renderText (taskFont style) (fromIntegral (leftBorder + h' + 3)) 0 (w - leftBorder - h' - 3 - rightBorder) h title - - restore - - case scaledIcon of - Just (Icon _ _ icon) -> do - save - translate (fromIntegral leftBorder) (fromIntegral . borderTop . margin . taskBorder $ style) - withIconStyle (taskIconStyle style) icon - paint - restore - - _ -> return () - - return surface - - -createScaledIcon :: ([Icon], Int) -> IO (Maybe Icon) -createScaledIcon (icons, h) = do - case bestIcon of - Just (Icon _ _ icon) -> do - scaledIcon <- createSimilarSurface icon ContentColorAlpha h h - renderWith scaledIcon $ do - imageW <- imageSurfaceGetWidth icon - imageH <- imageSurfaceGetHeight icon - - let scalef = (fromIntegral h)/(fromIntegral $ max imageW imageH) - - case () of - _ | imageH < imageW -> translate 0 (fromIntegral (imageW-imageH)*scalef/2) - | otherwise -> translate (fromIntegral (imageH-imageW)*scalef/2) 0 - - downscaled scalef icon - paint - fmap Just $ createIcon h scaledIcon - - _ -> return Nothing - - where - bestIcon = listToMaybe $ sortBy compareIcons icons - compareIcons = flip (compare `on` (\(Icon _ size _) -> size)) - - -windowOnDesktop :: Int -> WindowState -> Bool -windowOnDesktop desktop state = (windowVisible state) && (desktop == windowDesktop state) - - -taskbarRunner :: Phi -> Display -> IO () -taskbarRunner phi dispvar = do - (windows, states) <- liftIO $ withDisplay dispvar $ \disp -> do - (windows, states) <- getWindowStates disp (getAtoms dispvar) M.empty - desktopCount <- getDesktopCount disp (getAtoms dispvar) - current <- getCurrentDesktop disp (getAtoms dispvar) - names <- getDesktopNames disp (getAtoms dispvar) - activeWindow <- getActiveWindow disp (getAtoms dispvar) - sendMessage phi $ WindowListUpdate windows states - sendMessage phi $ DesktopCountUpdate desktopCount - sendMessage phi $ CurrentDesktopUpdate current - sendMessage phi $ DesktopNamesUpdate names - sendMessage phi $ ActiveWindowUpdate activeWindow - return (windows, states) - sendMessage phi Repaint - - flip evalStateT (windows, states) $ forever $ do - m <- receiveMessage phi - case (fromMessage m) of - Just (XEvent event) -> - handleEvent phi dispvar event - _ -> - return () - - -handleEvent :: Phi -> Display -> SomeEvent -> StateT ([WINDOW], M.Map WINDOW WindowState) IO () -handleEvent phi dispvar event = - case (fromEvent event) of - Just e -> handlePropertyNotifyEvent phi dispvar e - Nothing -> case (fromEvent event) of - Just e -> handleConfigureNotifyEvent phi dispvar e - Nothing -> return () - -handlePropertyNotifyEvent :: Phi -> Display -> PropertyNotifyEvent -> StateT ([WINDOW], M.Map WINDOW WindowState) IO () -handlePropertyNotifyEvent phi dispvar MkPropertyNotifyEvent {atom_PropertyNotifyEvent = atom, window_PropertyNotifyEvent = window} = do - let atoms = getAtoms dispvar - - when (elem atom $ map ($ atoms) [ atom_NET_ACTIVE_WINDOW - , atom_NET_NUMBER_OF_DESKTOPS - , atom_NET_CURRENT_DESKTOP - , atom_NET_DESKTOP_NAMES - , atom_NET_CLIENT_LIST - , atom_NET_WM_ICON - , atomWM_NAME - , atom_NET_WM_NAME - , atom_NET_WM_DESKTOP - , atom_NET_WM_STATE - ]) $ withDisplay dispvar $ \conn -> do - let rootwin = getRoot conn - if (window == rootwin) - then do - when (atom == atom_NET_ACTIVE_WINDOW atoms) $ do - activeWindow <- liftIO $ getActiveWindow conn atoms - sendMessage phi $ ActiveWindowUpdate activeWindow - sendMessage phi Repaint - when (atom == atom_NET_NUMBER_OF_DESKTOPS atoms) $ do - desktopCount <- liftIO $ getDesktopCount conn atoms - sendMessage phi $ DesktopCountUpdate desktopCount - sendMessage phi Repaint - when (atom == atom_NET_CURRENT_DESKTOP atoms) $ do - current <- liftIO $ getCurrentDesktop conn atoms - sendMessage phi $ CurrentDesktopUpdate current - sendMessage phi Repaint - when (atom == atom_NET_DESKTOP_NAMES atoms) $ do - names <- liftIO $ getDesktopNames conn atoms - sendMessage phi $ DesktopNamesUpdate names - sendMessage phi Repaint - when (atom == atom_NET_CLIENT_LIST atoms) $ do - (windows, windowStates) <- get - (windows', windowStates') <- liftIO $ getWindowStates conn atoms windowStates - - when (windows /= windows') $ do - sendMessage phi $ WindowListUpdate windows' windowStates' - sendMessage phi Repaint - put (windows', windowStates') - - else do - (windows, windowStates) <- get - when (elem window windows) $ do - case () of - _ | (atom == atom_NET_WM_ICON atoms) -> do - icons <- liftIO $ getWindowIcons conn atoms window - let windowStates' = M.update (\state -> Just state {windowIcons = icons}) window windowStates - sendMessage phi $ WindowListUpdate windows windowStates' - sendMessage phi Repaint - put (windows, windowStates') - - | otherwise -> do - (name, desktop, visible) <- liftIO $ getWindowInfo conn atoms window - let mwindowState = M.lookup window windowStates - case mwindowState of - Just windowState -> do - let windowState' = windowState {windowTitle = name, windowDesktop = desktop, windowVisible = visible} - - when (windowState /= windowState') $ do - let windowStates' = M.insert window windowState' windowStates - sendMessage phi $ WindowListUpdate windows windowStates' - sendMessage phi Repaint - put (windows, windowStates') - Nothing -> - return () - - -handleConfigureNotifyEvent :: Phi -> Display -> ConfigureNotifyEvent -> StateT ([WINDOW], M.Map WINDOW WindowState) IO () -handleConfigureNotifyEvent phi dispvar MkConfigureNotifyEvent {window_ConfigureNotifyEvent = window} = do - (windows, windowStates) <- get - when (elem window windows) $ withDisplay dispvar $ \conn -> do - let geom = fmap windowGeometry . M.lookup window $ windowStates - geom' <- liftIO $ getWindowGeometry conn 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') - - -getDesktopCount :: Connection -> Atoms -> IO Int -getDesktopCount conn atoms = - liftM (fromIntegral . fromMaybe 0 . join . fmap listToMaybe) $ getProperty32 conn (getRoot conn) (atom_NET_NUMBER_OF_DESKTOPS atoms) - -getCurrentDesktop :: Connection -> Atoms -> IO Int -getCurrentDesktop conn atoms = - liftM (fromIntegral . fromMaybe (-1) . join . fmap listToMaybe) $ getProperty32 conn (getRoot conn) (atom_NET_CURRENT_DESKTOP atoms) - -getDesktopNames :: Connection -> Atoms -> IO [String] -getDesktopNames conn atoms = - liftM (map (decode . map fromIntegral) . break' . fromMaybe []) $ getProperty8 conn (getRoot conn) (atom_NET_DESKTOP_NAMES atoms) - where - break' l = case dropWhile (== 0) l of - [] -> [] - l' -> w : break' l'' - where (w, l'') = break (== 0) l' - -getActiveWindow :: Connection -> Atoms -> IO WINDOW -getActiveWindow conn atoms = - liftM (fromXid . toXid . fromMaybe 0 . join . fmap listToMaybe) $ getProperty32 conn (getRoot conn) (atom_NET_ACTIVE_WINDOW atoms) - -getWindowStates :: Connection -> Atoms -> M.Map WINDOW WindowState -> IO ([WINDOW], M.Map WINDOW WindowState) -getWindowStates conn atoms windowStates = do - windows <- getWindowList conn atoms - - let windowStates' = map (\w -> (w, M.lookup w windowStates)) windows - - newWindowStates <- mapM getWindowState' windowStates' - - return (windows, M.fromList newWindowStates) - where - getWindowState' (window, Just windowState) = return (window, windowState) - getWindowState' (window, Nothing) = do - changeWindowAttributes conn window $ toValueParam [(CWEventMask, toMask [EventMaskPropertyChange, EventMaskStructureNotify])] - windowState <- getWindowState conn atoms window - return (window, windowState) - -getWindowState :: Connection -> Atoms -> WINDOW -> IO WindowState -getWindowState conn atoms window = do - (name, workspace, visible) <- getWindowInfo conn atoms window - icons <- getWindowIcons conn atoms window - geom <- getWindowGeometry conn window - - return $ WindowState { windowTitle = name - , windowDesktop = workspace - , windowVisible = visible - , windowIcons = icons - , windowGeometry = geom - } - -getWindowInfo :: Connection -> Atoms -> WINDOW -> IO (String, Int, Bool) -getWindowInfo conn atoms window = do - netwmname <- liftM (fmap (decode . map fromIntegral)) $ getProperty8 conn window (atom_NET_WM_NAME atoms) - wmname <- case netwmname of - Just name -> return name - Nothing -> liftM (map unsignedChr . fromMaybe []) $ getProperty8 conn window (atom_NET_WM_NAME atoms) - - workspace <- liftM (fromIntegral . fromMaybe 0xFFFFFFFF . join . fmap listToMaybe) $ getProperty32 conn window (atom_NET_WM_DESKTOP atoms) - visible <- showWindow conn atoms window - - return (wmname, workspace, visible) - where - unsignedChr = chr . fromIntegral - -getWindowIcons :: Connection -> Atoms -> WINDOW -> IO [Icon] -getWindowIcons conn atoms window = getProperty32 conn window (atom_NET_WM_ICON atoms) >>= readIcons . fromMaybe [] - - -readIcons :: [Word32] -> IO [Icon] -readIcons (width:height:iconData) = do - if ((fromIntegral $ length iconData) < (width*height)) then return [] else do - let (thisIcon, rest) = splitAt (fromIntegral (width*height)) iconData - surface <- createImageSurface FormatARGB32 (fromIntegral width) (fromIntegral height) - surfaceData <- imageSurfaceGetPixels surface :: IO (SurfaceData Int Word32) - forM_ (zip thisIcon [0..]) $ \(e, i) -> writeArray surfaceData i $ premultiply $ fromIntegral e - - surfaceMarkDirty surface - - liftM2 (:) (createIcon (fromIntegral $ max width height) surface) (readIcons rest) - -readIcons _ = return [] - -premultiply :: Word32 -> Word32 -premultiply c = a .|. r .|. g .|. b - where - amask = 0xFF000000 - rmask = 0x00FF0000 - gmask = 0x0000FF00 - bmask = 0x000000FF - - a = c .&. amask - pm mask = (((c .&. mask) * (a `shiftR` 24)) `div` 0xFF) .&. mask - - r = pm rmask - g = pm gmask - b = pm bmask - - -getWindowGeometry :: Connection -> WINDOW -> IO RECTANGLE -getWindowGeometry conn window = - getGeometry conn (fromXid . toXid $ window) >>= getReply >>= return . ((const $ MkRECTANGLE 0 0 0 0) ||| (\(MkGetGeometryReply _ _ x y width height _) -> MkRECTANGLE x y width height)) - -showWindow :: Connection -> Atoms -> WINDOW -> IO Bool -showWindow conn atoms window = do - states <- liftM (map (fromXid . toXid) . fromMaybe []) $ getProperty32 conn window (atom_NET_WM_STATE atoms) - transientFor <- liftM (map fromIntegral . fromMaybe []) $ getProperty32 conn window (atomWM_TRANSIENT_FOR atoms) - windowType <- liftM (fromMaybe (atom_NET_WM_WINDOW_TYPE_NORMAL atoms) . fmap (fromXid . toXid) . join . fmap listToMaybe) $ - getProperty32 conn window (atom_NET_WM_STATE atoms) - - return $ not $ or [ elem (atom_NET_WM_STATE_SKIP_TASKBAR atoms) states - , transientFor /= [] && transientFor /= [0] - , elem windowType $ map ($ atoms) [ atom_NET_WM_WINDOW_TYPE_DOCK - , atom_NET_WM_WINDOW_TYPE_DESKTOP - , atom_NET_WM_WINDOW_TYPE_TOOLBAR - , atom_NET_WM_WINDOW_TYPE_MENU - , atom_NET_WM_WINDOW_TYPE_SPLASH - ] - ] - - -getWindowList :: Connection -> Atoms -> IO [WINDOW] -getWindowList conn atoms = liftM (map (fromXid . toXid) . join . maybeToList) $ getProperty32 conn (getRoot conn) (atom_NET_CLIENT_LIST atoms) - -taskbar :: TaskbarConfig -> Taskbar -taskbar = Taskbar diff --git a/lib/Phi/Widgets/X11/Systray.hs b/lib/Phi/Widgets/X11/Systray.hs new file mode 100644 index 0000000..fffb181 --- /dev/null +++ b/lib/Phi/Widgets/X11/Systray.hs @@ -0,0 +1,294 @@ +{-# LANGUAGE MultiParamTypeClasses, DeriveDataTypeable, TypeSynonymInstances, FlexibleInstances #-} + +module Phi.Widgets.X11.Systray ( systray + ) where + +import Control.Concurrent +import Control.Monad +import Control.Monad.State +import Control.Monad.Trans + +import Data.Bits +import Data.IORef +import Data.Maybe +import Data.Typeable +import qualified Data.Map as M + +import Foreign.C.Types +import Foreign.Marshal +import Foreign.Ptr +import Foreign.Storable + +import Graphics.Rendering.Cairo +import Graphics.Rendering.Cairo.Types + +import Graphics.X11.Xlib hiding (Display) +import qualified Graphics.X11.Xlib as Xlib +import Graphics.X11.Xlib.Extras + +import Phi.Bindings.Util +import Phi.Bindings.SystrayErrorHandler + +import Phi.Phi +import Phi.Types +import Phi.Widget +import Phi.X11.Atoms + + +data SystrayIconState = SystrayIconState !Window !Window deriving (Show, Eq) + +instance Eq Phi where + _ == _ = True + +data SystrayState = SystrayState !Phi !Rectangle !Int ![SystrayIconState] deriving Eq + +data Systray = Systray deriving (Show, Eq) + +data SystrayMessage = AddIcon !Window !Window | RemoveIcon !Window | RenderIcon !Window !Window !Int !Int !Int !Int + deriving (Show, Typeable) + + +instance Widget Systray SystrayState (RenderCache SystrayState) where + initWidget (Systray) phi dispvar screens = do + phi' <- dupPhi phi + forkIO $ systrayRunner phi' dispvar $ snd . head $ screens + + return $ SystrayState phi (fst . head $ screens) 0 [] + + initCache _ = createRenderCache $ \(SystrayState phi systrayScreen reset icons) x y w h screen -> do + when (screen == systrayScreen) $ do + forM_ (zip [0..] icons) $ \(i, SystrayIconState midParent window) -> do + let x' = x + i*(h+2) + sendMessage phi $ RenderIcon midParent window x' y h h + + setOperator OperatorClear + paint + + minSize _ (SystrayState _ systrayScreen _ icons) height screen = case True of + _ | screen == systrayScreen -> max 0 $ (length icons)*(height+2)-1 + | otherwise -> 0 + + weight _ = 0 + + render _ = renderCached + + + handleMessage _ priv@(SystrayState phi screen reset icons) m = case (fromMessage m) of + 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 (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 -> Window -> IO () +systrayRunner phi dispvar panelWindow = do + let atoms = getAtoms dispvar + initSuccess <- withDisplay dispvar $ flip initSystray atoms + + case initSuccess of + Just xembedWindow -> flip evalStateT M.empty $ do + sendMessage phi HoldShutdown + + forever $ do + m <- receiveMessage phi + case (fromMessage m) of + Just event -> + handleEvent event phi dispvar panelWindow xembedWindow + _ -> + case (fromMessage m) of + Just (RenderIcon midParent window x y w h) -> do + withDisplay dispvar $ \disp -> do + liftIO $ flip catch (\_ -> return ()) $ do + sync disp False + setSystrayErrorHandler + + (_, x', y', w', h', _, _) <- getGeometry disp midParent + (_, x'', y'', w'', h'', _, _) <- getGeometry disp window + let resize = (fromIntegral x) /= x' || (fromIntegral y) /= y' || (fromIntegral w) /= w' || (fromIntegral h) /= h' + || 0 /= x'' || 0 /= y'' || (fromIntegral w) /= w'' || (fromIntegral h) /= h'' + + when resize $ do + moveResizeWindow disp midParent (fromIntegral x) (fromIntegral y) (fromIntegral w) (fromIntegral h) + moveResizeWindow disp window 0 0 (fromIntegral w) (fromIntegral h) + sync disp False + + clearArea disp window 0 0 (fromIntegral w) (fromIntegral h) True + + sync disp False + xSetErrorHandler + + lastErrorWindow <- liftIO $ getLastErrorWindow + when (lastErrorWindow == window) $ do + removeIcon phi disp True window + _ -> + case (fromMessage m) of + Just Shutdown -> do + windows <- gets M.keys + withDisplay dispvar $ \disp -> do + mapM_ (removeIcon phi disp True) windows + liftIO $ do + destroyWindow disp xembedWindow + sync disp False + sendMessage phi ReleaseShutdown + _ -> + return () + Nothing -> + return () + + +initSystray :: Xlib.Display -> Atoms -> IO (Maybe Window) +initSystray disp atoms = do + currentSystrayWin <- xGetSelectionOwner disp $ atom_NET_SYSTEM_TRAY_SCREEN atoms + + if currentSystrayWin /= 0 then do + pid <- liftM (fromMaybe "" . fmap (\pid -> " (pid" ++ show (fromIntegral pid :: CUShort) ++ ")") . join . fmap listToMaybe) $ + getWindowProperty16 disp (atom_NET_WM_PID atoms) currentSystrayWin + + putStrLn $ "Phi: another systray is running." ++ pid + + return Nothing + else do + xembedWin <- createSimpleWindow disp (defaultRootWindow disp) (-1) (-1) 1 1 0 0 0 + + -- orient horizontally + changeProperty32 disp xembedWin (atom_NET_SYSTEM_TRAY_ORIENTATION atoms) cARDINAL propModeReplace [0] + + -- set visual + let rootwin = defaultRootWindow disp + screen = defaultScreen disp + visual = defaultVisual disp screen + visualID = visualIDFromVisual visual + changeProperty32 disp xembedWin (atom_NET_SYSTEM_TRAY_VISUAL atoms) vISUALID propModeReplace [fromIntegral visualID] + + xSetSelectionOwner disp (atom_NET_SYSTEM_TRAY_SCREEN atoms) xembedWin currentTime + systrayWin <- xGetSelectionOwner disp $ atom_NET_SYSTEM_TRAY_SCREEN atoms + if systrayWin /= xembedWin then do + destroyWindow disp xembedWin + putStrLn $ "Phi: can't initialize systray." + return Nothing + + else do + allocaXEvent $ \event -> do + putClientMessage event rootwin (atomMANAGER atoms) [fromIntegral currentTime, fromIntegral (atom_NET_SYSTEM_TRAY_SCREEN atoms), fromIntegral xembedWin, 0, 0] + sendEvent disp rootwin False structureNotifyMask event + + return $ Just xembedWin + + +sYSTEM_TRAY_REQUEST_DOCK :: CInt +sYSTEM_TRAY_REQUEST_DOCK = 0 + +sYSTEM_TRAY_BEGIN_MESSAGE :: CInt +sYSTEM_TRAY_BEGIN_MESSAGE = 1 + +sYSTEM_TRAY_CANCEL_MESSAGE :: CInt +sYSTEM_TRAY_CANCEL_MESSAGE = 2 + +xEMBED_EMBEDDED_NOTIFY :: CInt +xEMBED_EMBEDDED_NOTIFY = 0 + +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 + 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) panelWindow $ fromIntegral iconID + + | opcode == sYSTEM_TRAY_BEGIN_MESSAGE || opcode == sYSTEM_TRAY_CANCEL_MESSAGE -> + return () + + | otherwise -> do + liftIO $ putStrLn "Phi: unknown tray message" + return () + + + _ -> + return () + +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 panelWindow xembedWindow = + withDisplay dispvar $ \disp -> removeIcon phi disp False window + +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 + 0 -> + return 0 + _ -> do + childrenPtr <- peek childrenPtrPtr + when (childrenPtr /= nullPtr) $ + xFree childrenPtr >> return () + peek parentPtr + midParent <- gets $ M.lookup window + when (midParent /= Just parent) $ + withDisplay dispvar $ \disp -> removeIcon phi disp False window + return () + +handleEvent _ _ _ _ _ = return () + + +addIcon :: Phi -> Xlib.Display -> Atoms -> Window -> Window -> StateT (M.Map Window Window) IO () +addIcon phi disp atoms panelWindow window = do + removeIcon phi disp False window + + liftIO $ selectInput disp window $ structureNotifyMask .|. propertyChangeMask + + midParent <- liftIO $ createSimpleWindow disp panelWindow (-16) (-16) 16 16 0 0 0 + + liftIO $ do + setWindowBackgroundPixmap disp midParent 1 -- ParentRelative + + sync disp False + setSystrayErrorHandler + + reparentWindow disp window midParent 0 0 + + mapRaised disp midParent + mapWindow disp window + + allocaXEvent $ \event -> do + putClientMessage event window (atom_XEMBED atoms) [fromIntegral currentTime, fromIntegral xEMBED_EMBEDDED_NOTIFY, 0, fromIntegral midParent, 0] + sendEvent disp window False 0xFFFFFF event + + sync disp False + xSetErrorHandler + + errorWindow <- liftIO $ getLastErrorWindow + case True of + _ | errorWindow /= window -> do + sendMessage phi $ AddIcon midParent window + sendMessage phi Repaint + modify $ M.insert window midParent + | otherwise -> + liftIO $ destroyWindow disp midParent + + +removeIcon :: Phi -> Xlib.Display -> Bool -> Window -> StateT (M.Map Window Window) IO () +removeIcon phi disp reparent window = do + mmidParent <- gets $ M.lookup window + case mmidParent of + Just midParent -> do + sendMessage phi $ RemoveIcon window + sendMessage phi Repaint + liftIO $ do + selectInput disp window $ noEventMask + when reparent $ + reparentWindow disp window (defaultRootWindow disp) 0 0 + destroyWindow disp midParent + sync disp False + modify $ M.delete window + _ -> + return () + + +systray :: Systray +systray = Systray diff --git a/lib/Phi/Widgets/X11/Taskbar.hs b/lib/Phi/Widgets/X11/Taskbar.hs new file mode 100644 index 0000000..07a7292 --- /dev/null +++ b/lib/Phi/Widgets/X11/Taskbar.hs @@ -0,0 +1,649 @@ +{-# LANGUAGE MultiParamTypeClasses, DeriveDataTypeable, TypeSynonymInstances, FlexibleInstances #-} + +module Phi.Widgets.X11.Taskbar ( IconStyle + , idIconStyle + , desaturateIconStyle + , TaskStyle(..) + , DesktopStyle(..) + , TaskbarConfig(..) + , defaultTaskbarConfig + , Taskbar + , taskbar + ) where + +import Control.Arrow +import Control.Concurrent +import Control.Monad +import Control.Monad.State.Strict +import Control.Monad.Trans + +import Data.Array.MArray +import Data.Bits +import Data.Char +import Data.Function +import Data.IORef +import Data.List +import Data.Maybe +import Data.Typeable +import Data.Unique +import Data.Word +import qualified Data.Accessor.Basic as A +import qualified Data.Accessor.Container as AC +import qualified Data.Map as M + +import Foreign.C.Types + +import Graphics.Rendering.Cairo +import Graphics.Rendering.Pango.Cairo +import Graphics.Rendering.Pango.Enums (PangoRectangle(..)) +import Graphics.Rendering.Pango.Layout +import Graphics.Rendering.Pango.Font + +import Graphics.XHB +import Graphics.XHB.Gen.Xproto + +import Codec.Binary.UTF8.String + +import Phi.Phi +import Phi.Types +import Phi.Border +import Phi.Widget +import Phi.X11 +import Phi.X11.Atoms +import Phi.X11.Util + + +newtype IconStyle = IconStyle { withIconStyle :: Surface -> Render () } +instance Eq IconStyle where + _ == _ = True + +idIconStyle :: IconStyle +idIconStyle = IconStyle $ flip withPatternForSurface setSource + +desaturateIconStyle :: Double -> IconStyle +desaturateIconStyle v = IconStyle $ \icon -> do + w <- imageSurfaceGetWidth icon + h <- imageSurfaceGetHeight icon + + renderWithSimilarSurface ContentColorAlpha w h $ \surface -> do + renderWith surface $ do + setOperator OperatorAdd + withPatternForSurface icon setSource + paint + + setSourceRGB 0 0 0 + paint + + setOperator OperatorHslSaturation + setSourceRGBA 0 0 0 (1-v) + paint + + setOperator OperatorDestIn + withPatternForSurface icon setSource + paint + + withPatternForSurface surface setSource + + +downscaled :: Double -> Surface -> Render () +downscaled s surface = do + case True of + _ | s < 0.5 -> do + w <- imageSurfaceGetWidth surface + h <- imageSurfaceGetHeight surface + + renderWithSimilarSurface ContentColorAlpha (ceiling (fromIntegral w*s)) (ceiling (fromIntegral h*s)) $ \surface' -> do + renderWith surface' $ do + scale 0.5 0.5 + downscaled (2*s) surface + paint + withPatternForSurface surface' setSource + + | otherwise -> do + scale s s + withPatternForSurface surface setSource + + +data TaskStyle = TaskStyle { taskFont :: !String + , taskColor :: !Color + , taskBorder :: !BorderConfig + , taskIconStyle :: !IconStyle + } deriving Eq + +data DesktopStyle = DesktopStyle { desktopFont :: !String + , desktopLabelWidth :: !Int + , desktopLabelGap :: !Int + , desktopColor :: !Color + , desktopBorder :: !BorderConfig + } + +data TaskbarConfig = TaskbarConfig { taskMaxSize :: !Int + , normalTaskStyle :: !TaskStyle + , activeTaskStyle :: !TaskStyle + , desktopStyle :: !(Maybe (DesktopStyle, DesktopStyle)) + } + +defaultStyle :: TaskStyle +defaultStyle = TaskStyle { taskFont = "Sans 8" + , taskColor = (0, 0, 0, 1) + , taskBorder = defaultBorderConfig { backgroundColor = (0.75, 0.75, 0.75, 1) } + , taskIconStyle = idIconStyle + } + +defaultTaskbarConfig :: TaskbarConfig +defaultTaskbarConfig = TaskbarConfig { taskMaxSize = 200 + , normalTaskStyle = defaultStyle + , activeTaskStyle = defaultStyle {taskBorder = defaultBorderConfig { borderColor = (1, 1, 1, 1) }} + , desktopStyle = Nothing + } + +data Taskbar = Taskbar TaskbarConfig + +data TaskbarState = TaskbarState { taskbarScreens :: ![Rectangle] + , taskbarActiveWindow :: !WINDOW + , taskbarDesktopCount :: !Int + , taskbarCurrentDesktop :: !Int + , taskbarDesktopNames :: ![String] + , taskbarWindows :: ![WINDOW] + , taskbarWindowStates :: !(M.Map WINDOW WindowState) + } deriving Eq + +data Icon = Icon !Unique !Int !Surface +instance Eq Icon where (Icon a _ _) == (Icon b _ _) = a == b +instance Show Icon where show (Icon _ size _) = "Icon { size = " ++ (show size) ++ " }" + +createIcon :: Int -> Surface -> IO Icon +createIcon size surface = do + id <- newUnique + return $ Icon id size surface + + +data WindowState = WindowState { windowTitle :: !String + , windowDesktop :: !Int + , windowVisible :: !Bool + , windowIcons :: ![Icon] + , windowGeometry :: !Rectangle + } deriving (Eq, Show) + +data WindowCache = WindowCache { createScaledIconCached :: !(IOCache ([Icon], Int) (Maybe Icon)) + , renderWindowCached :: !(IOCache (String, Maybe Icon, TaskStyle, Int, Int) Surface) + } + +createScaledIconCached' = A.fromSetGet (\a cache -> cache {createScaledIconCached = a}) createScaledIconCached +renderWindowCached' = A.fromSetGet (\a cache -> cache {renderWindowCached = a}) renderWindowCached + + +newtype DesktopCache = DesktopCache (IOCache () ()) + +emptyWindowCache :: WindowCache +emptyWindowCache = WindowCache { createScaledIconCached = createIOCache createScaledIcon + , renderWindowCached = createIOCache doRenderWindow + } + +data TaskbarCache = TaskbarCache { desktopCaches :: !(M.Map Int DesktopCache) + , windowCaches :: !(M.Map WINDOW WindowCache) + } + +-- substitute for the liftT function in Data.Accessor.MonadState that uses the strict StateT variant +liftT :: (Monad m) => A.T r s -> StateT s m a -> StateT r m a +liftT f m = do + s0 <- gets $ A.get f + (a,s1) <- lift $ runStateT m s0 + modify $ A.set f s1 + return a + +liftIOStateT :: (MonadIO m) => StateT s IO a -> StateT s m a +liftIOStateT m = do + s0 <- get + (a,s1) <- liftIO $ runStateT m s0 + put s1 + return a + +cached :: (MonadIO m, Eq a) => A.T s (IOCache a b) -> a -> StateT s m b +cached t = liftT t . liftIOStateT . runIOCache + +data TaskbarMessage = WindowListUpdate ![WINDOW] !(M.Map WINDOW WindowState) + | DesktopCountUpdate !Int + | CurrentDesktopUpdate !Int + | DesktopNamesUpdate ![String] + | ActiveWindowUpdate !WINDOW + deriving (Typeable, Show) + +instance Widget Taskbar TaskbarState (M.Map WINDOW WindowCache) X11 where + initWidget (Taskbar _) phi dispvar screens = do + phi' <- dupPhi phi + forkIO $ taskbarRunner phi' dispvar + + return $ TaskbarState (map fst screens) (fromXid xidNone) 0 (-1) [] [] M.empty + + initCache _ = M.empty + + minSize _ _ _ _ = 0 + weight _ = 1 + + render (Taskbar config) TaskbarState { taskbarScreens = screens + , taskbarActiveWindow = activeWindow + , taskbarDesktopCount = desktopCount + , taskbarCurrentDesktop = currentDesktop + , taskbarDesktopNames = desktopNames + , taskbarWindows = windows + , taskbarWindowStates = windowStates + } _ _ w h screen = do + let windowScreen w = maximumBy (compare `on` unionArea (windowGeometry w)) screens + screenWindows = filter ((== Just screen) . fmap windowScreen . flip M.lookup windowStates) windows + desktopNumbers = take desktopCount $ zip [0..] (desktopNames ++ repeat "") + desktops = map (\desktop -> (desktop, filter (fromMaybe False . fmap (windowOnDesktop . fst $ desktop) . flip M.lookup windowStates) screenWindows)) desktopNumbers + + windowCount = sum $ map (length . snd) $ desktops + + dstyle d = fmap (if d == currentDesktop then snd else fst) $ desktopStyle config + dlabelwidth d = fromMaybe 0 $ fmap desktopLabelWidth $ dstyle d + gap d ds = if null (snd $ desktops !! d) then 0 else desktopLabelGap ds + dleftwidth d = fromMaybe 0 $ fmap (\ds@DesktopStyle {desktopBorder = border} + -> (borderLeft $ margin border) + (borderWidth border) + (borderLeft $ padding border) + + dlabelwidth d + gap d ds) $ dstyle d + dwidth d = fromMaybe 0 $ fmap (\ds@DesktopStyle {desktopBorder = border} + -> (borderH $ margin border) + 2*(borderWidth border) + (borderH $ padding border) + + dlabelwidth d + gap d ds) $ dstyle d + + desktopsWidth = sum $ map (dwidth . fst) desktopNumbers + windowWidth = if windowCount == 0 then 0 else min (taskMaxSize config) ((w - desktopsWidth) `div` windowCount) + + surface <- liftIO $ createImageSurface FormatARGB32 w h + cache <- liftM (M.filterWithKey $ \w _ -> elem w windows) get + cache' <- renderWith surface $ flip execStateT cache $ do + lift $ do + setOperator OperatorClear + paint + + setOperator OperatorOver + + flip (flip foldM_ 0) desktops $ \nwindows (desktop, desktopWindows) -> do + let dstyle' = dstyle (fst desktop) + dx = dleftwidth (fst desktop) + (sum $ map dwidth $ take (fst desktop) [0..]) + nwindows*windowWidth + + case dstyle' of + Just ds -> do + let (r, g, b, a) = desktopColor ds + lift $ do + save + drawBorder (desktopBorder ds) (dx - dleftwidth (fst desktop)) 0 (dwidth (fst desktop) + windowWidth * length desktopWindows) h + clip + + setSourceRGBA r g b a + renderText (desktopFont ds) (fromIntegral (dx - dlabelwidth (fst desktop) - gap (fst desktop) ds)) 0 (dlabelwidth (fst desktop)) h $ snd desktop + + restore + + forM_ (zip [0..] desktopWindows) $ \(i, window) -> do + let style = (if window == activeWindow then activeTaskStyle else normalTaskStyle) config + h' = h - (borderV $ margin $ desktopBorder ds) - 2*(borderWidth $ desktopBorder ds) - (borderV $ padding $ desktopBorder ds) + mstate = M.lookup window windowStates + x = dx + i*windowWidth + y = (borderTop $ margin $ desktopBorder ds) + (borderWidth $ desktopBorder ds) + (borderTop $ padding $ desktopBorder ds) + + case mstate of + Just state -> do + windowSurface <- liftT (AC.mapDefault emptyWindowCache window) . liftIOStateT $ renderWindow state style windowWidth h' + lift $ do + save + translate (fromIntegral $ x - 5) (fromIntegral $ y - 5) + withPatternForSurface windowSurface setSource + paint + restore + + Nothing -> return () + + _ -> return () + + return $ nwindows + length desktopWindows + put cache' + + return [(True, SurfaceSlice 0 surface)] + + + handleMessage _ priv m = case (fromMessage m) of + Just (WindowListUpdate windows windowStates) -> priv { taskbarWindows = windows + , taskbarWindowStates = windowStates + } + Just (DesktopCountUpdate count) -> priv {taskbarDesktopCount = count} + Just (CurrentDesktopUpdate current) -> priv {taskbarCurrentDesktop = current} + Just (DesktopNamesUpdate names) -> priv {taskbarDesktopNames = names} + Just (ActiveWindowUpdate window) -> priv {taskbarActiveWindow = window} + _ -> case (fromMessage m) of + Just (UpdateScreens screens) -> priv {taskbarScreens = map fst screens} + _ -> priv + + +renderText :: String -> Int -> Int -> Int -> Int -> String -> Render () +renderText font x y w h text = do + layout <- createLayout "" + (_, PangoRectangle _ _ textWidth textHeight) <- liftIO $ do + layoutSetMarkup layout $ "" ++ (escapeMarkup text) ++ "" + layoutSetWidth layout $ Just $ fromIntegral w + layoutSetEllipsize layout EllipsizeEnd + + layoutGetExtents layout + + + moveTo ((fromIntegral x) + ((fromIntegral w) - textWidth)/2) ((fromIntegral y) + ((fromIntegral h) - textHeight)/2) + showLayout layout + +renderWindow :: WindowState -> TaskStyle -> Int -> Int -> StateT WindowCache IO Surface +renderWindow state style w h = do + let h' = h - (borderV $ margin $ taskBorder style) + + scaledIcon <- cached createScaledIconCached' (windowIcons state, h') + cached renderWindowCached' (windowTitle state, scaledIcon, style, w, h) + +doRenderWindow :: (String, Maybe Icon, TaskStyle, Int, Int) -> IO Surface +doRenderWindow (title, scaledIcon, style, w, h) = do + let (r, g, b, a) = taskColor style + leftBorder = (borderLeft $ margin $ taskBorder style) + (borderWidth $ taskBorder style) + (borderLeft $ padding $ taskBorder style) + rightBorder = (borderRight $ margin $ taskBorder style) + (borderWidth $ taskBorder style) + (borderRight $ padding $ taskBorder style) + h' = h - (borderV $ margin $ taskBorder style) + + surface <- createImageSurface FormatARGB32 (w+10) (h+10) + renderWith surface $ do + translate 5 5 + + save + drawBorder (taskBorder style) 0 0 w h + clip + + setSourceRGBA r g b a + renderText (taskFont style) (fromIntegral (leftBorder + h' + 3)) 0 (w - leftBorder - h' - 3 - rightBorder) h title + + restore + + case scaledIcon of + Just (Icon _ _ icon) -> do + save + translate (fromIntegral leftBorder) (fromIntegral . borderTop . margin . taskBorder $ style) + withIconStyle (taskIconStyle style) icon + paint + restore + + _ -> return () + + return surface + + +createScaledIcon :: ([Icon], Int) -> IO (Maybe Icon) +createScaledIcon (icons, h) = do + case bestIcon of + Just (Icon _ _ icon) -> do + scaledIcon <- createSimilarSurface icon ContentColorAlpha h h + renderWith scaledIcon $ do + imageW <- imageSurfaceGetWidth icon + imageH <- imageSurfaceGetHeight icon + + let scalef = (fromIntegral h)/(fromIntegral $ max imageW imageH) + + case () of + _ | imageH < imageW -> translate 0 (fromIntegral (imageW-imageH)*scalef/2) + | otherwise -> translate (fromIntegral (imageH-imageW)*scalef/2) 0 + + downscaled scalef icon + paint + fmap Just $ createIcon h scaledIcon + + _ -> return Nothing + + where + bestIcon = listToMaybe $ sortBy compareIcons icons + compareIcons = flip (compare `on` (\(Icon _ size _) -> size)) + + +windowOnDesktop :: Int -> WindowState -> Bool +windowOnDesktop desktop state = (windowVisible state) && (desktop == windowDesktop state) + + +taskbarRunner :: Phi -> X11 -> IO () +taskbarRunner phi x11 = do + (windows, states) <- liftIO $ do + (windows, states) <- getWindowStates x11 M.empty + desktopCount <- getDesktopCount x11 + current <- getCurrentDesktop x11 + names <- getDesktopNames x11 + activeWindow <- getActiveWindow x11 + sendMessage phi $ WindowListUpdate windows states + sendMessage phi $ DesktopCountUpdate desktopCount + sendMessage phi $ CurrentDesktopUpdate current + sendMessage phi $ DesktopNamesUpdate names + sendMessage phi $ ActiveWindowUpdate activeWindow + return (windows, states) + sendMessage phi Repaint + + flip evalStateT (windows, states) $ forever $ do + m <- receiveMessage phi + case (fromMessage m) of + Just (XEvent event) -> + handleEvent phi x11 event + _ -> + return () + + +handleEvent :: Phi -> X11 -> SomeEvent -> StateT ([WINDOW], M.Map WINDOW WindowState) IO () +handleEvent phi x11 event = + case (fromEvent event) of + Just e -> handlePropertyNotifyEvent phi x11 e + Nothing -> case (fromEvent event) of + Just e -> handleConfigureNotifyEvent phi x11 e + Nothing -> return () + +handlePropertyNotifyEvent :: Phi -> X11 -> PropertyNotifyEvent -> StateT ([WINDOW], M.Map WINDOW WindowState) IO () +handlePropertyNotifyEvent phi x11 MkPropertyNotifyEvent {atom_PropertyNotifyEvent = atom, window_PropertyNotifyEvent = window} = do + let atoms = x11Atoms x11 + rootwin = root_SCREEN . x11Screen $ x11 + + when (elem atom $ map ($ atoms) [ atom_NET_ACTIVE_WINDOW + , atom_NET_NUMBER_OF_DESKTOPS + , atom_NET_CURRENT_DESKTOP + , atom_NET_DESKTOP_NAMES + , atom_NET_CLIENT_LIST + , atom_NET_WM_ICON + , atomWM_NAME + , atom_NET_WM_NAME + , atom_NET_WM_DESKTOP + , atom_NET_WM_STATE + ]) $ do + if (window == rootwin) + then do + when (atom == atom_NET_ACTIVE_WINDOW atoms) $ do + activeWindow <- liftIO $ getActiveWindow x11 + sendMessage phi $ ActiveWindowUpdate activeWindow + sendMessage phi Repaint + when (atom == atom_NET_NUMBER_OF_DESKTOPS atoms) $ do + desktopCount <- liftIO $ getDesktopCount x11 + sendMessage phi $ DesktopCountUpdate desktopCount + sendMessage phi Repaint + when (atom == atom_NET_CURRENT_DESKTOP atoms) $ do + current <- liftIO $ getCurrentDesktop x11 + sendMessage phi $ CurrentDesktopUpdate current + sendMessage phi Repaint + when (atom == atom_NET_DESKTOP_NAMES atoms) $ do + names <- liftIO $ getDesktopNames x11 + sendMessage phi $ DesktopNamesUpdate names + sendMessage phi Repaint + when (atom == atom_NET_CLIENT_LIST atoms) $ do + (windows, windowStates) <- get + (windows', windowStates') <- liftIO $ getWindowStates x11 windowStates + + when (windows /= windows') $ do + sendMessage phi $ WindowListUpdate windows' windowStates' + sendMessage phi Repaint + put (windows', windowStates') + + else do + (windows, windowStates) <- get + when (elem window windows) $ do + case () of + _ | (atom == atom_NET_WM_ICON atoms) -> do + icons <- liftIO $ getWindowIcons x11 window + let windowStates' = M.update (\state -> Just state {windowIcons = icons}) window windowStates + sendMessage phi $ WindowListUpdate windows windowStates' + sendMessage phi Repaint + put (windows, windowStates') + + | otherwise -> do + (name, desktop, visible) <- liftIO $ getWindowInfo x11 window + let mwindowState = M.lookup window windowStates + case mwindowState of + Just windowState -> do + let windowState' = windowState {windowTitle = name, windowDesktop = desktop, windowVisible = visible} + + when (windowState /= windowState') $ do + let windowStates' = M.insert window windowState' windowStates + sendMessage phi $ WindowListUpdate windows windowStates' + sendMessage phi Repaint + put (windows, windowStates') + Nothing -> + return () + + +handleConfigureNotifyEvent :: Phi -> X11 -> ConfigureNotifyEvent -> StateT ([WINDOW], M.Map WINDOW WindowState) IO () +handleConfigureNotifyEvent phi x11 MkConfigureNotifyEvent {window_ConfigureNotifyEvent = window} = do + let conn = x11Connection x11 + (windows, windowStates) <- get + when (elem window windows) $ do + let geom = fmap windowGeometry . M.lookup window $ windowStates + geom' <- liftIO $ getWindowGeometry x11 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') + + +getDesktopCount :: X11 -> IO Int +getDesktopCount x11 = + liftM (fromIntegral . fromMaybe 0 . join . fmap listToMaybe) $ getProperty32 (x11Connection x11) (root_SCREEN . x11Screen $ x11) (atom_NET_NUMBER_OF_DESKTOPS . x11Atoms $ x11) + +getCurrentDesktop :: X11 -> IO Int +getCurrentDesktop x11 = + liftM (fromIntegral . fromMaybe (-1) . join . fmap listToMaybe) $ getProperty32 (x11Connection x11) (root_SCREEN . x11Screen $ x11) (atom_NET_CURRENT_DESKTOP . x11Atoms $ x11) + +getDesktopNames :: X11 -> IO [String] +getDesktopNames x11 = + liftM (map (decode . map fromIntegral) . break' . fromMaybe []) $ getProperty8 (x11Connection x11) (root_SCREEN . x11Screen $ x11) (atom_NET_DESKTOP_NAMES . x11Atoms $ x11) + where + break' l = case dropWhile (== 0) l of + [] -> [] + l' -> w : break' l'' + where (w, l'') = break (== 0) l' + +getActiveWindow :: X11 -> IO WINDOW +getActiveWindow x11 = + liftM (fromXid . toXid . fromMaybe 0 . join . fmap listToMaybe) $ getProperty32 (x11Connection x11) (root_SCREEN . x11Screen $ x11) (atom_NET_ACTIVE_WINDOW . x11Atoms $ x11) + +getWindowStates :: X11 -> M.Map WINDOW WindowState -> IO ([WINDOW], M.Map WINDOW WindowState) +getWindowStates x11 windowStates = do + windows <- getWindowList x11 + + let windowStates' = map (\w -> (w, M.lookup w windowStates)) windows + + newWindowStates <- mapM getWindowState' windowStates' + + return (windows, M.fromList newWindowStates) + where + getWindowState' (window, Just windowState) = return (window, windowState) + getWindowState' (window, Nothing) = do + changeWindowAttributes (x11Connection x11) window $ toValueParam [(CWEventMask, toMask [EventMaskPropertyChange, EventMaskStructureNotify])] + windowState <- getWindowState x11 window + return (window, windowState) + +getWindowState :: X11 -> WINDOW -> IO WindowState +getWindowState x11 window = do + (name, workspace, visible) <- getWindowInfo x11 window + icons <- getWindowIcons x11 window + geom <- getWindowGeometry x11 window + + return $ WindowState { windowTitle = name + , windowDesktop = workspace + , windowVisible = visible + , windowIcons = icons + , windowGeometry = geom + } + +getWindowInfo :: X11 -> WINDOW -> IO (String, Int, Bool) +getWindowInfo x11 window = do + let conn = x11Connection x11 + atoms = x11Atoms x11 + netwmname <- liftM (fmap (decode . map fromIntegral)) $ getProperty8 conn window (atom_NET_WM_NAME atoms) + wmname <- case netwmname of + Just name -> return name + Nothing -> liftM (map unsignedChr . fromMaybe []) $ getProperty8 conn window (atom_NET_WM_NAME atoms) + + workspace <- liftM (fromIntegral . fromMaybe 0xFFFFFFFF . join . fmap listToMaybe) $ getProperty32 conn window (atom_NET_WM_DESKTOP atoms) + visible <- showWindow conn atoms window + + return (wmname, workspace, visible) + where + unsignedChr = chr . fromIntegral + +getWindowIcons :: X11 -> WINDOW -> IO [Icon] +getWindowIcons x11 window = getProperty32 (x11Connection x11) window (atom_NET_WM_ICON . x11Atoms $ x11) >>= readIcons . fromMaybe [] + + +readIcons :: [Word32] -> IO [Icon] +readIcons (width:height:iconData) = do + if ((fromIntegral $ length iconData) < (width*height)) then return [] else do + let (thisIcon, rest) = splitAt (fromIntegral (width*height)) iconData + surface <- createImageSurface FormatARGB32 (fromIntegral width) (fromIntegral height) + surfaceData <- imageSurfaceGetPixels surface :: IO (SurfaceData Int Word32) + forM_ (zip thisIcon [0..]) $ \(e, i) -> writeArray surfaceData i $ premultiply $ fromIntegral e + + surfaceMarkDirty surface + + liftM2 (:) (createIcon (fromIntegral $ max width height) surface) (readIcons rest) + +readIcons _ = return [] + +premultiply :: Word32 -> Word32 +premultiply c = a .|. r .|. g .|. b + where + amask = 0xFF000000 + rmask = 0x00FF0000 + gmask = 0x0000FF00 + bmask = 0x000000FF + + a = c .&. amask + pm mask = (((c .&. mask) * (a `shiftR` 24)) `div` 0xFF) .&. mask + + r = pm rmask + g = pm gmask + b = pm bmask + + +getWindowGeometry :: X11 -> WINDOW -> IO Rectangle +getWindowGeometry x11 window = + getGeometry (x11Connection x11) (fromXid . toXid $ window) >>= getReply >>= + return . ((const $ Rectangle 0 0 0 0) ||| (\(MkGetGeometryReply _ _ x y width height _) -> Rectangle (fi x) (fi y) (fi width) (fi height))) + where + fi :: (Integral a, Num b) => a -> b + fi = fromIntegral + +showWindow :: Connection -> Atoms -> WINDOW -> IO Bool +showWindow conn atoms window = do + states <- liftM (map (fromXid . toXid) . fromMaybe []) $ getProperty32 conn window (atom_NET_WM_STATE atoms) + transientFor <- liftM (map fromIntegral . fromMaybe []) $ getProperty32 conn window (atomWM_TRANSIENT_FOR atoms) + windowType <- liftM (fromMaybe (atom_NET_WM_WINDOW_TYPE_NORMAL atoms) . fmap (fromXid . toXid) . join . fmap listToMaybe) $ + getProperty32 conn window (atom_NET_WM_STATE atoms) + + return $ not $ or [ elem (atom_NET_WM_STATE_SKIP_TASKBAR atoms) states + , transientFor /= [] && transientFor /= [0] + , elem windowType $ map ($ atoms) [ atom_NET_WM_WINDOW_TYPE_DOCK + , atom_NET_WM_WINDOW_TYPE_DESKTOP + , atom_NET_WM_WINDOW_TYPE_TOOLBAR + , atom_NET_WM_WINDOW_TYPE_MENU + , atom_NET_WM_WINDOW_TYPE_SPLASH + ] + ] + + +getWindowList :: X11 -> IO [WINDOW] +getWindowList x11 = liftM (map (fromXid . toXid) . join . maybeToList) $ getProperty32 (x11Connection x11) (root_SCREEN . x11Screen $ x11) (atom_NET_CLIENT_LIST . x11Atoms $ x11) + +taskbar :: TaskbarConfig -> Taskbar +taskbar = Taskbar diff --git a/lib/Phi/X11.hs b/lib/Phi/X11.hs index 7e0bfff..713b162 100644 --- a/lib/Phi/X11.hs +++ b/lib/Phi/X11.hs @@ -1,13 +1,17 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving, ExistentialQuantification #-} +{-# LANGUAGE GeneralizedNewtypeDeriving, ExistentialQuantification, TypeFamilies, FlexibleContexts, DeriveDataTypeable #-} -module Phi.X11 ( XConfig(..) +module Phi.X11 ( X11(..) + , XEvent(..) + , XMessage(..) + , XConfig(..) , defaultXConfig , runPhi ) where -import Graphics.XHB +import Graphics.XHB hiding (Window) +import qualified Graphics.XHB.Connection.Open as CO import Graphics.XHB.Gen.Xinerama -import Graphics.XHB.Gen.Xproto +import Graphics.XHB.Gen.Xproto hiding (Window) import Graphics.Rendering.Cairo @@ -36,33 +40,51 @@ import Phi.Phi import Phi.X11.Util import qualified Phi.Types as Phi import qualified Phi.Panel as Panel -import qualified Phi.Widget as Widget -import Phi.Widget hiding (Display, handleMessage) +import qualified Phi.Widget as Widget (handleMessage) +import Phi.Widget hiding (handleMessage) import Phi.X11.Atoms -data XConfig = XConfig { phiXScreenInfo :: !(Connection -> IO [RECTANGLE]) +data X11 = X11 { x11Connection :: !Connection + , x11Atoms :: !Atoms + , x11Screen :: !SCREEN + } + +instance Display X11 where + type Window X11 = WINDOW + + +newtype XEvent = XEvent SomeEvent deriving Typeable + +instance Show XEvent where + show _ = "XEvent (..)" + +data XMessage = UpdateScreens [(Rectangle, WINDOW)] deriving (Show, Typeable) + + +data XConfig = XConfig { phiXScreenInfo :: !(X11 -> IO [Rectangle]) } -data PhiState w s c = (Widget.Widget w s c) => PhiState { phiRootImage :: !Surface - , phiPanels :: ![PanelState w s c] - , 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 - , panelWidgetCache :: !c - } +data PhiState w s c = (Widget w s c X11) => PhiState { phiRootImage :: !Surface + , phiPanels :: ![PanelState w s c] + , phiRepaint :: !Bool + , phiShutdown :: !Bool + , phiShutdownHold :: !Int + , phiWidgetState :: !s + } + +data PanelState w s c = (Widget w s c X11) => PanelState { panelWindow :: !WINDOW + , panelPixmap :: !PIXMAP + , panelArea :: !Rectangle + , panelScreenArea :: !Rectangle + , panelWidgetCache :: !c + } data PhiConfig w s c = PhiConfig { phiPhi :: !Phi , phiPanelConfig :: !Panel.PanelConfig , phiXConfig :: !XConfig - , phiAtoms :: !Atoms + , phiX11 :: !X11 + , phiXCB :: !XCB.Connection , phiWidget :: !w } @@ -81,17 +103,22 @@ runPhiX config st (PhiX a) = runPhiReader config $ runStateT a st defaultXConfig = XConfig { phiXScreenInfo = getScreenInfo } -getScreenInfo :: Connection -> IO [RECTANGLE] -getScreenInfo conn = do +getScreenInfo :: X11 -> IO [Rectangle] +getScreenInfo x11 = do + let conn = x11Connection x11 + screen = x11Screen x11 exs <- queryScreens conn >>= getReply case exs of Right xs -> return . map screenInfoToRect $ screen_info_QueryScreensReply xs - Left _ -> getGeometry conn (fromXid . toXid $ getRoot conn) >>= getReply' "getScreenInfo: getGeometry failed" >>= - return . (\(MkGetGeometryReply _ _ x y w h _) -> [MkRECTANGLE x y w h]) + Left _ -> getGeometry conn (fromXid . toXid $ root_SCREEN screen) >>= getReply' "getScreenInfo: getGeometry failed" >>= + return . (\(MkGetGeometryReply _ _ x y w h _) -> [Rectangle (fi x) (fi y) (fi w) (fi h)]) where - screenInfoToRect (MkScreenInfo x y w h) = MkRECTANGLE x y w h + screenInfoToRect (MkScreenInfo x y w h) = Rectangle (fi x) (fi y) (fi w) (fi h) + + fi :: (Integral a, Num b) => a -> b + fi = fromIntegral -runPhi :: (Widget.Widget w s c) => XConfig -> Panel.PanelConfig -> w -> IO () +runPhi :: (Widget w s c X11) => XConfig -> Panel.PanelConfig -> w -> IO () runPhi xconfig config widget = do phi <- initPhi @@ -102,24 +129,30 @@ runPhi xconfig config widget = do conn <- liftM fromJust connect xcb <- XCB.connect + let dispname = displayInfo conn + screen = (roots_Setup . connectionSetup $ conn) !! CO.screen dispname + atoms <- initAtoms conn - changeWindowAttributes conn (getRoot conn) $ toValueParam [(CWEventMask, toMask [EventMaskPropertyChange, EventMaskStructureNotify])] + changeWindowAttributes conn (root_SCREEN screen) $ toValueParam [(CWEventMask, toMask [EventMaskPropertyChange, EventMaskStructureNotify])] bg <- createImageSurface FormatRGB24 1 1 - screens <- liftIO $ phiXScreenInfo xconfig conn - panelWindows <- mapM (createPanelWindow conn config) screens - let dispvar = Widget.Display conn atoms - widget' = widget <~> separator 0 (if weight widget > 0 then 0 else 1) + let x11 = X11 conn atoms screen + + screens <- liftIO $ phiXScreenInfo xconfig x11 + panelWindows <- mapM (createPanelWindow conn screen config) screens + + let widget' = widget <~> separator 0 (if weight widget > 0 then 0 else 1) screenPanels = zip screens panelWindows - initialState <- Widget.initWidget widget' phi dispvar screenPanels + initialState <- initWidget widget' phi x11 screenPanels runPhiX PhiConfig { phiPhi = phi , phiXConfig = xconfig , phiPanelConfig = config - , phiAtoms = atoms + , phiX11 = x11 + , phiXCB = xcb , phiWidget = widget' } PhiState { phiRootImage = bg @@ -129,15 +162,15 @@ runPhi xconfig config widget = do , phiShutdownHold = 0 , phiWidgetState = initialState } $ do - updateRootImage conn xcb + updateRootImage - panels <- mapM (\(screen, window) -> createPanel conn window screen) screenPanels + panels <- mapM (\(screen, window) -> createPanel window screen) screenPanels - forM_ panels $ setPanelProperties conn + forM_ panels setPanelProperties modify $ \state -> state { phiPanels = panels } - updatePanels conn xcb + updatePanels forM_ panels $ liftIO . mapWindow conn . panelWindow @@ -150,11 +183,11 @@ runPhi xconfig config widget = do available <- messageAvailable phi when (not available && repaint) $ do - updatePanels conn xcb + updatePanels modify $ \state -> state {phiRepaint = False} message <- receiveMessage phi - handleMessage conn xcb message + handleMessage message case (fromMessage message) of Just Shutdown -> @@ -179,8 +212,8 @@ termHandler :: Phi -> Handler termHandler phi = Catch $ sendMessage phi Shutdown -handleMessage :: (Widget w s c) => Connection -> XCB.Connection -> Message -> PhiX w s c () -handleMessage conn xcb m = do +handleMessage :: (Widget w s c X11) => Message -> PhiX w s c () +handleMessage m = do w <- asks phiWidget modify $ \state -> state {phiWidgetState = Widget.handleMessage w (phiWidgetState state) m} @@ -190,81 +223,86 @@ handleMessage conn xcb m = do _ -> case (fromMessage m) of Just (XEvent event) -> - handleEvent conn xcb event + handleEvent event _ -> return () -handleEvent :: (Widget w s c) => Connection -> XCB.Connection -> SomeEvent -> PhiX w s c () -handleEvent conn xcb event = +handleEvent :: (Widget w s c X11) => SomeEvent -> PhiX w s c () +handleEvent event = case (fromEvent event) of - Just e -> handlePropertyNotifyEvent conn xcb e + Just e -> handlePropertyNotifyEvent e Nothing -> case (fromEvent event) of - Just e -> handleConfigureNotifyEvent conn e + Just e -> handleConfigureNotifyEvent e Nothing -> return () -handlePropertyNotifyEvent :: (Widget w s c) => Connection -> XCB.Connection -> PropertyNotifyEvent -> PhiX w s c () -handlePropertyNotifyEvent conn xcb MkPropertyNotifyEvent { atom_PropertyNotifyEvent = atom } = do +handlePropertyNotifyEvent :: (Widget w s c X11) => PropertyNotifyEvent -> PhiX w s c () +handlePropertyNotifyEvent MkPropertyNotifyEvent { atom_PropertyNotifyEvent = atom } = do phi <- asks phiPhi - atoms <- asks phiAtoms + atoms <- asks (x11Atoms . phiX11) panels <- gets phiPanels when (atom == atom_XROOTPMAP_ID atoms || atom == atom_XROOTMAP_ID atoms) $ do - updateRootImage conn xcb + updateRootImage sendMessage phi ResetBackground sendMessage phi Repaint -handleConfigureNotifyEvent :: (Widget w s c) => Connection -> ConfigureNotifyEvent -> PhiX w s c () -handleConfigureNotifyEvent conn MkConfigureNotifyEvent { window_ConfigureNotifyEvent = window } | window == getRoot conn = do - phi <- asks phiPhi - xconfig <- asks phiXConfig - config <- asks phiPanelConfig - panels <- gets phiPanels - let screens = map panelScreenArea panels - screens' <- liftIO $ phiXScreenInfo xconfig conn - - when (screens /= screens') $ do - liftIO $ do - mapM_ (freePixmap conn . panelPixmap) panels - mapM_ (destroyWindow conn . panelWindow) $ drop (length screens') panels - - let panelsScreens = zip screens' $ map Just panels ++ repeat Nothing - - panels' <- forM panelsScreens $ \(screen, mpanel) -> - case mpanel of - Just panel -> do - let rect = panelBounds config screen - win = panelWindow panel - - liftIO $ configureWindow conn win $ toValueParam [ (ConfigWindowX, fromIntegral $ x_RECTANGLE rect) - , (ConfigWindowY, fromIntegral $ y_RECTANGLE rect) - , (ConfigWindowWidth, fromIntegral $ width_RECTANGLE rect) - , (ConfigWindowHeight, fromIntegral $ height_RECTANGLE rect) - ] - - panel' <- createPanel conn win screen - setPanelProperties conn panel' - - return panel' - Nothing -> do - win <- liftIO $ createPanelWindow conn config screen - panel <- createPanel conn win screen - setPanelProperties conn panel - liftIO $ mapWindow conn $ panelWindow panel - return panel - - modify $ \state -> state { phiPanels = panels' } +handleConfigureNotifyEvent :: (Widget w s c X11) => ConfigureNotifyEvent -> PhiX w s c () +handleConfigureNotifyEvent MkConfigureNotifyEvent { window_ConfigureNotifyEvent = window } = do + x11 <- asks phiX11 + let conn = x11Connection x11 + screen = x11Screen x11 + rootWindow = root_SCREEN screen + when (window == rootWindow) $ do + phi <- asks phiPhi + xconfig <- asks phiXConfig + config <- asks phiPanelConfig + panels <- gets phiPanels + let screens = map panelScreenArea panels + screens' <- liftIO $ phiXScreenInfo xconfig x11 - sendMessage phi $ UpdateScreens $ map (panelScreenArea &&& panelWindow) panels' - sendMessage phi Repaint - -handleConfigureNotifyEvent _ _ = return () + when (screens /= screens') $ do + liftIO $ do + mapM_ (freePixmap conn . panelPixmap) panels + mapM_ (destroyWindow conn . panelWindow) $ drop (length screens') panels + + let panelsScreens = zip screens' $ map Just panels ++ repeat Nothing + + panels' <- forM panelsScreens $ \(screenarea, mpanel) -> + case mpanel of + Just panel -> do + let rect = panelBounds config screenarea + win = panelWindow panel + + liftIO $ configureWindow conn win $ toValueParam [ (ConfigWindowX, fromIntegral $ rect_x rect) + , (ConfigWindowY, fromIntegral $ rect_y rect) + , (ConfigWindowWidth, fromIntegral $ rect_width rect) + , (ConfigWindowHeight, fromIntegral $ rect_height rect) + ] + + panel' <- createPanel win screenarea + setPanelProperties panel' + + return panel' + Nothing -> do + win <- liftIO $ createPanelWindow conn screen config screenarea + panel <- createPanel win screenarea + setPanelProperties panel + liftIO $ mapWindow conn $ panelWindow panel + return panel + + modify $ \state -> state { phiPanels = panels' } + + sendMessage phi $ UpdateScreens $ map (panelScreenArea &&& panelWindow) panels' + sendMessage phi Repaint receiveEvents :: Phi -> Connection -> IO () receiveEvents phi conn = do forever $ waitForEvent conn >>= sendMessage phi . XEvent -updatePanels :: (Widget w s c) => Connection -> XCB.Connection -> PhiX w s c () -updatePanels conn xcb = do +updatePanels :: (Widget w s c X11) => PhiX w s c () +updatePanels = do + X11 conn _ screen <- asks phiX11 + xcb <- asks phiXCB w <- asks phiWidget s <- gets phiWidgetState rootImage <- gets phiRootImage @@ -275,17 +313,16 @@ updatePanels conn xcb = do area = panelArea panel (panelSurfaces, cache') <- liftIO $ flip runStateT (panelWidgetCache panel) $ - (withDimension area $ Widget.render w s 0 0) (panelScreenArea panel) + (withDimension area $ render w s 0 0) (panelScreenArea panel) - let screen = head . roots_Setup . connectionSetup $ conn - visualtype = fromJust $ findVisualtype screen (root_visual_SCREEN screen) + let visualtype = fromJust $ findVisualtype screen (root_visual_SCREEN screen) xbuffer <- liftIO $ withDimension area $ XCB.createXCBSurface xcb (fromXid . toXid $ pixmap) visualtype liftIO $ (withDimension area $ withSimilarSurface xbuffer ContentColor) $ \buffer -> do renderWith buffer $ do save - translate (-(fromIntegral $ x_RECTANGLE area)) (-(fromIntegral $ y_RECTANGLE area)) + translate (-(fromIntegral $ rect_x area)) (-(fromIntegral $ rect_y area)) withPatternForSurface rootImage $ \pattern -> do patternSetExtend pattern ExtendRepeat setSource pattern @@ -313,12 +350,12 @@ updatePanels conn xcb = do modify $ \state -> state { phiPanels = panels' } -updateRootImage :: Connection -> XCB.Connection -> PhiX w s c () -updateRootImage conn xcb = do - atoms <- asks phiAtoms +updateRootImage :: PhiX w s c () +updateRootImage = do + X11 conn atoms screen <- asks phiX11 + xcb <- asks phiXCB - let screen = head . roots_Setup . connectionSetup $ conn - visualtype = fromJust $ findVisualtype screen (root_visual_SCREEN screen) + let visualtype = fromJust $ findVisualtype screen (root_visual_SCREEN screen) rootwin = root_SCREEN screen pixmap <- liftM (fromXid . toXid . fromMaybe 0 . listToMaybe . join . catMaybes) $ forM [atom_XROOTPMAP_ID atoms, atom_XROOTMAP_ID atoms] $ @@ -355,12 +392,12 @@ updateRootImage conn xcb = do return () -createPanel :: (Widget w s c) => Connection -> WINDOW -> RECTANGLE -> PhiX w s c (PanelState w s c) -createPanel conn win screenRect = do +createPanel :: (Widget w s c X11) => WINDOW -> Rectangle -> PhiX w s c (PanelState w s c) +createPanel win screenRect = do + (conn, screen) <- asks $ (x11Connection &&& x11Screen) . phiX11 config <- asks phiPanelConfig w <- asks phiWidget let rect = panelBounds config screenRect - screen = head . roots_Setup . connectionSetup $ conn depth = root_depth_SCREEN screen pixmap <- liftIO $ newResource conn @@ -374,10 +411,9 @@ createPanel conn win screenRect = do , panelWidgetCache = initCache w } -createPanelWindow :: Connection -> Panel.PanelConfig -> RECTANGLE -> IO WINDOW -createPanelWindow conn config screenRect = do +createPanelWindow :: Connection -> SCREEN -> Panel.PanelConfig -> Rectangle -> IO WINDOW +createPanelWindow conn screen config screenRect = do let rect = panelBounds config screenRect - screen = head . roots_Setup . connectionSetup $ conn depth = root_depth_SCREEN screen rootwin = root_SCREEN screen visual = root_visual_SCREEN screen @@ -387,9 +423,9 @@ createPanelWindow conn config screenRect = do return win -setPanelProperties :: Connection -> PanelState w s c -> PhiX w s c () -setPanelProperties conn panel = do - atoms <- asks phiAtoms +setPanelProperties :: PanelState w s c -> PhiX w s c () +setPanelProperties panel = do + (conn, atoms) <- asks $ (x11Connection &&& x11Atoms) . phiX11 liftIO $ do let name = map (fromIntegral . ord) "Phi" changeProperty8 conn PropModeReplace (panelWindow panel) (atomWM_NAME atoms) (atomSTRING atoms) name @@ -408,28 +444,28 @@ setPanelProperties conn panel = do changeProperty8 conn PropModeReplace (panelWindow panel) (atomWM_CLASS atoms) (atomSTRING atoms) $ map (fromIntegral . ord) "phi\0Phi" - setStruts conn panel + setStruts panel -setStruts :: Connection -> PanelState w s c -> PhiX w s c () -setStruts conn panel = do - atoms <- asks phiAtoms +setStruts :: PanelState w s c -> PhiX w s c () +setStruts panel = do + X11 conn atoms screen <- asks phiX11 config <- asks phiPanelConfig - let rootwin = getRoot conn + let rootwin = root_SCREEN screen position = Panel.panelPosition config area = panelArea panel rootHeight <- liftIO $ getGeometry conn (fromXid . toXid $ rootwin) >>= getReply' "setStruts: getGeometry failed" >>= return . height_GetGeometryReply let struts = [makeStruts i | i <- [0..11]] where - makeTopStruts 2 = (fromIntegral $ y_RECTANGLE area) + (fromIntegral $ height_RECTANGLE area) - makeTopStruts 8 = (fromIntegral $ x_RECTANGLE area) - makeTopStruts 9 = (fromIntegral $ x_RECTANGLE area) + (fromIntegral $ width_RECTANGLE area) - 1 + makeTopStruts 2 = (fromIntegral $ rect_y area) + (fromIntegral $ rect_height area) + makeTopStruts 8 = (fromIntegral $ rect_x area) + makeTopStruts 9 = (fromIntegral $ rect_x area) + (fromIntegral $ rect_width area) - 1 makeTopStruts _ = 0 - makeBottomStruts 3 = (fromIntegral rootHeight) - (fromIntegral $ y_RECTANGLE area) - makeBottomStruts 10 = (fromIntegral $ x_RECTANGLE area) - makeBottomStruts 11 = (fromIntegral $ x_RECTANGLE area) + (fromIntegral $ width_RECTANGLE area) - 1 + makeBottomStruts 3 = (fromIntegral rootHeight) - (fromIntegral $ rect_y area) + makeBottomStruts 10 = (fromIntegral $ rect_x area) + makeBottomStruts 11 = (fromIntegral $ rect_x area) + (fromIntegral $ rect_width area) - 1 makeBottomStruts _ = 0 makeStruts = case position of @@ -441,17 +477,17 @@ setStruts conn panel = do changeProperty32 conn PropModeReplace (panelWindow panel) (atom_NET_WM_STRUT_PARTIAL atoms) (atomCARDINAL atoms) struts -panelBounds :: Panel.PanelConfig -> RECTANGLE -> RECTANGLE +panelBounds :: Panel.PanelConfig -> Rectangle -> Rectangle panelBounds config screenBounds = case Panel.panelPosition config of - Phi.Top -> screenBounds { height_RECTANGLE = fromIntegral $ Panel.panelSize config } - Phi.Bottom -> screenBounds { height_RECTANGLE = fromIntegral $ Panel.panelSize config, - y_RECTANGLE = (y_RECTANGLE screenBounds) + (fromIntegral $ height_RECTANGLE screenBounds) - (fromIntegral $ Panel.panelSize config) } + Phi.Top -> screenBounds { rect_height = Panel.panelSize config } + Phi.Bottom -> screenBounds { rect_height = Panel.panelSize config, + rect_y = rect_y screenBounds + rect_height screenBounds - Panel.panelSize config } -withRectangle :: (Num x, Num y, Num w, Num h) => RECTANGLE -> (x -> y -> w -> h -> a) -> a +withRectangle :: (Num x, Num y, Num w, Num h) => Rectangle -> (x -> y -> w -> h -> a) -> a withRectangle r = withDimension r . withPosition r -withPosition :: (Num x, Num y) => RECTANGLE -> (x -> y -> a) -> a -withPosition r f = f (fromIntegral $ x_RECTANGLE r) (fromIntegral $ y_RECTANGLE r) +withPosition :: (Num x, Num y) => Rectangle -> (x -> y -> a) -> a +withPosition r f = f (fromIntegral $ rect_x r) (fromIntegral $ rect_y r) -withDimension :: (Num w, Num h) => RECTANGLE -> (w -> h -> a) -> a -withDimension r f = f (fromIntegral $ width_RECTANGLE r) (fromIntegral $ height_RECTANGLE r) +withDimension :: (Num w, Num h) => Rectangle -> (w -> h -> a) -> a +withDimension r f = f (fromIntegral $ rect_width r) (fromIntegral $ rect_height r) diff --git a/lib/Phi/X11/AtomList.hs b/lib/Phi/X11/AtomList.hs index 5fbd98c..31a029a 100644 --- a/lib/Phi/X11/AtomList.hs +++ b/lib/Phi/X11/AtomList.hs @@ -53,4 +53,4 @@ atoms = [ "ATOM" -- the expression must have the type (Connection -> String) specialAtoms :: [(String, Q Exp)] specialAtoms = [ ("_NET_SYSTEM_TRAY_SCREEN", [|("_NET_SYSTEM_TRAY_S" ++) . show . screen . displayInfo|]) - ] \ No newline at end of file + ] -- cgit v1.2.3