1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
|
------------------------------------------------------------------------------
-- |
-- 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.X11.Parsers (Segment, Widget(..), parseString, tColorsString, colorComponents)
import Xmobar.App.CommandThreads (initLoop, loop)
-- | 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 = "<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)
|
