diff options
Diffstat (limited to 'src')
32 files changed, 613 insertions, 463 deletions
diff --git a/src/Xmobar/App/Compile.hs b/src/Xmobar/App/Compile.hs index 80dbac7..5d1f48d 100644 --- a/src/Xmobar/App/Compile.hs +++ b/src/Xmobar/App/Compile.hs @@ -20,20 +20,17 @@ module Xmobar.App.Compile(recompile, trace, xmessage) where import Control.Monad.IO.Class -import Control.Monad.Fix (fix) -import Control.Exception.Extensible (try, bracket, SomeException(..)) +import Control.Exception.Extensible (bracket, SomeException(..)) import qualified Control.Exception.Extensible as E import Control.Monad (filterM, when) import Data.List ((\\)) -import Data.Maybe (isJust) import System.FilePath((</>), takeExtension) import System.IO import System.Directory import System.Process import System.Exit -import System.Posix.Process(executeFile, forkProcess, getAnyProcessStatus) +import System.Posix.Process(executeFile, forkProcess) import System.Posix.Types(ProcessID) -import System.Posix.Signals isExecutable :: FilePath -> IO Bool isExecutable f = @@ -144,14 +141,12 @@ recompile confDir dataDir execName force verb = liftIO $ do else shouldRecompile verb src bin lib if sc then do - uninstallSignalHandlers status <- bracket (openFile err WriteMode) hClose $ \errHandle -> waitForProcess =<< if useScript then runScript script bin confDir errHandle else runGHC bin confDir errHandle - installSignalHandlers if status == ExitSuccess then trace verb "Xmobar recompilation process exited with success!" else do @@ -168,24 +163,9 @@ recompile confDir dataDir execName force verb = liftIO $ do #ifdef RTSOPTS ++ ["-rtsopts", "-with-rtsopts", "-V0"] #endif +#ifdef SHARED_LIBRARIES + ++ ["-dynamic"] +#endif ++ ["-o", bin] runGHC bin = runProc "ghc" (opts bin) runScript script bin = runProc script [bin] - --- | Ignore SIGPIPE to avoid termination when a pipe is full, and SIGCHLD to --- avoid zombie processes, and clean up any extant zombie processes. -installSignalHandlers :: MonadIO m => m () -installSignalHandlers = liftIO $ do - installHandler openEndedPipe Ignore Nothing - installHandler sigCHLD Ignore Nothing - (try :: IO a -> IO (Either SomeException a)) - $ fix $ \more -> do - x <- getAnyProcessStatus False False - when (isJust x) more - return () - -uninstallSignalHandlers :: MonadIO m => m () -uninstallSignalHandlers = liftIO $ do - installHandler openEndedPipe Default Nothing - installHandler sigCHLD Default Nothing - return () diff --git a/src/Xmobar/App/Config.hs b/src/Xmobar/App/Config.hs index a284973..5c2f362 100644 --- a/src/Xmobar/App/Config.hs +++ b/src/Xmobar/App/Config.hs @@ -67,6 +67,7 @@ defaultConfig = , signal = SignalChan Nothing , textOutput = False , textOutputFormat = Plain + , dpi = 96.0 } -- | Return the path to the xmobar data directory. This directory is diff --git a/src/Xmobar/App/Opts.hs b/src/Xmobar/App/Opts.hs index 3a6b4e7..36da745 100644 --- a/src/Xmobar/App/Opts.hs +++ b/src/Xmobar/App/Opts.hs @@ -1,7 +1,7 @@ ------------------------------------------------------------------------------ -- | -- Module: Xmobar.App.Opts --- Copyright: (c) 2018, 2019, 2020, 2022 Jose Antonio Ortega Ruiz +-- Copyright: (c) 2018, 2019, 2020, 2022, 2023, 2024 Jose Antonio Ortega Ruiz -- License: BSD3-style (see LICENSE) -- -- Maintainer: jao@gnu.org @@ -52,6 +52,7 @@ data Opts = Help | Position String | WmClass String | WmName String + | Dpi String deriving (Show, Eq) options :: [OptDescr Opts] @@ -95,6 +96,8 @@ options = "On which X screen number to start" , Option "p" ["position"] (ReqArg Position "position") "Specify position of xmobar. Same syntax as in config file" + , Option "D" ["dpi"] (ReqArg Dpi "dpi") + "The DPI scaling factor. Default 96.0" ] getOpts :: [String] -> IO ([Opts], [String]) @@ -113,7 +116,7 @@ usage = usageInfo header options ++ footer info :: String info = "xmobar " ++ showVersion version - ++ "\n (C) 2010 - 2022 Jose A Ortega Ruiz" + ++ "\n (C) 2010 - 2024 Jose A Ortega Ruiz" ++ "\n (C) 2007 - 2010 Andrea Rossato\n " ++ mail ++ "\n" ++ license ++ "\n" @@ -161,6 +164,7 @@ doOpts conf (o:oo) = Right x -> doOpts' (conf {commands = commands conf ++ x}) Left e -> putStr (e ++ usage) >> exitWith (ExitFailure 1) Position s -> readPosition s + Dpi d -> doOpts' (conf {dpi = read d}) where readCom c str = case readStr str of [x] -> Right x diff --git a/src/Xmobar/Config/Parse.hs b/src/Xmobar/Config/Parse.hs index 16af3db..0b41267 100644 --- a/src/Xmobar/Config/Parse.hs +++ b/src/Xmobar/Config/Parse.hs @@ -19,7 +19,8 @@ module Xmobar.Config.Parse(readConfig , parseConfig , indexedFont - , indexedOffset) where + , indexedOffset + , colorComponents) where import Text.ParserCombinators.Parsec import Text.ParserCombinators.Parsec.Number (int) @@ -31,6 +32,14 @@ import Xmobar.Config.Types import qualified System.IO as S (readFile) +-- | Splits a colors string into its two components +colorComponents :: Config -> String -> (String, String) +colorComponents conf c = + case break (==',') c of + (f,',':b) -> (f, b) + (f, _) -> (f, bgColor conf) + + stripComments :: String -> String stripComments = unlines . map (drop 5 . strip False . (replicate 5 ' '++)) . lines @@ -63,7 +72,7 @@ parseConfig defaultConfig = <|?> pAllDesktops <|?> pOverrideRedirect <|?> pPickBroadest <|?> pLowerOnStart <|?> pPersistent <|?> pIconRoot <|?> pCommands <|?> pSepChar <|?> pAlignSep <|?> pTemplate - <|?> pVerbose <|?> pSignal + <|?> pVerbose <|?> pSignal <|?> pDpi fields = [ "font", "additionalFonts", "bgColor", "fgColor" , "wmClass", "wmName", "sepChar" @@ -72,7 +81,7 @@ parseConfig defaultConfig = , "allDesktops", "overrideRedirect", "pickBroadest" , "hideOnStart", "lowerOnStart", "persistent", "iconRoot" , "alpha", "commands", "verbose", "signal", "textOutput" - , "textOutputFormat" + , "textOutputFormat", "dpi" ] pTextOutput = readField textOutput "textOutput" @@ -103,6 +112,7 @@ parseConfig defaultConfig = pIconRoot = readField iconRoot "iconRoot" pAlpha = readField alpha "alpha" pVerbose = readField verbose "verbose" + pDpi = readField dpi "dpi" pSignal = field signal "signal" $ fail "signal is meant for use with Xmobar as a library.\n It is not meant for use in the configuration file." diff --git a/src/Xmobar/Config/Template.hs b/src/Xmobar/Config/Template.hs new file mode 100644 index 0000000..ad30c3d --- /dev/null +++ b/src/Xmobar/Config/Template.hs @@ -0,0 +1,188 @@ +------------------------------------------------------------------------------ +-- | +-- Module: Xmobar.Config.Template +-- Copyright: (c) 2022 jao +-- License: BSD3-style (see LICENSE) +-- +-- Maintainer: mail@jao.io +-- Stability: unstable +-- Portability: portable +-- Created: Fri Sep 30, 2022 06:33 +-- +-- +-- Parsing template strings +-- +------------------------------------------------------------------------------ + + +module Xmobar.Config.Template (parseString) where + +import Data.Maybe (fromMaybe) +import qualified Control.Monad as CM + +import Text.Parsec ((<|>)) +import Text.Read (readMaybe) + +import qualified Text.Parsec as P +import qualified Text.Parsec.Combinator as C + +import Text.ParserCombinators.Parsec (Parser) + +import qualified Xmobar.Config.Types as T + +type Context = (T.TextRenderInfo, T.FontIndex, Maybe [T.Action]) + +retSegment :: Context -> T.Widget -> Parser [T.Segment] +retSegment (i, idx, as) widget = return [(widget, i, idx, as)] + +-- | Run the template string parser for the given config, producing a list of +-- drawable segment specifications. +parseString :: T.Config -> String -> [T.Segment] +parseString c s = + case P.parse (stringParser ci) "" s of + Left _ -> [(T.Text $ "Could not parse string: " ++ s, ti, 0, Nothing)] + Right x -> concat x + where ci = (ti , 0, Nothing) + ti = T.TextRenderInfo (T.fgColor c) 0 0 [] + +-- Top level parser reading the full template string +stringParser :: Context -> Parser [[T.Segment]] +stringParser c = C.manyTill (allParsers c) C.eof + +allParsers :: Context -> Parser [T.Segment] +allParsers c = C.choice (textParser c:map (\f -> P.try (f c)) parsers) + where parsers = [ iconParser, hspaceParser, rawParser, actionParser + , fontParser, boxParser, colorParser ] + +-- Wrapper for notFollowedBy that returns the result of the first parser. +-- Also works around the issue that, at least in Parsec 3.0.0, notFollowedBy +-- accepts only parsers with return type Char. +notFollowedBy' :: Parser a -> Parser b -> Parser a +notFollowedBy' p e = do x <- p + C.notFollowedBy $ P.try (e >> return '*') + return x + +-- Parse a maximal string without markup +textParser :: Context -> Parser [T.Segment] +textParser c = + C.many1 (P.noneOf "<" <|> P.try (notFollowedBy' (P.char '<') suffixes)) + >>= retSegment c . T.Text + where suffixes = C.choice $ map (P.try . P.string) + [ "icon=" , "hspace=", "raw=" + , "action=", "/action>", "fn=", "/fn>" + , "box", "/box>", "fc=", "/fc>" ] + +-- Parse a "raw" tag, which we use to prevent other tags from creeping in. +-- The format here is net-string-esque: a literal "<raw=" followed by a string +-- of digits (base 10) denoting the length of the raw string, a literal ":" as +-- digit-string-terminator, the raw string itself, and then a literal "/>". +rawParser :: Context -> Parser [T.Segment] +rawParser c = do + P.string "<raw=" + lenstr <- C.many1 P.digit + P.char ':' + case reads lenstr of + [(len,[])] -> do + CM.guard ((len :: Integer) <= fromIntegral (maxBound :: Int)) + s <- C.count (fromIntegral len) P.anyChar + P.string "/>" + retSegment c (T.Text s) + _ -> CM.mzero + +iconParser :: Context -> Parser [T.Segment] +iconParser c = do + P.string "<icon=" + i <- C.manyTill (P.noneOf ">") (P.try (P.string "/>")) + retSegment c (T.Icon i) + +hspaceParser :: Context -> Parser [T.Segment] +hspaceParser c = do + P.string "<hspace=" + pVal <- C.manyTill P.digit (P.try (P.string "/>")) + retSegment c (T.Hspace (fromMaybe 0 $ readMaybe pVal)) + +actionParser :: Context -> Parser [T.Segment] +actionParser (ti, fi, act) = do + P.string "<action=" + command <- C.between (P.char '`') (P.char '`') (C.many1 (P.noneOf "`")) + <|> C.many1 (P.noneOf ">") + buttons <- (P.char '>' >> return "1") <|> (P.space >> P.spaces >> + C.between (P.string "button=") (P.string ">") (C.many1 (P.oneOf "12345"))) + let a = T.Spawn (toButtons buttons) command + a' = case act of + Nothing -> Just [a] + Just act' -> Just $ a : act' + s <- C.manyTill (allParsers (ti, fi, a')) (P.try $ P.string "</action>") + return (concat s) + +toButtons :: String -> [T.Button] +toButtons = map (\x -> read [x]) + +colorParser :: Context -> Parser [T.Segment] +colorParser (T.TextRenderInfo _ _ _ bs, fidx, a) = do + c <- C.between (P.string "<fc=") (P.string ">") (C.many1 colorc) + let colorParts = break (==':') c + let (ot,ob) = case break (==',') (drop 1 $ snd colorParts) of + (top,',':btm) -> (top, btm) + (top, _) -> (top, top) + tri = T.TextRenderInfo (fst colorParts) + (fromMaybe (-1) $ readMaybe ot) + (fromMaybe (-1) $ readMaybe ob) + bs + s <- C.manyTill (allParsers (tri, fidx, a)) (P.try $ P.string "</fc>") + return (concat s) + where colorc = P.alphaNum <|> P.oneOf ",:#" + +boxParser :: Context -> Parser [T.Segment] +boxParser (T.TextRenderInfo cs ot ob bs, f, a) = do + c <- C.between (P.string "<box") (P.string ">") + (C.option "" (C.many1 (P.alphaNum <|> P.oneOf "= #,"))) + let b = T.Box T.BBFull (T.BoxOffset T.C 0) 1 cs (T.BoxMargins 0 0 0 0) + let g = boxReader b (words c) + s <- C.manyTill + (allParsers (T.TextRenderInfo cs ot ob (g : bs), f, a)) + (P.try $ P.string "</box>") + return (concat s) + +boxReader :: T.Box -> [String] -> T.Box +boxReader b [] = b +boxReader b (x:xs) = boxReader (boxParamReader b param val) xs + where (param,val) = case break (=='=') x of + (p,'=':v) -> (p, v) + (p, _) -> (p, "") + +boxParamReader :: T.Box -> String -> String -> T.Box +boxParamReader b _ "" = b + +boxParamReader (T.Box bb off lw fc mgs) "type" val = + T.Box (fromMaybe bb $ readMaybe ("BB" ++ val)) off lw fc mgs + +boxParamReader (T.Box bb (T.BoxOffset alg off) lw fc mgs) "offset" (a:o) = + T.Box bb (T.BoxOffset align offset) lw fc mgs + where offset = fromMaybe off $ readMaybe o + align = fromMaybe alg $ readMaybe [a] + +boxParamReader (T.Box bb off lw fc mgs) "width" val = + T.Box bb off (fromMaybe lw $ readMaybe val) fc mgs + +boxParamReader (T.Box bb off lw _ mgs) "color" val = + T.Box bb off lw val mgs + +boxParamReader (T.Box bb off lw fc mgs@(T.BoxMargins mt mr mb ml)) ('m':pos) v = + let mgs' = case pos of + "t" -> T.BoxMargins (maybeVal mt) mr mb ml + "r" -> T.BoxMargins mt (maybeVal mr) mb ml + "b" -> T.BoxMargins mt mr (maybeVal mb) ml + "l" -> T.BoxMargins mt mr mb (maybeVal ml) + _ -> mgs + maybeVal d = fromMaybe d (readMaybe v) + in T.Box bb off lw fc mgs' + +boxParamReader b _ _ = b + +fontParser :: Context -> Parser [T.Segment] +fontParser (i, _, a) = do + f <- C.between (P.string "<fn=") (P.string ">") (C.many1 P.digit) + s <- C.manyTill (allParsers (i, fromMaybe 0 $ readMaybe f, a)) + (P.try $ P.string "</fn>") + return (concat s) diff --git a/src/Xmobar/Config/Types.hs b/src/Xmobar/Config/Types.hs index 4959aa1..785b55b 100644 --- a/src/Xmobar/Config/Types.hs +++ b/src/Xmobar/Config/Types.hs @@ -15,14 +15,28 @@ module Xmobar.Config.Types ( Config (..) , XPosition (..), Align (..), Border (..), TextOutputFormat (..) + , Segment , FontIndex + , Box(..) + , BoxBorder(..) + , BoxOffset(..) + , BoxMargins(..) + , TextRenderInfo(..) + , Widget(..) , SignalChan (..) + , Action (..) + , Button ) where import qualified Control.Concurrent.STM as STM import qualified Xmobar.Run.Runnable as R import qualified Xmobar.System.Signal as S +import Data.Int (Int32) +import Foreign.C.Types (CInt) + +import Xmobar.Run.Actions (Action (..), Button) + -- $config -- Configuration data type @@ -71,20 +85,94 @@ data Config = , template :: String -- ^ The output template , verbose :: Bool -- ^ Emit additional debug messages , signal :: SignalChan -- ^ Channel to send signals to xmobar + , dpi :: Double -- ^ DPI scaling factor for fonts } deriving (Read, Show) -data XPosition = Top - | TopH Int - | TopW Align Int - | TopSize Align Int Int - | TopP Int Int +-- | The position datatype +data XPosition = Top -- ^ Top of the screen, full width, auto height + + | TopH -- ^ Top of the screen, full width with + -- specific height + Int -- ^ Height (in pixels) + + -- | Top of the screen, full width with + -- specific height and margins + | TopHM + Int -- ^ Height (in pixels) + Int -- ^ Left margin (in pixels) + Int -- ^ Right margin (in pixels) + Int -- ^ Top margin (in pixels) + Int -- ^ Bottom margin (in pixels) + + -- | Top of the screen with specific width + -- (as screen percentage) and alignment + | TopW + Align -- ^ Alignement (L|C|R) + Int -- ^ Width as screen percentage (0-100) + + -- | Top of the screen with specific width + -- (as screen percentage), height and + -- alignment + | TopSize + Align -- ^ Alignement (L|C|R) + Int -- ^ Width as screen percentage (0-100) + Int -- ^ Height (in pixels) + + -- | Top of the screen with specific left/right + -- margins + | TopP + Int -- ^ Left margin (in pixels) + Int -- ^ Right margin (in pixels) + + -- | Bottom of the screen, full width, auto height | Bottom - | BottomH Int - | BottomP Int Int - | BottomW Align Int - | BottomSize Align Int Int - | Static {xpos, ypos, width, height :: Int} - | OnScreen Int XPosition + + | BottomH -- ^ Bottom of the screen, full width, with + -- specific height + Int -- ^ Height (in pixels) + + -- | Bottom of the screen with specific height + -- and margins + | BottomHM + Int -- ^ Height (in pixels) + Int -- ^ Left margin (in pixels) + Int -- ^ Right margin (in pixels) + Int -- ^ Top margin (in pixels) + Int -- ^ Bottom margin (in pixels) + + -- | Bottom of the screen with specific + -- left/right margins + | BottomP + Int -- ^ Left margin (in pixels) + Int -- ^ Bottom margin (in pixels) + + -- | Bottom of the screen with specific width + -- (as screen percentage) and alignment + -- and alignment + | BottomW + Align -- ^ Alignement (L|C|R) + Int -- ^ Width as screen percentage (0-100) + + -- | Bottom of the screen with specific width + -- (as screen percentage), height + -- and alignment + | BottomSize + Align -- ^ Alignement (L|C|R) + Int -- ^ Width as screen percentage (0-100) + Int -- ^ Height (in pixels) + + -- | Static position and specific size + | Static { xpos :: Int -- ^ Position X (in pixels) + , ypos :: Int -- ^ Position Y (in pixels) + , width :: Int -- ^ Width (in pixels) + , height :: Int -- ^ Height (in pixels) + } + + -- | Along with the position characteristics + -- specify the screen to display the bar + | OnScreen + Int -- ^ Screen id (primary is 0) + XPosition -- ^ Position deriving ( Read, Show, Eq ) data Align = L | R | C deriving ( Read, Show, Eq ) @@ -110,3 +198,34 @@ instance Read SignalChan where instance Show SignalChan where show (SignalChan (Just _)) = "SignalChan (Just <tmvar>)" show (SignalChan Nothing) = "SignalChan Nothing" + +data Widget = Icon String | Text String | Hspace Int32 deriving Show + +data BoxOffset = BoxOffset Align Int32 deriving (Eq, Show) + +-- margins: Top, Right, Bottom, Left +data BoxMargins = BoxMargins Int32 Int32 Int32 Int32 deriving (Eq, Show) + +data BoxBorder = BBTop + | BBBottom + | BBVBoth + | BBLeft + | BBRight + | BBHBoth + | BBFull + deriving (Read, Eq, Show) + +data Box = Box { bBorder :: BoxBorder + , bOffset :: BoxOffset + , bWidth :: CInt + , bColor :: String + , bMargins :: BoxMargins + } deriving (Eq, Show) + +data TextRenderInfo = TextRenderInfo { tColorsString :: String + , tBgTopOffset :: Int32 + , tBgBottomOffset :: Int32 + , tBoxes :: [Box] + } deriving Show + +type Segment = (Widget, TextRenderInfo, FontIndex, Maybe [Action]) diff --git a/src/Xmobar/Draw/Boxes.hs b/src/Xmobar/Draw/Boxes.hs index 1358805..ff55ab3 100644 --- a/src/Xmobar/Draw/Boxes.hs +++ b/src/Xmobar/Draw/Boxes.hs @@ -1,7 +1,7 @@ ------------------------------------------------------------------------------ -- | -- Module: Xmobar.X11.Boxes --- Copyright: (c) 2022 Jose Antonio Ortega Ruiz +-- Copyright: (c) 2022, 2024 Jose Antonio Ortega Ruiz -- License: BSD3-style (see LICENSE) -- -- Maintainer: jao@gnu.org @@ -16,7 +16,6 @@ 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) @@ -25,30 +24,29 @@ type BoxRect = (Double, Double, Double, Double) -- 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 = +boxLines :: T.Box -> Double -> Double -> Double -> [Line] +boxLines (T.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] + T.BBTop -> [rtop] + T.BBBottom -> [rbot] + T.BBVBoth -> [rtop, rbot] + T.BBLeft -> [rleft] + T.BBRight -> [rright] + T.BBHBoth -> [rleft, rright] + T.BBFull -> [rtop, rbot, rleft, rright] where - (P.BoxMargins top right bot left) = margins - (P.BoxOffset align m) = offset + (T.BoxMargins top right bot left) = margins + (T.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 + xmin = x0 - fromIntegral left - lc + xmax = x1 + fromIntegral right + lc + ymin = fromIntegral top + lc + ymax = ht - fromIntegral bot - lc rtop = (xmin + p0, ymin, xmax + p1, ymin) rbot = (xmin + p0, ymax, xmax + p1, ymax) rleft = (xmin, ymin + p0, xmin, ymax + p1) diff --git a/src/Xmobar/Draw/Cairo.hs b/src/Xmobar/Draw/Cairo.hs index 7e22df4..2338b10 100644 --- a/src/Xmobar/Draw/Cairo.hs +++ b/src/Xmobar/Draw/Cairo.hs @@ -2,7 +2,7 @@ ------------------------------------------------------------------------------ -- | -- Module: Xmobar.X11.Cairo --- Copyright: (c) 2022 Jose Antonio Ortega Ruiz +-- Copyright: (c) 2022, 2023, 2024 Jose Antonio Ortega Ruiz -- License: BSD3-style (see LICENSE) -- -- Maintainer: jao@gnu.org @@ -29,14 +29,13 @@ 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 Renderinfo = (C.Segment, Surface -> Double -> Double -> IO (), Double) +type BoundedBox = (Double, Double, [C.Box]) type Acc = (Double, T.Actions, [BoundedBox]) readColourName :: String -> (SRGB.Colour Double, Double) @@ -63,10 +62,10 @@ renderLines color wd lns = do 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) = +segmentMarkup :: C.Config -> C.Segment -> String +segmentMarkup conf (C.Text txt, info, idx, _actions) = let fnt = TextPango.fixXft $ ConfigParse.indexedFont conf idx - (fg, bg) = P.colorComponents conf (P.tColorsString info) + (fg, bg) = ConfigParse.colorComponents conf (C.tColorsString info) attrs = [Pango.FontDescr fnt, Pango.FontForeground fg] attrs' = if bg == C.bgColor conf then attrs @@ -74,8 +73,8 @@ segmentMarkup conf (P.Text txt, info, idx, _actions) = 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 +withRenderinfo :: Pango.PangoContext -> T.DrawContext -> C.Segment -> IO Renderinfo +withRenderinfo ctx dctx seg@(C.Text _, inf, idx, a) = do let conf = T.dcConfig dctx lyt <- Pango.layoutEmpty ctx mk <- Pango.layoutSetMarkup lyt (segmentMarkup conf seg) :: IO String @@ -88,25 +87,28 @@ withRenderinfo ctx dctx seg@(P.Text _, inf, idx, a) = 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) + return ((C.Text mk, inf, idx, a), slyt, wd) -withRenderinfo _ _ seg@(P.Hspace w, _, _, _) = +withRenderinfo _ _ seg@(C.Hspace w, _, _, _) = return (seg, \_ _ _ -> return (), fromIntegral w) -withRenderinfo _ dctx seg@(P.Icon p, _, _, _) = do +withRenderinfo _ dctx seg@(C.Icon p, info, _, _) = do let (wd, _) = T.dcIconLookup dctx p ioff = C.iconOffset (T.dcConfig dctx) vpos = T.dcHeight dctx / 2 + fromIntegral ioff - render _ off mx = when (off + wd <= mx) $ T.dcIconDrawer dctx off vpos p + conf = T.dcConfig dctx + (fg, bg) = ConfigParse.colorComponents conf (C.tColorsString info) + render _ off mx = when (off + wd <= mx) $ + T.dcIconDrawer dctx off vpos p fg bg return (seg, render, wd) -drawBox :: T.DrawContext -> Surface -> Double -> Double -> P.Box -> IO () -drawBox dctx surf x0 x1 box@(P.Box _ _ w color _) = +drawBox :: T.DrawContext -> Surface -> Double -> Double -> C.Box -> IO () +drawBox dctx surf x0 x1 box@(C.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 () + T.DrawContext -> Surface -> C.TextRenderInfo -> Double -> Double -> IO () drawSegmentBackground dctx surf info x0 x1 = when (bg /= C.bgColor conf && (top >= 0 || bot >= 0)) $ Cairo.renderWith surf $ do @@ -114,19 +116,20 @@ drawSegmentBackground dctx surf info x0 x1 = 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 + (_, bg) = ConfigParse.colorComponents conf (C.tColorsString info) + top = fromIntegral $ C.tBgTopOffset info + bot = fromIntegral $ C.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 + bs = C.tBoxes info boxs' = if null bs then boxs else (off, end, bs):boxs - drawSegmentBackground dctx surface info off end - render surface off maxoff + when (end > off) $ do + drawSegmentBackground dctx surface info off end + render surface off maxoff return (off + lwidth, acts', boxs') renderOuterBorder :: C.Config -> Double -> Double -> Cairo.Render () @@ -166,25 +169,27 @@ drawCairoBackground dctx surf = do drawSegments :: T.DrawContext -> Surface -> IO T.Actions drawSegments dctx surf = do - let [left, center, right] = take 3 $ T.dcSegments dctx ++ repeat [] + let segs = 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 + Pango.cairoContextSetResolution ctx $ C.dpi conf + llyts <- mapM (withRenderinfo ctx dctx) (head segs) + rlyts <- mapM (withRenderinfo ctx dctx) (segs !! 2) + clyts <- mapM (withRenderinfo ctx dctx) (segs !! 1) #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 + rstart = max lend (dw - rw) + cstart = if lend > 1 || rw == 0 then max lend ((dw - cw) / 2.0) else lend + (_, as', bx') <- if cw > 0 + then foldM (drawSegment dctx surf rstart) (cstart, as, bx) clyts + else return (0, as, bx) (_, 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) diff --git a/src/Xmobar/Draw/Types.hs b/src/Xmobar/Draw/Types.hs index 75dd714..1a076b3 100644 --- a/src/Xmobar/Draw/Types.hs +++ b/src/Xmobar/Draw/Types.hs @@ -17,16 +17,15 @@ module Xmobar.Draw.Types where -import Xmobar.Config.Types (Config) +import Xmobar.Config.Types (Config, Segment) import Xmobar.Run.Actions (Action) -import Xmobar.Run.Parsers (Segment) type Position = Double type ActionPos = ([Action], Position, Position) type Actions = [ActionPos] type IconLookup = String -> (Double, Double) -type IconDrawer = Double -> Double -> String -> IO () +type IconDrawer = Double -> Double -> String -> String -> String -> IO () data DrawContext = DC { dcIconDrawer :: IconDrawer , dcIconLookup :: IconLookup diff --git a/src/Xmobar/Plugins/EWMH.hs b/src/Xmobar/Plugins/EWMH.hs index 94fd7d7..78f1cc0 100644 --- a/src/Xmobar/Plugins/EWMH.hs +++ b/src/Xmobar/Plugins/EWMH.hs @@ -19,6 +19,7 @@ module Xmobar.Plugins.EWMH (EWMH(..)) where import Control.Applicative (Applicative(..)) import Control.Monad.State +import Control.Monad import Control.Monad.Reader import Graphics.X11 hiding (Modifier, Color) import Graphics.X11.Xlib.Extras diff --git a/src/Xmobar/Plugins/Kbd.hs b/src/Xmobar/Plugins/Kbd.hs index 2214628..3871ca8 100644 --- a/src/Xmobar/Plugins/Kbd.hs +++ b/src/Xmobar/Plugins/Kbd.hs @@ -14,9 +14,11 @@ module Xmobar.Plugins.Kbd(Kbd(..)) where -import Data.List (isPrefixOf) +import Data.Bifunctor (bimap) +import Data.List (find, tails, isPrefixOf) import Data.Maybe (fromMaybe) -import Data.Char (toLower) +import Data.Char (toLower, isLetter) +import Data.Function ((&)) import Control.Monad (forever) import Control.Applicative ((<|>)) import Graphics.X11.Xlib @@ -26,6 +28,13 @@ import Xmobar.Run.Exec import Xmobar.X11.Events (nextEvent') import Xmobar.System.Kbd +-- some strong typing +newtype Lay = Lay String deriving (Eq) +newtype Sym = Sym String +instance Show Sym where show (Sym s) = s +type KbdOpts' = [(Lay, Sym)] +typed :: [(String, String)] -> [(Lay, Sym)] +typed = map (bimap Lay Sym) -- 'Bad' prefixes of layouts noLaySymbols :: [String] @@ -49,15 +58,22 @@ split p s = case break p s of (pref, "") -> [pref] -- replaces input string if on search list (exact match) with corresponding --- element on replacement list. +-- element on replacement list, and returns it paired with the following item -- --- if not found, return string unchanged -searchReplaceLayout :: KbdOpts -> String -> String -searchReplaceLayout opts s = fromMaybe s $ lookup s opts - --- returns the active layout -getKbdLay :: Display -> KbdOpts -> IO String -getKbdLay dpy opts = do +-- if not found, return string unchanged, paired with empty string +searchReplaceLayout :: KbdOpts' -> String -> (Lay, Lay, Sym) +searchReplaceLayout opts curr + = maybe (Lay "", Lay "", Sym curr) + pickSymWithAdjLays + (find currLayout (tails $ cycle opts)) + where + pickSymWithAdjLays ((l1, _):(_, s):(l2, _):_) = (l1, l2, s) + pickSymWithAdjLays _ = error "This should never happen" + currLayout = (Lay curr ==) . (!! 1) . map fst + +-- returns the active layout and the following one +getCurAndNextKbdLays :: Display -> KbdOpts' -> IO (Lay, Lay, Sym) +getCurAndNextKbdLays dpy opts = do lay <- splitLayout <$> getLayoutStr dpy grps <- map (map toLower . take 2) <$> getGrpNames dpy curLay <- getKbdLayout dpy @@ -73,6 +89,37 @@ getKbdLay dpy opts = do newtype Kbd = Kbd [(String, String)] deriving (Read, Show) +attachClickAction :: (Lay, Lay, Sym) -> Sym +attachClickAction (Lay prv, Lay nxt, txt) = txt & linkTo nxt `onKey` "1" + & linkTo prv `onKey` "3" + where + splitLayParensPhon :: String -> (String, String, String) + splitLayParensPhon = (\(a, (b, c)) -> (a, b, c)) + . second (second (drop 1) . break (== ')') . drop 1) + . break (== '(') + parseLayPhon :: String -> (Maybe String, Maybe String) + parseLayPhon s = let (l, p, i) = splitLayParensPhon s + l' = if all isLetter l + then Just ("-layout " ++ l) + else Nothing + p' = if (p, i) == ("phonetic", "") + then Just "-variant phonetic" + else Nothing + in (l', p') + linkTo :: String -> String -> Sym -> Sym + linkTo linked button currLay = Sym $ case parseLayPhon linked of + (Nothing, _) -> "??" + (Just linkedLay, phon) -> wrapIn setxkbmap button currLay + where + setxkbmap = unwords ["setxkbmap", linkedLay, fromMaybe "" phon] + wrapIn :: String -> String -> Sym -> String + wrapIn action buttons (Sym sym) = openingTag ++ sym ++ closingTag + where + openingTag = "<action=`" ++ action ++ "` button=" ++ buttons ++ ">" + closingTag = "</action>" + onKey = ($) + second = fmap + instance Exec Kbd where alias (Kbd _) = "kbd" start (Kbd opts) cb = do @@ -80,7 +127,7 @@ instance Exec Kbd where dpy <- openDisplay "" -- initial set of layout - cb =<< getKbdLay dpy opts + cb . show . attachClickAction =<< getCurAndNextKbdLays dpy (typed opts) -- enable listing for -- group changes @@ -91,7 +138,6 @@ instance Exec Kbd where allocaXEvent $ \e -> forever $ do nextEvent' dpy e _ <- getEvent e - cb =<< getKbdLay dpy opts + cb . show . attachClickAction =<< getCurAndNextKbdLays dpy (typed opts) closeDisplay dpy - return () diff --git a/src/Xmobar/Plugins/Kraken.hs b/src/Xmobar/Plugins/Kraken.hs index 2345b3d..5d565e0 100644 --- a/src/Xmobar/Plugins/Kraken.hs +++ b/src/Xmobar/Plugins/Kraken.hs @@ -36,7 +36,7 @@ instance Exec Kraken where cb (display g) loop mv g - loop mvar (Map.fromList $ zip ps (repeat 0.0)) + loop mvar (Map.fromList $ map (, 0.0) ps) where display :: Map.Map String Double -> String diff --git a/src/Xmobar/Plugins/Locks.hs b/src/Xmobar/Plugins/Locks.hs index 9176312..35a3f97 100644 --- a/src/Xmobar/Plugins/Locks.hs +++ b/src/Xmobar/Plugins/Locks.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE TupleSections #-} ----------------------------------------------------------------------------- -- | -- Module : Plugins.Locks @@ -16,45 +17,70 @@ module Xmobar.Plugins.Locks(Locks(..)) where import Graphics.X11 import Data.List +import Data.List.Extra (trim) import Data.Bits +import Data.Maybe (fromJust) import Control.Monad +import Control.Monad.Extra (ifM) import Graphics.X11.Xlib.Extras import Xmobar.Run.Exec import Xmobar.System.Kbd import Xmobar.X11.Events (nextEvent') -data Locks = Locks +data Locks = Locks | Locks' [(String, (String, String))] deriving (Read, Show) locks :: [ ( KeySym, String )] -locks = [ ( xK_Caps_Lock, "CAPS" ) - , ( xK_Num_Lock, "NUM" ) +locks = [ ( xK_Caps_Lock, "CAPS" ) + , ( xK_Num_Lock, "NUM" ) , ( xK_Scroll_Lock, "SCROLL" ) ] -run' :: Display -> Window -> IO String -run' d root = do +type Labels = [ ( String, (String, String) )] +defaultLabels :: Labels +defaultLabels = let nms = map snd locks + in zip nms (map (, mempty) nms) + +type LabelledLock = (KeySym, String, String, String) + +attach :: (KeySym, String) -> Labels -> LabelledLock +(key, lock) `attach` lbls = let (enb, dis) = fromJust $ lookup lock lbls + in (key, lock, enb, dis) + +enabled :: (a, b, c, d) -> c +enabled (_, _, c, _) = c +disabled :: (a, b, c, d) -> d +disabled (_, _, _, d) = d + +isEnabled :: (Bits a1, Foldable t, Foldable t1, Integral a) + => Display -> t (a, t1 KeyCode) -> a1 -> (KeySym, b, c, d) -> IO Bool +isEnabled d modMap m ( ks, _, _, _ ) = do + kc <- keysymToKeycode d ks + return $ case find (elem kc . snd) modMap of + Nothing -> False + Just ( i, _ ) -> testBit m (fromIntegral i) + +run' :: Display -> Window -> Labels -> IO String +run' d root labels = do modMap <- getModifierMapping d ( _, _, _, _, _, _, _, m ) <- queryPointer d root - ls <- filterM ( \( ks, _ ) -> do - kc <- keysymToKeycode d ks - return $ case find (elem kc . snd) modMap of - Nothing -> False - Just ( i, _ ) -> testBit m (fromIntegral i) - ) locks - - return $ unwords $ map snd ls + ls' <- forM (map (`attach` labels) locks) + (\l -> ifM (isEnabled d modMap m l) + (return (enabled l)) + (return (disabled l))) + return $ trim $ unwords ls' instance Exec Locks where - alias Locks = "locks" - start Locks cb = do + alias _ = "locks" + start Locks cb = start (Locks' defaultLabels) cb + start (Locks' labels) cb = do d <- openDisplay "" root <- rootWindow d (defaultScreen d) _ <- xkbSelectEventDetails d xkbUseCoreKbd xkbIndicatorStateNotify m m allocaXEvent $ \ep -> forever $ do - cb =<< run' d root + cb =<< run' d root labels nextEvent' d ep getEvent ep diff --git a/src/Xmobar/Plugins/Monitors/Alsa.hs b/src/Xmobar/Plugins/Monitors/Alsa.hs index dfc7329..8d02931 100644 --- a/src/Xmobar/Plugins/Monitors/Alsa.hs +++ b/src/Xmobar/Plugins/Monitors/Alsa.hs @@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Plugins.Monitors.Alsa --- Copyright : (c) 2018 Daniel Schüssler +-- Copyright : (c) 2018, 2024 Daniel Schüssler -- License : BSD-style (see LICENSE) -- -- Maintainer : Jose A. Ortega Ruiz <jao@gnu.org> @@ -25,6 +25,7 @@ import Control.Concurrent.Async import Control.Exception import Control.Monad import Data.IORef +import Data.Maybe (fromJust) import Data.Time.Clock import Xmobar.Plugins.Monitors.Common import qualified Xmobar.Plugins.Monitors.Volume as Volume; @@ -129,7 +130,8 @@ alsaReaderThread mixerName alsaCtlPath outputCallback mvar = {std_out = CreatePipe} runAlsaOnce = - withCreateProcess createProc $ \_ (Just alsaOut) _ _ -> do + withCreateProcess createProc $ \_ out _ _ -> do + let alsaOut = fromJust out hSetBuffering alsaOut LineBuffering tryPutMVar mvar () -- Refresh immediately after restarting alsactl diff --git a/src/Xmobar/Plugins/Monitors/Batt/Common.hs b/src/Xmobar/Plugins/Monitors/Batt/Common.hs index 3262b78..ddb2b8c 100644 --- a/src/Xmobar/Plugins/Monitors/Batt/Common.hs +++ b/src/Xmobar/Plugins/Monitors/Batt/Common.hs @@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Plugins.Monitors.Batt.Common --- Copyright : (c) 2010, 2011, 2012, 2013, 2015, 2016, 2018, 2019 Jose A Ortega +-- Copyright : (c) 2010-2016, 2018, 2019, 2024 Jose A Ortega -- (c) 2010 Andrea Rossato, Petr Rockai -- License : BSD-style (see LICENSE) -- @@ -18,7 +18,7 @@ module Xmobar.Plugins.Monitors.Batt.Common (BattOpts(..) , Status(..) , maybeAlert) where -import System.Process (system) +import System.Process (spawnCommand, waitForProcess) import Control.Monad (unless, void) import Xmobar.Plugins.Monitors.Common @@ -54,4 +54,4 @@ maybeAlert opts left = case onLowAction opts of Nothing -> return () Just x -> unless (isNaN left || actionThreshold opts < 100 * left) - $ void $ system x + $ void $ spawnCommand (x ++ " &") >>= waitForProcess diff --git a/src/Xmobar/Plugins/Monitors/Common/Output.hs b/src/Xmobar/Plugins/Monitors/Common/Output.hs index bd60710..c0a00ab 100644 --- a/src/Xmobar/Plugins/Monitors/Common/Output.hs +++ b/src/Xmobar/Plugins/Monitors/Common/Output.hs @@ -3,7 +3,7 @@ ------------------------------------------------------------------------------ -- | -- Module: Xmobar.Plugins.Monitors.Strings --- Copyright: (c) 2018, 2019, 2020, 2022 Jose Antonio Ortega Ruiz +-- Copyright: (c) 2018, 2019, 2020, 2022, 2024 Jose Antonio Ortega Ruiz -- License: BSD3-style (see LICENSE) -- -- Maintainer: jao@gnu.org @@ -88,9 +88,9 @@ pShowWithColors p f x = do pColorizeString :: (Num a, Ord a, MonadIO m) => MonitorConfig -> a -> String -> m String pColorizeString p x s = do let col = pSetColor p s - [ll,hh] = map fromIntegral $ sort [pLow p, pHigh p] -- consider high < low - pure $ head $ [col pHighColor | x > hh ] ++ - [col pNormalColor | x > ll ] ++ + cols = map fromIntegral $ sort [pLow p, pHigh p] -- consider high < low + pure $ head $ [col pHighColor | x > (cols !! 1) ] ++ + [col pNormalColor | x > head cols ] ++ [col pLowColor | True] pSetColor :: MonitorConfig -> String -> PSelector (Maybe String) -> String @@ -140,7 +140,7 @@ showWithUnits d n x padString :: Int -> Int -> String -> Bool -> String -> String -> String padString mnw mxw pad pr ellipsis s = let len = length s - rmin = if mnw < 0 then 0 else mnw + rmin = max mnw 0 rmax = if mxw <= 0 then max len rmin else mxw (rmn, rmx) = if rmin <= rmax then (rmin, rmax) else (rmax, rmin) rlen = min (max rmn len) rmx @@ -197,9 +197,9 @@ colorizeString x s = do h <- getConfigValue high l <- getConfigValue low let col = setColor s - [ll,hh] = map fromIntegral $ sort [l, h] -- consider high < low - head $ [col highColor | x > hh ] ++ - [col normalColor | x > ll ] ++ + cols = map fromIntegral $ sort [l, h] -- consider high < low + head $ [col highColor | x > cols !! 1 ] ++ + [col normalColor | x > head cols ] ++ [col lowColor | True] showWithColors :: (Num a, Ord a) => (a -> String) -> a -> Monitor String @@ -260,11 +260,11 @@ logScaling f v = do h <- fromIntegral `fmap` getConfigValue high l <- fromIntegral `fmap` getConfigValue low bw <- fromIntegral `fmap` getConfigValue barWidth - let [ll, hh] = sort [l, h] + let ws = sort [l, h] bw' = if bw > 0 then bw else 10 scaled x | x == 0.0 = 0 - | x <= ll = 1 / bw' - | otherwise = f + logBase 2 (x / hh) / bw' + | x <= head ws = 1 / bw' + | otherwise = f + logBase 2 (x / ws !! 1) / bw' return $ scaled v showLogBar :: Float -> Float -> Monitor String diff --git a/src/Xmobar/Plugins/Monitors/Disk.hs b/src/Xmobar/Plugins/Monitors/Disk.hs index 47d1eac..95bcff6 100644 --- a/src/Xmobar/Plugins/Monitors/Disk.hs +++ b/src/Xmobar/Plugins/Monitors/Disk.hs @@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module : Plugins.Monitors.Disk --- Copyright : (c) 2010, 2011, 2012, 2014, 2018, 2019 Jose A Ortega Ruiz +-- Copyright : (c) 2010-2012, 2014, 2018, 2019, 2024 Jose A Ortega Ruiz -- License : BSD-style (see LICENSE) -- -- Maintainer : Jose A Ortega Ruiz <jao@gnu.org> @@ -131,10 +131,9 @@ startDiskIO disks args rate cb = do runM args diskIOConfig (runDiskIO dref disks) rate cb runDiskU' :: DiskUOpts -> String -> [Integer] -> Monitor String -runDiskU' opts tmp stat = do +runDiskU' opts tmp (total:free:diff:_) = do setConfigValue tmp template - let [total, free, diff] = stat - strs = map sizeToStr [free, diff] + let strs = map sizeToStr [free, diff] freep = if total > 0 then free * 100 `div` total else 0 fr = fromIntegral freep / 100 s <- zipWithM showWithColors' strs [freep, 100 - freep] @@ -146,6 +145,7 @@ runDiskU' opts tmp stat = do uvb <- showVerticalBar (fromIntegral $ 100 - freep) (1 - fr) uipat <- showIconPattern (usedIconPattern opts) (1 - fr) parseTemplate $ [sizeToStr total] ++ s ++ sp ++ [fb,fvb,fipat,ub,uvb,uipat] +runDiskU' _ _ _ = return "" runDiskU :: [(String, String)] -> [String] -> Monitor String runDiskU disks argv = do diff --git a/src/Xmobar/Plugins/Monitors/Mem/Linux.hs b/src/Xmobar/Plugins/Monitors/Mem/Linux.hs index 79dcc9d..7a81c6d 100644 --- a/src/Xmobar/Plugins/Monitors/Mem/Linux.hs +++ b/src/Xmobar/Plugins/Monitors/Mem/Linux.hs @@ -25,9 +25,13 @@ parseMEM = let content = map words $ take 8 $ lines file info = M.fromList $ map ( \line -> (head line, (read $ line !! 1 :: Float) / 1024)) content - [total, free, buffer, cache] = - map (info M.!) ["MemTotal:", "MemFree:", "Buffers:", "Cached:"] - available = M.findWithDefault (free + buffer + cache) "MemAvailable:" info + info' x = info M.! (x ++ ":") + total = info' "MemTotal" + free = info' "MemFree" + buffer = info' "Buffers" + cache = info' "Cached" + available = + M.findWithDefault (free + buffer + cache) "MemAvailable:" info used = total - available usedratio = used / total freeratio = free / total diff --git a/src/Xmobar/Plugins/Monitors/Net/Linux.hs b/src/Xmobar/Plugins/Monitors/Net/Linux.hs index 9306497..f9cbc28 100644 --- a/src/Xmobar/Plugins/Monitors/Net/Linux.hs +++ b/src/Xmobar/Plugins/Monitors/Net/Linux.hs @@ -47,7 +47,10 @@ isUp d = flip catchIOError (const $ return False) $ do return $! (head . B.lines) operstate `elem` ["up", "unknown"] readNetDev :: [String] -> IO NetDevRawTotal -readNetDev ~[d, x, y] = do +readNetDev ds = do + let (d, x, y) = case ds of + d':x':y':_ -> (d', x', y') + _ -> ("", "", "") up <- unsafeInterleaveIO $ isUp d return $ N d (if up then ND (r x) (r y) else NI) where r s | s == "" = 0 diff --git a/src/Xmobar/Run/Actions.hs b/src/Xmobar/Run/Actions.hs index 2a49312..cbc10c5 100644 --- a/src/Xmobar/Run/Actions.hs +++ b/src/Xmobar/Run/Actions.hs @@ -16,7 +16,7 @@ module Xmobar.Run.Actions ( Button , runAction' , stripActions) where -import System.Process (system) +import System.Process (spawnCommand, waitForProcess) import Control.Monad (void) import Text.Regex (Regex, subRegex, mkRegex, matchRegex) import Data.Word (Word32) @@ -26,11 +26,11 @@ type Button = Word32 data Action = Spawn [Button] String deriving (Eq, Read, Show) runAction :: Action -> IO () -runAction (Spawn _ s) = void $ system (s ++ "&") +runAction (Spawn _ s) = void $ spawnCommand (s ++ " &") >>= waitForProcess -- | Run action with stdout redirected to stderr runAction' :: Action -> IO () -runAction' (Spawn _ s) = void $ system (s ++ " 1>&2 &") +runAction' (Spawn _ s) = void $ spawnCommand (s ++ " 1>&2 &") >>= waitForProcess stripActions :: String -> String stripActions s = case matchRegex actionRegex s of diff --git a/src/Xmobar/Run/Parsers.hs b/src/Xmobar/Run/Parsers.hs deleted file mode 100644 index 9b36786..0000000 --- a/src/Xmobar/Run/Parsers.hs +++ /dev/null @@ -1,244 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} - ------------------------------------------------------------------------------ --- | --- Module : Xmobar.Run.Parsers --- Copyright : (c) Andrea Rossato --- License : BSD-style (see LICENSE) --- --- Maintainer : Jose A. Ortega Ruiz <jao@gnu.org> --- Stability : unstable --- Portability : portable --- --- Parsing for template substrings --- ------------------------------------------------------------------------------ - -module Xmobar.Run.Parsers ( parseString - , colorComponents - , Segment - , FontIndex - , Box(..) - , BoxBorder(..) - , BoxOffset(..) - , BoxMargins(..) - , TextRenderInfo(..) - , Widget(..)) where - -import Control.Monad (guard, mzero) -import Data.Maybe (fromMaybe) -import Data.Int (Int32) -import Text.ParserCombinators.Parsec -import Text.Read (readMaybe) -import Foreign.C.Types (CInt) - -import Xmobar.Config.Types -import Xmobar.Run.Actions - -data Widget = Icon String | Text String | Hspace Int32 deriving Show - -data BoxOffset = BoxOffset Align Int32 deriving (Eq, Show) - --- margins: Top, Right, Bottom, Left -data BoxMargins = BoxMargins Int32 Int32 Int32 Int32 deriving (Eq, Show) - -data BoxBorder = BBTop - | BBBottom - | BBVBoth - | BBLeft - | BBRight - | BBHBoth - | BBFull - deriving (Read, Eq, Show) - -data Box = Box { bBorder :: BoxBorder - , bOffset :: BoxOffset - , bWidth :: CInt - , bColor :: String - , bMargins :: BoxMargins - } deriving (Eq, Show) - -data TextRenderInfo = TextRenderInfo { tColorsString :: String - , tBgTopOffset :: Int32 - , tBgBottomOffset :: Int32 - , tBoxes :: [Box] - } deriving Show - -type Segment = (Widget, TextRenderInfo, FontIndex, Maybe [Action]) - --- | Runs the string parser -parseString :: Config -> String -> IO [Segment] -parseString c s = - case parse (stringParser ci 0 Nothing) "" s of - Left _ -> return [(Text $ "Could not parse string: " ++ s - , ci - , 0 - , Nothing)] - Right x -> return (concat x) - where ci = TextRenderInfo (fgColor c) 0 0 [] - --- | Splits a colors string into its two components -colorComponents :: Config -> String -> (String, String) -colorComponents conf c = - case break (==',') c of - (f,',':b) -> (f, b) - (f, _) -> (f, bgColor conf) - -allParsers :: TextRenderInfo -> FontIndex -> Maybe [Action] -> Parser [Segment] -allParsers c f a = textParser c f a - <|> try (iconParser c f a) - <|> try (hspaceParser c f a) - <|> try (rawParser c f a) - <|> try (actionParser c f a) - <|> try (fontParser c a) - <|> try (boxParser c f a) - <|> colorParser c f a - --- | Gets the string and combines the needed parsers -stringParser :: TextRenderInfo -> FontIndex -> Maybe [Action] -> Parser [[Segment]] -stringParser c f a = manyTill (allParsers c f a) eof - --- | Parses a maximal string without markup. -textParser :: TextRenderInfo -> FontIndex -> Maybe [Action] -> Parser [Segment] -textParser c f a = do s <- many1 $ - noneOf "<" <|> - try (notFollowedBy' (char '<') - (try (string "fc=") <|> - try (string "box") <|> - try (string "fn=") <|> - try (string "action=") <|> - try (string "/action>") <|> - try (string "icon=") <|> - try (string "hspace=") <|> - try (string "raw=") <|> - try (string "/fn>") <|> - try (string "/box>") <|> - string "/fc>")) - return [(Text s, c, f, a)] - --- | Parse a "raw" tag, which we use to prevent other tags from creeping in. --- The format here is net-string-esque: a literal "<raw=" followed by a --- string of digits (base 10) denoting the length of the raw string, --- a literal ":" as digit-string-terminator, the raw string itself, and --- then a literal "/>". -rawParser :: TextRenderInfo -> FontIndex -> Maybe [Action] -> Parser [Segment] -rawParser c f a = do - string "<raw=" - lenstr <- many1 digit - char ':' - case reads lenstr of - [(len,[])] -> do - guard ((len :: Integer) <= fromIntegral (maxBound :: Int)) - s <- count (fromIntegral len) anyChar - string "/>" - return [(Text s, c, f, a)] - _ -> mzero - --- | Wrapper for notFollowedBy that returns the result of the first parser. --- Also works around the issue that, at least in Parsec 3.0.0, notFollowedBy --- accepts only parsers with return type Char. -notFollowedBy' :: Parser a -> Parser b -> Parser a -notFollowedBy' p e = do x <- p - notFollowedBy $ try (e >> return '*') - return x - -iconParser :: TextRenderInfo -> FontIndex -> Maybe [Action] -> Parser [Segment] -iconParser c f a = do - string "<icon=" - i <- manyTill (noneOf ">") (try (string "/>")) - return [(Icon i, c, f, a)] - -hspaceParser :: TextRenderInfo -> FontIndex -> Maybe [Action] -> Parser [Segment] -hspaceParser c f a = do - string "<hspace=" - pVal <- manyTill digit (try (string "/>")) - return [(Hspace (fromMaybe 0 $ readMaybe pVal), c, f, a)] - -actionParser :: TextRenderInfo -> FontIndex -> Maybe [Action] -> Parser [Segment] -actionParser c f act = do - string "<action=" - command <- choice [between (char '`') (char '`') (many1 (noneOf "`")), - many1 (noneOf ">")] - buttons <- (char '>' >> return "1") <|> (space >> spaces >> - between (string "button=") (string ">") (many1 (oneOf "12345"))) - let a = Spawn (toButtons buttons) command - a' = case act of - Nothing -> Just [a] - Just act' -> Just $ a : act' - s <- manyTill (allParsers c f a') (try $ string "</action>") - return (concat s) - -toButtons :: String -> [Button] -toButtons = map (\x -> read [x]) - --- | Parsers a string wrapped in a color specification. -colorParser :: TextRenderInfo -> FontIndex -> Maybe [Action] -> Parser [Segment] -colorParser (TextRenderInfo _ _ _ bs) fidx a = do - c <- between (string "<fc=") (string ">") colors - let colorParts = break (==':') c - let (ot,ob) = case break (==',') (Prelude.drop 1 $ snd colorParts) of - (top,',':btm) -> (top, btm) - (top, _) -> (top, top) - tri = TextRenderInfo (fst colorParts) - (fromMaybe (-1) $ readMaybe ot) - (fromMaybe (-1) $ readMaybe ob) - bs - s <- manyTill (allParsers tri fidx a) (try $ string "</fc>") - return (concat s) - --- | Parses a string wrapped in a box specification. -boxParser :: TextRenderInfo -> FontIndex -> Maybe [Action] -> Parser [Segment] -boxParser (TextRenderInfo cs ot ob bs) f a = do - c <- between (string "<box") (string ">") - (option "" (many1 (alphaNum - <|> char '=' - <|> char ' ' - <|> char '#' - <|> char ','))) - let b = Box BBFull (BoxOffset C 0) 1 cs (BoxMargins 0 0 0 0) - let g = boxReader b (words c) - s <- manyTill - (allParsers (TextRenderInfo cs ot ob (g : bs)) f a) - (try $ string "</box>") - return (concat s) - -boxReader :: Box -> [String] -> Box -boxReader b [] = b -boxReader b (x:xs) = do - let (param,val) = case break (=='=') x of - (p,'=':v) -> (p, v) - (p, _) -> (p, "") - boxReader (boxParamReader b param val) xs - -boxParamReader :: Box -> String -> String -> Box -boxParamReader b _ "" = b -boxParamReader (Box bb off lw fc mgs) "type" val = - Box (fromMaybe bb $ readMaybe ("BB" ++ val)) off lw fc mgs -boxParamReader (Box bb (BoxOffset alg off) lw fc mgs) "offset" (a:o) = - Box bb (BoxOffset align offset) lw fc mgs - where offset = fromMaybe off $ readMaybe o - align = fromMaybe alg $ readMaybe [a] -boxParamReader (Box bb off lw fc mgs) "width" val = - Box bb off (fromMaybe lw $ readMaybe val) fc mgs -boxParamReader (Box bb off lw _ mgs) "color" val = - Box bb off lw val mgs -boxParamReader (Box bb off lw fc mgs@(BoxMargins mt mr mb ml)) ('m':pos) val = do - let mgs' = case pos of - "t" -> BoxMargins (fromMaybe mt $ readMaybe val) mr mb ml - "r" -> BoxMargins mt (fromMaybe mr $ readMaybe val) mb ml - "b" -> BoxMargins mt mr (fromMaybe mb $ readMaybe val) ml - "l" -> BoxMargins mt mr mb (fromMaybe ml $ readMaybe val) - _ -> mgs - Box bb off lw fc mgs' -boxParamReader b _ _ = b - --- | Parsers a string wrapped in a font specification. -fontParser :: TextRenderInfo -> Maybe [Action] -> Parser [Segment] -fontParser c a = do - f <- between (string "<fn=") (string ">") colors - s <- manyTill (allParsers c (fromMaybe 0 $ readMaybe f) a) (try $ string "</fn>") - return (concat s) - --- | Parses a color specification (hex or named) -colors :: Parser String -colors = many1 (alphaNum <|> char ',' <|> char ':' <|> char '#') diff --git a/src/Xmobar/Run/Template.hs b/src/Xmobar/Run/Template.hs index 87c84d3..68feacb 100644 --- a/src/Xmobar/Run/Template.hs +++ b/src/Xmobar/Run/Template.hs @@ -77,5 +77,6 @@ splitTemplate alignSep template = (ce,_:ri) -> [le, ce, ri] _ -> def _ -> def - where [l, r] = if length alignSep == 2 then alignSep else defaultAlign + where sep = if length alignSep == 2 then alignSep else defaultAlign + (l, r) = (head sep, sep !! 1) def = [template, "", ""] diff --git a/src/Xmobar/System/DBus.hs b/src/Xmobar/System/DBus.hs index 103a5a9..90bee2a 100644 --- a/src/Xmobar/System/DBus.hs +++ b/src/Xmobar/System/DBus.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE ScopedTypeVariables #-} ----------------------------------------------------------------------------- -- | -- Module : DBus @@ -17,9 +18,10 @@ module Xmobar.System.DBus (runIPC) where import DBus import DBus.Client hiding (interfaceName) import qualified DBus.Client as DC +import DBus.Socket import Data.Maybe (isNothing) import Control.Concurrent.STM -import Control.Exception (handle) +import Control.Exception import System.IO (stderr, hPutStrLn) import Control.Monad.IO.Class (liftIO) @@ -35,10 +37,10 @@ interfaceName :: InterfaceName interfaceName = interfaceName_ "org.Xmobar.Control" runIPC :: TMVar SignalType -> IO () -runIPC mvst = handle printException exportConnection +runIPC mvst = exportConnection `catches` [ + Handler(\ (ex :: ClientError) -> hPutStrLn stderr (clientErrorMessage ex)), + Handler(\ (ex :: SocketError) -> hPutStrLn stderr (socketErrorMessage ex))] where - printException :: ClientError -> IO () - printException = hPutStrLn stderr . clientErrorMessage exportConnection = do client <- connectSession requestName client busName [ nameDoNotQueue ] diff --git a/src/Xmobar/System/Environment.hs b/src/Xmobar/System/Environment.hs index 25802fe..0491bcc 100644 --- a/src/Xmobar/System/Environment.hs +++ b/src/Xmobar/System/Environment.hs @@ -13,14 +13,14 @@ ----------------------------------------------------------------------------- module Xmobar.System.Environment(expandEnv) where -import Data.Maybe (fromMaybe) -import System.Environment (lookupEnv) +import qualified Data.Maybe as M +import qualified System.Environment as E expandEnv :: String -> IO String expandEnv "" = return "" expandEnv (c:s) = case c of '$' -> do - envVar <- fromMaybe "" <$> lookupEnv e + envVar <- M.fromMaybe "" <$> E.lookupEnv e remainder <- expandEnv s' return $ envVar ++ remainder where (e, s') = getVar s @@ -36,12 +36,13 @@ expandEnv (c:s) = case c of False -> do remainder <- expandEnv $ drop 1 s return $ escString s ++ remainder - where escString s' = let (cc:_) = s' in + where escString (cc:_) = case cc of 't' -> "\t" 'n' -> "\n" '$' -> "$" _ -> [cc] + escString [] = "" _ -> do remainder <- expandEnv s diff --git a/src/Xmobar/Text/Loop.hs b/src/Xmobar/Text/Loop.hs index 05379cd..5d2c43f 100644 --- a/src/Xmobar/Text/Loop.hs +++ b/src/Xmobar/Text/Loop.hs @@ -45,4 +45,4 @@ eventLoop cfg signal tv = do updateString :: Config -> TVar [String] -> IO String updateString conf v = do s <- readTVarIO v - format conf (concat s) + return $ format conf (concat s) diff --git a/src/Xmobar/Text/Output.hs b/src/Xmobar/Text/Output.hs index 783a5bb..677b6d2 100644 --- a/src/Xmobar/Text/Output.hs +++ b/src/Xmobar/Text/Output.hs @@ -15,13 +15,15 @@ module Xmobar.Text.Output (initLoop, format) where -import Xmobar.Config.Types (Config(textOutputFormat, additionalFonts, font) - , TextOutputFormat(..)) -import Xmobar.Run.Parsers ( Segment - , Widget(..) - , parseString - , tColorsString - , colorComponents) +import Xmobar.Config.Types ( Config (..) + , TextOutputFormat (..) + , Segment + , Widget (..) + , tColorsString) + + +import Xmobar.Config.Parse (colorComponents) +import Xmobar.Config.Template (parseString) import Xmobar.Text.Ansi (withAnsiColor) import Xmobar.Text.Pango (withPangoMarkup) @@ -47,9 +49,9 @@ formatWithColor conf (Hspace n, i, x, y) = formatWithColor conf (Text $ replicate (fromIntegral n) ' ', i, x, y) formatWithColor _ _ = "" -format :: Config -> String -> IO String +format :: Config -> String -> String format conf s = do - segments <- parseString conf s + let segments = parseString conf s case textOutputFormat conf of - Swaybar -> return $ formatSwaybar conf segments - _ -> return (concatMap (formatWithColor conf) segments) + Swaybar -> formatSwaybar conf segments + _ -> concatMap (formatWithColor conf) segments diff --git a/src/Xmobar/Text/Swaybar.hs b/src/Xmobar/Text/Swaybar.hs index a2fc585..355de06 100644 --- a/src/Xmobar/Text/Swaybar.hs +++ b/src/Xmobar/Text/Swaybar.hs @@ -24,16 +24,16 @@ import Data.ByteString.Lazy.UTF8 (toString) import GHC.Generics -import Xmobar.Config.Types (Config (additionalFonts)) - -import Xmobar.Run.Parsers ( Segment - , Widget(..) - , Box(..) - , BoxBorder(..) - , FontIndex - , tBoxes - , tColorsString - , colorComponents) +import Xmobar.Config.Types ( Config (additionalFonts) + , Segment + , Widget(..) + , Box(..) + , BoxBorder(..) + , FontIndex + , tBoxes + , tColorsString) + +import Xmobar.Config.Parse (colorComponents) import Xmobar.Text.SwaybarClicks (startHandler) import Xmobar.Text.Pango (withPangoFont) diff --git a/src/Xmobar/X11/Bitmap.hs b/src/Xmobar/X11/Bitmap.hs index b14356f..c5304d9 100644 --- a/src/Xmobar/X11/Bitmap.hs +++ b/src/Xmobar/X11/Bitmap.hs @@ -2,7 +2,7 @@ ----------------------------------------------------------------------------- -- | -- Module : X11.Bitmap --- Copyright : (C) 2013, 2015, 2017, 2018, 2022 Alexander Polakov +-- Copyright : (C) 2013, 2015, 2017, 2018, 2022, 2024 Alexander Polakov -- License : BSD3 -- -- Maintainer : jao@gnu.org @@ -116,8 +116,9 @@ 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 - let w = width i + withColors d [fc, bc] $ \cs -> do + let (fc', bc') = (head cs, cs !! 1) + w = width i h = height i y' = 1 + y - fromIntegral h `div` 2 setForeground d gc fc' diff --git a/src/Xmobar/X11/Draw.hs b/src/Xmobar/X11/Draw.hs index a056136..a1ec901 100644 --- a/src/Xmobar/X11/Draw.hs +++ b/src/Xmobar/X11/Draw.hs @@ -25,7 +25,6 @@ import Foreign.C.Types as FT 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 @@ -38,11 +37,8 @@ import qualified Xmobar.X11.XRender as XRender #endif drawXBitmap :: T.XConf -> X11.GC -> X11.Pixmap -> D.IconDrawer -drawXBitmap xconf gc p h v path = do +drawXBitmap xconf gc p h v path fc bc = do let disp = T.display xconf - conf = T.config xconf - fc = C.fgColor conf - bc = C.bgColor conf case M.lookup path (T.iconCache xconf) of Just bm -> liftIO $ B.drawBitmap disp p gc fc bc (round h) (round v) bm Nothing -> return () @@ -69,7 +65,7 @@ withPixmap disp win (X11.Rectangle _ _ w h) depth action = do X11.sync disp True return res -draw :: [[P.Segment]] -> T.X [D.ActionPos] +draw :: [[C.Segment]] -> T.X [D.ActionPos] draw segments = do xconf <- ask let disp = T.display xconf @@ -89,7 +85,7 @@ draw segments = do #ifdef XRENDER color = C.bgColor conf alph = C.alpha conf - XRender.drawBackground disp p color alph (X11.Rectangle 0 0 w h) + XRender.drawBackground disp p color alph rect #endif CS.withXlibSurface disp p vis (fromIntegral w) (fromIntegral h) render diff --git a/src/Xmobar/X11/Events.hs b/src/Xmobar/X11/Events.hs index 4334f6b..fbd2bd0 100644 --- a/src/Xmobar/X11/Events.hs +++ b/src/Xmobar/X11/Events.hs @@ -1,7 +1,7 @@ ------------------------------------------------------------------------------ -- | -- Module: Xmobar.X11.Events --- Copyright: (c) 2018 Jose Antonio Ortega Ruiz +-- Copyright: (c) 2018, 2022 Jose Antonio Ortega Ruiz -- License: BSD3-style (see LICENSE) -- -- Maintainer: jao@gnu.org @@ -17,20 +17,19 @@ module Xmobar.X11.Events(nextEvent') where -import Control.Concurrent -import System.Posix.Types (Fd(..)) +import qualified Control.Concurrent as C +import qualified System.Posix.Types as T -import Graphics.X11.Xlib ( - Display(..), XEventPtr, nextEvent, pending, connectionNumber) +import qualified Graphics.X11.Xlib as X -- | A version of nextEvent that does not block in foreign calls. -nextEvent' :: Display -> XEventPtr -> IO () +nextEvent' :: X.Display -> X.XEventPtr -> IO () nextEvent' d p = do - pend <- pending d + pend <- X.pending d if pend /= 0 - then nextEvent d p + then X.nextEvent d p else do - threadWaitRead (Fd fd) + C.threadWaitRead (T.Fd fd) nextEvent' d p where - fd = connectionNumber d + fd = X.connectionNumber d diff --git a/src/Xmobar/X11/Loop.hs b/src/Xmobar/X11/Loop.hs index 599e680..2dfb34d 100644 --- a/src/Xmobar/X11/Loop.hs +++ b/src/Xmobar/X11/Loop.hs @@ -3,7 +3,7 @@ ------------------------------------------------------------------------------ -- | -- Module: Xmobar.App.X11EventLoop --- Copyright: (c) 2018, 2020, 2022 Jose Antonio Ortega Ruiz +-- Copyright: (c) 2018, 2020, 2022, 2023, 2024 Jose Antonio Ortega Ruiz -- License: BSD3-style (see LICENSE) -- -- Maintainer: jao@gnu.org @@ -22,6 +22,7 @@ import Prelude hiding (lookup) import Control.Concurrent as Concurrent import Control.Concurrent.STM as STM +import Control.Monad as MR import Control.Monad.Reader as MR import Data.Bits (Bits((.|.))) @@ -35,10 +36,10 @@ import qualified Graphics.X11.Xinerama as Xinerama import qualified Graphics.X11.Xrandr as Xrandr import qualified Xmobar.Config.Types as C +import qualified Xmobar.Config.Template as CT 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 @@ -145,15 +146,14 @@ signalLoop xc@(T.XConf d r w fs is cfg) actions signalv strs = do r' <- W.repositionWin d w (NE.head fs) rcfg signalLoop (T.XConf d r' w fs is rcfg) actions signalv strs -parseSegments :: C.Config -> STM.TVar [String] -> IO [[P.Segment]] +parseSegments :: C.Config -> STM.TVar [String] -> IO [[C.Segment]] parseSegments conf v = do s <- STM.readTVarIO v - let l:c:r:_ = s ++ repeat "" - MR.liftIO $ mapM (P.parseString conf) [l, c, r] + return $ map (CT.parseString conf) (take 3 $ s ++ repeat "") -updateIconCache :: T.XConf -> [[P.Segment]] -> IO T.XConf +updateIconCache :: T.XConf -> [[C.Segment]] -> IO T.XConf updateIconCache xc@(T.XConf d _ w _ c cfg) segs = do - let paths = [p | (P.Icon p, _, _, _) <- concat segs] + let paths = [p | (C.Icon p, _, _, _) <- concat segs] c' <- Bitmap.updateCache d w c (C.iconRoot cfg) paths return $ xc {T.iconCache = c'} diff --git a/src/Xmobar/X11/Window.hs b/src/Xmobar/X11/Window.hs index ad7ebf7..87d56f4 100644 --- a/src/Xmobar/X11/Window.hs +++ b/src/Xmobar/X11/Window.hs @@ -86,10 +86,14 @@ setPosition c p rs ht = T.Top -> X.Rectangle rx ry rw h T.TopP l r -> X.Rectangle (rx + fi l) ry (rw - fi l - fi r) h T.TopH ch -> X.Rectangle rx ry rw (mh ch) + T.TopHM ch l r t _ -> + X.Rectangle (rx + fi l) (ry + fi t) (rw - fi l - fi r) (mh ch) T.TopW a i -> X.Rectangle (ax a i) ry (nw i) h T.TopSize a i ch -> X.Rectangle (ax a i) ry (nw i) (mh ch) T.Bottom -> X.Rectangle rx ny rw h T.BottomH ch -> X.Rectangle rx (ny' ch) rw (mh ch) + T.BottomHM ch l r _ b -> + X.Rectangle (rx + fi l) (ry + fi rh - fi b - fi (mh ch)) (rw - fi l - fi r) (mh ch) T.BottomW a i -> X.Rectangle (ax a i) ny (nw i) h T.BottomP l r -> X.Rectangle (rx + fi l) ny (rw - fi l - fi r) h T.BottomSize a i ch -> X.Rectangle (ax a i) (ny' ch) (nw i) (mh ch) @@ -160,18 +164,20 @@ getRootWindowHeight srs = maximum (map getMaxScreenYCoord srs) getStrutValues :: X.Rectangle -> T.XPosition -> Int -> [Int] getStrutValues r@(X.Rectangle x y w h) p rwh = case p of - T.OnScreen _ p' -> getStrutValues r p' rwh - T.Top -> [0, 0, st, 0, 0, 0, 0, 0, nx, nw, 0, 0] - T.TopH _ -> [0, 0, st, 0, 0, 0, 0, 0, nx, nw, 0, 0] - T.TopP _ _ -> [0, 0, st, 0, 0, 0, 0, 0, nx, nw, 0, 0] - T.TopW _ _ -> [0, 0, st, 0, 0, 0, 0, 0, nx, nw, 0, 0] - T.TopSize {} -> [0, 0, st, 0, 0, 0, 0, 0, nx, nw, 0, 0] - T.Bottom -> [0, 0, 0, sb, 0, 0, 0, 0, 0, 0, nx, nw] - T.BottomH _ -> [0, 0, 0, sb, 0, 0, 0, 0, 0, 0, nx, nw] - T.BottomP _ _ -> [0, 0, 0, sb, 0, 0, 0, 0, 0, 0, nx, nw] - T.BottomW _ _ -> [0, 0, 0, sb, 0, 0, 0, 0, 0, 0, nx, nw] - T.BottomSize {} -> [0, 0, 0, sb, 0, 0, 0, 0, 0, 0, nx, nw] - T.Static {} -> getStaticStrutValues p rwh + T.OnScreen _ p' -> getStrutValues r p' rwh + T.Top -> [0, 0, st , 0 , 0, 0, 0, 0, nx, nw, 0 , 0 ] + T.TopH _ -> [0, 0, st , 0 , 0, 0, 0, 0, nx, nw, 0 , 0 ] + T.TopHM _ _ _ _ b -> [0, 0, st+b, 0 , 0, 0, 0, 0, nx, nw, 0 , 0 ] + T.TopP _ _ -> [0, 0, st , 0 , 0, 0, 0, 0, nx, nw, 0 , 0 ] + T.TopW _ _ -> [0, 0, st , 0 , 0, 0, 0, 0, nx, nw, 0 , 0 ] + T.TopSize {} -> [0, 0, st , 0 , 0, 0, 0, 0, nx, nw, 0 , 0 ] + T.Bottom -> [0, 0, 0 , sb , 0, 0, 0, 0, 0 , 0 , nx, nw] + T.BottomH _ -> [0, 0, 0 , sb , 0, 0, 0, 0, 0 , 0 , nx, nw] + T.BottomHM _ _ _ t _ -> [0, 0, 0 , sb+t, 0, 0, 0, 0, 0 , 0 , nx, nw] + T.BottomP _ _ -> [0, 0, 0 , sb , 0, 0, 0, 0, 0 , 0 , nx, nw] + T.BottomW _ _ -> [0, 0, 0 , sb , 0, 0, 0, 0, 0 , 0 , nx, nw] + T.BottomSize {} -> [0, 0, 0 , sb , 0, 0, 0, 0, 0 , 0 , nx, nw] + T.Static {} -> getStaticStrutValues p rwh where st = fi y + fi h sb = rwh - fi y nx = fi x |