summaryrefslogtreecommitdiffhomepage
path: root/src/Xmobar/X11
diff options
context:
space:
mode:
Diffstat (limited to 'src/Xmobar/X11')
-rw-r--r--src/Xmobar/X11/CairoDraw.hs47
-rw-r--r--src/Xmobar/X11/Draw.hs105
-rw-r--r--src/Xmobar/X11/Loop.hs4
-rw-r--r--src/Xmobar/X11/XlibDraw.hs243
4 files changed, 72 insertions, 327 deletions
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]
generated by cgit v1.2.3 (git 2.46.0) at 2025-10-31 07:28:49 +0000