cairo: non-cairo is not an option

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]