From c7681d79108f6e03f5adc33ebb96f14cf9b83f16 Mon Sep 17 00:00:00 2001 From: jao Date: Mon, 19 Sep 2022 02:26:50 +0100 Subject: wee refactoring (more types in X11.Types) --- src/Xmobar/X11/Bitmap.hs | 2 +- src/Xmobar/X11/CairoDraw.hs | 59 ++++++++++++++++++--------------------------- src/Xmobar/X11/Draw.hs | 24 +++++++++--------- src/Xmobar/X11/Loop.hs | 2 +- src/Xmobar/X11/Types.hs | 29 ++++++++++++++++------ 5 files changed, 59 insertions(+), 57 deletions(-) diff --git a/src/Xmobar/X11/Bitmap.hs b/src/Xmobar/X11/Bitmap.hs index 027462d..220741e 100644 --- a/src/Xmobar/X11/Bitmap.hs +++ b/src/Xmobar/X11/Bitmap.hs @@ -113,7 +113,7 @@ loadBitmap d w p = do 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 + withColors d [fc, bc] $ \[fc', bc'] -> do let w = width i h = height i y' = 1 + y - fromIntegral h `div` 2 diff --git a/src/Xmobar/X11/CairoDraw.hs b/src/Xmobar/X11/CairoDraw.hs index a4172bb..dd2ea2b 100644 --- a/src/Xmobar/X11/CairoDraw.hs +++ b/src/Xmobar/X11/CairoDraw.hs @@ -15,7 +15,7 @@ -- ------------------------------------------------------------------------------ -module Xmobar.X11.CairoDraw (drawSegments, DrawContext (..), BitmapDrawer) where +module Xmobar.X11.CairoDraw (drawSegments) where import qualified Data.Colour.SRGB as SRGB import qualified Data.Colour.Names as CNames @@ -34,19 +34,11 @@ 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 qualified Xmobar.X11.Types as T type Renderinfo = (P.Segment, Surface -> Double -> Double -> IO (), Double) -type BitmapDrawer = Double -> Double -> String -> IO () -type Actions = [X.ActionPos] - -data DrawContext = DC { dcBitmapDrawer :: BitmapDrawer - , dcBitmapLookup :: String -> Maybe B.Bitmap - , dcConfig :: C.Config - , dcWidth :: Double - , dcHeight :: Double - , dcSegments :: [[P.Segment]] - } +type BoundedBox = (Double, Double, [P.Box]) +type Acc = (Double, T.Actions, [BoundedBox]) readColourName :: String -> (SRGB.Colour Double, Double) readColourName str = @@ -83,14 +75,14 @@ segmentMarkup conf (P.Text txt, info, idx, _actions) = in Pango.markSpan attrs' $ Pango.escapeMarkup txt segmentMarkup _ _ = "" -withRenderinfo :: Pango.PangoContext -> DrawContext -> P.Segment -> IO Renderinfo +withRenderinfo :: Pango.PangoContext -> T.DrawContext -> P.Segment -> IO Renderinfo withRenderinfo ctx dctx seg@(P.Text _, inf, idx, a) = do - let conf = dcConfig dctx + 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' + (dcHeight dctx - h + u) / 2.0 + voff = voff' + (T.dcHeight dctx - h + u) / 2.0 wd = w - o slyt s off mx = do when (off + w > mx) $ do @@ -103,35 +95,32 @@ withRenderinfo _ _ seg@(P.Hspace w, _, _, _) = return (seg, \_ _ _ -> return (), fromIntegral w) withRenderinfo _ dctx seg@(P.Icon p, _, _, _) = do - let bm = dcBitmapLookup dctx p + let bm = T.dcBitmapLookup dctx p wd = maybe 0 (fromIntegral . B.width) bm - ioff = C.iconOffset (dcConfig dctx) - vpos = dcHeight dctx / 2 + fromIntegral ioff - render _ off mx = when (off + wd <= mx) $ dcBitmapDrawer dctx off vpos p + 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 :: DrawContext -> Surface -> Double -> Double -> P.Box -> IO () +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 (dcHeight dctx) x0 x1) + renderLines color (fromIntegral w) (Boxes.boxLines box (T.dcHeight dctx) x0 x1) drawSegmentBackground :: - DrawContext -> Surface -> P.TextRenderInfo -> Double -> Double -> IO () + 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) (dcHeight dctx - bot - top) + Cairo.rectangle x0 top (x1 - x0) (T.dcHeight dctx - bot - top) Cairo.fillPreserve - where conf = dcConfig dctx + where conf = T.dcConfig dctx (_, bg) = P.colorComponents conf (P.tColorsString info) top = fromIntegral $ P.tBgTopOffset info bot = fromIntegral $ P.tBgBottomOffset info -type BoundedBox = (Double, Double, [P.Box]) -type Acc = (Double, Actions, [BoundedBox]) - -drawSegment :: DrawContext -> Surface -> Double -> Acc -> Renderinfo -> IO Acc +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 @@ -156,10 +145,10 @@ drawBorder conf w h surf = C.NoBorder -> return () _ -> Cairo.renderWith surf (renderOuterBorder conf w h) -drawBBox :: DrawContext -> Surface -> BoundedBox -> IO () +drawBBox :: T.DrawContext -> Surface -> BoundedBox -> IO () drawBBox dctx surf (from, to, bs) = mapM_ (drawBox dctx surf from to) bs -drawBoxes :: DrawContext -> Surface -> [BoundedBox] -> IO () +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) @@ -177,12 +166,12 @@ drawCairoBackground dctx surf = do Cairo.renderWith surf $ setSourceColor (c, 1.0) >> Cairo.paint #endif -drawSegments :: DrawContext -> Surface -> IO Actions +drawSegments :: T.DrawContext -> Surface -> IO T.Actions drawSegments dctx surf = do - let [left, center, right] = take 3 $ dcSegments dctx - dh = dcHeight dctx - dw = dcWidth dctx - conf = dcConfig dctx + 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 diff --git a/src/Xmobar/X11/Draw.hs b/src/Xmobar/X11/Draw.hs index f11dd0e..48ddb91 100644 --- a/src/Xmobar/X11/Draw.hs +++ b/src/Xmobar/X11/Draw.hs @@ -27,7 +27,7 @@ import qualified Graphics.X11.Xlib as X11 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.Types as T import qualified Xmobar.X11.CairoDraw as CD import qualified Xmobar.X11.CairoSurface as CS @@ -35,18 +35,18 @@ import qualified Xmobar.X11.CairoSurface as CS import qualified Xmobar.X11.XRender as XRender #endif -drawXBitmap :: X.XConf -> X11.GC -> X11.Pixmap -> CD.BitmapDrawer +drawXBitmap :: T.XConf -> X11.GC -> X11.Pixmap -> T.BitmapDrawer drawXBitmap xconf gc p h v path = do - let disp = X.display xconf - conf = X.config xconf + let disp = T.display xconf + conf = T.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) +lookupXBitmap :: T.XConf -> String -> Maybe B.Bitmap +lookupXBitmap xconf path = M.lookup path (T.iconCache xconf) withPixmap :: X11.Display -> X11.Drawable -> X11.Rectangle -> FT.CInt -> (X11.GC -> X11.Pixmap -> IO a) -> IO a @@ -64,21 +64,21 @@ withPixmap disp win (X11.Rectangle _ _ w h) depth action = do X11.sync disp True return res -draw :: [[P.Segment]] -> X.X [X.ActionPos] +draw :: [[P.Segment]] -> T.X [T.ActionPos] draw segments = do xconf <- ask - let disp = X.display xconf - win = X.window xconf - rect@(X11.Rectangle _ _ w h) = X.rect xconf + let disp = T.display xconf + win = T.window xconf + rect@(X11.Rectangle _ _ w h) = T.rect xconf screen = X11.defaultScreenOfDisplay disp depth = X11.defaultDepthOfScreen screen vis = X11.defaultVisualOfScreen screen - conf = X.config xconf + conf = T.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 + dctx = T.DC bdraw blook conf (fromIntegral w) (fromIntegral h) segments render = CD.drawSegments dctx #ifdef XRENDER diff --git a/src/Xmobar/X11/Loop.hs b/src/Xmobar/X11/Loop.hs index 74c4c67..3975e21 100644 --- a/src/Xmobar/X11/Loop.hs +++ b/src/Xmobar/X11/Loop.hs @@ -87,7 +87,7 @@ eventLoop dpy w signalv = E.nextEvent' dpy e #endif ev <- X11x.getEvent e - let send s = STM.atomically (STM.putTMVar signalv s) + let send = STM.atomically . STM.putTMVar signalv case ev of X11x.ConfigureEvent {} -> send S.Reposition X11x.RRScreenChangeNotifyEvent {} -> send S.Reposition diff --git a/src/Xmobar/X11/Types.hs b/src/Xmobar/X11/Types.hs index ce5eec9..309b6bf 100644 --- a/src/Xmobar/X11/Types.hs +++ b/src/Xmobar/X11/Types.hs @@ -17,26 +17,39 @@ module Xmobar.X11.Types where -import Graphics.X11.Xlib -import Control.Monad.Reader +import qualified Graphics.X11.Xlib as X11 import qualified Data.List.NonEmpty as NE +import Control.Monad.Reader (ReaderT) + import Xmobar.Config.Types import Xmobar.Run.Actions (Action) -import Xmobar.X11.Bitmap -import Xmobar.X11.Text +import Xmobar.Run.Parsers (Segment) +import Xmobar.X11.Bitmap (Bitmap, BitmapCache) +import Xmobar.X11.Text (XFont) -- | The X type is a ReaderT type X = ReaderT XConf IO -- | The ReaderT inner component data XConf = - XConf { display :: Display - , rect :: Rectangle - , window :: Window + XConf { display :: X11.Display + , rect :: X11.Rectangle + , window :: X11.Window , fontList :: NE.NonEmpty XFont , iconCache :: BitmapCache , config :: Config } -type ActionPos = ([Action], Position, Position) +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]] + } -- cgit v1.2.3