{-# LANGUAGE MultiParamTypeClasses, DeriveDataTypeable, TypeSynonymInstances, FlexibleInstances #-} module Phi.Widgets.Taskbar ( IconStyle , idIconStyle , desaturateIconStyle , TaskStyle(..) , DesktopStyle(..) , TaskbarConfig(..) , defaultTaskbarConfig , Taskbar , taskbar ) where 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.X11.Xlib (Window) import qualified Graphics.X11.Xlib as Xlib import qualified Graphics.X11.Xlib.Extras as XExtras import Codec.Binary.UTF8.String import Phi.Phi import Phi.Types import Phi.Border import Phi.Widget import Phi.X11.Atoms 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 :: ![Xlib.Rectangle] , taskbarActiveWindow :: !Window , taskbarDesktopCount :: !Int , taskbarCurrentDesktop :: !Int , 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 :: !Xlib.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 ![Xlib.Window] !(M.Map Window WindowState) | DesktopCountUpdate !Int | CurrentDesktopUpdate !Int | 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) 0 0 (-1) [] M.empty initCache _ = M.empty minSize _ _ _ _ = 0 weight _ = 1 render (Taskbar config) TaskbarState { taskbarScreens = screens , taskbarActiveWindow = activeWindow , taskbarDesktopCount = desktopCount , taskbarCurrentDesktop = currentDesktop , 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 [0..] desktops = map (\desktop -> (desktop, filter (fromMaybe False . fmap (windowOnDesktop 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 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 desktop dx = dleftwidth desktop + (sum $ map dwidth $ take 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 desktop) 0 (dwidth desktop + windowWidth * length desktopWindows) h clip setSourceRGBA r g b a renderText (desktopFont ds) (fromIntegral (dx - dlabelwidth desktop - gap desktop ds)) 0 (dlabelwidth desktop) h $ show (desktop+1) 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 (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) activeWindow <- getActiveWindow disp (getAtoms dispvar) sendMessage phi $ WindowListUpdate windows states sendMessage phi $ DesktopCountUpdate desktopCount sendMessage phi $ CurrentDesktopUpdate current sendMessage phi $ ActiveWindowUpdate activeWindow return (windows, states) sendMessage phi Repaint flip evalStateT (windows, states) $ forever $ do m <- receiveMessage phi case (fromMessage m) of Just event -> handleEvent phi dispvar event _ -> return () handleEvent :: Phi -> Display -> XExtras.Event -> StateT ([Window], M.Map Window WindowState) IO () handleEvent phi dispvar XExtras.PropertyEvent {XExtras.ev_atom = atom, XExtras.ev_window = window} = do let atoms = getAtoms dispvar when (elem atom $ Xlib.wM_NAME : map ($ atoms) [ atom_NET_ACTIVE_WINDOW , atom_NET_NUMBER_OF_DESKTOPS , atom_NET_CURRENT_DESKTOP , atom_NET_CLIENT_LIST , atom_NET_WM_ICON , atom_NET_WM_NAME , atom_NET_WM_DESKTOP , atom_NET_WM_STATE ]) $ withDisplay dispvar $ \disp -> do let rootwin = Xlib.defaultRootWindow disp if (window == rootwin) then do when (atom == atom_NET_ACTIVE_WINDOW atoms) $ do activeWindow <- liftIO $ getActiveWindow disp atoms sendMessage phi $ ActiveWindowUpdate activeWindow sendMessage phi Repaint when (atom == atom_NET_NUMBER_OF_DESKTOPS atoms) $ do desktopCount <- liftIO $ getDesktopCount disp atoms sendMessage phi $ DesktopCountUpdate desktopCount sendMessage phi Repaint when (atom == atom_NET_CURRENT_DESKTOP atoms) $ do current <- liftIO $ getCurrentDesktop disp atoms sendMessage phi $ CurrentDesktopUpdate current sendMessage phi Repaint when (atom == atom_NET_CLIENT_LIST atoms) $ do (windows, windowStates) <- get (windows', windowStates') <- liftIO $ getWindowStates disp 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 disp 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 disp 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 () handleEvent phi dispvar XExtras.ConfigureEvent {XExtras.ev_window = window} = do (windows, windowStates) <- get when (elem window windows) $ withDisplay dispvar $ \disp -> do let geom = fmap windowGeometry . M.lookup window $ windowStates geom' <- liftIO $ getWindowGeometry disp window when (geom /= (Just geom')) $ do let windowStates' = M.update (\state -> Just state {windowGeometry = geom'}) window windowStates sendMessage phi $ WindowListUpdate windows windowStates' sendMessage phi Repaint put (windows, windowStates') handleEvent _ _ _ = return () getDesktopCount :: Xlib.Display -> Atoms -> IO Int getDesktopCount disp atoms = liftM (fromIntegral . fromMaybe 0 . join . fmap listToMaybe) $ XExtras.getWindowProperty32 disp (atom_NET_NUMBER_OF_DESKTOPS atoms) $ Xlib.defaultRootWindow disp getCurrentDesktop :: Xlib.Display -> Atoms -> IO Int getCurrentDesktop disp atoms = liftM (fromIntegral . fromMaybe (-1) . join . fmap listToMaybe) $ XExtras.getWindowProperty32 disp (atom_NET_CURRENT_DESKTOP atoms) $ Xlib.defaultRootWindow disp getActiveWindow :: Xlib.Display -> Atoms -> IO Window getActiveWindow disp atoms = liftM (fromIntegral . fromMaybe 0 . join . fmap listToMaybe) $ XExtras.getWindowProperty32 disp (atom_NET_ACTIVE_WINDOW atoms) $ Xlib.defaultRootWindow disp getWindowStates :: Xlib.Display -> Atoms -> M.Map Window WindowState -> IO ([Window], M.Map Window WindowState) getWindowStates disp atoms windowStates = do windows <- getWindowList disp atoms let windowStates' = map (\w -> (w, M.lookup w windowStates)) windows newWindowStates <- mapM getWindowState' windowStates' return (windows, M.fromList newWindowStates) where getWindowState' (window, Just windowState) = return (window, windowState) getWindowState' (window, Nothing) = do Xlib.selectInput disp window $ Xlib.propertyChangeMask .|. Xlib.structureNotifyMask windowState <- getWindowState disp atoms window return (window, windowState) getWindowState :: Xlib.Display -> Atoms -> Window -> IO WindowState getWindowState disp atoms window = do (name, workspace, visible) <- getWindowInfo disp atoms window icons <- getWindowIcons disp atoms window geom <- getWindowGeometry disp window return $ WindowState { windowTitle = name , windowDesktop = workspace , windowVisible = visible , windowIcons = icons , windowGeometry = geom } getWindowInfo :: Xlib.Display -> Atoms -> Window -> IO (String, Int, Bool) getWindowInfo disp atoms window = do netwmname <- liftM (fmap (decode . map fromIntegral)) $ XExtras.getWindowProperty8 disp (atom_NET_WM_NAME atoms) window wmname <- case netwmname of Just name -> return name Nothing -> liftM (map unsignedChr . fromMaybe []) $ XExtras.getWindowProperty8 disp Xlib.wM_NAME window workspace <- liftM (fromIntegral . fromMaybe 0xFFFFFFFF . join . fmap listToMaybe) $ XExtras.getWindowProperty32 disp (atom_NET_WM_DESKTOP atoms) window visible <- showWindow disp atoms window return (wmname, workspace, visible) where unsignedChr = chr . fromIntegral . (fromIntegral :: (CChar -> CUChar)) getWindowIcons :: Xlib.Display -> Atoms -> Window -> IO [Icon] getWindowIcons disp atoms window = XExtras.getWindowProperty32 disp (atom_NET_WM_ICON atoms) window >>= readIcons . fromMaybe [] readIcons :: [CLong] -> 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 :: Xlib.Display -> Window -> IO Xlib.Rectangle getWindowGeometry disp window = flip catch (\_ -> return $ Xlib.Rectangle 0 0 0 0) $ do (_, _, _, width, height, _, _) <- Xlib.getGeometry disp window (ret, x, y, _) <- Xlib.translateCoordinates disp window (Xlib.defaultRootWindow disp) 0 0 return $ if ret then Xlib.Rectangle x y width height else Xlib.Rectangle 0 0 0 0 showWindow :: Xlib.Display -> Atoms -> Window -> IO Bool showWindow disp atoms window = do states <- liftM (map fromIntegral . fromMaybe []) $ XExtras.getWindowProperty32 disp (atom_NET_WM_STATE atoms) window transientForHint <- XExtras.getTransientForHint disp window windowType <- liftM (fromMaybe (atom_NET_WM_WINDOW_TYPE_NORMAL atoms) . fmap fromIntegral . join . fmap listToMaybe) $ XExtras.getWindowProperty32 disp (atom_NET_WM_STATE atoms) window return $ not $ or [ elem (atom_NET_WM_STATE_SKIP_TASKBAR atoms) states , transientForHint /= Nothing , 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 :: Xlib.Display -> Atoms -> IO [Window] getWindowList disp atoms = liftM (map fromIntegral . join . maybeToList) $ XExtras.getWindowProperty32 disp (atom_NET_CLIENT_LIST atoms) $ Xlib.defaultRootWindow disp taskbar :: TaskbarConfig -> Taskbar taskbar = Taskbar