From 23399ceab6ca3fe9938cf97b7aa726258512be98 Mon Sep 17 00:00:00 2001 From: jao Date: Sat, 29 Jan 2022 01:59:17 +0000 Subject: Refactoring of the previous patch and its surroundings --- src/Xmobar/App/CommandThreads.hs | 82 +++++++++++++++++++++++++++++++++++++--- src/Xmobar/App/EventLoop.hs | 31 +-------------- src/Xmobar/App/Main.hs | 55 ++++++--------------------- src/Xmobar/App/TextEventLoop.hs | 53 ++++++++------------------ src/Xmobar/X11/Draw.hs | 6 +-- src/Xmobar/X11/Parsers.hs | 55 +++++++++++---------------- 6 files changed, 129 insertions(+), 153 deletions(-) diff --git a/src/Xmobar/App/CommandThreads.hs b/src/Xmobar/App/CommandThreads.hs index 1de2936..931a072 100644 --- a/src/Xmobar/App/CommandThreads.hs +++ b/src/Xmobar/App/CommandThreads.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} + ------------------------------------------------------------------------------ -- | -- Module: Xmobar.App.CommandThreads @@ -14,18 +16,29 @@ -- ------------------------------------------------------------------------------ -module Xmobar.App.CommandThreads ( startCommand +module Xmobar.App.CommandThreads ( initLoop + , loop , newRefreshLock - , refreshLock - , refreshLockT) where + , refreshLock) where +import Control.Concurrent (forkIO) +import Control.Exception (bracket_, bracket, handle, SomeException(..)) import Control.Concurrent.STM -import Control.Concurrent.Async (Async, async) -import Control.Exception (bracket_) +import Control.Concurrent.Async (Async, async, cancel) +import Control.Monad (guard, void, unless) +import Data.Maybe (isJust) +import Data.Foldable (for_) -import Xmobar.System.Signal (SignalType) +import Xmobar.System.Signal +import Xmobar.Config.Types import Xmobar.Run.Runnable (Runnable) import Xmobar.Run.Exec (start, trigger, alias) +import Xmobar.Run.Template +import Xmobar.App.Timer (withTimer) + +#ifdef DBUS +import Xmobar.System.DBus +#endif newRefreshLock :: IO (TMVar ()) newRefreshLock = newTMVarIO () @@ -43,6 +56,45 @@ refreshLockT var action = do putTMVar var () return r +type StartFunction = TMVar SignalType + -> TMVar () + -> [[([Async ()], TVar String)]] + -> IO () + +loop :: Config -> StartFunction -> IO () +loop conf starter = withDeferSignals $ do + cls <- mapM (parseTemplate (commands conf) (sepChar conf)) + (splitTemplate (alignSep conf) (template conf)) + let confSig = unSignalChan (signal conf) + sig <- maybe newEmptyTMVarIO pure confSig + unless (isJust confSig) $ setupSignalHandler sig + refLock <- newRefreshLock + withTimer (refreshLock refLock) $ + bracket (mapM (mapM $ startCommand sig) cls) + cleanupThreads + $ \vars -> do + starter sig refLock vars + +cleanupThreads :: [[([Async ()], a)]] -> IO () +cleanupThreads vars = + for_ (concat vars) $ \(asyncs, _) -> + for_ asyncs cancel + +-- | Initialises context for an event loop, returning a TVar that +-- will hold the current list of values computed by commands. +initLoop :: TMVar SignalType -> TMVar () -> [[([Async ()], TVar String)]] + -> IO (TVar [String]) +initLoop sig lock vs = do + tv <- newTVarIO ([] :: [String]) + _ <- forkIO (handle (handler "checker") (checker tv [] vs sig lock)) +#ifdef DBUS + runIPC sig +#endif + return tv + where + handler thing (SomeException e) = + void $ putStrLn ("Thread " ++ thing ++ " failed: " ++ show e) + -- | Runs a command as an independent thread and returns its Async handles -- and the TVar the command will be writing to. startCommand :: TMVar SignalType @@ -59,3 +111,21 @@ startCommand sig (com,s,ss) (atomically . putTMVar sig) return ([a1, a2], var) where is = s ++ "Updating..." ++ ss + +-- | Send signal to eventLoop every time a var is updated +checker :: TVar [String] + -> [String] + -> [[([Async ()], TVar String)]] + -> TMVar SignalType + -> TMVar () + -> IO () +checker tvar ov vs sig pauser = do + nval <- atomically $ refreshLockT pauser $ do + nv <- mapM concatV vs + guard (nv /= ov) + writeTVar tvar nv + return nv + atomically $ putTMVar sig Wakeup + checker tvar nval vs sig pauser + where + concatV = fmap concat . mapM (readTVar . snd) diff --git a/src/Xmobar/App/EventLoop.hs b/src/Xmobar/App/EventLoop.hs index 1764b1d..b1bd3ff 100644 --- a/src/Xmobar/App/EventLoop.hs +++ b/src/Xmobar/App/EventLoop.hs @@ -52,7 +52,7 @@ import Xmobar.X11.Bitmap as Bitmap import Xmobar.X11.Types import Xmobar.System.Utils (safeIndex) -import Xmobar.App.CommandThreads (refreshLockT) +import Xmobar.App.CommandThreads (initLoop) #ifndef THREADED_RUNTIME import Xmobar.X11.Events(nextEvent') @@ -62,10 +62,6 @@ import Xmobar.X11.Events(nextEvent') import Graphics.X11.Xft #endif -#ifdef DBUS -import Xmobar.System.DBus -#endif - runX :: XConf -> X () -> IO () runX xc f = runReaderT f xc @@ -79,15 +75,11 @@ startLoop xcfg@(XConf _ _ w _ _ _ _) sig pauser vs = do #ifdef XFT xftInitFtLibrary #endif - tv <- newTVarIO [] - _ <- forkIO (handle (handler "checker") (checker tv [] vs sig pauser)) + tv <- initLoop sig pauser vs #ifdef THREADED_RUNTIME _ <- forkOS (handle (handler "eventer") (eventer sig)) #else _ <- forkIO (handle (handler "eventer") (eventer sig)) -#endif -#ifdef DBUS - runIPC sig #endif eventLoop tv xcfg [] sig where @@ -115,25 +107,6 @@ startLoop xcfg@(XConf _ _ w _ _ _ _) sig pauser vs = do putTMVar signal (Action (ev_button ev) (fi $ ev_x ev)) _ -> return () --- | Send signal to eventLoop every time a var is updated -checker :: TVar [String] - -> [String] - -> [[([Async ()], TVar String)]] - -> TMVar SignalType - -> TMVar () - -> IO () -checker tvar ov vs signal pauser = do - nval <- atomically $ refreshLockT pauser $ do - nv <- mapM concatV vs - guard (nv /= ov) - writeTVar tvar nv - return nv - atomically $ putTMVar signal Wakeup - checker tvar nval vs signal pauser - where - concatV = fmap concat . mapM (readTVar . snd) - - -- | Continuously wait for a signal from a thread or a interrupt handler eventLoop :: TVar [String] -> XConf diff --git a/src/Xmobar/App/Main.hs b/src/Xmobar/App/Main.hs index ead3249..7bcf3bd 100644 --- a/src/Xmobar/App/Main.hs +++ b/src/Xmobar/App/Main.hs @@ -17,37 +17,30 @@ module Xmobar.App.Main (xmobar, xmobarMain, configFromArgs) where -import Control.Concurrent.Async (Async, cancel) -import Control.Concurrent.STM (newEmptyTMVarIO) -import Control.Exception (bracket) -import Control.Monad (unless) - -import Data.Foldable (for_) import qualified Data.Map as Map import Data.List (intercalate) -import Data.Maybe (isJust) import System.Posix.Process (executeFile) import System.Environment (getArgs) import System.FilePath ((), takeBaseName, takeDirectory, takeExtension) import Text.Parsec.Error (ParseError) import Data.List.NonEmpty (NonEmpty(..)) +import Control.Monad (unless) import Graphics.X11.Xlib import Xmobar.Config.Types import Xmobar.Config.Parse -import Xmobar.System.Signal (setupSignalHandler, withDeferSignals) -import Xmobar.Run.Template +import Xmobar.System.Signal (withDeferSignals) + import Xmobar.X11.Types import Xmobar.X11.Text import Xmobar.X11.Window import Xmobar.App.Opts (recompileFlag, verboseFlag, getOpts, doOpts) -import Xmobar.App.CommandThreads (startCommand, newRefreshLock, refreshLock) +import Xmobar.App.CommandThreads (loop) import Xmobar.App.EventLoop (startLoop) import Xmobar.App.TextEventLoop (startTextLoop) import Xmobar.App.Compile (recompile, trace) import Xmobar.App.Config -import Xmobar.App.Timer (withTimer) xXmobar :: Config -> IO () xXmobar conf = withDeferSignals $ do @@ -55,36 +48,15 @@ xXmobar conf = withDeferSignals $ do d <- openDisplay "" fs <- initFont d (font conf) fl <- mapM (initFont d) (additionalFonts conf) - cls <- mapM (parseTemplate (commands conf) (sepChar conf)) - (splitTemplate (alignSep conf) (template conf)) - let confSig = unSignalChan (signal conf) - sig <- maybe newEmptyTMVarIO pure confSig - unless (isJust confSig) $ setupSignalHandler sig - refLock <- newRefreshLock - withTimer (refreshLock refLock) $ - bracket (mapM (mapM $ startCommand sig) cls) - cleanupThreads - $ \vars -> do - (r,w) <- createWin d fs conf - let ic = Map.empty - to = textOffset conf - ts = textOffsets conf ++ replicate (length fl) (-1) - startLoop (XConf d r w (fs :| fl) (to :| ts) ic conf) sig refLock vars + let ic = Map.empty + to = textOffset conf + ts = textOffsets conf ++ replicate (length fl) (-1) + loop conf $ \sig lock vars -> do + (r,w) <- createWin d fs conf + startLoop (XConf d r w (fs :| fl) (to :| ts) ic conf) sig lock vars textXmobar :: Config -> IO () -textXmobar conf = withDeferSignals $ do - initThreads - cls <- mapM (parseTemplate (commands conf) (sepChar conf)) - (splitTemplate (alignSep conf) (template conf)) - let confSig = unSignalChan (signal conf) - sig <- maybe newEmptyTMVarIO pure confSig - unless (isJust confSig) $ setupSignalHandler sig - refLock <- newRefreshLock - withTimer (refreshLock refLock) $ - bracket (mapM (mapM $ startCommand sig) cls) - cleanupThreads - $ \vars -> do - startTextLoop conf sig refLock vars +textXmobar conf = loop conf (startTextLoop conf) xmobar :: Config -> IO () xmobar cfg = if textOutput cfg then textXmobar cfg else xXmobar cfg @@ -92,11 +64,6 @@ xmobar cfg = if textOutput cfg then textXmobar cfg else xXmobar cfg configFromArgs :: Config -> IO Config configFromArgs cfg = getArgs >>= getOpts >>= doOpts cfg . fst -cleanupThreads :: [[([Async ()], a)]] -> IO () -cleanupThreads vars = - for_ (concat vars) $ \(asyncs, _) -> - for_ asyncs cancel - buildLaunch :: [String] -> Bool -> Bool -> String -> ParseError -> IO () buildLaunch args verb force p e = do let exec = takeBaseName p diff --git a/src/Xmobar/App/TextEventLoop.hs b/src/Xmobar/App/TextEventLoop.hs index 50ee17c..6135554 100644 --- a/src/Xmobar/App/TextEventLoop.hs +++ b/src/Xmobar/App/TextEventLoop.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE CPP #-} - ------------------------------------------------------------------------------ -- | -- Module: Xmobar.App.TextEventLoop @@ -21,21 +19,14 @@ module Xmobar.App.TextEventLoop (startTextLoop) where import Prelude hiding (lookup) import Control.Monad.Reader -import Control.Concurrent + import Control.Concurrent.Async (Async) import Control.Concurrent.STM -import Control.Exception (handle, SomeException(..)) import Xmobar.System.Signal import Xmobar.Config.Types (Config) - -import Xmobar.X11.Parsers (parseStringAsText) - -import Xmobar.App.CommandThreads (refreshLockT) - -#ifdef DBUS -import Xmobar.System.DBus -#endif +import Xmobar.X11.Parsers (Segment, Widget(..), parseString) +import Xmobar.App.CommandThreads (initLoop) -- | Starts the main event loop and threads startTextLoop :: Config @@ -44,33 +35,8 @@ startTextLoop :: Config -> [[([Async ()], TVar String)]] -> IO () startTextLoop cfg sig pauser vs = do - tv <- newTVarIO [] - _ <- forkIO (handle (handler "checker") (checker tv [] vs sig pauser)) -#ifdef DBUS - runIPC sig -#endif + tv <- initLoop sig pauser vs eventLoop cfg tv sig - where - handler thing (SomeException e) = - void $ putStrLn ("Thread " ++ thing ++ " failed: " ++ show e) - --- | Send signal to eventLoop every time a var is updated -checker :: TVar [String] - -> [String] - -> [[([Async ()], TVar String)]] - -> TMVar SignalType - -> TMVar () - -> IO () -checker tvar ov vs signal pauser = do - nval <- atomically $ refreshLockT pauser $ do - nv <- mapM concatV vs - guard (nv /= ov) - writeTVar tvar nv - return nv - atomically $ putTMVar signal Wakeup - checker tvar nval vs signal pauser - where - concatV = fmap concat . mapM (readTVar . snd) -- | Continuously wait for a signal from a thread or a interrupt handler eventLoop :: Config -> TVar [String] -> TMVar SignalType -> IO () @@ -85,3 +51,14 @@ updateString conf v = do s <- readTVarIO v let l:c:r:_ = s ++ repeat "" liftIO $ concat `fmap` mapM (parseStringAsText conf) [l, c, r] + +asText :: Segment -> String +asText (Text s, _, _, _) = s +asText (Hspace n, _, _, _) = replicate (fromIntegral n) ' ' +asText _ = "" + +parseStringAsText :: Config -> String -> IO String +parseStringAsText c s = do + segments <- parseString c s + let txts = map asText segments + return (concat txts) diff --git a/src/Xmobar/X11/Draw.hs b/src/Xmobar/X11/Draw.hs index 1b3d4ee..129701b 100644 --- a/src/Xmobar/X11/Draw.hs +++ b/src/Xmobar/X11/Draw.hs @@ -4,7 +4,7 @@ ------------------------------------------------------------------------------ -- | -- Module: Xmobar.X11.Draw --- Copyright: (c) 2018, 2020 Jose Antonio Ortega Ruiz +-- Copyright: (c) 2018, 2020, 2022 Jose Antonio Ortega Ruiz -- License: BSD3-style (see LICENSE) -- -- Maintainer: jao@gnu.org @@ -149,9 +149,7 @@ printStrings dr gc fontlist voffs offs a boxes sl@((s,c,i,l):xs) = do C -> (remWidth + offs) `div` 2 R -> remWidth L -> offs - (fc,bc) = case break (==',') (tColorsString c) of - (f,',':b) -> (f, b ) - (f, _) -> (f, bgColor conf) + (fc,bc) = colorComponents conf (tColorsString c) valign <- verticalOffset ht s fontst voff conf let (ht',ay) = case (tBgTopOffset c, tBgBottomOffset c) of (-1,_) -> (0, -1) diff --git a/src/Xmobar/X11/Parsers.hs b/src/Xmobar/X11/Parsers.hs index 34d4336..0119208 100644 --- a/src/Xmobar/X11/Parsers.hs +++ b/src/Xmobar/X11/Parsers.hs @@ -2,20 +2,21 @@ ----------------------------------------------------------------------------- -- | --- Module : Xmobar.Parsers +-- Module : Xmobar.X11.Parsers -- Copyright : (c) Andrea Rossato -- License : BSD-style (see LICENSE) -- -- Maintainer : Jose A. Ortega Ruiz -- Stability : unstable --- Portability : unportable +-- Portability : portable -- -- Parsing for template substrings -- ----------------------------------------------------------------------------- module Xmobar.X11.Parsers ( parseString - , parseStringAsText + , colorComponents + , Segment , Box(..) , BoxBorder(..) , BoxOffset(..) @@ -56,9 +57,10 @@ data TextRenderInfo = } deriving Show type FontIndex = Int +type Segment = (Widget, TextRenderInfo, FontIndex, Maybe [Action]) + -- | Runs the string parser -parseString :: Config -> String - -> IO [(Widget, TextRenderInfo, FontIndex, Maybe [Action])] +parseString :: Config -> String -> IO [Segment] parseString c s = case parse (stringParser ci 0 Nothing) "" s of Left _ -> return [(Text $ "Could not parse string: " ++ s @@ -68,20 +70,17 @@ parseString c s = Right x -> return (concat x) where ci = TextRenderInfo (fgColor c) 0 0 [] -asText :: (Widget, TextRenderInfo, FontIndex, Maybe [Action]) -> String -asText (Text s, _, _, _) = s -asText _ = "" - -parseStringAsText :: Config -> String -> IO String -parseStringAsText c s = do - chunks <- parseString c s - let txts = map asText chunks - return (concat txts) +-- | 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 [(Widget, TextRenderInfo, FontIndex, Maybe [Action])] + -> Parser [Segment] allParsers c f a = textParser c f a <|> try (iconParser c f a) <|> try (hspaceParser c f a) @@ -92,13 +91,11 @@ allParsers c f a = textParser c f a <|> colorParser c f a -- | Gets the string and combines the needed parsers -stringParser :: TextRenderInfo -> FontIndex -> Maybe [Action] - -> Parser [[(Widget, TextRenderInfo, FontIndex, Maybe [Action])]] +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 [(Widget, TextRenderInfo, FontIndex, Maybe [Action])] +textParser :: TextRenderInfo -> FontIndex -> Maybe [Action] -> Parser [Segment] textParser c f a = do s <- many1 $ noneOf "<" <|> try (notFollowedBy' (char '<') @@ -123,7 +120,7 @@ textParser c f a = do s <- many1 $ rawParser :: TextRenderInfo -> FontIndex -> Maybe [Action] - -> Parser [(Widget, TextRenderInfo, FontIndex, Maybe [Action])] + -> Parser [Segment] rawParser c f a = do string "> return '*') return x -iconParser :: TextRenderInfo -> FontIndex -> Maybe [Action] - -> Parser [(Widget, TextRenderInfo, FontIndex, Maybe [Action])] +iconParser :: TextRenderInfo -> FontIndex -> Maybe [Action] -> Parser [Segment] iconParser c f a = do string "") (try (string "/>")) return [(Icon i, c, f, a)] -hspaceParser :: TextRenderInfo -> FontIndex -> Maybe [Action] - -> Parser [(Widget, TextRenderInfo, FontIndex, Maybe [Action])] +hspaceParser :: TextRenderInfo -> FontIndex -> Maybe [Action] -> Parser [Segment] hspaceParser c f a = do string "")) return [(Hspace (fromMaybe 0 $ readMaybe pVal), c, f, a)] -actionParser :: TextRenderInfo -> FontIndex -> Maybe [Action] - -> Parser [(Widget, TextRenderInfo, FontIndex, Maybe [Action])] +actionParser :: TextRenderInfo -> FontIndex -> Maybe [Action] -> Parser [Segment] actionParser c f act = do string " [Button] toButtons = map (\x -> read [x]) -- | Parsers a string wrapped in a color specification. -colorParser :: TextRenderInfo -> FontIndex -> Maybe [Action] - -> Parser [(Widget, TextRenderInfo, FontIndex, Maybe [Action])] +colorParser :: TextRenderInfo -> FontIndex -> Maybe [Action] -> Parser [Segment] colorParser (TextRenderInfo _ _ _ bs) f a = do c <- between (string "") colors let colorParts = break (==':') c @@ -191,8 +184,7 @@ colorParser (TextRenderInfo _ _ _ bs) f a = do return (concat s) -- | Parses a string wrapped in a box specification. -boxParser :: TextRenderInfo -> FontIndex -> Maybe [Action] - -> Parser [(Widget, TextRenderInfo, FontIndex, Maybe [Action])] +boxParser :: TextRenderInfo -> FontIndex -> Maybe [Action] -> Parser [Segment] boxParser (TextRenderInfo cs ot ob bs) f a = do c <- between (string "") (option "" (many1 (alphaNum <|> char '=' <|> char ' ' <|> char '#' <|> char ','))) let b = Box BBFull (BoxOffset C 0) 1 cs (BoxMargins 0 0 0 0) @@ -231,8 +223,7 @@ boxParamReader (Box bb off lw fc mgs@(BoxMargins mt mr mb ml)) ('m':pos) val = d boxParamReader b _ _ = b -- | Parsers a string wrapped in a font specification. -fontParser :: TextRenderInfo -> Maybe [Action] - -> Parser [(Widget, TextRenderInfo, FontIndex, Maybe [Action])] +fontParser :: TextRenderInfo -> Maybe [Action] -> Parser [Segment] fontParser c a = do f <- between (string "") colors s <- manyTill (allParsers c (fromMaybe 0 $ readMaybe f) a) (try $ string "") -- cgit v1.2.3