cairo: bitmaps

5 files changed, 98 insertions, 70 deletions

diff --git a/src/Xmobar/X11/Bitmap.hs b/src/Xmobar/X11/Bitmap.hs
index 2aea470..026cd5c 100644
--- a/src/Xmobar/X11/Bitmap.hs
+++ b/src/Xmobar/X11/Bitmap.hs
@@ -53,8 +53,9 @@ data Bitmap = Bitmap { width  :: Dimension
                      , bitmapType :: BitmapType
                      }
 
-updateCache :: Display -> Window -> Map FilePath Bitmap -> FilePath ->
-               [[(Widget, TextRenderInfo, Int, Maybe [Action])]] -> IO (Map FilePath Bitmap)
+updateCache :: Display -> Window -> Map FilePath Bitmap -> FilePath
+            -> [[(Widget, TextRenderInfo, Int, Maybe [Action])]]
+            -> IO (Map FilePath Bitmap)
 updateCache dpy win cache iconRoot ps = do
   let paths = map (\(Icon p, _, _, _) -> p) . concatMap (filter icons) $ ps
       icons (Icon _, _, _, _) = True
diff --git a/src/Xmobar/X11/CairoDraw.hs b/src/Xmobar/X11/CairoDraw.hs
index 4ed8d84..9dac493 100644
--- a/src/Xmobar/X11/CairoDraw.hs
+++ b/src/Xmobar/X11/CairoDraw.hs
@@ -16,6 +16,9 @@
 
 module Xmobar.X11.CairoDraw (drawInPixmap) where
 
+import Prelude hiding (lookup)
+import Data.Map (lookup)
+
 import Control.Monad.IO.Class
 import Control.Monad.Reader
 
@@ -33,21 +36,45 @@ import Xmobar.Run.Actions (Action)
 import Xmobar.Config.Types
 import Xmobar.Text.Pango (fixXft)
 import Xmobar.X11.Types
+import qualified Xmobar.X11.Bitmap as B
 import Xmobar.X11.CairoSurface
 
 type ActionPos = ([Action], Position, Position)
 type Actions = [ActionPos]
-type LayoutInfo = (Segment, P.PangoLayout, Double, Double)
-
-drawInPixmap :: Pixmap -> Dimension -> Dimension -> [[Segment]] -> X Actions
-drawInPixmap p w h s = do
+type Renderinfo = (Segment, Surface -> Double -> IO (), Double)
+type BitmapDrawer = Double -> Double -> String -> IO ()
+
+data DrawContext = DC { dcBitmapDrawer :: BitmapDrawer
+                      , dcBitmapLookup :: String -> Maybe B.Bitmap
+                      , dcConfig :: Config
+                      , dcWidth :: Double
+                      , dcHeight :: Double
+                      , dcSegments :: [[Segment]]
+                      }
+
+drawInPixmap :: GC -> Pixmap -> [[Segment]] -> X Actions
+drawInPixmap gc p s = do
   xconf <- ask
   let disp = display xconf
       vis = defaultVisualOfScreen (defaultScreenOfDisplay disp)
-      c = config xconf
-      fi = fromIntegral
-      render = renderSegments c w h s
-  liftIO $ withXlibSurface disp p vis (fi w) (fi h) render
+      (Rectangle _ _ w h) = rect xconf
+      dw = fromIntegral w
+      dh = fromIntegral h
+      dc = DC (drawXBitmap xconf gc p) (lookupXBitmap xconf) (config xconf) dw dh s
+      render = renderSegments dc
+  liftIO $ withXlibSurface disp p vis (fromIntegral w) (fromIntegral h) render
+
+lookupXBitmap :: XConf -> String -> Maybe B.Bitmap
+lookupXBitmap xconf path = lookup path (iconS xconf)
+
+drawXBitmap :: XConf -> GC -> Pixmap -> BitmapDrawer
+drawXBitmap xconf gc p h v path = do
+  let disp = display xconf
+      conf = config xconf
+      fc = fgColor conf
+      bc = bgColor conf
+      bm = lookupXBitmap xconf path
+  liftIO $ maybe (return ()) (B.drawBitmap disp p gc fc bc (round h) (round v)) bm
 
 segmentMarkup :: Config -> Segment -> String
 segmentMarkup conf (Text txt, info, idx, _actions) =
@@ -58,31 +85,39 @@ segmentMarkup conf (Text txt, info, idx, _actions) =
   in P.markSpan attrs' $ P.escapeMarkup txt
 segmentMarkup _ _ = ""
 
