cairo: fonts, offsets, colors, actions

5 files changed, 111 insertions, 58 deletions

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]