diff options
Diffstat (limited to 'src/Xmobar')
| -rw-r--r-- | src/Xmobar/Config/Types.hs | 20 | ||||
| -rw-r--r-- | src/Xmobar/X11/Boxes.hs | 73 | ||||
| -rw-r--r-- | src/Xmobar/X11/CairoDraw.hs | 208 | ||||
| -rw-r--r-- | src/Xmobar/X11/Loop.hs | 211 |
4 files changed, 264 insertions, 248 deletions
diff --git a/src/Xmobar/Config/Types.hs b/src/Xmobar/Config/Types.hs index a448d5d..4959aa1 100644 --- a/src/Xmobar/Config/Types.hs +++ b/src/Xmobar/Config/Types.hs @@ -15,12 +15,13 @@ module Xmobar.Config.Types ( Config (..) , XPosition (..), Align (..), Border (..), TextOutputFormat (..) - , FontIndex, SignalChan (..) + , FontIndex + , SignalChan (..) ) where import qualified Control.Concurrent.STM as STM -import Xmobar.Run.Runnable (Runnable(..)) -import Xmobar.System.Signal (SignalType) +import qualified Xmobar.Run.Runnable as R +import qualified Xmobar.System.Signal as S -- $config -- Configuration data type @@ -35,7 +36,8 @@ data Config = , fgColor :: String -- ^ Default font color , position :: XPosition -- ^ Top Bottom or Static , textOutput :: Bool -- ^ Write data to stdout instead of X - , textOutputFormat :: TextOutputFormat -- ^ Which color format to use for stdout: Ansi or Pango + , textOutputFormat :: TextOutputFormat + -- ^ Which color format to use for stdout: Ansi or Pango , textOffset :: Int -- ^ Offset from top of window for text , textOffsets :: [Int] -- ^ List of offsets for additionalFonts , iconOffset :: Int -- ^ Offset from top of window for icons @@ -57,8 +59,8 @@ data Config = , persistent :: Bool -- ^ Whether automatic hiding should -- be enabled or disabled , iconRoot :: FilePath -- ^ Root folder for icons - , commands :: [Runnable] -- ^ For setting the command, - -- the command arguments + , commands :: [R.Runnable] -- ^ For setting the command, + -- the command arguments -- and refresh rate for the programs -- to run (optional) , sepChar :: String -- ^ The character to be used for indicating @@ -68,7 +70,7 @@ data Config = -- right text alignment , template :: String -- ^ The output template , verbose :: Bool -- ^ Emit additional debug messages - , signal :: SignalChan -- ^ The signal channel to send signals to xmobar + , signal :: SignalChan -- ^ Channel to send signals to xmobar } deriving (Read, Show) data XPosition = Top @@ -98,9 +100,9 @@ data Border = NoBorder data TextOutputFormat = Plain | Ansi | Pango | Swaybar deriving (Read, Show, Eq) -type FontIndex = Int +type FontIndex = Int -newtype SignalChan = SignalChan { unSignalChan :: Maybe (STM.TMVar SignalType) } +newtype SignalChan = SignalChan {unSignalChan :: Maybe (STM.TMVar S.SignalType)} instance Read SignalChan where readsPrec _ _ = fail "SignalChan is not readable from a String" diff --git a/src/Xmobar/X11/Boxes.hs b/src/Xmobar/X11/Boxes.hs index 87a081f..4ea7144 100644 --- a/src/Xmobar/X11/Boxes.hs +++ b/src/Xmobar/X11/Boxes.hs @@ -7,51 +7,62 @@ -- Maintainer: jao@gnu.org -- Stability: unstable -- Portability: unportable ---Start date: Fri Sep 16, 2022 04:01 +-- Start date: Fri Sep 16, 2022 04:01 -- -- Borders and boxes -- ------------------------------------------------------------------------------ -module Xmobar.X11.Boxes (boxLines, borderRect) where +module Xmobar.X11.Boxes (Line, boxLines, BoxRect, borderRect) where -import Xmobar.Run.Parsers -import Xmobar.Config.Types +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 :: Box -> Double -> Double -> Double -> [(Double, Double, Double, Double)] -boxLines (Box bd offset lw _ margins) ht x0 x1 = +boxLines :: P.Box -> Double -> Double -> Double -> [Line] +boxLines (P.Box bd offset lw _ margins) ht x0 x1 = case bd of - BBTop -> [rtop]; BBBottom -> [rbot]; BBVBoth -> [rtop, rbot] - BBLeft -> [rleft]; BBRight -> [rright]; BBHBoth -> [rleft, rright] - BBFull -> [rtop, rbot, rleft, rright] - where (BoxMargins top right bot left) = margins - (BoxOffset align m) = offset - ma = fromIntegral m - (p0, p1) = case align of L -> (0, -ma); C -> (ma, -ma); 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) + 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 :: Border -> Double -> Double -> (Double, Double, Double, Double) +borderRect :: T.Border -> Double -> Double -> BoxRect borderRect bdr w h = case bdr of - TopB -> (0, 0, w - 1, 0) - BottomB -> (0, h - 1, w - 1, 0) - FullB -> (0, 0, w - 1, h - 1) - TopBM m -> (0, fi m, w - 1, 0) - BottomBM m -> (0, h - fi m, w - 1, 0) - FullBM m -> (fi m, fi m, w - 2 * fi m, h - 2 * fi m) - NoBorder -> (-1, -1, -1, -1) + 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 index b7ecd34..0007f3e 100644 --- a/src/Xmobar/X11/CairoDraw.hs +++ b/src/Xmobar/X11/CairoDraw.hs @@ -17,76 +17,77 @@ module Xmobar.X11.CairoDraw (drawInPixmap) where -import Prelude hiding (lookup) - -import Data.Map (lookup) +import qualified Data.Map as M import qualified Data.Colour.SRGB as SRGB import qualified Data.Colour.Names as CNames -import Control.Monad.IO.Class -import Control.Monad.Reader - -import Graphics.X11.Xlib hiding (Segment, drawSegments) -import Graphics.Rendering.Cairo.Types -import qualified Graphics.Rendering.Cairo as C -import qualified Graphics.Rendering.Pango as P - -import Xmobar.Run.Parsers (Segment - , Widget(..) - , Box (..) - , TextRenderInfo (..) - , colorComponents) -import Xmobar.Config.Types -import Xmobar.Config.Parse (indexedFont, indexedOffset) -import Xmobar.Text.Pango (fixXft) -import Xmobar.X11.Types -import Xmobar.X11.Boxes (boxLines, borderRect) +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 + +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 X +import Xmobar.X11.CairoSurface (withXlibSurface) + #ifdef XRENDER -import Xmobar.X11.XRender (drawBackground) +import qualified Xmobar.X11.XRender as XRender #endif -import Xmobar.X11.CairoSurface -type Renderinfo = (Segment, Surface -> Double -> Double -> IO (), Double) +type Renderinfo = (P.Segment, Surface -> Double -> Double -> IO (), Double) type BitmapDrawer = Double -> Double -> String -> IO () -type Actions = [ActionPos] +type Actions = [X.ActionPos] data DrawContext = DC { dcBitmapDrawer :: BitmapDrawer , dcBitmapLookup :: String -> Maybe B.Bitmap - , dcConfig :: Config + , dcConfig :: C.Config , dcWidth :: Double , dcHeight :: Double - , dcSegments :: [[Segment]] + , dcSegments :: [[P.Segment]] } -drawInPixmap :: GC -> Pixmap -> [[Segment]] -> X Actions +drawInPixmap :: X11.GC -> X11.Pixmap -> [[P.Segment]] -> X.X Actions drawInPixmap gc p s = do xconf <- ask - let disp = display xconf - vis = defaultVisualOfScreen (defaultScreenOfDisplay disp) - (Rectangle _ _ w h) = rect xconf + 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 = config xconf + conf = X.config xconf dc = DC (drawXBitmap xconf gc p) (lookupXBitmap xconf) conf dw dh s render = drawSegments dc #ifdef XRENDER - liftIO $ drawBackground disp p (bgColor conf) (alpha conf) (Rectangle 0 0 w h) + 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 :: XConf -> GC -> Pixmap -> BitmapDrawer +drawXBitmap :: X.XConf -> X11.GC -> X11.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 + 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 :: XConf -> String -> Maybe B.Bitmap -lookupXBitmap xconf path = lookup path (iconCache xconf) +lookupXBitmap :: X.XConf -> String -> Maybe B.Bitmap +lookupXBitmap xconf path = M.lookup path (X.iconCache xconf) readColourName :: String -> (SRGB.Colour Double, Double) readColourName str = @@ -97,113 +98,116 @@ readColourName str = [(c,d)] -> (c, read ("0x" ++ d)) _ -> (CNames.white, 1.0) -setSourceColor :: (SRGB.Colour Double, Double) -> C.Render () +setSourceColor :: (SRGB.Colour Double, Double) -> Cairo.Render () setSourceColor (colour, alph) = - if alph < 1 then C.setSourceRGBA r g b alph else C.setSourceRGB r g b + 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 -> [(Double, Double, Double, Double)] -> C.Render () +renderLines :: String -> Double -> [Boxes.Line] -> Cairo.Render () renderLines color wd lns = do setSourceColor (readColourName color) - C.setLineWidth wd - mapM_ (\(x0, y0, x1, y1) -> C.moveTo x0 y0 >> C.lineTo x1 y1 >> C.stroke) lns - -segmentMarkup :: Config -> Segment -> String -segmentMarkup conf (Text txt, info, idx, _actions) = - let fnt = fixXft $ indexedFont conf idx - (fg, bg) = colorComponents conf (tColorsString info) - attrs = [P.FontDescr fnt, P.FontForeground fg] - attrs' = if bg == bgColor conf then attrs else P.FontBackground bg:attrs - in P.markSpan attrs' $ P.escapeMarkup txt + 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 :: P.PangoContext -> DrawContext -> Segment -> IO Renderinfo -withRenderinfo ctx dctx seg@(Text _, inf, idx, a) = do +withRenderinfo :: Pango.PangoContext -> DrawContext -> P.Segment -> IO Renderinfo +withRenderinfo ctx dctx seg@(P.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 + 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 wd = w - o slyt s off mx = do when (off + w > mx) $ do - P.layoutSetEllipsize lyt P.EllipsizeEnd - P.layoutSetWidth lyt (Just $ mx - off) - C.renderWith s $ C.moveTo off voff >> P.showLayout lyt - return ((Text mk, inf, idx, a), slyt, wd) + 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@(Hspace w, _, _, _) = +withRenderinfo _ _ seg@(P.Hspace w, _, _, _) = return (seg, \_ _ _ -> return (), fromIntegral w) -withRenderinfo _ dctx seg@(Icon p, _, _, _) = do +withRenderinfo _ dctx seg@(P.Icon p, _, _, _) = do let bm = dcBitmapLookup dctx p wd = maybe 0 (fromIntegral . B.width) bm - ioff = iconOffset (dcConfig dctx) + 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) -drawBox :: DrawContext -> Surface -> Double -> Double -> Box -> IO () -drawBox dctx surf x0 x1 box@(Box _ _ w color _) = - C.renderWith surf $ - renderLines color (fromIntegral w) (boxLines box (dcHeight dctx) x0 x1) +drawBox :: 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) drawSegmentBackground :: - DrawContext -> Surface -> TextRenderInfo -> Double -> Double -> IO () + DrawContext -> Surface -> P.TextRenderInfo -> Double -> Double -> IO () drawSegmentBackground dctx surf info x0 x1 = - when (bg /= bgColor conf && (top >= 0 || bot >= 0)) $ - C.renderWith surf $ do + when (bg /= C.bgColor conf && (top >= 0 || bot >= 0)) $ + Cairo.renderWith surf $ do setSourceColor (readColourName bg) - C.rectangle x0 top (x1 - x0) (dcHeight dctx - bot - top) - C.fillPreserve + Cairo.rectangle x0 top (x1 - x0) (dcHeight dctx - bot - top) + Cairo.fillPreserve where conf = dcConfig dctx - (_, bg) = colorComponents conf (tColorsString info) - top = fromIntegral $ tBgTopOffset info - bot = fromIntegral $ tBgBottomOffset info + (_, bg) = P.colorComponents conf (P.tColorsString info) + top = fromIntegral $ P.tBgTopOffset info + bot = fromIntegral $ P.tBgBottomOffset info -type BoundedBoxes = [(Double, Double, [Box])] -type SegAcc = (Double, Actions, BoundedBoxes) +type BoundedBox = (Double, Double, [P.Box]) +type Acc = (Double, Actions, [BoundedBox]) -drawSegment :: DrawContext -> Surface -> Double -> SegAcc -> Renderinfo -> IO SegAcc +drawSegment :: 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 = tBoxes info + 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 :: Config -> Double -> Double -> C.Render () +renderOuterBorder :: C.Config -> Double -> Double -> Cairo.Render () renderOuterBorder conf mw mh = do - let (x0, y0, w, h) = borderRect (border conf) mw mh - setSourceColor (readColourName (borderColor conf)) - C.setLineWidth (fromIntegral (borderWidth conf)) - C.rectangle x0 y0 w h - C.stroke + 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 :: Config -> Double -> Double -> Surface -> IO () +drawBorder :: C.Config -> Double -> Double -> Surface -> IO () drawBorder conf w h surf = - case border conf of - NoBorder -> return () - _ -> C.renderWith surf (renderOuterBorder conf w h) + case C.border conf of + C.NoBorder -> return () + _ -> Cairo.renderWith surf (renderOuterBorder conf w h) -drawBoxes' :: DrawContext -> Surface -> (Double, Double, [Box]) -> IO () -drawBoxes' dctx surf (from, to, bs) = mapM_ (drawBox dctx surf from to) bs +drawBBox :: DrawContext -> Surface -> BoundedBox -> IO () +drawBBox dctx surf (from, to, bs) = mapM_ (drawBox dctx surf from to) bs -drawBoxes :: DrawContext -> Surface -> BoundedBoxes -> IO () +drawBoxes :: DrawContext -> Surface -> [BoundedBox] -> IO () drawBoxes dctx surf ((from, to, b):(from', to', b'):bxs) = if to < from' || b /= b' - then do drawBoxes' dctx surf (from, to, 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] = drawBoxes' dctx surf bi +drawBoxes dctx surf [bi] = drawBBox dctx surf bi drawBoxes _ _ [] = return () @@ -211,7 +215,7 @@ drawBoxes _ _ [] = return () drawCairoBackground :: DrawContext -> Surface -> IO () drawCairoBackground dctx surf = do let (c, _) = readColourName (bgColor (dcConfig dctx)) - C.renderWith surf $ setSourceColor (c, 1.0) >> C.paint + Cairo.renderWith surf $ setSourceColor (c, 1.0) >> Cairo.paint #endif drawSegments :: DrawContext -> Surface -> IO Actions @@ -221,7 +225,7 @@ drawSegments dctx surf = do dw = dcWidth dctx conf = dcConfig dctx sWidth = foldl (\a (_,_,w) -> a + w) 0 - ctx <- P.cairoCreateContext Nothing + ctx <- Pango.cairoCreateContext Nothing llyts <- mapM (withRenderinfo ctx dctx) left rlyts <- mapM (withRenderinfo ctx dctx) right clyts <- mapM (withRenderinfo ctx dctx) center @@ -237,5 +241,5 @@ drawSegments dctx surf = do (_, 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 (borderWidth conf > 0) (drawBorder conf dw dh surf) + when (C.borderWidth conf > 0) (drawBorder conf dw dh surf) return as'' diff --git a/src/Xmobar/X11/Loop.hs b/src/Xmobar/X11/Loop.hs index aeaf38a..3c1a25c 100644 --- a/src/Xmobar/X11/Loop.hs +++ b/src/Xmobar/X11/Loop.hs @@ -19,159 +19,158 @@ module Xmobar.X11.Loop (x11Loop) where import Prelude hiding (lookup) -import Graphics.X11.Xlib hiding (textExtents, textWidth, Segment, Button) -import Graphics.X11.Xlib.Extras -import Graphics.X11.Xinerama -import Graphics.X11.Xrandr -import Control.Monad.Reader -import Control.Concurrent -import Control.Concurrent.STM +import Control.Concurrent as Concurrent +import Control.Concurrent.STM as STM +import Control.Monad.Reader as MR -import Data.Bits +import Data.Bits (Bits((.|.))) import qualified Data.Map as Map -import Data.List.NonEmpty (NonEmpty(..)) +import Data.List.NonEmpty (NonEmpty((:|))) import qualified Data.List.NonEmpty as NE -import Xmobar.System.Signal -import Xmobar.Config.Types ( persistent - , alpha - , font - , additionalFonts - , position - , iconRoot - , Config - , XPosition(..)) - -import Xmobar.Run.Actions -import Xmobar.Run.Parsers -import Xmobar.X11.Window -import Xmobar.X11.Text -import Xmobar.X11.Draw -import Xmobar.X11.Bitmap as Bitmap -import Xmobar.X11.Types -import Xmobar.System.Utils (forkThread) - -import Xmobar.Run.Loop (loop) +import qualified Graphics.X11.Xlib as X11 +import qualified Graphics.X11.Xlib.Extras as X11x +import qualified Graphics.X11.Xinerama as Xinerama +import qualified Graphics.X11.Xrandr as Xrandr + +import qualified Xmobar.Config.Types as C + +import qualified Xmobar.Run.Actions as A +import qualified Xmobar.Run.Loop as L +import qualified Xmobar.Run.Parsers as P + +import qualified Xmobar.System.Utils as U +import qualified Xmobar.System.Signal as S + +import qualified Xmobar.X11.Types as T +import qualified Xmobar.X11.Text as Text +import qualified Xmobar.X11.Draw as Draw +import qualified Xmobar.X11.Bitmap as Bitmap +import qualified Xmobar.X11.Window as W #ifndef THREADED_RUNTIME -import Xmobar.X11.Events(nextEvent') +import qualified Xmobar.X11.Events as E #endif -runX :: XConf -> X a -> IO a -runX xc f = runReaderT f xc +runX :: T.XConf -> T.X a -> IO a +runX xc f = MR.runReaderT f xc --- | Starts the main event loop and threads -x11Loop :: Config -> IO () +-- | Starts the main event loop thread +x11Loop :: C.Config -> IO () x11Loop conf = do - initThreads - d <- openDisplay "" - fs <- initFont d (font conf) - fl <- mapM (initFont d) (additionalFonts conf) - (r,w) <- createWin d fs conf - loop conf (startLoop (XConf d r w (fs :| fl) Map.empty conf)) - -startLoop :: XConf -> TMVar SignalType -> TVar [String] -> IO () -startLoop xcfg@(XConf _ _ w _ _ _) sig tv = do - forkThread "X event handler" (x11EventLoop w sig) - signalLoop xcfg [] sig tv + X11.initThreads + d <- X11.openDisplay "" + fs <- Text.initFont d (C.font conf) + fl <- mapM (Text.initFont d) (C.additionalFonts conf) + (r,w) <- W.createWin d fs conf + L.loop conf (startLoop (T.XConf d r w (fs :| fl) Map.empty conf)) + +startLoop :: T.XConf -> STM.TMVar S.SignalType -> STM.TVar [String] -> IO () +startLoop xcfg sig tv = do + U.forkThread "X event handler" (eventLoop (T.display xcfg) (T.window xcfg) sig) + signalLoop xcfg [] sig tv -- | Translates X11 events received by w to signals handled by signalLoop -x11EventLoop :: Window -> TMVar SignalType -> IO () -x11EventLoop w signal = - allocaXEvent $ \e -> do - dpy <- openDisplay "" - xrrSelectInput dpy (defaultRootWindow dpy) rrScreenChangeNotifyMask - selectInput dpy w (exposureMask .|. structureNotifyMask .|. buttonPressMask) - - forever $ do +eventLoop :: X11.Display -> X11.Window -> STM.TMVar S.SignalType -> IO () +eventLoop dpy w signalv = + X11.allocaXEvent $ \e -> do + let root = X11.defaultRootWindow dpy + m = X11.exposureMask .|. X11.structureNotifyMask .|. X11.buttonPressMask + Xrandr.xrrSelectInput dpy root X11.rrScreenChangeNotifyMask + X11.selectInput dpy w m + + MR.forever $ do #ifdef THREADED_RUNTIME - nextEvent dpy e + X11.nextEvent dpy e #else - nextEvent' dpy e + E.nextEvent' dpy e #endif - ev <- getEvent e + ev <- X11x.getEvent e + let send s = STM.atomically (STM.putTMVar signalv s) case ev of - ConfigureEvent {} -> atomically $ putTMVar signal Reposition - ExposeEvent {} -> atomically $ putTMVar signal Wakeup - RRScreenChangeNotifyEvent {} -> atomically $ putTMVar signal Reposition - ButtonEvent {} -> atomically $ - putTMVar signal (Action (ev_button ev) (fi $ ev_x ev)) + X11x.ConfigureEvent {} -> send S.Reposition + X11x.RRScreenChangeNotifyEvent {} -> send S.Reposition + X11x.ExposeEvent {} -> send S.Wakeup + X11x.ButtonEvent {} -> send (S.Action b p) + where (b, p) = (X11x.ev_button ev, fromIntegral $ X11x.ev_x ev) _ -> return () -- | Continuously wait for a signal from a thread or an interrupt handler. -- 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 :: XConf - -> [([Action], Position, Position)] - -> TMVar SignalType - -> TVar [String] +signalLoop :: T.XConf + -> [([A.Action], X11.Position, X11.Position)] + -> STM.TMVar S.SignalType + -> STM.TVar [String] -> IO () -signalLoop xc@(XConf d r w fs is cfg) actions signal strs = do - typ <- atomically $ takeTMVar signal +signalLoop xc@(T.XConf d r w fs is cfg) actions signalv strs = do + typ <- STM.atomically $ STM.takeTMVar signalv case typ of - Wakeup -> wakeup - Action button x -> runActions actions button x >> loopOn - Reposition -> reposWindow cfg - ChangeScreen -> updateConfigPosition d cfg >>= reposWindow - Hide t -> hiderev t Hide hideWindow - Reveal t -> hiderev t Reveal (showWindow r cfg) - Toggle t -> toggle t - TogglePersistent -> updateCfg $ cfg {persistent = not $ persistent cfg} - SetAlpha a -> updateCfg $ cfg {alpha = a} + S.Wakeup -> wakeup + S.Action button x -> runActions actions button x >> loopOn + S.Reposition -> reposWindow cfg + S.ChangeScreen -> updateConfigPosition d cfg >>= reposWindow + S.Hide t -> hiderev t S.Hide W.hideWindow + S.Reveal t -> hiderev t S.Reveal (W.showWindow r cfg) + S.Toggle t -> toggle t + S.TogglePersistent -> updateCfg $ cfg {C.persistent = not $ C.persistent cfg} + S.SetAlpha a -> updateCfg $ cfg {C.alpha = a} where - loopOn' xc' = signalLoop xc' actions signal strs + loopOn' xc' = signalLoop xc' actions signalv strs loopOn = loopOn' xc - updateCfg cfg' = loopOn' (xc {config = cfg'}) + updateCfg cfg' = loopOn' (xc {T.config = cfg'}) wakeup = do segs <- parseSegments cfg strs xc' <- updateIconCache xc segs - actions' <- runX xc' $ drawInWin segs - signalLoop xc' actions' signal strs + actions' <- runX xc' $ Draw.drawInWin segs + signalLoop xc' actions' signalv strs hiderev t sign op - | t == 0 = unless (persistent cfg) (op d w) >> loopOn + | t == 0 = MR.unless (C.persistent cfg) (op d w) >> loopOn | otherwise = do - void $ forkIO - $ threadDelay (t*100*1000) >> - atomically (putTMVar signal $ sign 0) + MR.void $ Concurrent.forkIO + $ Concurrent.threadDelay (t*100*1000) >> + STM.atomically (STM.putTMVar signalv $ sign 0) loopOn toggle t = do - ismapped <- isMapped d w - atomically (putTMVar signal $ if ismapped then Hide t else Reveal t) - loopOn + ismapped <- W.isMapped d w + let s = if ismapped then S.Hide t else S.Reveal t + STM.atomically (STM.putTMVar signalv s) + loopOn reposWindow rcfg = do - r' <- repositionWin d w (NE.head fs) rcfg - signalLoop (XConf d r' w fs is rcfg) actions signal strs + r' <- W.repositionWin d w (NE.head fs) rcfg + signalLoop (T.XConf d r' w fs is rcfg) actions signalv strs -parseSegments :: Config -> TVar [String] -> IO [[Segment]] +parseSegments :: C.Config -> STM.TVar [String] -> IO [[P.Segment]] parseSegments conf v = do - s <- readTVarIO v + s <- STM.readTVarIO v let l:c:r:_ = s ++ repeat "" - liftIO $ mapM (parseString conf) [l, c, r] + MR.liftIO $ mapM (P.parseString conf) [l, c, r] -updateIconCache :: XConf -> [[Segment]] -> IO XConf -updateIconCache xc@(XConf d _ w _ c cfg) segs = do - c' <- updateCache d w c (iconRoot cfg) [p | (Icon p, _, _, _) <- concat segs] - return $ xc {iconCache = c'} +updateIconCache :: T.XConf -> [[P.Segment]] -> IO T.XConf +updateIconCache xc@(T.XConf d _ w _ c cfg) segs = do + let paths = [p | (P.Icon p, _, _, _) <- concat segs] + c' <- Bitmap.updateCache d w c (C.iconRoot cfg) paths + return $ xc {T.iconCache = c'} -updateConfigPosition :: Display -> Config -> IO Config +updateConfigPosition :: X11.Display -> C.Config -> IO C.Config updateConfigPosition disp cfg = - case position cfg of - OnScreen n o -> do - srs <- getScreenInfo disp + case C.position cfg of + C.OnScreen n o -> do + srs <- Xinerama.getScreenInfo disp return (if n == length srs - then (cfg {position = OnScreen 1 o}) - else (cfg {position = OnScreen (n+1) o})) - o -> return (cfg {position = OnScreen 1 o}) + then (cfg {C.position = C.OnScreen 1 o}) + else (cfg {C.position = C.OnScreen (n+1) o})) + o -> return (cfg {C.position = C.OnScreen 1 o}) -runActions :: [ActionPos] -> Button -> Position -> IO () +runActions :: [T.ActionPos] -> A.Button -> X11.Position -> IO () runActions actions button pos = - mapM_ runAction $ - filter (\(Spawn b _) -> button `elem` b) $ + mapM_ A.runAction $ + filter (\(A.Spawn b _) -> button `elem` b) $ concatMap (\(a,_,_) -> a) $ filter (\(_, from, to) -> pos >= from && pos <= to) actions |