-withLayoutInfo :: P.PangoContext -> Double -> Config -> Segment -> IO LayoutInfo
-withLayoutInfo ctx maxh conf seg@(Text _, inf, idx, a) = do
+withRenderinfo :: P.PangoContext -> DrawContext -> Segment -> IO Renderinfo
+withRenderinfo ctx dctx seg@(Text _, inf, idx, a) = do
+  let conf = dcConfig dctx
   lyt <- P.layoutEmpty ctx
   mk <- P.layoutSetMarkup lyt (segmentMarkup conf seg) :: IO String
   (_, P.PangoRectangle o u w h) <- P.layoutGetExtents lyt
   let voff' = fromIntegral $ indexedOffset conf idx
-      voff = voff' + (maxh - h + u) / 2.0
-  return ((Text mk, inf, idx, a), lyt, w - o, voff)
-
-withLayoutInfo ctx _ _ seg = do
-  lyt <- P.layoutEmpty ctx
-  let n = case seg of (Hspace w, _, _, _) -> w; _ -> 0
-  return (seg, lyt, fromIntegral n, 0)
-
-renderLayout :: Surface -> Double -> (Double, Actions)
-             -> LayoutInfo -> IO (Double, Actions)
-renderLayout surface maxoff (off, actions) (segment, lyt, lwidth, voff) =
+      voff = voff' + (dcHeight dctx - h + u) / 2.0
+      slyt s pos = C.renderWith s $ C.moveTo pos voff >> P.showLayout lyt
+  return ((Text mk, inf, idx, a), slyt, w - o)
+
+withRenderinfo _ _ seg@(Hspace w, _, _, _) = do
+  return (seg, \_ _ -> return (), fromIntegral w)
+
+withRenderinfo _ dctx seg@(Icon p, _, idx, _) = do
+  let bm = dcBitmapLookup dctx p
+      wd = maybe 0 (fromIntegral . B.width) bm
+      ioff = indexedOffset (dcConfig dctx) idx
+      vpos = dcHeight dctx / 2  - fromIntegral ioff
+      draw _ off = dcBitmapDrawer dctx off vpos p
+  return (seg, draw, wd)
+
+renderSegment ::
+  Surface -> Double -> (Double, Actions) -> Renderinfo -> IO (Double, Actions)
+renderSegment surface maxoff (off, acts) (segment, render, lwidth) =
   if off + lwidth > maxoff
-  then pure (off, actions)
+  then pure (off, acts)
   else do
-    C.renderWith surface $ C.moveTo off voff >> P.showLayout lyt
+    render surface off
     let end = round $ off + lwidth
         (_, _, _, a) = segment
