From 34bb65029f0fdcb3f88043b3b0ca6ebd46bee161 Mon Sep 17 00:00:00 2001 From: jao Date: Fri, 4 Feb 2022 00:34:44 +0000 Subject: Xmobar.App.TextEventLoop -> Xmobar.Text.Loop --- src/Xmobar/App/Main.hs | 4 +- src/Xmobar/App/TextEventLoop.hs | 127 ---------------------------------------- src/Xmobar/Text/Loop.hs | 127 ++++++++++++++++++++++++++++++++++++++++ 3 files changed, 129 insertions(+), 129 deletions(-) delete mode 100644 src/Xmobar/App/TextEventLoop.hs create mode 100644 src/Xmobar/Text/Loop.hs (limited to 'src') diff --git a/src/Xmobar/App/Main.hs b/src/Xmobar/App/Main.hs index c660a88..52cdca5 100644 --- a/src/Xmobar/App/Main.hs +++ b/src/Xmobar/App/Main.hs @@ -30,12 +30,12 @@ import Xmobar.App.Config import Xmobar.Config.Types import Xmobar.Config.Parse import qualified Xmobar.X11.Loop as X11 +import qualified Xmobar.Text.Loop as Text import Xmobar.App.Opts (recompileFlag, verboseFlag, getOpts, doOpts) -import Xmobar.App.TextEventLoop (textLoop) import Xmobar.App.Compile (recompile, trace) xmobar :: Config -> IO () -xmobar cfg = if textOutput cfg then textLoop cfg else X11.loop cfg +xmobar cfg = if textOutput cfg then Text.loop cfg else X11.loop cfg configFromArgs :: Config -> IO Config configFromArgs cfg = getArgs >>= getOpts >>= doOpts cfg . fst diff --git a/src/Xmobar/App/TextEventLoop.hs b/src/Xmobar/App/TextEventLoop.hs deleted file mode 100644 index d41e1a7..0000000 --- a/src/Xmobar/App/TextEventLoop.hs +++ /dev/null @@ -1,127 +0,0 @@ ------------------------------------------------------------------------------- --- | --- Module: Xmobar.App.TextEventLoop --- Copyright: (c) 2022 Jose Antonio Ortega Ruiz --- License: BSD3-style (see LICENSE) --- --- Maintainer: jao@gnu.org --- Stability: unstable --- Portability: unportable --- Created: Fri Jan 28, 2022 01:21 --- --- --- Text-only event loop --- ------------------------------------------------------------------------------- - -module Xmobar.App.TextEventLoop (textLoop) where - -import Prelude hiding (lookup) -import Text.Printf -import System.IO -import Data.List (intercalate) - -import Control.Monad.Reader - -import Control.Concurrent.Async (Async) -import Control.Concurrent.STM - -import Xmobar.System.Signal -import Xmobar.Config.Types (Config(textOutputFormat), TextOutputFormat(..)) -import Xmobar.Run.Loop (initLoop, loop) -import Xmobar.Run.Parsers ( Segment - , Widget(..) - , parseString - , tColorsString - , colorComponents) - --- | Starts the main event loop and threads -textLoop :: Config -> IO () -textLoop conf = loop conf (startTextLoop' conf) - -startTextLoop' :: Config - -> TMVar SignalType - -> TMVar () - -> [[([Async ()], TVar String)]] - -> IO () -startTextLoop' cfg sig pauser vs = do - hSetBuffering stdin LineBuffering - hSetBuffering stdout LineBuffering - tv <- initLoop sig pauser vs - eventLoop cfg tv sig - --- | Continuously wait for a signal from a thread or a interrupt handler -eventLoop :: Config -> TVar [String] -> TMVar SignalType -> IO () -eventLoop cfg tv signal = do - typ <- atomically $ takeTMVar signal - case typ of - Wakeup -> updateString cfg tv >>= putStrLn >> eventLoop cfg tv signal - _ -> eventLoop cfg tv signal - -updateString :: Config -> TVar [String] -> IO String -updateString conf v = do - s <- readTVarIO v - let l:c:r:_ = s ++ repeat "" - liftIO $ concat `fmap` mapM (parseStringAsText conf) [l, c, r] - -asInt :: String -> String -asInt x = case (reads $ "0x" ++ x) :: [(Integer, String)] of - [(v, "") ] -> show v - _ -> "" - -namedColor :: String -> String -namedColor c = - case c of - "black" -> "0"; "red" -> "1"; "green" -> "2"; "yellow" -> "3"; "blue" -> "4"; - "magenta" -> "5"; "cyan" -> "6"; "white" -> "7"; _ -> "" - -ansiCode :: String -> String -ansiCode ('#':r:g:[b]) = ansiCode ['#', '0', r, '0', g, '0', b] -ansiCode ('#':r0:r1:g0:g1:b0:[b1]) = - "2;" ++ intercalate ";" (map asInt [[r0,r1], [g0,g1], [b0,b1]]) -ansiCode ('#':n) = ansiCode n -ansiCode c = "5;" ++ if null i then namedColor c else i where i = asInt c - -withAnsiColor :: (String, String) -> String -> String -withAnsiColor (fg, bg) s = wrap "38;" fg (wrap "48;" bg s) - where wrap cd cl w = - if null cl - then w - else "\x1b[" ++ cd ++ ansiCode cl ++ "m" ++ w ++ "\x1b[0m" - -replaceAll :: (Eq a) => a -> [a] -> [a] -> [a] -replaceAll c s = concatMap (\x -> if x == c then s else [x]) - -xmlEscape :: String -> String -xmlEscape s = replaceAll '"' """ $ - replaceAll '\'' "'" $ - replaceAll '<' "<" $ - replaceAll '>' ">" $ - replaceAll '&' "&" s - -withPangoColor :: (String, String) -> String -> String -withPangoColor (fg, bg) s = - printf fmt (xmlEscape fg) (xmlEscape bg) (xmlEscape s) - where fmt = "%s" - -withColor :: TextOutputFormat -> (String, String) -> String -> String -withColor format color = case format of - Plain -> id - Ansi -> withAnsiColor color - Pango -> withPangoColor color - - -asText :: Config -> Segment -> String -asText conf (Text s, info, _, _) = - withColor (textOutputFormat conf) components s - where components = colorComponents conf color - color = tColorsString info -asText colors (Hspace n, i, x, y) = - asText colors (Text $ replicate (fromIntegral n) ' ', i, x, y) -asText _ _ = "" - -parseStringAsText :: Config -> String -> IO String -parseStringAsText c s = do - segments <- parseString c s - let txts = map (asText c) segments - return (concat txts) diff --git a/src/Xmobar/Text/Loop.hs b/src/Xmobar/Text/Loop.hs new file mode 100644 index 0000000..244c165 --- /dev/null +++ b/src/Xmobar/Text/Loop.hs @@ -0,0 +1,127 @@ +------------------------------------------------------------------------------ +-- | +-- Module: Xmobar.Text.Loop +-- Copyright: (c) 2022 Jose Antonio Ortega Ruiz +-- License: BSD3-style (see LICENSE) +-- +-- Maintainer: jao@gnu.org +-- Stability: unstable +-- Portability: unportable +-- Created: Fri Jan 28, 2022 01:21 +-- +-- +-- Text-only event loop +-- +------------------------------------------------------------------------------ + +module Xmobar.Text.Loop (loop) where + +import Prelude hiding (lookup) +import Text.Printf +import System.IO +import Data.List (intercalate) + +import Control.Monad.Reader + +import Control.Concurrent.Async (Async) +import Control.Concurrent.STM + +import Xmobar.System.Signal +import Xmobar.Config.Types (Config(textOutputFormat), TextOutputFormat(..)) +import qualified Xmobar.Run.Loop as Loop +import Xmobar.Run.Parsers ( Segment + , Widget(..) + , parseString + , tColorsString + , colorComponents) + +-- | Starts the main event loop and threads +loop :: Config -> IO () +loop conf = Loop.loop conf (startTextLoop' conf) + +startTextLoop' :: Config + -> TMVar SignalType + -> TMVar () + -> [[([Async ()], TVar String)]] + -> IO () +startTextLoop' cfg sig pauser vs = do + hSetBuffering stdin LineBuffering + hSetBuffering stdout LineBuffering + tv <- Loop.initLoop sig pauser vs + eventLoop cfg tv sig + +-- | Continuously wait for a signal from a thread or a interrupt handler +eventLoop :: Config -> TVar [String] -> TMVar SignalType -> IO () +eventLoop cfg tv signal = do + typ <- atomically $ takeTMVar signal + case typ of + Wakeup -> updateString cfg tv >>= putStrLn >> eventLoop cfg tv signal + _ -> eventLoop cfg tv signal + +updateString :: Config -> TVar [String] -> IO String +updateString conf v = do + s <- readTVarIO v + let l:c:r:_ = s ++ repeat "" + liftIO $ concat `fmap` mapM (parseStringAsText conf) [l, c, r] + +asInt :: String -> String +asInt x = case (reads $ "0x" ++ x) :: [(Integer, String)] of + [(v, "") ] -> show v + _ -> "" + +namedColor :: String -> String +namedColor c = + case c of + "black" -> "0"; "red" -> "1"; "green" -> "2"; "yellow" -> "3"; "blue" -> "4"; + "magenta" -> "5"; "cyan" -> "6"; "white" -> "7"; _ -> "" + +ansiCode :: String -> String +ansiCode ('#':r:g:[b]) = ansiCode ['#', '0', r, '0', g, '0', b] +ansiCode ('#':r0:r1:g0:g1:b0:[b1]) = + "2;" ++ intercalate ";" (map asInt [[r0,r1], [g0,g1], [b0,b1]]) +ansiCode ('#':n) = ansiCode n +ansiCode c = "5;" ++ if null i then namedColor c else i where i = asInt c + +withAnsiColor :: (String, String) -> String -> String +withAnsiColor (fg, bg) s = wrap "38;" fg (wrap "48;" bg s) + where wrap cd cl w = + if null cl + then w + else "\x1b[" ++ cd ++ ansiCode cl ++ "m" ++ w ++ "\x1b[0m" + +replaceAll :: (Eq a) => a -> [a] -> [a] -> [a] +replaceAll c s = concatMap (\x -> if x == c then s else [x]) + +xmlEscape :: String -> String +xmlEscape s = replaceAll '"' """ $ + replaceAll '\'' "'" $ + replaceAll '<' "<" $ + replaceAll '>' ">" $ + replaceAll '&' "&" s + +withPangoColor :: (String, String) -> String -> String +withPangoColor (fg, bg) s = + printf fmt (xmlEscape fg) (xmlEscape bg) (xmlEscape s) + where fmt = "%s" + +withColor :: TextOutputFormat -> (String, String) -> String -> String +withColor format color = case format of + Plain -> id + Ansi -> withAnsiColor color + Pango -> withPangoColor color + + +asText :: Config -> Segment -> String +asText conf (Text s, info, _, _) = + withColor (textOutputFormat conf) components s + where components = colorComponents conf color + color = tColorsString info +asText colors (Hspace n, i, x, y) = + asText colors (Text $ replicate (fromIntegral n) ' ', i, x, y) +asText _ _ = "" + +parseStringAsText :: Config -> String -> IO String +parseStringAsText c s = do + segments <- parseString c s + let txts = map (asText c) segments + return (concat txts) -- cgit v1.2.3