summaryrefslogtreecommitdiffhomepage
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Xmobar/Config/Types.hs11
-rw-r--r--src/Xmobar/Text/Pango.hs6
-rw-r--r--src/Xmobar/X11/CairoDraw.hs71
-rw-r--r--src/Xmobar/X11/CairoSurface.hsc4
-rw-r--r--src/Xmobar/X11/Draw.hs12
-rw-r--r--src/Xmobar/X11/Loop.hs49
-rw-r--r--src/Xmobar/X11/XlibDraw.hs33
7 files changed, 126 insertions, 60 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 = "<span foreground=\"%s\" background=\"%s\">%s</span>"
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]
generated by cgit v1.2.3 (git 2.46.0) at 2025-10-31 20:15:26 +0000