-        actions' = case a of Just as -> (as, round off, end):actions; _ -> actions
-    return (off + lwidth, actions')
+        acts' = case a of Just as -> (as, round off, end):acts; _ -> acts
+    return (off + lwidth, acts')
 
 setSourceColor :: RGBS.Colour Double -> C.Render ()
 setSourceColor = RGBS.uncurryRGB C.setSourceRGB . SRGB.toSRGB
@@ -130,27 +165,27 @@ renderBorder conf w h surf =
     NoBorder -> return ()
     _ -> C.renderWith surf (outerBorder conf w h)
 
-layoutsWidth :: [(Segment, P.PangoLayout, Double, Double)] -> Double
-layoutsWidth = foldl (\a (_,_,w,_) -> a + w) 0
+layoutsWidth :: [Renderinfo] -> Double
+layoutsWidth = foldl (\a (_,_,w) -> a + w) 0
 
-renderSegments ::
-  Config -> Dimension -> Dimension -> [[Segment]] -> Surface -> IO Actions
-renderSegments conf w h segments surface = do
-  let [left, center, right] = take 3 segments
-      dh = fromIntegral h
-      dw = fromIntegral w
+renderSegments :: DrawContext -> Surface -> IO Actions
+renderSegments dctx surface = do
+  let [left, center, right] = take 3 $ dcSegments dctx
+      dh = dcHeight dctx
+      dw = dcWidth dctx
+      conf = dcConfig dctx
   ctx <- P.cairoCreateContext Nothing
-  llyts <- mapM (withLayoutInfo ctx dh conf) left
-  rlyts <- mapM (withLayoutInfo ctx dh conf) right
-  clyts <- mapM (withLayoutInfo ctx dh conf) center
+  llyts <- mapM (withRenderinfo ctx dctx) left
+  rlyts <- mapM (withRenderinfo ctx dctx) right
+  clyts <- mapM (withRenderinfo ctx dctx) center
   renderBackground conf surface
-  (lend, as) <- foldM (renderLayout surface dw) (0, []) llyts
+  (lend, as) <- foldM (renderSegment surface dw) (0, []) llyts
   let rw = layoutsWidth rlyts
       rstart = max (lend + 1) (dw - rw - 1)
       cmax = rstart - 1
       cw = layoutsWidth clyts
       cstart = lend + 1 + max 0 (dw - rw - lend - cw) / 2.0
-  (_, as') <- foldM (renderLayout surface cmax) (cstart, as) clyts
-  (_, as'') <- foldM (renderLayout surface dw) (rstart, as') rlyts
+  (_, as') <- foldM (renderSegment surface cmax) (cstart, as) clyts
+  (_, as'') <- foldM (renderSegment surface dw) (rstart, as') rlyts
   when (borderWidth conf > 0) (renderBorder conf dw dh surface)
   return as''
diff --git a/src/Xmobar/X11/Draw.hs b/src/Xmobar/X11/Draw.hs
index 2d61b67..7642afc 100644
--- a/src/Xmobar/X11/Draw.hs
+++ b/src/Xmobar/X11/Draw.hs
@@ -37,33 +37,28 @@ import Xmobar.X11.XlibDraw
 #endif
 
 -- | Draws in and updates the window
-#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
-
+drawInWin :: [[Segment]] -> X [([Action], Position, Position)]
+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
 
 #if defined(XFT) || defined(CAIRO)
-  let xconf = config r
-      alph = alpha xconf
+  let cconf = config xconf
+      alph = alpha cconf
   when (alph < 255)
-     (liftIO $ drawBackground d p (bgColor xconf) alph (Rectangle 0 0 wid ht))
+     (liftIO $ drawBackground d p (bgColor cconf) alph (Rectangle 0 0 wid ht))
 #endif
 
 #ifdef CAIRO
-  res <- drawInPixmap p wid ht segments
+  res <- drawInPixmap gc p segments
 #else
-  res <- liftIO $ updateActions conf bound segments
+  res <- updateActions (rect xconf) segments
   drawInPixmap gc p wid ht segments
 #endif
   -- copy the pixmap with the new string to the window
diff --git a/src/Xmobar/X11/Loop.hs b/src/Xmobar/X11/Loop.hs
index c6a4e97..8f74b79 100644
--- a/src/Xmobar/X11/Loop.hs
+++ b/src/Xmobar/X11/Loop.hs
@@ -112,6 +112,7 @@ x11EventLoop w signal =
         _ -> return ()
 
 -- | Continuously wait for a signal from a thread or an interrupt handler
+-- The list of actions provide also the positions of clickable rectangles
 signalLoop :: XConf
           -> [([Action], Position, Position)]
           -> TMVar SignalType
@@ -121,14 +122,10 @@ signalLoop xc@(XConf d r w fs vos is cfg) as signal tv = do
       typ <- atomically $ takeTMVar signal
       case typ of
          Wakeup -> do
-            str <- updateSegments cfg tv
-            xc' <- updateCache d w is (iconRoot cfg) str >>=
+            segs <- updateSegments cfg tv
+            xc' <- updateCache d w is (iconRoot cfg) segs >>=
                      \c -> return xc { iconS = c }
-#ifdef CAIRO
-            as' <- runX xc' $ drawInWin r str
-#else
-            as' <- runX xc' $ drawInWin xc r str
-#endif
+            as' <- runX xc' $ drawInWin segs
             signalLoop xc' as' signal tv
 
          Reposition ->
diff --git a/src/Xmobar/X11/XlibDraw.hs b/src/Xmobar/X11/XlibDraw.hs
index 9483c16..77de23b 100644
--- a/src/Xmobar/X11/XlibDraw.hs
+++ b/src/Xmobar/X11/XlibDraw.hs
@@ -262,9 +262,9 @@ drawBoxBorder
     _ -> error "unreachable code"
 
 
-updateActions :: XConf -> Rectangle -> [[Segment]]
-              -> IO [([Action], Position, Position)]
-updateActions conf (Rectangle _ _ wid _) ~[left,center,right] = do
+updateActions :: Rectangle -> [[Segment]] -> X [([Action], Position, Position)]
+updateActions (Rectangle _ _ wid _) ~[left,center,right] = do
+  conf <- ask
   let d = display conf
       fs = fontListS conf
       strLn :: [Segment] -> IO [(Maybe [Action], Position, Position)]
@@ -286,6 +286,6 @@ updateActions conf (Rectangle _ _ wid _) ~[left,center,right] = do
                      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]
+  liftIO $ fmap concat $ mapM (\(a,xs) ->
+                          (\xs' -> partCoord (offset a xs') xs') <$> strLn xs) $
+                         zip [L,C,R] [left,center,right]