From b2d0d19c4b3d33ea336e78c62e7eddfa805281ac Mon Sep 17 00:00:00 2001 From: jao Date: Sat, 10 Sep 2022 04:33:56 +0100 Subject: cairo: fonts, offsets, colors, actions --- src/Xmobar/Config/Types.hs | 11 +++++++ src/Xmobar/Text/Pango.hs | 6 ++-- src/Xmobar/X11/CairoDraw.hs | 71 +++++++++++++++++++++++++++++++++-------- src/Xmobar/X11/CairoSurface.hsc | 4 +-- src/Xmobar/X11/Draw.hs | 12 +++++-- src/Xmobar/X11/Loop.hs | 49 ++++++---------------------- src/Xmobar/X11/XlibDraw.hs | 33 ++++++++++++++++++- xmobar.cabal | 4 ++- 8 files changed, 129 insertions(+), 61 deletions(-) diff --git a/src/Xmobar/Config/Types.hs b/src/Xmobar/Config/Types.hs index 951759d..216ac19 100644 --- a/src/Xmobar/Config/Types.hs +++ b/src/Xmobar/Config/Types.hs @@ -18,6 +18,7 @@ module Xmobar.Config.Types Config (..) , XPosition (..), Align (..), Border (..), TextOutputFormat (..) , SignalChan (..) + , indexedFont, indexedOffset ) where import qualified Control.Concurrent.STM as STM @@ -73,6 +74,16 @@ data Config = , signal :: SignalChan -- ^ The signal channel used to send signals to xmobar } deriving (Read, Show) +indexedFont :: Config -> Int -> String +indexedFont config idx = + if idx < 1 || idx > length (additionalFonts config) + then font config else (additionalFonts config) !! (idx - 1) + +indexedOffset :: Config -> Int -> Int +indexedOffset config idx = + if idx < 1 || idx > length (textOffsets config) + then textOffset config else (textOffsets config) !! (idx - 1) + data XPosition = Top | TopH Int | TopW Align Int diff --git a/src/Xmobar/Text/Pango.hs b/src/Xmobar/Text/Pango.hs index 609e3b1..a3fc899 100644 --- a/src/Xmobar/Text/Pango.hs +++ b/src/Xmobar/Text/Pango.hs @@ -15,7 +15,8 @@ -- ------------------------------------------------------------------------------ -module Xmobar.Text.Pango (withPangoColor, withPangoFont, withPangoMarkup) where +module Xmobar.Text.Pango (withPangoColor, withPangoFont, withPangoMarkup, fixXft) +where import Text.Printf (printf) import Data.List (isPrefixOf) @@ -36,7 +37,8 @@ withPangoColor (fg, bg) s = where fmt = "%s" fixXft :: String -> String -fixXft font = if "xft:" `isPrefixOf` font then drop 4 font else font +fixXft font = + if "xft:" `isPrefixOf` font then replaceAll '-' " " $ drop 4 font else font withPangoFont :: String -> String -> String withPangoFont font txt = printf fmt (fixXft font) (xmlEscape txt) diff --git a/src/Xmobar/X11/CairoDraw.hs b/src/Xmobar/X11/CairoDraw.hs index 424ea90..527b68a 100644 --- a/src/Xmobar/X11/CairoDraw.hs +++ b/src/Xmobar/X11/CairoDraw.hs @@ -20,29 +20,72 @@ import Control.Monad.IO.Class import Control.Monad.Reader import Graphics.X11.Xlib hiding (Segment) -import GI.Cairo.Render.Types +import Graphics.Rendering.Cairo.Types +import qualified Graphics.Rendering.Cairo as C +import qualified Graphics.Rendering.Pango as P -import Xmobar.Run.Parsers (Segment) +import qualified Data.Colour.SRGB as SRGB +import qualified Data.Colour.Names as CNames +import qualified Data.Colour.RGBSpace as RGBS + +import Xmobar.Run.Parsers (Segment, Widget(..), colorComponents, tColorsString) +import Xmobar.Run.Actions (Action) +import Xmobar.Config.Types +import Xmobar.Text.Pango (fixXft) import Xmobar.X11.Types import Xmobar.X11.CairoSurface --- import Xmobar.Text.Pango -import Xmobar.Config.Types -drawInPixmap :: Pixmap -> Dimension -> Dimension -> [[Segment]] -> X () +type ActionPos = ([Action], Position, Position) +type Actions = [ActionPos] + +drawInPixmap :: Pixmap -> Dimension -> Dimension -> [[Segment]] -> X Actions drawInPixmap p w h s = do xconf <- ask let disp = display xconf - scr = screenOfDisplay disp 0 + vis = defaultVisualOfScreen (defaultScreenOfDisplay disp) c = config xconf fi = fromIntegral - liftIO $ withBitmapSurface disp p scr (fi w) (fi h) (renderSegments c s) + render = (renderSegments c w h s) + liftIO $ withXlibSurface disp p vis (fi w) (fi h) render + +withMarkup :: Config -> Segment -> String +withMarkup conf (Text txt, info, idx, _actions) = + let fnt = fixXft $ indexedFont conf idx + (fg, bg) = colorComponents conf (tColorsString info) + attrs = [P.FontDescr fnt, P.FontForeground fg, P.FontBackground bg] + in P.markSpan attrs $ P.escapeMarkup txt +withMarkup _ _ = "" + +type FPair = (Position, Actions) + +renderSegment :: + Double -> Config -> Surface -> P.PangoLayout -> FPair -> Segment -> IO FPair +renderSegment mh conf surface lyt (offset,actions) seg@(Text _, _, idx, a) = do + _ <- (P.layoutSetMarkup lyt (withMarkup conf seg)) :: IO String + (_, P.PangoRectangle o u w h) <- P.layoutGetExtents lyt + let voff' = fromIntegral $ indexedOffset conf idx + voff = voff' + (mh - h + u) / 2.0 + hoff = fromIntegral offset + C.renderWith surface $ C.moveTo hoff voff >> P.showLayout lyt + let end = round $ hoff + o + w + actions' = case a of Just as -> (as, offset, end):actions; _ -> actions + return (end, actions') +renderSegment _h _c _surface _lyt acc _segment = pure acc -renderSegment :: String -> String -> Surface -> Segment -> IO () -renderSegment _fg _bg _surface _segment = undefined +background :: Config -> SRGB.Colour Double -> C.Render () +background conf colour = do + RGBS.uncurryRGB C.setSourceRGB (SRGB.toSRGB colour) + C.paintWithAlpha $ (fromIntegral (alpha conf)) / 255.0 -renderSegments :: Config -> [[Segment]] -> Surface -> IO () -renderSegments conf segments surface = do - let bg = bgColor conf - fg = fgColor conf - mapM_ (renderSegment fg bg surface) (concat segments) +renderSegments :: + Config -> Dimension -> Dimension -> [[Segment]] -> Surface -> IO Actions +renderSegments conf _w h segments surface = do + ctx <- P.cairoCreateContext Nothing + lyt <- P.layoutEmpty ctx + col <- case CNames.readColourName (bgColor conf) of + Just c -> return c + Nothing -> return $ SRGB.sRGB24read (bgColor conf) + C.renderWith surface (background conf col) + let dh = fromIntegral h + snd `fmap` foldM (renderSegment dh conf surface lyt) (0, []) (concat segments) diff --git a/src/Xmobar/X11/CairoSurface.hsc b/src/Xmobar/X11/CairoSurface.hsc index af2e7ae..2037abe 100644 --- a/src/Xmobar/X11/CairoSurface.hsc +++ b/src/Xmobar/X11/CairoSurface.hsc @@ -20,8 +20,8 @@ module Xmobar.X11.CairoSurface (withXlibSurface, withBitmapSurface) where import Graphics.X11.Xlib.Types import Graphics.X11.Types -import GI.Cairo.Render.Types -import qualified GI.Cairo.Render.Internal as Internal +import Graphics.Rendering.Cairo.Types +import qualified Graphics.Rendering.Cairo.Internal as Internal import Foreign import Foreign.C diff --git a/src/Xmobar/X11/Draw.hs b/src/Xmobar/X11/Draw.hs index 6890fb1..ea7fa95 100644 --- a/src/Xmobar/X11/Draw.hs +++ b/src/Xmobar/X11/Draw.hs @@ -25,6 +25,7 @@ import Control.Monad.Reader import Graphics.X11.Xlib hiding (Segment) import Xmobar.Run.Parsers (Segment) +import Xmobar.Run.Actions (Action) import Xmobar.X11.Types #ifdef CAIRO @@ -34,8 +35,13 @@ import Xmobar.X11.XlibDraw #endif -- | Draws in and updates the window -drawInWin :: Rectangle -> [[Segment]] -> X () +#ifdef CAIRO +drawInWin :: Rectangle -> [[Segment]] -> X [([Action], Position, Position)] drawInWin (Rectangle _ _ wid ht) segments = do +#else +drawInWin :: XConf -> Rectangle -> [[Segment]] -> X [([Action], Position, Position)] +drawInWin conf bound@(Rectangle _ _ wid ht) segments = do +#endif r <- ask let d = display r w = window r @@ -44,8 +50,9 @@ drawInWin (Rectangle _ _ wid ht) segments = do gc <- liftIO $ createGC d w liftIO $ setGraphicsExposures d gc False #ifdef CAIRO - drawInPixmap p wid ht segments + res <- drawInPixmap p wid ht segments #else + res <- liftIO $ updateActions conf bound segments drawInPixmap gc p wid ht segments #endif -- copy the pixmap with the new string to the window @@ -55,3 +62,4 @@ drawInWin (Rectangle _ _ wid ht) segments = do liftIO $ freePixmap d p -- resync (discard events, we don't read/process events from this display conn) liftIO $ sync d True + return res diff --git a/src/Xmobar/X11/Loop.hs b/src/Xmobar/X11/Loop.hs index 2d97733..c6a4e97 100644 --- a/src/Xmobar/X11/Loop.hs +++ b/src/Xmobar/X11/Loop.hs @@ -24,17 +24,13 @@ import Graphics.X11.Xlib.Extras import Graphics.X11.Xinerama import Graphics.X11.Xrandr -import Control.Arrow ((&&&)) import Control.Monad.Reader import Control.Concurrent import Control.Concurrent.STM import Data.Bits -import Data.Map hiding (foldr, map, filter) import qualified Data.Map as Map import Data.List.NonEmpty (NonEmpty(..)) - -import Data.Maybe (fromJust, isJust) import qualified Data.List.NonEmpty as NE import Xmobar.System.Signal @@ -47,7 +43,6 @@ import Xmobar.Config.Types ( persistent , position , iconRoot , Config - , Align(..) , XPosition(..)) import Xmobar.Run.Actions @@ -57,7 +52,7 @@ import Xmobar.X11.Text import Xmobar.X11.Draw import Xmobar.X11.Bitmap as Bitmap import Xmobar.X11.Types -import Xmobar.System.Utils (safeIndex, forkThread) +import Xmobar.System.Utils (forkThread) import Xmobar.Run.Loop (loop) @@ -69,7 +64,7 @@ import Xmobar.X11.Events(nextEvent') import Graphics.X11.Xft #endif -runX :: XConf -> X () -> IO () +runX :: XConf -> X a -> IO a runX xc f = runReaderT f xc -- | Starts the main event loop and threads @@ -126,11 +121,14 @@ signalLoop xc@(XConf d r w fs vos is cfg) as signal tv = do typ <- atomically $ takeTMVar signal case typ of Wakeup -> do - str <- updateString cfg tv + str <- updateSegments cfg tv xc' <- updateCache d w is (iconRoot cfg) str >>= \c -> return xc { iconS = c } - as' <- updateActions xc r str - runX xc' $ drawInWin r str +#ifdef CAIRO + as' <- runX xc' $ drawInWin r str +#else + as' <- runX xc' $ drawInWin xc r str +#endif signalLoop xc' as' signal tv Reposition -> @@ -198,35 +196,8 @@ signalLoop xc@(XConf d r w fs vos is cfg) as signal tv = do filter (\(_, from, to) -> x >= from && x <= to) as loopOn -updateString :: Config -> TVar [String] -> IO [[Segment]] -updateString conf v = do +updateSegments :: Config -> TVar [String] -> IO [[Segment]] +updateSegments conf v = do s <- readTVarIO v let l:c:r:_ = s ++ repeat "" liftIO $ mapM (parseString conf) [l, c, r] - -updateActions :: XConf -> Rectangle -> [[Segment]] - -> IO [([Action], Position, Position)] -updateActions conf (Rectangle _ _ wid _) ~[left,center,right] = do - let (d,fs) = (display &&& fontListS) conf - strLn :: [Segment] -> IO [(Maybe [Action], Position, Position)] - strLn = liftIO . mapM getCoords - iconW i = maybe 0 Bitmap.width (lookup i $ iconS conf) - getCoords (Text s,_,i,a) = - textWidth d (safeIndex fs i) s >>= \tw -> return (a, 0, fi tw) - getCoords (Icon s,_,_,a) = return (a, 0, fi $ iconW s) - getCoords (Hspace w,_,_,a) = return (a, 0, fi w) - partCoord off xs = map (\(a, x, x') -> (fromJust a, x, x')) $ - filter (\(a, _,_) -> isJust a) $ - scanl (\(_,_,x') (a,_,w') -> (a, x', x' + w')) - (Nothing, 0, off) - xs - totSLen = foldr (\(_,_,len) -> (+) len) 0 - remWidth xs = fi wid - totSLen xs - offs = 1 - offset a xs = case a of - C -> (remWidth xs + offs) `div` 2 - R -> remWidth xs - L -> offs - fmap concat $ mapM (\(a,xs) -> - (\xs' -> partCoord (offset a xs') xs') <$> strLn xs) $ - zip [L,C,R] [left,center,right] diff --git a/src/Xmobar/X11/XlibDraw.hs b/src/Xmobar/X11/XlibDraw.hs index 3536791..c0bdb36 100644 --- a/src/Xmobar/X11/XlibDraw.hs +++ b/src/Xmobar/X11/XlibDraw.hs @@ -18,13 +18,14 @@ ------------------------------------------------------------------------------ -module Xmobar.X11.XlibDraw (drawInPixmap) where +module Xmobar.X11.XlibDraw (drawInPixmap, updateActions) where import Prelude hiding (lookup) import Control.Monad.IO.Class import Control.Monad.Reader import Data.Map hiding ((\\), foldr, map, filter) import Data.List ((\\)) +import Data.Maybe (fromJust, isJust) import qualified Data.List.NonEmpty as NE import Graphics.X11.Xlib hiding (textExtents, textWidth, Segment) @@ -32,6 +33,7 @@ import Graphics.X11.Xlib.Extras import Xmobar.Config.Types import Xmobar.Run.Parsers hiding (parseString) +import Xmobar.Run.Actions import qualified Xmobar.X11.Bitmap as B import Xmobar.X11.Types import Xmobar.X11.Text @@ -232,3 +234,32 @@ drawBoxBorder BBLeft -> drawLine d dr gc (x1 - 1 + ml) p1 (x1 - 1 + ml) (ht + p2) BBRight -> drawLine d dr gc (x2 + lc - 1 - mr) p1 (x2 + lc - 1 - mr) (ht + p2) _ -> error "unreachable code" + + +updateActions :: XConf -> Rectangle -> [[Segment]] + -> IO [([Action], Position, Position)] +updateActions conf (Rectangle _ _ wid _) ~[left,center,right] = do + let d = display conf + fs = fontListS conf + strLn :: [Segment] -> IO [(Maybe [Action], Position, Position)] + strLn = liftIO . mapM getCoords + iconW i = maybe 0 B.width (lookup i $ iconS conf) + getCoords (Text s,_,i,a) = + textWidth d (safeIndex fs i) s >>= \tw -> return (a, 0, fi tw) + getCoords (Icon s,_,_,a) = return (a, 0, fi $ iconW s) + getCoords (Hspace w,_,_,a) = return (a, 0, fi w) + partCoord off xs = map (\(a, x, x') -> (fromJust a, x, x')) $ + filter (\(a, _,_) -> isJust a) $ + scanl (\(_,_,x') (a,_,w') -> (a, x', x' + w')) + (Nothing, 0, off) + xs + totSLen = foldr (\(_,_,len) -> (+) len) 0 + remWidth xs = fi wid - totSLen xs + offs = 1 + offset a xs = case a of + C -> (remWidth xs + offs) `div` 2 + R -> remWidth xs + L -> offs + fmap concat $ mapM (\(a,xs) -> + (\xs' -> partCoord (offset a xs') xs') <$> strLn xs) $ + zip [L,C,R] [left,center,right] diff --git a/xmobar.cabal b/xmobar.cabal index 6601a97..9a078c8 100644 --- a/xmobar.cabal +++ b/xmobar.cabal @@ -236,7 +236,9 @@ library cpp-options: -DXFT if flag(with_cairo) - build-depends: gi-cairo-render >= 0.1.1 && < 0.2 + build-depends: cairo >= 0.13 && < 0.14, + pango >= 0.13 && < 0.14, + colour >= 2.3.6 other-modules: Xmobar.X11.CairoSurface, Xmobar.X11.CairoDraw x-c2hs-header: xmobar-gtk2hs.h cpp-options: -DCAIRO -- cgit v1.2.3