From 4b4c9fe0a8849fad124a2f75e815e648dafd4969 Mon Sep 17 00:00:00 2001 From: jao Date: Tue, 20 Sep 2022 05:41:27 +0100 Subject: new namespace: Xmobar.Draw --- src/Xmobar/Draw/Boxes.hs | 68 ++++++++++++++++ src/Xmobar/Draw/Cairo.hs | 192 +++++++++++++++++++++++++++++++++++++++++++ src/Xmobar/Draw/Types.hs | 52 ++++++++++++ src/Xmobar/X11/Bitmap.hs | 27 +++---- src/Xmobar/X11/Boxes.hs | 68 ---------------- src/Xmobar/X11/CairoDraw.hs | 193 -------------------------------------------- src/Xmobar/X11/Draw.hs | 12 +-- src/Xmobar/X11/Loop.hs | 14 ++-- src/Xmobar/X11/Types.hs | 18 +---- 9 files changed, 338 insertions(+), 306 deletions(-) create mode 100644 src/Xmobar/Draw/Boxes.hs create mode 100644 src/Xmobar/Draw/Cairo.hs create mode 100644 src/Xmobar/Draw/Types.hs delete mode 100644 src/Xmobar/X11/Boxes.hs delete mode 100644 src/Xmobar/X11/CairoDraw.hs (limited to 'src') diff --git a/src/Xmobar/Draw/Boxes.hs b/src/Xmobar/Draw/Boxes.hs new file mode 100644 index 0000000..1358805 --- /dev/null +++ b/src/Xmobar/Draw/Boxes.hs @@ -0,0 +1,68 @@ +------------------------------------------------------------------------------ +-- | +-- Module: Xmobar.X11.Boxes +-- Copyright: (c) 2022 Jose Antonio Ortega Ruiz +-- License: BSD3-style (see LICENSE) +-- +-- Maintainer: jao@gnu.org +-- Stability: unstable +-- Portability: unportable +-- Start date: Fri Sep 16, 2022 04:01 +-- +-- Borders and boxes +-- +------------------------------------------------------------------------------ + +module Xmobar.Draw.Boxes (Line, boxLines, BoxRect, borderRect) where + +import qualified Xmobar.Config.Types as T +import qualified Xmobar.Run.Parsers as P + +type Line = (Double, Double, Double, Double) +type BoxRect = (Double, Double, Double, Double) + +-- | Computes the coordinates of a list of lines representing a Box. +-- The Box is to be positioned between x0 and x1, with height ht, and drawn +-- with line width lw. The returned lists are coordinates of the beginning +-- and end of each line. +boxLines :: P.Box -> Double -> Double -> Double -> [Line] +boxLines (P.Box bd offset lw _ margins) ht x0 x1 = + case bd of + P.BBTop -> [rtop] + P.BBBottom -> [rbot] + P.BBVBoth -> [rtop, rbot] + P.BBLeft -> [rleft] + P.BBRight -> [rright] + P.BBHBoth -> [rleft, rright] + P.BBFull -> [rtop, rbot, rleft, rright] + where + (P.BoxMargins top right bot left) = margins + (P.BoxOffset align m) = offset + ma = fromIntegral m + (p0, p1) = case align of + T.L -> (0, -ma) + T.C -> (ma, -ma) + T.R -> (ma, 0) + lc = fromIntegral lw / 2 + [mt, mr, mb, ml] = map fromIntegral [top, right, bot, left] + xmin = x0 - ml - lc + xmax = x1 + mr + lc + ymin = mt + lc + ymax = ht - mb - lc + rtop = (xmin + p0, ymin, xmax + p1, ymin) + rbot = (xmin + p0, ymax, xmax + p1, ymax) + rleft = (xmin, ymin + p0, xmin, ymax + p1) + rright = (xmax, ymin + p0, xmax, ymax + p1) + +-- | Computes the rectangle (x, y, width, height) for the given Border. +borderRect :: T.Border -> Double -> Double -> BoxRect +borderRect bdr w h = + case bdr of + T.TopB -> (0, 0, w - 1, 0) + T.BottomB -> (0, h - 1, w - 1, 0) + T.FullB -> (0, 0, w - 1, h - 1) + T.TopBM m -> (0, fi m, w - 1, 0) + T.BottomBM m -> (0, h - fi m, w - 1, 0) + T.FullBM m -> (fi m, fi m, w - 2 * fi m, h - 2 * fi m) + T.NoBorder -> (-1, -1, -1, -1) + where fi = fromIntegral diff --git a/src/Xmobar/Draw/Cairo.hs b/src/Xmobar/Draw/Cairo.hs new file mode 100644 index 0000000..8fa4c46 --- /dev/null +++ b/src/Xmobar/Draw/Cairo.hs @@ -0,0 +1,192 @@ +{-# LANGUAGE CPP #-} +------------------------------------------------------------------------------ +-- | +-- Module: Xmobar.X11.Cairo +-- Copyright: (c) 2022 Jose Antonio Ortega Ruiz +-- License: BSD3-style (see LICENSE) +-- +-- Maintainer: jao@gnu.org +-- Stability: unstable +-- Portability: unportable +-- Created: Fri Sep 09, 2022 02:03 +-- +-- Drawing the xmobar contents using Cairo and Pango +-- +-- +------------------------------------------------------------------------------ + +module Xmobar.Draw.Cairo (drawSegments) where + +import qualified Data.Colour.SRGB as SRGB +import qualified Data.Colour.Names as CNames + +import Control.Monad (foldM, when) + +import qualified Graphics.Rendering.Cairo as Cairo +import qualified Graphics.Rendering.Pango as Pango + +import Graphics.Rendering.Cairo.Types(Surface) + +import qualified Xmobar.Config.Types as C +import qualified Xmobar.Config.Parse as ConfigParse +import qualified Xmobar.Run.Parsers as P +import qualified Xmobar.Text.Pango as TextPango + +import qualified Xmobar.Draw.Boxes as Boxes +import qualified Xmobar.Draw.Types as T + +type Renderinfo = (P.Segment, Surface -> Double -> Double -> IO (), Double) +type BoundedBox = (Double, Double, [P.Box]) +type Acc = (Double, T.Actions, [BoundedBox]) + +readColourName :: String -> (SRGB.Colour Double, Double) +readColourName str = + case CNames.readColourName str of + Just c -> (c, 1.0) + Nothing -> case SRGB.sRGB24reads str of + [(c, "")] -> (c, 1.0) + [(c,d)] -> (c, read ("0x" ++ d)) + _ -> (CNames.white, 1.0) + +setSourceColor :: (SRGB.Colour Double, Double) -> Cairo.Render () +setSourceColor (colour, alph) = + if alph < 1 then Cairo.setSourceRGBA r g b alph else Cairo.setSourceRGB r g b + where rgb = SRGB.toSRGB colour + r = SRGB.channelRed rgb + g = SRGB.channelGreen rgb + b = SRGB.channelBlue rgb + +renderLines :: String -> Double -> [Boxes.Line] -> Cairo.Render () +renderLines color wd lns = do + setSourceColor (readColourName color) + Cairo.setLineWidth wd + mapM_ (\(x0, y0, x1, y1) -> + Cairo.moveTo x0 y0 >> Cairo.lineTo x1 y1 >> Cairo.stroke) lns + +segmentMarkup :: C.Config -> P.Segment -> String +segmentMarkup conf (P.Text txt, info, idx, _actions) = + let fnt = TextPango.fixXft $ ConfigParse.indexedFont conf idx + (fg, bg) = P.colorComponents conf (P.tColorsString info) + attrs = [Pango.FontDescr fnt, Pango.FontForeground fg] + attrs' = if bg == C.bgColor conf + then attrs + else Pango.FontBackground bg:attrs + in Pango.markSpan attrs' $ Pango.escapeMarkup txt +segmentMarkup _ _ = "" + +withRenderinfo :: Pango.PangoContext -> T.DrawContext -> P.Segment -> IO Renderinfo +withRenderinfo ctx dctx seg@(P.Text _, inf, idx, a) = do + let conf = T.dcConfig dctx + lyt <- Pango.layoutEmpty ctx + mk <- Pango.layoutSetMarkup lyt (segmentMarkup conf seg) :: IO String + (_, Pango.PangoRectangle o u w h) <- Pango.layoutGetExtents lyt + let voff' = fromIntegral $ ConfigParse.indexedOffset conf idx + voff = voff' + (T.dcHeight dctx - h + u) / 2.0 + wd = w - o + slyt s off mx = do + when (off + w > mx) $ do + Pango.layoutSetEllipsize lyt Pango.EllipsizeEnd + Pango.layoutSetWidth lyt (Just $ mx - off) + Cairo.renderWith s $ Cairo.moveTo off voff >> Pango.showLayout lyt + return ((P.Text mk, inf, idx, a), slyt, wd) + +withRenderinfo _ _ seg@(P.Hspace w, _, _, _) = + return (seg, \_ _ _ -> return (), fromIntegral w) + +withRenderinfo _ dctx seg@(P.Icon p, _, _, _) = do + let bm = T.dcBitmapLookup dctx p + wd = maybe 0 (fromIntegral . T.bWidth) bm + ioff = C.iconOffset (T.dcConfig dctx) + vpos = T.dcHeight dctx / 2 + fromIntegral ioff + render _ off mx = when (off + wd <= mx) $ T.dcBitmapDrawer dctx off vpos p + return (seg, render, wd) + +drawBox :: T.DrawContext -> Surface -> Double -> Double -> P.Box -> IO () +drawBox dctx surf x0 x1 box@(P.Box _ _ w color _) = + Cairo.renderWith surf $ + renderLines color (fromIntegral w) (Boxes.boxLines box (T.dcHeight dctx) x0 x1) + +drawSegmentBackground :: + T.DrawContext -> Surface -> P.TextRenderInfo -> Double -> Double -> IO () +drawSegmentBackground dctx surf info x0 x1 = + when (bg /= C.bgColor conf && (top >= 0 || bot >= 0)) $ + Cairo.renderWith surf $ do + setSourceColor (readColourName bg) + Cairo.rectangle x0 top (x1 - x0) (T.dcHeight dctx - bot - top) + Cairo.fillPreserve + where conf = T.dcConfig dctx + (_, bg) = P.colorComponents conf (P.tColorsString info) + top = fromIntegral $ P.tBgTopOffset info + bot = fromIntegral $ P.tBgBottomOffset info + +drawSegment :: T.DrawContext -> Surface -> Double -> Acc -> Renderinfo -> IO Acc +drawSegment dctx surface maxoff (off, acts, boxs) (segment, render, lwidth) = do + let end = min maxoff (off + lwidth) + (_, info, _, a) = segment + acts' = case a of Just as -> (as, off, end):acts; _ -> acts + bs = P.tBoxes info + boxs' = if null bs then boxs else (off, end, bs):boxs + drawSegmentBackground dctx surface info off end + render surface off maxoff + return (off + lwidth, acts', boxs') + +renderOuterBorder :: C.Config -> Double -> Double -> Cairo.Render () +renderOuterBorder conf mw mh = do + let (x0, y0, w, h) = Boxes.borderRect (C.border conf) mw mh + setSourceColor (readColourName (C.borderColor conf)) + Cairo.setLineWidth (fromIntegral (C.borderWidth conf)) + Cairo.rectangle x0 y0 w h + Cairo.stroke + +drawBorder :: C.Config -> Double -> Double -> Surface -> IO () +drawBorder conf w h surf = + case C.border conf of + C.NoBorder -> return () + _ -> Cairo.renderWith surf (renderOuterBorder conf w h) + +drawBBox :: T.DrawContext -> Surface -> BoundedBox -> IO () +drawBBox dctx surf (from, to, bs) = mapM_ (drawBox dctx surf from to) bs + +drawBoxes :: T.DrawContext -> Surface -> [BoundedBox] -> IO () +drawBoxes dctx surf ((from, to, b):(from', to', b'):bxs) = + if to < from' || b /= b' + then do drawBBox dctx surf (from, to, b) + drawBoxes dctx surf $ (from', to', b'):bxs + else drawBoxes dctx surf $ (from, to', b'):bxs + +drawBoxes dctx surf [bi] = drawBBox dctx surf bi + +drawBoxes _ _ [] = return () + +#ifndef XRENDER +drawCairoBackground :: DrawContext -> Surface -> IO () +drawCairoBackground dctx surf = do + let (c, _) = readColourName (C.bgColor (dcConfig dctx)) + Cairo.renderWith surf $ setSourceColor (c, 1.0) >> Cairo.paint +#endif + +drawSegments :: T.DrawContext -> Surface -> IO T.Actions +drawSegments dctx surf = do + let [left, center, right] = take 3 $ T.dcSegments dctx ++ repeat [] + dh = T.dcHeight dctx + dw = T.dcWidth dctx + conf = T.dcConfig dctx + sWidth = foldl (\a (_,_,w) -> a + w) 0 + ctx <- Pango.cairoCreateContext Nothing + llyts <- mapM (withRenderinfo ctx dctx) left + rlyts <- mapM (withRenderinfo ctx dctx) right + clyts <- mapM (withRenderinfo ctx dctx) center +#ifndef XRENDER + drawCairoBackground dctx surf +#endif + (lend, as, bx) <- foldM (drawSegment dctx surf dw) (0, [], []) llyts + let rw = sWidth rlyts + rstart = max (lend + 1) (dw - rw - 1) + cmax = rstart - 1 + cw = sWidth clyts + cstart = lend + 1 + max 0 (dw - rw - lend - cw) / 2.0 + (_, as', bx') <- foldM (drawSegment dctx surf cmax) (cstart, as, bx) clyts + (_, as'', bx'') <- foldM (drawSegment dctx surf dw) (rstart, as', bx') rlyts + drawBoxes dctx surf (reverse bx'') + when (C.borderWidth conf > 0) (drawBorder conf dw dh surf) + return as'' diff --git a/src/Xmobar/Draw/Types.hs b/src/Xmobar/Draw/Types.hs new file mode 100644 index 0000000..219a64b --- /dev/null +++ b/src/Xmobar/Draw/Types.hs @@ -0,0 +1,52 @@ +------------------------------------------------------------------------------ +-- | +-- Module: Xmobar.Draw.Types +-- Copyright: (c) 2022 jao +-- License: BSD3-style (see LICENSE) +-- +-- Maintainer: mail@jao.io +-- Stability: unstable +-- Portability: portable +-- Created: Tue Sep 20, 2022 04:49 +-- +-- +-- Type definitions for describing drawing operations +-- +------------------------------------------------------------------------------ + + +module Xmobar.Draw.Types where + +import GHC.Word (Word32, Word64) + +import Data.Map (Map) + +import Xmobar.Config.Types (Config) +import Xmobar.Run.Actions (Action) +import Xmobar.Run.Parsers (Segment) + +type Position = Double +type ActionPos = ([Action], Position, Position) +type Actions = [ActionPos] + +type BitmapDrawer = Double -> Double -> String -> IO () + +data BitmapType = Mono Word64 | Poly + +data Bitmap = Bitmap { bWidth :: Word32 + , bHeight :: Word32 + , bPixmap :: Word64 + , bShapepixmap :: Maybe Word64 + , bBitmaptype :: BitmapType + } + +type BitmapCache = Map FilePath Bitmap + + +data DrawContext = DC { dcBitmapDrawer :: BitmapDrawer + , dcBitmapLookup :: String -> Maybe Bitmap + , dcConfig :: Config + , dcWidth :: Double + , dcHeight :: Double + , dcSegments :: [[Segment]] + } diff --git a/src/Xmobar/X11/Bitmap.hs b/src/Xmobar/X11/Bitmap.hs index 220741e..d6a818b 100644 --- a/src/Xmobar/X11/Bitmap.hs +++ b/src/Xmobar/X11/Bitmap.hs @@ -20,10 +20,14 @@ module Xmobar.X11.Bitmap import Control.Monad import Control.Monad.Trans(MonadIO(..)) import Data.Map hiding (map) + import Graphics.X11.Xlib hiding (Segment) + import System.Directory (doesFileExist) import System.FilePath (()) import System.Mem.Weak ( addFinalizer ) + +import Xmobar.Draw.Types (BitmapType(..), Bitmap(..), BitmapCache) import Xmobar.X11.ColorCache #ifdef XPM @@ -43,17 +47,6 @@ runExceptT = runErrorT #endif -data BitmapType = Mono Pixel | Poly - -data Bitmap = Bitmap { width :: Dimension - , height :: Dimension - , pixmap :: Pixmap - , shapePixmap :: Maybe Pixmap - , bitmapType :: BitmapType - } - -type BitmapCache = Map FilePath Bitmap - updateCache :: Display -> Window -> Map FilePath Bitmap -> FilePath -> [FilePath] -> IO BitmapCache updateCache dpy win cache iconRoot paths = do @@ -114,15 +107,15 @@ drawBitmap :: Display -> Drawable -> GC -> String -> String -> Position -> Position -> Bitmap -> IO () drawBitmap d p gc fc bc x y i = withColors d [fc, bc] $ \[fc', bc'] -> do - let w = width i - h = height i + let w = bWidth i + h = bHeight i y' = 1 + y - fromIntegral h `div` 2 setForeground d gc fc' setBackground d gc bc' - case shapePixmap i of + case bShapepixmap i of Nothing -> return () Just mask -> setClipOrigin d gc x y' >> setClipMask d gc mask - case bitmapType i of - Poly -> copyArea d (pixmap i) p gc 0 0 w h x y' - Mono pl -> copyPlane d (pixmap i) p gc 0 0 w h x y' pl + case bBitmaptype i of + Poly -> copyArea d (bPixmap i) p gc 0 0 w h x y' + Mono pl -> copyPlane d (bPixmap i) p gc 0 0 w h x y' pl setClipMask d gc 0 diff --git a/src/Xmobar/X11/Boxes.hs b/src/Xmobar/X11/Boxes.hs deleted file mode 100644 index 4ea7144..0000000 --- a/src/Xmobar/X11/Boxes.hs +++ /dev/null @@ -1,68 +0,0 @@ ------------------------------------------------------------------------------- --- | --- Module: Xmobar.X11.Boxes --- Copyright: (c) 2022 Jose Antonio Ortega Ruiz --- License: BSD3-style (see LICENSE) --- --- Maintainer: jao@gnu.org --- Stability: unstable --- Portability: unportable --- Start date: Fri Sep 16, 2022 04:01 --- --- Borders and boxes --- ------------------------------------------------------------------------------- - -module Xmobar.X11.Boxes (Line, boxLines, BoxRect, borderRect) where - -import qualified Xmobar.Config.Types as T -import qualified Xmobar.Run.Parsers as P - -type Line = (Double, Double, Double, Double) -type BoxRect = (Double, Double, Double, Double) - --- | Computes the coordinates of a list of lines representing a Box. --- The Box is to be positioned between x0 and x1, with height ht, and drawn --- with line width lw. The returned lists are coordinates of the beginning --- and end of each line. -boxLines :: P.Box -> Double -> Double -> Double -> [Line] -boxLines (P.Box bd offset lw _ margins) ht x0 x1 = - case bd of - P.BBTop -> [rtop] - P.BBBottom -> [rbot] - P.BBVBoth -> [rtop, rbot] - P.BBLeft -> [rleft] - P.BBRight -> [rright] - P.BBHBoth -> [rleft, rright] - P.BBFull -> [rtop, rbot, rleft, rright] - where - (P.BoxMargins top right bot left) = margins - (P.BoxOffset align m) = offset - ma = fromIntegral m - (p0, p1) = case align of - T.L -> (0, -ma) - T.C -> (ma, -ma) - T.R -> (ma, 0) - lc = fromIntegral lw / 2 - [mt, mr, mb, ml] = map fromIntegral [top, right, bot, left] - xmin = x0 - ml - lc - xmax = x1 + mr + lc - ymin = mt + lc - ymax = ht - mb - lc - rtop = (xmin + p0, ymin, xmax + p1, ymin) - rbot = (xmin + p0, ymax, xmax + p1, ymax) - rleft = (xmin, ymin + p0, xmin, ymax + p1) - rright = (xmax, ymin + p0, xmax, ymax + p1) - --- | Computes the rectangle (x, y, width, height) for the given Border. -borderRect :: T.Border -> Double -> Double -> BoxRect -borderRect bdr w h = - case bdr of - T.TopB -> (0, 0, w - 1, 0) - T.BottomB -> (0, h - 1, w - 1, 0) - T.FullB -> (0, 0, w - 1, h - 1) - T.TopBM m -> (0, fi m, w - 1, 0) - T.BottomBM m -> (0, h - fi m, w - 1, 0) - T.FullBM m -> (fi m, fi m, w - 2 * fi m, h - 2 * fi m) - T.NoBorder -> (-1, -1, -1, -1) - where fi = fromIntegral diff --git a/src/Xmobar/X11/CairoDraw.hs b/src/Xmobar/X11/CairoDraw.hs deleted file mode 100644 index dd2ea2b..0000000 --- a/src/Xmobar/X11/CairoDraw.hs +++ /dev/null @@ -1,193 +0,0 @@ -{-# LANGUAGE CPP #-} ------------------------------------------------------------------------------- --- | --- Module: Xmobar.X11.CairoDraw --- Copyright: (c) 2022 Jose Antonio Ortega Ruiz --- License: BSD3-style (see LICENSE) --- --- Maintainer: jao@gnu.org --- Stability: unstable --- Portability: unportable --- Created: Fri Sep 09, 2022 02:03 --- --- Drawing the xmobar contents using Cairo and Pango --- --- ------------------------------------------------------------------------------- - -module Xmobar.X11.CairoDraw (drawSegments) where - -import qualified Data.Colour.SRGB as SRGB -import qualified Data.Colour.Names as CNames - -import Control.Monad (foldM, when) - -import qualified Graphics.Rendering.Cairo as Cairo -import qualified Graphics.Rendering.Pango as Pango - -import Graphics.Rendering.Cairo.Types(Surface) - -import qualified Xmobar.Config.Types as C -import qualified Xmobar.Config.Parse as ConfigParse -import qualified Xmobar.Run.Parsers as P -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 T - -type Renderinfo = (P.Segment, Surface -> Double -> Double -> IO (), Double) -type BoundedBox = (Double, Double, [P.Box]) -type Acc = (Double, T.Actions, [BoundedBox]) - -readColourName :: String -> (SRGB.Colour Double, Double) -readColourName str = - case CNames.readColourName str of - Just c -> (c, 1.0) - Nothing -> case SRGB.sRGB24reads str of - [(c, "")] -> (c, 1.0) - [(c,d)] -> (c, read ("0x" ++ d)) - _ -> (CNames.white, 1.0) - -setSourceColor :: (SRGB.Colour Double, Double) -> Cairo.Render () -setSourceColor (colour, alph) = - if alph < 1 then Cairo.setSourceRGBA r g b alph else Cairo.setSourceRGB r g b - where rgb = SRGB.toSRGB colour - r = SRGB.channelRed rgb - g = SRGB.channelGreen rgb - b = SRGB.channelBlue rgb - -renderLines :: String -> Double -> [Boxes.Line] -> Cairo.Render () -renderLines color wd lns = do - setSourceColor (readColourName color) - Cairo.setLineWidth wd - mapM_ (\(x0, y0, x1, y1) -> - Cairo.moveTo x0 y0 >> Cairo.lineTo x1 y1 >> Cairo.stroke) lns - -segmentMarkup :: C.Config -> P.Segment -> String -segmentMarkup conf (P.Text txt, info, idx, _actions) = - let fnt = TextPango.fixXft $ ConfigParse.indexedFont conf idx - (fg, bg) = P.colorComponents conf (P.tColorsString info) - attrs = [Pango.FontDescr fnt, Pango.FontForeground fg] - attrs' = if bg == C.bgColor conf - then attrs - else Pango.FontBackground bg:attrs - in Pango.markSpan attrs' $ Pango.escapeMarkup txt -segmentMarkup _ _ = "" - -withRenderinfo :: Pango.PangoContext -> T.DrawContext -> P.Segment -> IO Renderinfo -withRenderinfo ctx dctx seg@(P.Text _, inf, idx, a) = do - let conf = T.dcConfig dctx - lyt <- Pango.layoutEmpty ctx - mk <- Pango.layoutSetMarkup lyt (segmentMarkup conf seg) :: IO String - (_, Pango.PangoRectangle o u w h) <- Pango.layoutGetExtents lyt - let voff' = fromIntegral $ ConfigParse.indexedOffset conf idx - voff = voff' + (T.dcHeight dctx - h + u) / 2.0 - wd = w - o - slyt s off mx = do - when (off + w > mx) $ do - Pango.layoutSetEllipsize lyt Pango.EllipsizeEnd - Pango.layoutSetWidth lyt (Just $ mx - off) - Cairo.renderWith s $ Cairo.moveTo off voff >> Pango.showLayout lyt - return ((P.Text mk, inf, idx, a), slyt, wd) - -withRenderinfo _ _ seg@(P.Hspace w, _, _, _) = - return (seg, \_ _ _ -> return (), fromIntegral w) - -withRenderinfo _ dctx seg@(P.Icon p, _, _, _) = do - let bm = T.dcBitmapLookup dctx p - wd = maybe 0 (fromIntegral . B.width) bm - ioff = C.iconOffset (T.dcConfig dctx) - vpos = T.dcHeight dctx / 2 + fromIntegral ioff - render _ off mx = when (off + wd <= mx) $ T.dcBitmapDrawer dctx off vpos p - return (seg, render, wd) - -drawBox :: T.DrawContext -> Surface -> Double -> Double -> P.Box -> IO () -drawBox dctx surf x0 x1 box@(P.Box _ _ w color _) = - Cairo.renderWith surf $ - renderLines color (fromIntegral w) (Boxes.boxLines box (T.dcHeight dctx) x0 x1) - -drawSegmentBackground :: - T.DrawContext -> Surface -> P.TextRenderInfo -> Double -> Double -> IO () -drawSegmentBackground dctx surf info x0 x1 = - when (bg /= C.bgColor conf && (top >= 0 || bot >= 0)) $ - Cairo.renderWith surf $ do - setSourceColor (readColourName bg) - Cairo.rectangle x0 top (x1 - x0) (T.dcHeight dctx - bot - top) - Cairo.fillPreserve - where conf = T.dcConfig dctx - (_, bg) = P.colorComponents conf (P.tColorsString info) - top = fromIntegral $ P.tBgTopOffset info - bot = fromIntegral $ P.tBgBottomOffset info - -drawSegment :: T.DrawContext -> Surface -> Double -> Acc -> Renderinfo -> IO Acc -drawSegment dctx surface maxoff (off, acts, boxs) (segment, render, lwidth) = do - let end = min maxoff (off + lwidth) - (_, info, _, a) = segment - acts' = case a of Just as -> (as, round off, round end):acts; _ -> acts - bs = P.tBoxes info - boxs' = if null bs then boxs else (off, end, bs):boxs - drawSegmentBackground dctx surface info off end - render surface off maxoff - return (off + lwidth, acts', boxs') - -renderOuterBorder :: C.Config -> Double -> Double -> Cairo.Render () -renderOuterBorder conf mw mh = do - let (x0, y0, w, h) = Boxes.borderRect (C.border conf) mw mh - setSourceColor (readColourName (C.borderColor conf)) - Cairo.setLineWidth (fromIntegral (C.borderWidth conf)) - Cairo.rectangle x0 y0 w h - Cairo.stroke - -drawBorder :: C.Config -> Double -> Double -> Surface -> IO () -drawBorder conf w h surf = - case C.border conf of - C.NoBorder -> return () - _ -> Cairo.renderWith surf (renderOuterBorder conf w h) - -drawBBox :: T.DrawContext -> Surface -> BoundedBox -> IO () -drawBBox dctx surf (from, to, bs) = mapM_ (drawBox dctx surf from to) bs - -drawBoxes :: T.DrawContext -> Surface -> [BoundedBox] -> IO () -drawBoxes dctx surf ((from, to, b):(from', to', b'):bxs) = - if to < from' || b /= b' - then do drawBBox dctx surf (from, to, b) - drawBoxes dctx surf $ (from', to', b'):bxs - else drawBoxes dctx surf $ (from, to', b'):bxs - -drawBoxes dctx surf [bi] = drawBBox dctx surf bi - -drawBoxes _ _ [] = return () - -#ifndef XRENDER -drawCairoBackground :: DrawContext -> Surface -> IO () -drawCairoBackground dctx surf = do - let (c, _) = readColourName (C.bgColor (dcConfig dctx)) - Cairo.renderWith surf $ setSourceColor (c, 1.0) >> Cairo.paint -#endif - -drawSegments :: T.DrawContext -> Surface -> IO T.Actions -drawSegments dctx surf = do - let [left, center, right] = take 3 $ T.dcSegments dctx ++ repeat [] - dh = T.dcHeight dctx - dw = T.dcWidth dctx - conf = T.dcConfig dctx - sWidth = foldl (\a (_,_,w) -> a + w) 0 - ctx <- Pango.cairoCreateContext Nothing - llyts <- mapM (withRenderinfo ctx dctx) left - rlyts <- mapM (withRenderinfo ctx dctx) right - clyts <- mapM (withRenderinfo ctx dctx) center -#ifndef XRENDER - drawCairoBackground dctx surf -#endif - (lend, as, bx) <- foldM (drawSegment dctx surf dw) (0, [], []) llyts - let rw = sWidth rlyts - rstart = max (lend + 1) (dw - rw - 1) - cmax = rstart - 1 - cw = sWidth clyts - cstart = lend + 1 + max 0 (dw - rw - lend - cw) / 2.0 - (_, as', bx') <- foldM (drawSegment dctx surf cmax) (cstart, as, bx) clyts - (_, as'', bx'') <- foldM (drawSegment dctx surf dw) (rstart, as', bx') rlyts - drawBoxes dctx surf (reverse bx'') - when (C.borderWidth conf > 0) (drawBorder conf dw dh surf) - return as'' diff --git a/src/Xmobar/X11/Draw.hs b/src/Xmobar/X11/Draw.hs index 48ddb91..7e0dfd1 100644 --- a/src/Xmobar/X11/Draw.hs +++ b/src/Xmobar/X11/Draw.hs @@ -26,16 +26,18 @@ import qualified Graphics.X11.Xlib as X11 import qualified Xmobar.Config.Types as C import qualified Xmobar.Run.Parsers as P +import qualified Xmobar.Draw.Types as D +import qualified Xmobar.Draw.Cairo as DC + import qualified Xmobar.X11.Bitmap as B import qualified Xmobar.X11.Types as T -import qualified Xmobar.X11.CairoDraw as CD import qualified Xmobar.X11.CairoSurface as CS #ifdef XRENDER import qualified Xmobar.X11.XRender as XRender #endif -drawXBitmap :: T.XConf -> X11.GC -> X11.Pixmap -> T.BitmapDrawer +drawXBitmap :: T.XConf -> X11.GC -> X11.Pixmap -> D.BitmapDrawer drawXBitmap xconf gc p h v path = do let disp = T.display xconf conf = T.config xconf @@ -64,7 +66,7 @@ withPixmap disp win (X11.Rectangle _ _ w h) depth action = do X11.sync disp True return res -draw :: [[P.Segment]] -> T.X [T.ActionPos] +draw :: [[P.Segment]] -> T.X [D.ActionPos] draw segments = do xconf <- ask let disp = T.display xconf @@ -78,8 +80,8 @@ draw segments = do liftIO $ withPixmap disp win rect depth $ \gc p -> do let bdraw = drawXBitmap xconf gc p blook = lookupXBitmap xconf - dctx = T.DC bdraw blook conf (fromIntegral w) (fromIntegral h) segments - render = CD.drawSegments dctx + dctx = D.DC bdraw blook conf (fromIntegral w) (fromIntegral h) segments + render = DC.drawSegments dctx #ifdef XRENDER color = C.bgColor conf diff --git a/src/Xmobar/X11/Loop.hs b/src/Xmobar/X11/Loop.hs index 3975e21..599e680 100644 --- a/src/Xmobar/X11/Loop.hs +++ b/src/Xmobar/X11/Loop.hs @@ -43,6 +43,8 @@ import qualified Xmobar.Run.Parsers as P import qualified Xmobar.System.Utils as U import qualified Xmobar.System.Signal as S +import qualified Xmobar.Draw.Types as D + import qualified Xmobar.X11.Types as T import qualified Xmobar.X11.Text as Text import qualified Xmobar.X11.Draw as Draw @@ -100,11 +102,8 @@ eventLoop dpy w signalv = -- The list of actions provides the positions of clickable rectangles, -- and there is a mutable variable for received signals and the list -- of strings updated by running monitors. -signalLoop :: T.XConf - -> [([A.Action], X11.Position, X11.Position)] - -> STM.TMVar S.SignalType - -> STM.TVar [String] - -> IO () +signalLoop :: + T.XConf -> D.Actions -> STM.TMVar S.SignalType -> STM.TVar [String] -> IO () signalLoop xc@(T.XConf d r w fs is cfg) actions signalv strs = do typ <- STM.atomically $ STM.takeTMVar signalv case typ of @@ -168,9 +167,10 @@ updateConfigPosition disp cfg = else (cfg {C.position = C.OnScreen (n+1) o})) o -> return (cfg {C.position = C.OnScreen 1 o}) -runActions :: [T.ActionPos] -> A.Button -> X11.Position -> IO () +runActions :: D.Actions -> A.Button -> X11.Position -> IO () runActions actions button pos = mapM_ A.runAction $ filter (\(A.Spawn b _) -> button `elem` b) $ concatMap (\(a,_,_) -> a) $ - filter (\(_, from, to) -> pos >= from && pos <= to) actions + filter (\(_, from, to) -> pos' >= from && pos' <= to) actions + where pos' = fromIntegral pos diff --git a/src/Xmobar/X11/Types.hs b/src/Xmobar/X11/Types.hs index 309b6bf..e880cc0 100644 --- a/src/Xmobar/X11/Types.hs +++ b/src/Xmobar/X11/Types.hs @@ -23,9 +23,8 @@ import qualified Data.List.NonEmpty as NE import Control.Monad.Reader (ReaderT) import Xmobar.Config.Types -import Xmobar.Run.Actions (Action) -import Xmobar.Run.Parsers (Segment) -import Xmobar.X11.Bitmap (Bitmap, BitmapCache) + +import Xmobar.X11.Bitmap (BitmapCache) import Xmobar.X11.Text (XFont) -- | The X type is a ReaderT @@ -40,16 +39,3 @@ data XConf = , iconCache :: BitmapCache , config :: Config } - -type ActionPos = ([Action], X11.Position, X11.Position) -type Actions = [ActionPos] - -type BitmapDrawer = Double -> Double -> String -> IO () - -data DrawContext = DC { dcBitmapDrawer :: BitmapDrawer - , dcBitmapLookup :: String -> Maybe Bitmap - , dcConfig :: Config - , dcWidth :: Double - , dcHeight :: Double - , dcSegments :: [[Segment]] - } -- cgit v1.2.3