From 44e407836e1437bd1f78edc4980eeb9fe42399b6 Mon Sep 17 00:00:00 2001 From: jao Date: Mon, 19 Sep 2022 01:36:14 +0100 Subject: cairo: non-cairo is not an option --- src/Xmobar/X11/CairoDraw.hs | 47 +-------- src/Xmobar/X11/Draw.hs | 105 ++++++++++++------- src/Xmobar/X11/Loop.hs | 4 +- src/Xmobar/X11/XlibDraw.hs | 243 -------------------------------------------- 4 files changed, 72 insertions(+), 327 deletions(-) delete mode 100644 src/Xmobar/X11/XlibDraw.hs (limited to 'src/Xmobar') diff --git a/src/Xmobar/X11/CairoDraw.hs b/src/Xmobar/X11/CairoDraw.hs index d66f959..a4172bb 100644 --- a/src/Xmobar/X11/CairoDraw.hs +++ b/src/Xmobar/X11/CairoDraw.hs @@ -15,18 +15,13 @@ -- ------------------------------------------------------------------------------ -module Xmobar.X11.CairoDraw (drawInPixmap) where - -import qualified Data.Map as M +module Xmobar.X11.CairoDraw (drawSegments, DrawContext (..), BitmapDrawer) where import qualified Data.Colour.SRGB as SRGB import qualified Data.Colour.Names as CNames -import Control.Monad.IO.Class (liftIO) import Control.Monad (foldM, when) -import Control.Monad.Reader (ask) -import qualified Graphics.X11.Xlib as X11 import qualified Graphics.Rendering.Cairo as Cairo import qualified Graphics.Rendering.Pango as Pango @@ -40,11 +35,6 @@ import qualified Xmobar.Text.Pango as TextPango import qualified Xmobar.X11.Boxes as Boxes import qualified Xmobar.X11.Bitmap as B import qualified Xmobar.X11.Types as X -import Xmobar.X11.CairoSurface (withXlibSurface) - -#ifdef XRENDER -import qualified Xmobar.X11.XRender as XRender -#endif type Renderinfo = (P.Segment, Surface -> Double -> Double -> IO (), Double) type BitmapDrawer = Double -> Double -> String -> IO () @@ -58,37 +48,6 @@ data DrawContext = DC { dcBitmapDrawer :: BitmapDrawer , dcSegments :: [[P.Segment]] } -drawInPixmap :: X11.GC -> X11.Pixmap -> [[P.Segment]] -> X.X Actions -drawInPixmap gc p s = do - xconf <- ask - let disp = X.display xconf - vis = X11.defaultVisualOfScreen (X11.defaultScreenOfDisplay disp) - (X11.Rectangle _ _ w h) = X.rect xconf - dw = fromIntegral w - dh = fromIntegral h - conf = X.config xconf - dc = DC (drawXBitmap xconf gc p) (lookupXBitmap xconf) conf dw dh s - render = drawSegments dc -#ifdef XRENDER - color = C.bgColor conf - alph = C.alpha conf - liftIO $ XRender.drawBackground disp p color alph (X11.Rectangle 0 0 w h) -#endif - liftIO $ withXlibSurface disp p vis (fromIntegral w) (fromIntegral h) render - -drawXBitmap :: X.XConf -> X11.GC -> X11.Pixmap -> BitmapDrawer -drawXBitmap xconf gc p h v path = do - let disp = X.display xconf - conf = X.config xconf - fc = C.fgColor conf - bc = C.bgColor conf - case lookupXBitmap xconf path of - Just bm -> liftIO $ B.drawBitmap disp p gc fc bc (round h) (round v) bm - Nothing -> return () - -lookupXBitmap :: X.XConf -> String -> Maybe B.Bitmap -lookupXBitmap xconf path = M.lookup path (X.iconCache xconf) - readColourName :: String -> (SRGB.Colour Double, Double) readColourName str = case CNames.readColourName str of @@ -148,8 +107,8 @@ withRenderinfo _ dctx seg@(P.Icon p, _, _, _) = do wd = maybe 0 (fromIntegral . B.width) bm ioff = C.iconOffset (dcConfig dctx) vpos = dcHeight dctx / 2 + fromIntegral ioff - draw _ off mx = when (off + wd <= mx) $ dcBitmapDrawer dctx off vpos p - return (seg, draw, wd) + render _ off mx = when (off + wd <= mx) $ dcBitmapDrawer dctx off vpos p + return (seg, render, wd) drawBox :: DrawContext -> Surface -> Double -> Double -> P.Box -> IO () drawBox dctx surf x0 x1 box@(P.Box _ _ w color _) = diff --git a/src/Xmobar/X11/Draw.hs b/src/Xmobar/X11/Draw.hs index 4f14d22..f11dd0e 100644 --- a/src/Xmobar/X11/Draw.hs +++ b/src/Xmobar/X11/Draw.hs @@ -1,61 +1,90 @@ {-# LANGUAGE CPP #-} - ------------------------------------------------------------------------------ -- | -- Module: Xmobar.X11.Draw --- Copyright: (c) 2018, 2020, 2022 Jose Antonio Ortega Ruiz +-- Copyright: (c) 2022 Jose Antonio Ortega Ruiz -- License: BSD3-style (see LICENSE) -- -- Maintainer: jao@gnu.org -- Stability: unstable --- Portability: portable --- Created: Sat Nov 24, 2018 18:49 +-- Portability: unportable +-- Created: Fri Sep 09, 2022 02:03 -- +-- Drawing the xmobar contents using Cairo and Pango -- --- Drawing the xmobar contents -- ------------------------------------------------------------------------------ +module Xmobar.X11.Draw (draw) where -module Xmobar.X11.Draw (drawInWin) where - -import Control.Monad.IO.Class -import Control.Monad.Reader +import qualified Data.Map as M -import Graphics.X11.Xlib hiding (Segment) +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Reader (ask) +import Foreign.C.Types as FT +import qualified Graphics.X11.Xlib as X11 -import Xmobar.Run.Parsers (Segment) -import Xmobar.X11.Types +import qualified Xmobar.Config.Types as C +import qualified Xmobar.Run.Parsers as P +import qualified Xmobar.X11.Bitmap as B +import qualified Xmobar.X11.Types as X +import qualified Xmobar.X11.CairoDraw as CD +import qualified Xmobar.X11.CairoSurface as CS -#ifdef CAIRO -import Xmobar.X11.CairoDraw -#else -import Xmobar.X11.XlibDraw +#ifdef XRENDER +import qualified Xmobar.X11.XRender as XRender #endif --- | Draws in and updates the window -drawInWin :: [[Segment]] -> X [ActionPos] -drawInWin segments = do - xconf <- ask - let d = display xconf - w = window xconf - (Rectangle _ _ wid ht) = rect xconf - depth = defaultDepthOfScreen (defaultScreenOfDisplay d) - p <- liftIO $ createPixmap d w wid ht depth - gc <- liftIO $ createGC d w - liftIO $ setGraphicsExposures d gc False - -#ifdef CAIRO - res <- drawInPixmap gc p segments -#else - res <- updateActions (rect xconf) segments - drawInPixmap gc p wid ht segments -#endif +drawXBitmap :: X.XConf -> X11.GC -> X11.Pixmap -> CD.BitmapDrawer +drawXBitmap xconf gc p h v path = do + let disp = X.display xconf + conf = X.config xconf + fc = C.fgColor conf + bc = C.bgColor conf + case lookupXBitmap xconf path of + Just bm -> liftIO $ B.drawBitmap disp p gc fc bc (round h) (round v) bm + Nothing -> return () + +lookupXBitmap :: X.XConf -> String -> Maybe B.Bitmap +lookupXBitmap xconf path = M.lookup path (X.iconCache xconf) + +withPixmap :: X11.Display -> X11.Drawable -> X11.Rectangle -> FT.CInt + -> (X11.GC -> X11.Pixmap -> IO a) -> IO a +withPixmap disp win (X11.Rectangle _ _ w h) depth action = do + p <- X11.createPixmap disp win w h depth + gc <- X11.createGC disp win + X11.setGraphicsExposures disp gc False + res <- action gc p -- copy the pixmap with the new string to the window - liftIO $ copyArea d p w gc 0 0 wid ht 0 0 + X11.copyArea disp p win gc 0 0 w h 0 0 -- free up everything (we do not want to leak memory!) - liftIO $ freeGC d gc - liftIO $ freePixmap d p + X11.freeGC disp gc + X11.freePixmap disp p -- resync (discard events, we don't read/process events from this display conn) - liftIO $ sync d True + X11.sync disp True return res + +draw :: [[P.Segment]] -> X.X [X.ActionPos] +draw segments = do + xconf <- ask + let disp = X.display xconf + win = X.window xconf + rect@(X11.Rectangle _ _ w h) = X.rect xconf + screen = X11.defaultScreenOfDisplay disp + depth = X11.defaultDepthOfScreen screen + vis = X11.defaultVisualOfScreen screen + conf = X.config xconf + + liftIO $ withPixmap disp win rect depth $ \gc p -> do + let bdraw = drawXBitmap xconf gc p + blook = lookupXBitmap xconf + dctx = CD.DC bdraw blook conf (fromIntegral w) (fromIntegral h) segments + render = CD.drawSegments dctx + +#ifdef XRENDER + color = C.bgColor conf + alph = C.alpha conf + XRender.drawBackground disp p color alph (X11.Rectangle 0 0 w h) +#endif + + CS.withXlibSurface disp p vis (fromIntegral w) (fromIntegral h) render diff --git a/src/Xmobar/X11/Loop.hs b/src/Xmobar/X11/Loop.hs index 3c1a25c..74c4c67 100644 --- a/src/Xmobar/X11/Loop.hs +++ b/src/Xmobar/X11/Loop.hs @@ -25,9 +25,9 @@ import Control.Concurrent.STM as STM import Control.Monad.Reader as MR import Data.Bits (Bits((.|.))) -import qualified Data.Map as Map import Data.List.NonEmpty (NonEmpty((:|))) import qualified Data.List.NonEmpty as NE +import qualified Data.Map as Map import qualified Graphics.X11.Xlib as X11 import qualified Graphics.X11.Xlib.Extras as X11x @@ -125,7 +125,7 @@ signalLoop xc@(T.XConf d r w fs is cfg) actions signalv strs = do wakeup = do segs <- parseSegments cfg strs xc' <- updateIconCache xc segs - actions' <- runX xc' $ Draw.drawInWin segs + actions' <- runX xc' (Draw.draw segs) signalLoop xc' actions' signalv strs hiderev t sign op diff --git a/src/Xmobar/X11/XlibDraw.hs b/src/Xmobar/X11/XlibDraw.hs deleted file mode 100644 index 84f0975..0000000 --- a/src/Xmobar/X11/XlibDraw.hs +++ /dev/null @@ -1,243 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE TupleSections #-} - ------------------------------------------------------------------------------- --- | --- Module: Xmobar.X11.XlibDraw --- Copyright: (c) 2018, 2020, 2022 Jose Antonio Ortega Ruiz --- License: BSD3-style (see LICENSE) --- --- Maintainer: jao@gnu.org --- Stability: unstable --- Portability: portable --- Created: Sat Nov 24, 2018 18:49 --- --- --- Drawing the xmobar contents using Xlib and Xft primitives --- ------------------------------------------------------------------------------- - -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) -import Graphics.X11.Xlib.Extras - -import Xmobar.Config.Types -import Xmobar.Config.Parse (indexedOffset) -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 -import Xmobar.X11.ColorCache -import Xmobar.System.Utils (safeIndex) - -fi :: (Integral a, Num b) => a -> b -fi = fromIntegral - -drawInPixmap :: GC -> Pixmap -> Dimension -> Dimension -> [[Segment]] -> X () -drawInPixmap gc p wid ht ~[left,center,right] = do - r <- ask - let c = config r - d = display r - fs = fontList r - strLn = liftIO . mapM getWidth - iconW i = maybe 0 B.width (lookup i $ iconCache r) - getWidth (Text s,cl,i,_) = - textWidth d (safeIndex fs i) s >>= \tw -> return (Text s,cl,i,fi tw) - getWidth (Icon s,cl,i,_) = return (Icon s,cl,i,fi $ iconW s) - getWidth (Hspace s,cl,i,_) = return (Hspace s,cl,i,fi s) - - withColors d [bgColor c, borderColor c] $ \[bgcolor, bdcolor] -> do - liftIO $ setForeground d gc bgcolor - liftIO $ fillRectangle d p gc 0 0 wid ht - - -- write to the pixmap the new string - printStrings p gc fs 1 L [] =<< strLn left - printStrings p gc fs 1 R [] =<< strLn right - printStrings p gc fs 1 C [] =<< strLn center - -- draw border if requested - liftIO $ drawBorder (border c) (borderWidth c) d p gc bdcolor wid ht - -verticalOffset :: (Integral b, Integral a, MonadIO m) => - a -> Widget -> XFont -> Int -> Config -> m b -verticalOffset ht (Text t) fontst voffs _ - | voffs > -1 = return $ fi voffs - | otherwise = do - (as,ds) <- liftIO $ textExtents fontst t - let margin = (fi ht - fi ds - fi as) `div` 2 - return $ fi as + margin - 1 -verticalOffset ht (Icon _) _ _ conf - | iconOffset conf > -1 = return $ fi (iconOffset conf) - | otherwise = return $ fi (ht `div` 2) - 1 -verticalOffset _ (Hspace _) _ voffs _ = return $ fi voffs - -printString :: Display -> Drawable -> XFont -> GC - -> String -> String - -> Position -> Position -> Position -> Position - -> String -> Int - -> IO () - -printString d p fs gc fc bc x y _ _ s a = - withColors d [fc, bc] $ \[fc', bc'] -> do - setForeground d gc fc' - when (a == 255) (setBackground d gc bc') - liftIO $ wcDrawImageString d p fs gc x y s - -printStrings :: Drawable -> GC - -> NE.NonEmpty XFont - -> Position -> Align - -> [((Position, Position), Box)] - -> [(Widget, TextRenderInfo, Int, Position)] - -> X () -printStrings _ _ _ _ _ _ [] = return () -printStrings dr gc fontlist offs a boxes sl@((s,c,i,l):xs) = do - r <- ask - let conf = config r - d = display r - alph = alpha conf - Rectangle _ _ wid ht = rect r - totSLen = foldr (\(_,_,_,len) -> (+) len) 0 sl - remWidth = fi wid - fi totSLen - fontst = safeIndex fontlist i - offset = case a of - C -> (remWidth + offs) `div` 2 - R -> remWidth - L -> offs - (fc,bc) = colorComponents conf (tColorsString c) - valign <- verticalOffset ht s fontst (indexedOffset conf i) conf - let (ht',ay) = case (tBgTopOffset c, tBgBottomOffset c) of - (-1,_) -> (0, -1) - (_,-1) -> (0, -1) - (ot,ob) -> (fromIntegral ht - ot - ob, ob) - case s of - (Text t) -> liftIO $ printString d dr fontst gc fc bc offset valign ay ht' t alph - (Icon p) -> liftIO $ maybe (return ()) - (B.drawBitmap d dr gc fc bc offset valign) - (lookup p (iconCache r)) - (Hspace _) -> liftIO $ return () - let triBoxes = tBoxes c - dropBoxes = filter (\(_,b) -> b `notElem` triBoxes) boxes - boxes' = map (\((x1,_),b) -> ((x1, offset + l), b)) - (filter (\(_,b) -> b `elem` triBoxes) boxes) - ++ map ((offset, offset + l),) (triBoxes \\ map snd boxes) - if Prelude.null xs - then liftIO $ drawBoxes d dr gc (fromIntegral ht) (dropBoxes ++ boxes') - else liftIO $ drawBoxes d dr gc (fromIntegral ht) dropBoxes - printStrings dr gc fontlist (offs + l) a boxes' xs - -drawBoxes :: Display -> Drawable -> GC - -> Position -> [((Position, Position), Box)] - -> IO () -drawBoxes _ _ _ _ [] = return () -drawBoxes d dr gc ht (b:bs) = do - let (xx, Box bb offset lineWidth fc mgs) = b - lw = fromIntegral lineWidth :: Position - withColors d [fc] $ \[fc'] -> do - setForeground d gc fc' - setLineAttributes d gc lineWidth lineSolid capNotLast joinMiter - case bb of - BBVBoth -> do - drawBoxBorder d dr gc BBTop offset ht xx lw mgs - drawBoxBorder d dr gc BBBottom offset ht xx lw mgs - BBHBoth -> do - drawBoxBorder d dr gc BBLeft offset ht xx lw mgs - drawBoxBorder d dr gc BBRight offset ht xx lw mgs - BBFull -> do - drawBoxBorder d dr gc BBTop offset ht xx lw mgs - drawBoxBorder d dr gc BBBottom offset ht xx lw mgs - drawBoxBorder d dr gc BBLeft offset ht xx lw mgs - drawBoxBorder d dr gc BBRight offset ht xx lw mgs - _ -> drawBoxBorder d dr gc bb offset ht xx lw mgs - drawBoxes d dr gc ht bs - -drawBoxBorder :: Display -> Drawable -> GC - -> BoxBorder -> BoxOffset - -> Position -> (Position, Position) -> Position - -> BoxMargins - -> IO () -drawBoxBorder - d dr gc pos (BoxOffset alg offset) ht (x1,x2) lw (BoxMargins mt mr mb ml) = do - let (p1,p2) = case alg of - L -> (0, -offset) - C -> (offset, -offset) - R -> (offset, 0 ) - lc = lw `div` 2 - case pos of - BBTop -> drawLine d dr gc (x1 + p1) (mt + lc) (x2 + p2) (mt + lc) - BBBottom -> do - let lc' = max lc 1 + mb - drawLine d dr gc (x1 + p1) (ht - lc') (x2 + p2) (ht - lc') - 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" - - -drawBorder :: Border -> Int -> Display -> Drawable -> GC -> Pixel - -> Dimension -> Dimension -> IO () -drawBorder b lw d p gc c wi ht = case b of - NoBorder -> return () - TopB -> drawBorder (TopBM 0) lw d p gc c wi ht - BottomB -> drawBorder (BottomBM 0) lw d p gc c wi ht - FullB -> drawBorder (FullBM 0) lw d p gc c wi ht - TopBM m -> sf >> sla >> - drawLine d p gc 0 (fi m + boff) (fi wi) (fi m + boff) - BottomBM m -> let rw = fi ht - fi m + boff in - sf >> sla >> drawLine d p gc 0 rw (fi wi) rw - FullBM m -> let mp = fi m - pad = 2 * fi mp + fi lw - in sf >> sla >> - drawRectangle d p gc mp mp (wi - pad) (ht - pad) - where sf = setForeground d gc c - sla = setLineAttributes d gc (fi lw) lineSolid capNotLast joinMiter - boff = borderOffset b lw - -borderOffset :: (Integral a) => Border -> Int -> a -borderOffset b lw = - case b of - BottomB -> negate boffs - BottomBM _ -> negate boffs - TopB -> boffs - TopBM _ -> boffs - _ -> 0 - where boffs = calcBorderOffset lw - -calcBorderOffset :: (Integral a) => Int -> a -calcBorderOffset = ceiling . (/2) . toDouble - where toDouble = fi :: (Integral a) => a -> Double - -updateActions :: Rectangle -> [[Segment]] -> X [([Action], Position, Position)] -updateActions (Rectangle _ _ wid _) ~[left,center,right] = do - conf <- ask - let d = display conf - fs = fontList conf - strLn :: [Segment] -> IO [(Maybe [Action], Position, Position)] - strLn = liftIO . mapM getCoords - iconW i = maybe 0 B.width (lookup i $ iconCache 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 - liftIO $ fmap concat $ mapM (\(a,xs) -> - (\xs' -> partCoord (offset a xs') xs') <$> strLn xs) $ - zip [L,C,R] [left,center,right] -- cgit v1.2.3