new namespace: Xmobar.Draw

6 files changed, 26 insertions, 306 deletions

diff --git a/src/Xmobar/X11/Bitmap.hs b/src/Xmobar/X11/Bitmap.hs
index 220741e..d6a818b 100644
--- a/src/Xmobar/X11/Bitmap.hs
+++ b/src/Xmobar/X11/Bitmap.hs
@@ -20,10 +20,14 @@ module Xmobar.X11.Bitmap
 import Control.Monad
 import Control.Monad.Trans(MonadIO(..))
 import Data.Map hiding (map)
+
 import Graphics.X11.Xlib hiding (Segment)
+
 import System.Directory (doesFileExist)
 import System.FilePath ((</>))
 import System.Mem.Weak ( addFinalizer )
+
+import Xmobar.Draw.Types (BitmapType(..), Bitmap(..), BitmapCache)
 import Xmobar.X11.ColorCache
 
 #ifdef XPM
@@ -43,17 +47,6 @@ runExceptT = runErrorT
 
 #endif
 
-data BitmapType = Mono Pixel | Poly
-
-data Bitmap = Bitmap { width  :: Dimension
-                     , height :: Dimension
-                     , pixmap :: Pixmap
-                     , shapePixmap :: Maybe Pixmap
-                     , bitmapType :: BitmapType
-                     }
-
-type BitmapCache = Map FilePath Bitmap
-
 updateCache :: Display -> Window -> Map FilePath Bitmap -> FilePath -> [FilePath]
             -> IO BitmapCache
 updateCache dpy win cache iconRoot paths = do
@@ -114,15 +107,15 @@ drawBitmap :: Display -> Drawable -> GC -> String -> String
               -> Position -> Position -> Bitmap -> IO ()
 drawBitmap d p gc fc bc x y i =
   withColors d [fc, bc] $ \[fc', bc'] -> do
-    let w = width i
-        h = height i
+    let w = bWidth i
+        h = bHeight i
         y' = 1 + y - fromIntegral h `div` 2
     setForeground d gc fc'
     setBackground d gc bc'
-    case shapePixmap i of
+    case bShapepixmap i of
          Nothing -> return ()
          Just mask -> setClipOrigin d gc x y' >> setClipMask d gc mask
-    case bitmapType i of
-         Poly -> copyArea d (pixmap i) p gc 0 0 w h x y'
-         Mono pl -> copyPlane d (pixmap i) p gc 0 0 w h x y' pl
+    case bBitmaptype i of
+         Poly -> copyArea d (bPixmap i) p gc 0 0 w h x y'
+         Mono pl -> copyPlane d (bPixmap i) p gc 0 0 w h x y' pl
     setClipMask d gc 0
