summaryrefslogtreecommitdiffhomepage
path: root/src/Xmobar/Text
diff options
context:
space:
mode:
Diffstat (limited to 'src/Xmobar/Text')
-rw-r--r--src/Xmobar/Text/Loop.hs127
1 files changed, 127 insertions, 0 deletions
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 '"' "&quot;" $
+ replaceAll '\'' "&apos;" $
+ replaceAll '<' "&lt;" $
+ replaceAll '>' "&gt;" $
+ replaceAll '&' "&amp;" s
+
+withPangoColor :: (String, String) -> String -> String
+withPangoColor (fg, bg) s =
+ printf fmt (xmlEscape fg) (xmlEscape bg) (xmlEscape s)
+ where fmt = "<span foreground=\"%s\" background=\"%s\">%s</span>"
+
+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)