Refactoring of the previous patch and its surroundings

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,16 +75,12 @@ 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
     handler thing (SomeException e) =
@@ -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 <jao@gnu.org>
 -- 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 "<raw="
   lenstr <- many1 digit
@@ -144,22 +141,19 @@ notFollowedBy' p e = do x <- p
                         notFollowedBy $ try (e >> 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 "<icon="
   i <- manyTill (noneOf ">") (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 "<hspace="
   pVal <- manyTill digit (try (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 "<action="
   command <- choice [between (char '`') (char '`') (many1 (noneOf "`")),
@@ -177,8 +171,7 @@ toButtons :: 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 "<fc=") (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 "<box") (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 "<fn=") (string ">") colors
   s <- manyTill (allParsers c (fromMaybe 0 $ readMaybe f) a) (try $ string "</fn>")