diff options
Diffstat (limited to 'lib/Phi/Widgets/Taskbar.hs')
| -rw-r--r-- | lib/Phi/Widgets/Taskbar.hs | 103 |
1 files changed, 78 insertions, 25 deletions
diff --git a/lib/Phi/Widgets/Taskbar.hs b/lib/Phi/Widgets/Taskbar.hs index d7907a0..3f3b3c2 100644 --- a/lib/Phi/Widgets/Taskbar.hs +++ b/lib/Phi/Widgets/Taskbar.hs @@ -1,6 +1,10 @@ -{-# LANGUAGE TypeFamilies, DeriveDataTypeable #-} +{-# LANGUAGE TypeFamilies, DeriveDataTypeable, TypeSynonymInstances #-} -module Phi.Widgets.Taskbar ( TaskbarConfig(..) +module Phi.Widgets.Taskbar ( IconStyle + , idIconStyle + , desaturateIconStyle + , TaskStyle(..) + , TaskbarConfig(..) , defaultTaskbarConfig , taskbar ) where @@ -41,19 +45,62 @@ import Phi.Widget import Phi.X11.Atoms -data TaskbarConfig = TaskbarConfig { taskbarFont :: !String - , taskMaxSize :: !Int +type IconStyle = Surface -> Render () +instance Show IconStyle where + show _ = "IconStyle" + +idIconStyle :: IconStyle +idIconStyle = flip withPatternForSurface setSource + +desaturateIconStyle :: Double -> IconStyle +desaturateIconStyle v icon = do + w <- imageSurfaceGetWidth icon + h <- imageSurfaceGetHeight icon + + renderWithSimilarSurface ContentColorAlpha w h $ \surface1 -> do + renderWithSimilarSurface ContentColor w h $ \surface2 -> do + renderWith surface1 $ do + renderWith surface2 $ do + withPatternForSurface icon setSource + paint + + setOperator OperatorHslSaturation + setSourceRGBA 0 0 0 (1-v) + paint + + withPatternForSurface surface2 setSource + paint + + setOperator OperatorDestIn + withPatternForSurface icon setSource + paint + + withPatternForSurface surface1 setSource + +data TaskStyle = TaskStyle { taskFont :: !String + , taskColor :: !Color + , taskBorder :: !BorderConfig + , taskIconStyle :: !IconStyle + } deriving Show + +data TaskbarConfig = TaskbarConfig { taskMaxSize :: !Int , showDesktops :: !Bool - , taskBorder :: !BorderConfig - , activeTaskBorder :: !BorderConfig + , normalTaskStyle :: !TaskStyle + , activeTaskStyle :: !TaskStyle } deriving Show +defaultStyle :: TaskStyle +defaultStyle = TaskStyle { taskFont = "Sans 8" + , taskColor = (0, 0, 0, 1) + , taskBorder = defaultBorderConfig + , taskIconStyle = idIconStyle + } + defaultTaskbarConfig :: TaskbarConfig -defaultTaskbarConfig = TaskbarConfig { taskbarFont = "Sans 7" - , taskMaxSize = 150 +defaultTaskbarConfig = TaskbarConfig { taskMaxSize = 150 , showDesktops = False - , taskBorder = defaultBorderConfig - , activeTaskBorder = defaultBorderConfig { borderColor = (1, 1, 1, 1) } + , normalTaskStyle = defaultStyle + , activeTaskStyle = defaultStyle {taskBorder = defaultBorderConfig { borderColor = (1, 1, 1, 1) }} } data Taskbar = Taskbar TaskbarConfig deriving Show @@ -90,35 +137,41 @@ instance WidgetClass Taskbar where minSize _ = 0 weight _ = 1 - render (Taskbar config) TaskbarState {taskbarActiveWindow = activeWindow, taskbarDesktopCount = desktopCount, taskbarWindows = windows, taskbarWindowStates = windowStates, taskbarWindowIcons = windowIcons} w h = do + render (Taskbar config) TaskbarState { taskbarActiveWindow = activeWindow + , taskbarDesktopCount = desktopCount + , taskbarWindows = windows + , taskbarWindowStates = windowStates + , taskbarWindowIcons = windowIcons + } w h = do let desktopWindows = map (\desktop -> (desktop, filter (fromMaybe False . fmap (windowOnDesktop desktop) . flip M.lookup windowStates) windows)) $ take desktopCount [0..] windowCount = sum $ map (length . snd) $ desktopWindows when (windowCount /= 0) $ do let windowWidth = min (taskMaxSize config) (w `div` windowCount) forM_ (zip [0..] $ join $ map snd desktopWindows) $ \(i, window) -> do - let border = if window == activeWindow then activeTaskBorder config else taskBorder config - leftBorder = (borderLeft $ margin border) + (borderWidth border) + (borderLeft $ padding border) - rightBorder = (borderRight $ margin border) + (borderWidth border) + (borderRight $ padding border) - h' = h - (borderV $ margin border) + let style = (if window == activeWindow then activeTaskStyle else normalTaskStyle) config + (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) mstate = M.lookup window windowStates micons = M.lookup window windowIcons case (mstate, micons) of (Just state, Just icons) -> do save - drawBorder border (i*windowWidth) 0 windowWidth h + drawBorder (taskBorder style) (i*windowWidth) 0 windowWidth h clip - setSourceRGB 1 1 1 - renderText config (fromIntegral (i*windowWidth + leftBorder + h' + 3)) 0 (windowWidth - leftBorder - h' - 3 - rightBorder) h $ windowTitle state + setSourceRGBA r g b a + renderText style (fromIntegral (i*windowWidth + leftBorder + h' + 3)) 0 (windowWidth - leftBorder - h' - 3 - rightBorder) h $ windowTitle state restore case bestIcon h' icons of - Just icon -> withPatternForSurface icon $ \pattern -> do + Just icon -> do save - translate (fromIntegral $ i*windowWidth + leftBorder) (fromIntegral $ borderTop $ margin border) + translate (fromIntegral $ i*windowWidth + leftBorder) (fromIntegral $ borderTop $ margin $ taskBorder style) imageW <- imageSurfaceGetWidth icon imageH <- imageSurfaceGetHeight icon @@ -127,8 +180,8 @@ instance WidgetClass Taskbar where when (imageH < imageW) $ translate 0 $ (fromIntegral (imageW-imageH))/2 - - setSource pattern + + taskIconStyle style icon paint restore @@ -144,11 +197,11 @@ instance WidgetClass Taskbar where _ -> priv -renderText :: TaskbarConfig -> Int -> Int -> Int -> Int -> String -> Render () -renderText config x y w h text = do +renderText :: TaskStyle -> Int -> Int -> Int -> Int -> String -> Render () +renderText style x y w h text = do layout <- createLayout "" (_, PangoRectangle _ _ textWidth textHeight) <- liftIO $ do - layoutSetMarkup layout $ "<span font='" ++ (taskbarFont config) ++ "'>" ++ (escapeMarkup text) ++ "</span>" + layoutSetMarkup layout $ "<span font='" ++ (taskFont style) ++ "'>" ++ (escapeMarkup text) ++ "</span>" layoutSetWidth layout $ Just $ fromIntegral w layoutSetEllipsize layout EllipsizeEnd |