diff --git a/src/Xmobar/X11/Boxes.hs b/src/Xmobar/X11/Boxes.hs
deleted file mode 100644
index 4ea7144..0000000
--- a/src/Xmobar/X11/Boxes.hs
+++ /dev/null
@@ -1,68 +0,0 @@
-------------------------------------------------------------------------------
--- |
--- 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.X11.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/X11/CairoDraw.hs b/src/Xmobar/X11/CairoDraw.hs
deleted file mode 100644
index dd2ea2b..0000000
--- a/src/Xmobar/X11/CairoDraw.hs
+++ /dev/null
@@ -1,193 +0,0 @@
-{-# LANGUAGE CPP #-}
-------------------------------------------------------------------------------
--- |
--- Module: Xmobar.X11.CairoDraw
--- 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.X11.CairoDraw (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.X11.Boxes as Boxes
-import qualified Xmobar.X11.Bitmap as B
-import qualified Xmobar.X11.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 . B.width) 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, round off, round 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/X11/Draw.hs b/src/Xmobar/X11/Draw.hs
index 48ddb91..7e0dfd1 100644
--- a/src/Xmobar/X11/Draw.hs
+++ b/src/Xmobar/X11/Draw.hs
@@ -26,16 +26,18 @@ import qualified Graphics.X11.Xlib as X11
 
 import qualified Xmobar.Config.Types as C
 import qualified Xmobar.Run.Parsers as P
+import qualified Xmobar.Draw.Types as D
+import qualified Xmobar.Draw.Cairo as DC
+
 import qualified Xmobar.X11.Bitmap as B
 import qualified Xmobar.X11.Types as T
-import qualified Xmobar.X11.CairoDraw as CD
 import qualified Xmobar.X11.CairoSurface as CS
 
 #ifdef XRENDER
 import qualified Xmobar.X11.XRender as XRender
 #endif
 
-drawXBitmap :: T.XConf -> X11.GC -> X11.Pixmap -> T.BitmapDrawer
+drawXBitmap :: T.XConf -> X11.GC -> X11.Pixmap -> D.BitmapDrawer
 drawXBitmap xconf gc p h v path = do
   let disp = T.display xconf
       conf = T.config xconf
@@ -64,7 +66,7 @@ withPixmap disp win (X11.Rectangle _ _ w h) depth action = do
   X11.sync disp True
   return res
 
-draw :: [[P.Segment]] -> T.X [T.ActionPos]
+draw :: [[P.Segment]] -> T.X [D.ActionPos]
 draw segments = do
   xconf <- ask
   let disp = T.display xconf
@@ -78,8 +80,8 @@ draw segments = do
   liftIO $ withPixmap disp win rect depth $ \gc p -> do
     let bdraw = drawXBitmap xconf gc p
         blook = lookupXBitmap xconf
-        dctx = T.DC bdraw blook conf (fromIntegral w) (fromIntegral h) segments
-        render = CD.drawSegments dctx
+        dctx = D.DC bdraw blook conf (fromIntegral w) (fromIntegral h) segments
+        render = DC.drawSegments dctx
 
 #ifdef XRENDER
         color = C.bgColor conf
diff --git a/src/Xmobar/X11/Loop.hs b/src/Xmobar/X11/Loop.hs
index 3975e21..599e680 100644
--- a/src/Xmobar/X11/Loop.hs
+++ b/src/Xmobar/X11/Loop.hs
@@ -43,6 +43,8 @@ import qualified Xmobar.Run.Parsers as P
 import qualified Xmobar.System.Utils as U
 import qualified Xmobar.System.Signal as S
 
+import qualified Xmobar.Draw.Types as D
+
 import qualified Xmobar.X11.Types as T
 import qualified Xmobar.X11.Text as Text
 import qualified Xmobar.X11.Draw as Draw
@@ -100,11 +102,8 @@ eventLoop dpy w signalv =
 -- The list of actions provides the positions of clickable rectangles,
 -- and there is a mutable variable for received signals and the list
 -- of strings updated by running monitors.
-signalLoop :: T.XConf
-          -> [([A.Action], X11.Position, X11.Position)]
-          -> STM.TMVar S.SignalType
-          -> STM.TVar [String]
-          -> IO ()
+signalLoop ::
+  T.XConf -> D.Actions -> STM.TMVar S.SignalType -> STM.TVar [String] -> IO ()
 signalLoop xc@(T.XConf d r w fs is cfg) actions signalv strs = do
     typ <- STM.atomically $ STM.takeTMVar signalv
     case typ of
@@ -168,9 +167,10 @@ updateConfigPosition disp cfg =
               else (cfg {C.position = C.OnScreen (n+1) o}))
     o -> return (cfg {C.position = C.OnScreen 1 o})
 
-runActions :: [T.ActionPos] -> A.Button -> X11.Position -> IO ()
+runActions :: D.Actions -> A.Button -> X11.Position -> IO ()
 runActions actions button pos =
   mapM_ A.runAction $
    filter (\(A.Spawn b _) -> button `elem` b) $
    concatMap (\(a,_,_) -> a) $
-   filter (\(_, from, to) -> pos >= from && pos <= to) actions
+   filter (\(_, from, to) -> pos' >= from && pos' <= to) actions
+  where pos' = fromIntegral pos
diff --git a/src/Xmobar/X11/Types.hs b/src/Xmobar/X11/Types.hs
index 309b6bf..e880cc0 100644
--- a/src/Xmobar/X11/Types.hs
+++ b/src/Xmobar/X11/Types.hs
@@ -23,9 +23,8 @@ import qualified Data.List.NonEmpty as NE
 import Control.Monad.Reader (ReaderT)
 
 import Xmobar.Config.Types
-import Xmobar.Run.Actions (Action)
-import Xmobar.Run.Parsers (Segment)
-import Xmobar.X11.Bitmap (Bitmap, BitmapCache)
+
+import Xmobar.X11.Bitmap (BitmapCache)
 import Xmobar.X11.Text (XFont)
 
 -- | The X type is a ReaderT
@@ -40,16 +39,3 @@ data XConf =
           , iconCache :: BitmapCache
           , config    :: Config
           }
-
-type ActionPos = ([Action], X11.Position, X11.Position)
-type Actions = [ActionPos]
-
-type BitmapDrawer = Double -> Double -> String -> IO ()
-
-data DrawContext = DC { dcBitmapDrawer :: BitmapDrawer
-                      , dcBitmapLookup :: String -> Maybe Bitmap
-                      , dcConfig :: Config
-                      , dcWidth :: Double
-                      , dcHeight :: Double
-                      , dcSegments :: [[Segment]]
-                      }