new namespace: Xmobar.Draw

3 files changed, 312 insertions, 0 deletions

diff --git a/src/Xmobar/Draw/Boxes.hs b/src/Xmobar/Draw/Boxes.hs
new file mode 100644
index 0000000..1358805
--- /dev/null
+++ b/src/Xmobar/Draw/Boxes.hs
@@ -0,0 +1,68 @@
+------------------------------------------------------------------------------
+-- |
+-- Module: Xmobar.X11.Boxes
+-- Copyright: (c) 2022 Jose Antonio Ortega Ruiz
+-- License: BSD3-style (see LICENSE)
+--
+-- Maintainer: jao@gnu.org
+-- Stability: unstable
+-- Portability: unportable
+-- Start date: Fri Sep 16, 2022 04:01
+--
+-- Borders and boxes
+--
+------------------------------------------------------------------------------
+
+module Xmobar.Draw.Boxes (Line, boxLines, BoxRect, borderRect) where
+
+import qualified Xmobar.Config.Types as T
+import qualified Xmobar.Run.Parsers as P
+
+type Line = (Double, Double, Double, Double)
+type BoxRect = (Double, Double, Double, Double)
+
+-- | Computes the coordinates of a list of lines representing a Box.
+-- The Box is to be positioned between x0 and x1, with height ht, and drawn
+-- with line width lw.  The returned lists are coordinates of the beginning
+-- and end of each line.
+boxLines :: P.Box -> Double -> Double -> Double -> [Line]
+boxLines (P.Box bd offset lw _ margins) ht x0 x1 =
+  case bd of
+    P.BBTop    -> [rtop]
+    P.BBBottom -> [rbot]
+    P.BBVBoth  -> [rtop, rbot]
+    P.BBLeft   -> [rleft]
+    P.BBRight  -> [rright]
+    P.BBHBoth  -> [rleft, rright]
+    P.BBFull   -> [rtop, rbot, rleft, rright]
+  where
+    (P.BoxMargins top right bot left) = margins
+    (P.BoxOffset align m) = offset
+    ma = fromIntegral m
+    (p0, p1) = case align of
+                 T.L -> (0, -ma)
+                 T.C -> (ma, -ma)
+                 T.R -> (ma, 0)
+    lc = fromIntegral lw / 2
+    [mt, mr, mb, ml] = map fromIntegral [top, right, bot, left]
+    xmin = x0 - ml - lc
+    xmax = x1 + mr + lc
+    ymin = mt + lc
+    ymax = ht - mb - lc
+    rtop = (xmin + p0, ymin, xmax + p1, ymin)
+    rbot = (xmin + p0, ymax, xmax + p1, ymax)
+    rleft = (xmin, ymin + p0, xmin, ymax + p1)
+    rright = (xmax, ymin + p0, xmax, ymax + p1)
+
+-- | Computes the rectangle (x, y, width, height) for the given Border.
+borderRect :: T.Border -> Double -> Double -> BoxRect
+borderRect bdr w h =
+  case bdr of
+    T.TopB       -> (0, 0, w - 1, 0)
+    T.BottomB    -> (0, h - 1, w - 1, 0)
+    T.FullB      -> (0, 0, w - 1, h - 1)
+    T.TopBM m    -> (0, fi m, w - 1, 0)
+    T.BottomBM m -> (0, h - fi m, w - 1, 0)
+    T.FullBM m   -> (fi m, fi m, w - 2 * fi m, h - 2 * fi m)
+    T.NoBorder   -> (-1, -1, -1, -1)
+  where fi = fromIntegral
diff --git a/src/Xmobar/Draw/Cairo.hs b/src/Xmobar/Draw/Cairo.hs
new file mode 100644
index 0000000..8fa4c46
--- /dev/null
+++ b/src/Xmobar/Draw/Cairo.hs
@@ -0,0 +1,192 @@
+{-# LANGUAGE CPP #-}
+------------------------------------------------------------------------------
+-- |
+-- Module: Xmobar.X11.Cairo
+-- Copyright: (c) 2022 Jose Antonio Ortega Ruiz
+-- License: BSD3-style (see LICENSE)
+--
+-- Maintainer: jao@gnu.org
+-- Stability: unstable
+-- Portability: unportable
+-- Created: Fri Sep 09, 2022 02:03
+--
+-- Drawing the xmobar contents using Cairo and Pango
+--
+--
+------------------------------------------------------------------------------
+
+module Xmobar.Draw.Cairo (drawSegments) where
+
+import qualified Data.Colour.SRGB as SRGB
+import qualified Data.Colour.Names as CNames
+
+import Control.Monad (foldM, when)
+
+import qualified Graphics.Rendering.Cairo as Cairo
+import qualified Graphics.Rendering.Pango as Pango
+
+import Graphics.Rendering.Cairo.Types(Surface)
+
+import qualified Xmobar.Config.Types as C
+import qualified Xmobar.Config.Parse as ConfigParse
+import qualified Xmobar.Run.Parsers as P
+import qualified Xmobar.Text.Pango as TextPango
+
+import qualified Xmobar.Draw.Boxes as Boxes
+import qualified Xmobar.Draw.Types as T
+
+type Renderinfo = (P.Segment, Surface -> Double -> Double -> IO (), Double)
+type BoundedBox = (Double, Double, [P.Box])
+type Acc = (Double, T.Actions, [BoundedBox])
+
+readColourName :: String -> (SRGB.Colour Double, Double)
+readColourName str =
+  case CNames.readColourName str of
+    Just c -> (c, 1.0)
+    Nothing -> case SRGB.sRGB24reads str of
+                 [(c, "")] -> (c, 1.0)
+                 [(c,d)] -> (c, read ("0x" ++ d))
+                 _ ->  (CNames.white, 1.0)
+
+setSourceColor :: (SRGB.Colour Double, Double) -> Cairo.Render ()
+setSourceColor (colour, alph) =
+  if alph < 1 then Cairo.setSourceRGBA r g b alph else Cairo.setSourceRGB r g b
+  where rgb = SRGB.toSRGB colour
+        r = SRGB.channelRed rgb
+        g = SRGB.channelGreen rgb
+        b = SRGB.channelBlue rgb
+
+renderLines :: String -> Double -> [Boxes.Line] -> Cairo.Render ()
+renderLines color wd lns = do
+  setSourceColor (readColourName color)
+  Cairo.setLineWidth wd
+  mapM_ (\(x0, y0, x1, y1) ->
+           Cairo.moveTo x0 y0 >> Cairo.lineTo x1 y1 >> Cairo.stroke) lns
+
+segmentMarkup :: C.Config -> P.Segment -> String
+segmentMarkup conf (P.Text txt, info, idx, _actions) =
+  let fnt = TextPango.fixXft $ ConfigParse.indexedFont conf idx
+      (fg, bg) = P.colorComponents conf (P.tColorsString info)
+      attrs = [Pango.FontDescr fnt, Pango.FontForeground fg]
+      attrs' = if bg == C.bgColor conf
+               then attrs
+               else Pango.FontBackground bg:attrs
+  in Pango.markSpan attrs' $ Pango.escapeMarkup txt
+segmentMarkup _ _ = ""
+
+withRenderinfo :: Pango.PangoContext -> T.DrawContext -> P.Segment -> IO Renderinfo
+withRenderinfo ctx dctx seg@(P.Text _, inf, idx, a) = do
+  let conf = T.dcConfig dctx
+  lyt <- Pango.layoutEmpty ctx
+  mk <- Pango.layoutSetMarkup lyt (segmentMarkup conf seg) :: IO String
+  (_, Pango.PangoRectangle o u w h) <- Pango.layoutGetExtents lyt
+  let voff' = fromIntegral $ ConfigParse.indexedOffset conf idx
+      voff = voff' + (T.dcHeight dctx - h + u) / 2.0
+      wd = w - o
+      slyt s off mx = do
+        when (off + w > mx) $ do
+          Pango.layoutSetEllipsize lyt Pango.EllipsizeEnd
+          Pango.layoutSetWidth lyt (Just $ mx - off)
+        Cairo.renderWith s $ Cairo.moveTo off voff >> Pango.showLayout lyt
+  return ((P.Text mk, inf, idx, a), slyt, wd)
+
+withRenderinfo _ _ seg@(P.Hspace w, _, _, _) =
+  return (seg, \_ _ _ -> return (), fromIntegral w)
+
+withRenderinfo _ dctx seg@(P.Icon p, _, _, _) = do
+  let bm = T.dcBitmapLookup dctx p
+      wd = maybe 0 (fromIntegral . T.bWidth) bm
+      ioff = C.iconOffset (T.dcConfig dctx)
+      vpos = T.dcHeight dctx / 2  + fromIntegral ioff
+      render _ off mx = when (off + wd <= mx) $ T.dcBitmapDrawer dctx off vpos p
+  return (seg, render, wd)
+
+drawBox :: T.DrawContext -> Surface -> Double -> Double -> P.Box -> IO ()
+drawBox dctx surf x0 x1 box@(P.Box _ _ w color _) =
+  Cairo.renderWith surf $
+    renderLines color (fromIntegral w) (Boxes.boxLines box (T.dcHeight dctx) x0 x1)
+
+drawSegmentBackground ::
+  T.DrawContext -> Surface -> P.TextRenderInfo -> Double -> Double -> IO ()
+drawSegmentBackground dctx surf info x0 x1 =
+  when (bg /= C.bgColor conf && (top >= 0 || bot >= 0)) $
+    Cairo.renderWith surf $ do
+      setSourceColor (readColourName bg)
+      Cairo.rectangle x0 top (x1 - x0) (T.dcHeight dctx - bot - top)
+      Cairo.fillPreserve
+  where conf = T.dcConfig dctx
+        (_, bg) = P.colorComponents conf (P.tColorsString info)
+        top = fromIntegral $ P.tBgTopOffset info
+        bot = fromIntegral $ P.tBgBottomOffset info
+
+drawSegment :: T.DrawContext -> Surface -> Double -> Acc -> Renderinfo -> IO Acc
+drawSegment dctx surface maxoff (off, acts, boxs) (segment, render, lwidth) = do
+  let end = min maxoff (off + lwidth)
+      (_, info, _, a) = segment
+      acts' = case a of Just as -> (as, off, end):acts; _ -> acts
+      bs = P.tBoxes info
+      boxs' = if null bs then boxs else (off, end, bs):boxs
+  drawSegmentBackground dctx surface info off end
+  render surface off maxoff
+  return (off + lwidth, acts', boxs')
+
+renderOuterBorder :: C.Config -> Double -> Double -> Cairo.Render ()
+renderOuterBorder conf mw mh = do
+  let (x0, y0, w, h) = Boxes.borderRect (C.border conf) mw mh
+  setSourceColor (readColourName (C.borderColor conf))
+  Cairo.setLineWidth (fromIntegral (C.borderWidth conf))
+  Cairo.rectangle x0 y0 w h
+  Cairo.stroke
+
+drawBorder :: C.Config -> Double -> Double -> Surface -> IO ()
+drawBorder conf w h surf =
+  case C.border conf of
+    C.NoBorder -> return ()
+    _ -> Cairo.renderWith surf (renderOuterBorder conf w h)
+
+drawBBox :: T.DrawContext -> Surface -> BoundedBox -> IO ()
+drawBBox dctx surf (from, to, bs) = mapM_ (drawBox dctx surf from to) bs
+
+drawBoxes :: T.DrawContext -> Surface -> [BoundedBox] -> IO ()
+drawBoxes dctx surf ((from, to, b):(from', to', b'):bxs) =
+  if to < from' || b /= b'
+  then do drawBBox dctx surf (from, to, b)
+          drawBoxes dctx surf $ (from', to', b'):bxs
+  else drawBoxes dctx surf $ (from, to', b'):bxs
+
+drawBoxes dctx surf [bi] = drawBBox dctx surf bi
+
+drawBoxes _ _ [] = return ()
+
+#ifndef XRENDER
+drawCairoBackground :: DrawContext -> Surface -> IO ()
+drawCairoBackground dctx surf = do
+  let (c, _) = readColourName (C.bgColor (dcConfig dctx))
+  Cairo.renderWith surf $ setSourceColor (c, 1.0) >> Cairo.paint
+#endif
+
+drawSegments :: T.DrawContext -> Surface -> IO T.Actions
+drawSegments dctx surf = do
+  let [left, center, right] = take 3 $ T.dcSegments dctx ++ repeat []
+      dh = T.dcHeight dctx
+      dw = T.dcWidth dctx
+      conf = T.dcConfig dctx
+      sWidth = foldl (\a (_,_,w) -> a + w) 0
+  ctx <- Pango.cairoCreateContext Nothing
+  llyts <- mapM (withRenderinfo ctx dctx) left
+  rlyts <- mapM (withRenderinfo ctx dctx) right
+  clyts <- mapM (withRenderinfo ctx dctx) center
+#ifndef XRENDER
+  drawCairoBackground dctx surf
+#endif
+  (lend, as, bx) <- foldM (drawSegment dctx surf dw) (0, [], []) llyts
+  let rw = sWidth rlyts
+      rstart = max (lend + 1) (dw - rw - 1)
+      cmax = rstart - 1
+      cw = sWidth clyts
+      cstart = lend + 1 + max 0 (dw - rw - lend - cw) / 2.0
+  (_, as', bx') <- foldM (drawSegment dctx surf cmax) (cstart, as, bx) clyts
+  (_, as'', bx'') <- foldM (drawSegment dctx surf dw) (rstart, as', bx') rlyts
+  drawBoxes dctx surf (reverse bx'')
+  when (C.borderWidth conf > 0) (drawBorder conf dw dh surf)
+  return as''
diff --git a/src/Xmobar/Draw/Types.hs b/src/Xmobar/Draw/Types.hs
new file mode 100644
index 0000000..219a64b
--- /dev/null
+++ b/src/Xmobar/Draw/Types.hs
@@ -0,0 +1,52 @@
+------------------------------------------------------------------------------
+-- |
+-- Module: Xmobar.Draw.Types
+-- Copyright: (c) 2022 jao
+-- License: BSD3-style (see LICENSE)
+--
+-- Maintainer: mail@jao.io
+-- Stability: unstable
+-- Portability: portable
+-- Created: Tue Sep 20, 2022 04:49
+--
+--
+-- Type definitions for describing drawing operations
+--
+------------------------------------------------------------------------------
+
+
+module Xmobar.Draw.Types where
+
+import GHC.Word (Word32, Word64)
+
+import Data.Map (Map)
+
+import Xmobar.Config.Types (Config)
+import Xmobar.Run.Actions (Action)
+import Xmobar.Run.Parsers (Segment)
+
+type Position = Double
+type ActionPos = ([Action], Position, Position)
+type Actions = [ActionPos]
+
+type BitmapDrawer = Double -> Double -> String -> IO ()
+
+data BitmapType = Mono Word64 | Poly
+
+data Bitmap = Bitmap { bWidth  :: Word32
+                     , bHeight :: Word32
+                     , bPixmap :: Word64
+                     , bShapepixmap :: Maybe Word64
+                     , bBitmaptype :: BitmapType
+                     }
+
+type BitmapCache = Map FilePath Bitmap
+
+
+data DrawContext = DC { dcBitmapDrawer :: BitmapDrawer
+                      , dcBitmapLookup :: String -> Maybe Bitmap
+                      , dcConfig :: Config
+                      , dcWidth :: Double
+                      , dcHeight :: Double
+                      , dcSegments :: [[Segment]]
+                      }