qbar/src/QBar/Theme.hs

+module QBar.Theme (
+  Theme(..),
+  ThemedBlockOutput(..),
+  ThemedBlockText(..),
+  ThemedBlockTextSegment(..),
+  defaultTheme,
+  findTheme,
+  isAnimated,
+  mkTheme,
+  mkThemedBlockOutput,
+  themeNames,
+  themes,
+  whiteThemedBlockOutput,
+) where
+
+import QBar.BlockOutput
+import QBar.Color
+import QBar.Prelude
+
+import Control.Applicative ((<|>))
+import Control.Lens ((^.))
+import Control.Monad.State.Lazy (State, evalState, get, put)
+import Data.Colour.RGBSpace
+import Data.Colour.RGBSpace.HSV (hsv)
+import Data.HashMap.Lazy qualified as HM
+import Data.Maybe (fromMaybe)
+import Data.Text.Lazy qualified as T
+import Data.Time.Clock.POSIX (getPOSIXTime)
+import Pipes
+
+
+data ThemedBlockOutput = ThemedBlockOutput {
+    _fullText :: ThemedBlockText,
+    _shortText :: Maybe ThemedBlockText,
+    _blockName :: Maybe T.Text
+  }
+  deriving (Eq, Show)
+
+newtype ThemedBlockText = ThemedBlockText [ThemedBlockTextSegment]
+  deriving (Eq, Show)
+instance Semigroup ThemedBlockText where
+  (ThemedBlockText a) <> (ThemedBlockText b) = ThemedBlockText (a <> b)
+instance Monoid ThemedBlockText where
+  mempty = ThemedBlockText []
+
+data ThemedBlockTextSegment = ThemedBlockTextSegment {
+    themedSegmentText :: T.Text,
+    color :: Color,
+    backgroundColor :: Maybe Color
+  }
+  deriving (Eq, Show)
+
+data Theme = StaticTheme StaticTheme | AnimatedTheme AnimatedTheme
+
+type StaticTheme = [BlockOutput] -> [ThemedBlockOutput]
+type SimplifiedTheme = Bool -> Importance -> (Color, Maybe Color)
+type AnimatedTheme = forall r. Pipe [BlockOutput] [ThemedBlockOutput] IO r
+
+isAnimated :: Theme -> Bool
+isAnimated (AnimatedTheme _) = True
+isAnimated _ = False
+
+
+themesList :: [(Text, Theme)]
+themesList = [
+    ("default", defaultTheme),
+    ("rainbow", rainbowTheme)
+  ]
+
+themeNames :: [Text]
+themeNames = map fst themesList
+
+themes :: HM.HashMap Text Theme
+themes = HM.fromList themesList
+
+
+findTheme :: Text -> Either Text Theme
+findTheme themeName = maybe invalidThemeName Right $ HM.lookup themeName themes
+  where
+    invalidThemeName :: Either Text Theme
+    invalidThemeName = Left $ "Invalid theme: " <> themeName
+
+mkTheme :: SimplifiedTheme -> Theme
+mkTheme theming' = StaticTheme $ map themeBlock
+  where
+    themeBlock :: BlockOutput -> ThemedBlockOutput
+    themeBlock block@BlockOutput{_blockName} = ThemedBlockOutput{_fullText = fullText', _shortText = shortText', _blockName}
+      where
+        theming :: SimplifiedTheme
+        theming
+          | block ^. invalid = invalidSimplifiedTheme
+          | otherwise = theming'
+        fullText' :: ThemedBlockText
+        fullText' = themeBlockText theming $ block ^. fullText
+        shortText' :: Maybe ThemedBlockText
+        shortText' = themeBlockText theming <$> block ^. shortText
+    themeBlockText :: SimplifiedTheme -> BlockText -> ThemedBlockText
+    themeBlockText theming (BlockText b) = ThemedBlockText $ themeSegment theming <$> b
+    themeSegment :: SimplifiedTheme -> BlockTextSegment -> ThemedBlockTextSegment
+    themeSegment theming BlockTextSegment {active, importance, segmentText} = mkThemedSegment (theming active importance) segmentText
+    themeSegment theming StyledBlockTextSegment {color, backgroundColor, segmentText} = mkThemedSegment (themedColor, themedBackgroundColor) segmentText
+      where
+        themedColor :: Color
+        themedColor = fromMaybe normalThemedColor color
+        themedBackgroundColor :: Maybe Color
+        themedBackgroundColor = backgroundColor <|> normalThemedBackground
+        (normalThemedColor, normalThemedBackground) = theming False normalImportant
+
+mkThemedBlockOutput :: (Color, Maybe Color) -> Text -> ThemedBlockOutput
+mkThemedBlockOutput color text = ThemedBlockOutput {
+  _fullText = mkThemedText color text,
+  _shortText = Nothing,
+  _blockName = Nothing
+}
+
+mkThemedText :: (Color, Maybe Color) -> Text -> ThemedBlockText
+mkThemedText color text = ThemedBlockText [mkThemedSegment color text]
+
+mkThemedSegment :: (Color, Maybe Color) -> Text -> ThemedBlockTextSegment
+mkThemedSegment (color, backgroundColor) text = ThemedBlockTextSegment{themedSegmentText=text, color, backgroundColor}
+
+whiteThemedBlockOutput :: Text -> ThemedBlockOutput
+whiteThemedBlockOutput = mkThemedBlockOutput (ColorRGB (RGB 1 1 1), Nothing)
+
+invalidColor :: Color
+invalidColor = ColorRGBA (RGB (0x96 / 255) (0x98 / 255) (0x96 / 255)) (0x77 / 255)
+
+invalidSimplifiedTheme :: SimplifiedTheme
+invalidSimplifiedTheme _ _ = (invalidColor, Nothing)
+
+defaultTheme :: Theme
+defaultTheme = mkTheme defaultTheme'
+  where
+    defaultTheme' :: SimplifiedTheme
+    defaultTheme' True (CriticalImportant _) = (ColorRGB (RGB 0 0 0), Just $ ColorRGB (RGB 1 0 0))
+    defaultTheme' False (CriticalImportant _) = (ColorRGB (RGB 0.8 0.15 0.15), Nothing)
+    defaultTheme' True (ErrorImportant _) = (ColorRGB (RGB 1 0.3 0), Nothing)
+    defaultTheme' False (ErrorImportant _) = (ColorRGB (RGB 0.7 0.35 0.2), Nothing)
+    defaultTheme' True (WarnImportant _) = (ColorRGB (RGB 1 0.9 0), Nothing)
+    defaultTheme' False (WarnImportant _) = (ColorRGB (RGB 0.6 0.6 0), Nothing)
+    defaultTheme' True (NormalImportant _) = (ColorRGB (RGB 1 1 1), Nothing)
+    defaultTheme' False (NormalImportant _) = (ColorRGB (RGB (0x96 / 255) (0x98 / 255) (0x96 / 255)), Nothing)
+
+rainbowTheme :: Theme
+rainbowTheme = AnimatedTheme rainbowThemePipe
+  where
+    rainbowThemePipe :: AnimatedTheme
+    rainbowThemePipe = do
+      time <- liftIO $ fromRational . toRational <$> getPOSIXTime
+      yield . rainbowThemePipe' time =<< await
+      rainbowThemePipe
+    rainbowThemePipe' :: Double -> StaticTheme
+    rainbowThemePipe' time blocks = reverse $ evalState (mapM rainbowBlock $ reverse blocks) 0
+      where
+        rainbowBlock :: BlockOutput -> State Integer ThemedBlockOutput
+        rainbowBlock block@BlockOutput{_blockName} = do
+          let text = rawText $ block ^. fullText
+          let chars = reverse . splitToChars $ text
+          coloredChars <- mapM rainbowChar chars
+          let rainbowText = reverse coloredChars
+          return $ ThemedBlockOutput {
+            _blockName,
+            _fullText = ThemedBlockText rainbowText,
+            _shortText = Nothing
+          }
+        rainbowChar :: T.Text -> State Integer ThemedBlockTextSegment
+        rainbowChar char = do
+          color <- nextRainbowColor
+          return $ mkThemedSegment (color, Nothing) $ char
+        nextRainbowColor :: State Integer Color
+        -- nextRainbowColor = state $ \index -> (rainbowColor (fromInteger index), index + 1)
+        nextRainbowColor = do
+          index <- get
+          put $ index + 1
+          return $ rainbowColor (fromInteger index + time * 10)
+        rainbowColor :: Double -> Color
+        rainbowColor position =
+          let hue' = position * 3
+              color = hsv hue' 0.8 1.0
+          in ColorRGB color
+        splitToChars :: T.Text -> [T.Text]
+        splitToChars = splitStringToChars . T.unpack
+        splitStringToChars :: String -> [T.Text]
+        splitStringToChars [] = []
+        splitStringToChars ('&':xs) = splitStringToCharsAmp "&" xs
+        splitStringToChars (x:xs) = T.singleton x : splitStringToChars xs
+        splitStringToCharsAmp :: String -> String -> [T.Text]
+        splitStringToCharsAmp _ [] = []
+        splitStringToCharsAmp acc (';':xs) = T.pack (acc <> ";") : splitStringToChars xs
+        splitStringToCharsAmp acc (x:xs) = splitStringToCharsAmp (acc <> [x]) xs

qbar/src/QBar/Time.hs

+{-# LANGUAGE OverloadedLists #-}
+
+module QBar.Time (
+  HasSleepScheduler(..),
+  Interval(..),
+  SleepScheduler,
+  createSleepScheduler,
+  everyMinute,
+  everyNSeconds,
+  humanReadableInterval,
+  nextIntervalTime,
+  sleepUntil',
+  sleepUntil,
+  sleepUntilInterval',
+  sleepUntilInterval,
+) where
+
+import QBar.Prelude
+
+import Control.Concurrent.Async
+import Control.Concurrent.Event qualified as Event
+import Control.Concurrent.MVar
+import Data.Ord (comparing)
+import Data.SortedList (SortedList, toSortedList, fromSortedList, singleton, partition, insert)
+import Data.Time.Clock (UTCTime, getCurrentTime, diffUTCTime, utctDayTime, addUTCTime)
+
+newtype Interval = IntervalSeconds Integer
+  deriving (Read, Show)
+
+-- |Describes an interval that is run every "n" seconds after midnight.
+everyNSeconds :: Integer -> Interval
+everyNSeconds = IntervalSeconds
+
+-- |Describes an interval that is run every minute.
+everyMinute :: Interval
+everyMinute = IntervalSeconds 60
+
+nextIntervalTime :: MonadIO m => Interval -> m UTCTime
+nextIntervalTime (IntervalSeconds intervalSeconds) = liftIO $ do
+  now <- getCurrentTime
+  let dayTime = utctDayTime now
+  let daySeconds :: Integer = floor dayTime
+  let intervalId = daySeconds `div` intervalSeconds
+  return now {
+    utctDayTime = fromInteger $ (intervalId + 1) * intervalSeconds
+  }
+
+humanReadableInterval :: Interval -> String
+humanReadableInterval (IntervalSeconds i) = show i <> "s"
+
+data SleepScheduler = SleepScheduler (MVar (SortedList ScheduledEvent, [ScheduledEvent])) Event.Event
+data ScheduledEvent = ScheduledEvent {
+  time :: UTCTime,
+  event :: Event.Event,
+  fireOnNegativeTimeJump :: Bool
+} deriving Eq
+instance Ord ScheduledEvent where
+  compare = comparing time
+
+class HasSleepScheduler m where
+  askSleepScheduler :: m SleepScheduler
+
+createSleepScheduler :: MonadIO m => m SleepScheduler
+createSleepScheduler = liftIO $ do
+  scheduler <- SleepScheduler <$> newMVar ([], []) <*> Event.new
+  link =<< async (schedulerThread scheduler)
+  return scheduler
+  where
+    schedulerThread :: SleepScheduler -> IO ()
+    schedulerThread (SleepScheduler eventsMVar trigger) = schedulerThread' =<< getCurrentTime
+      where
+        schedulerThread' :: UTCTime -> IO ()
+        schedulerThread' lastTime = do
+          start <- getCurrentTime
+
+          -- Check for a negative time step (threshold is between 5 and 65 seconds, depending on loop activity)
+          when (start < addUTCTime (fromInteger (-5)) lastTime) $ fireEvents fireOnNegativeTimeJump
+
+          (sortedEvents, _) <- readMVar eventsMVar
+          waitResult <- case fromSortedList sortedEvents of
+            [] -> True <$ Event.wait trigger
+            (ScheduledEvent{time} : _) -> waitForEvent time
+
+          when waitResult $ do
+            now <- getCurrentTime
+            fireEvents (checkEvent now)
+
+          schedulerThread' start
+
+        -- Waits for the next event, with a timeout. A return value of 'False' indicates a timeout occured.
+        waitForEvent :: UTCTime -> IO Bool
+        waitForEvent eventTime = do
+          now <- getCurrentTime
+          let timeUntil = diffUTCTime eventTime now
+          if
+            | timeUntil <= 0 -> return True
+            | timeUntil < 60 -> True <$ Event.waitTimeout trigger (ceiling $ toRational timeUntil * 1000000)
+            -- False indicates a timeout, in which case no events need to be fired
+            | otherwise -> Event.waitTimeout trigger (60 * 1000000)
+
+
+        fireEvents :: (ScheduledEvent -> Bool) -> IO ()
+        fireEvents predicate =
+          modifyMVar_ eventsMVar $ \(hots, colds) -> do
+            let allEvents = hots <> toSortedList colds
+            let (activeEvents, futureEvents) = partition predicate allEvents
+            mapM_ (Event.set . event) activeEvents
+            -- Sleep scheduler thread 'Event' is cleared during 'modifyMVar_' to prevent race conditions.
+            Event.clear trigger
+            return (futureEvents, [])
+
+        -- Predicate to check if an event should be fired.
+        checkEvent :: UTCTime -> ScheduledEvent -> Bool
+        checkEvent now ScheduledEvent{time} = now >= time
+
+
+queueScheduledEvent :: MonadIO m => SleepScheduler -> ScheduledEvent -> m ()
+queueScheduledEvent (SleepScheduler eventsMVar trigger) event@ScheduledEvent{time=eventTime} = liftIO $
+  modifyMVar_ eventsMVar $ \(sorted, unsorted) ->
+    -- Sleep scheduler thread 'Event' is set during 'modifyMVar_' to prevent race conditions.
+    case fromSortedList sorted of
+      [] -> (singleton event, unsorted) <$ Event.set trigger
+      (first : _) ->
+        if eventTime < time first
+          -- Event happens before the first event, so it is inserted at the front of the sorted list and the scheduler thread is notified
+          then (insert event sorted, unsorted) <$ Event.set trigger
+          -- Otherwise it is added to the unsorted pool and will be handled later.
+          else return (sorted, event:unsorted)
+
+
+-- |Suspends the thread until the given time is reached.
+sleepUntil :: (HasSleepScheduler m, MonadIO m) => UTCTime -> m ()
+sleepUntil time = do
+  scheduler <- askSleepScheduler
+  sleepUntil' scheduler time
+
+sleepUntil' :: MonadIO m => SleepScheduler -> UTCTime -> m ()
+sleepUntil' scheduler time = liftIO $ do
+  event <- Event.new
+  queueScheduledEvent scheduler (ScheduledEvent {time, event, fireOnNegativeTimeJump=False})
+  Event.wait event
+
+-- |Suspends the thread until the next time boundary described by 'Interval' is reached. Also returns when the system time jumps backwards.
+sleepUntilInterval :: (HasSleepScheduler m, MonadIO m) => Interval -> m ()
+sleepUntilInterval interval = do
+  scheduler <- askSleepScheduler
+  sleepUntilInterval' scheduler interval
+
+sleepUntilInterval' :: MonadIO m => SleepScheduler -> Interval -> m ()
+sleepUntilInterval' scheduler interval = liftIO $ do
+  event <- Event.new
+  time <- nextIntervalTime interval
+  queueScheduledEvent scheduler (ScheduledEvent {time, event, fireOnNegativeTimeJump=True})
+  Event.wait event

qbar/src/QBar/Utils.hs

+module QBar.Utils (
+  mkBroadcastCacheP,
+  mkBroadcastP,
+  randomIdentifier,
+  signalEventPipe,
+) where
+
+import QBar.Prelude
+
+import Control.Concurrent.Event as Event
+import Control.Concurrent.STM (atomically)
+import Control.Concurrent.STM.TChan
+import Control.Concurrent.STM.TVar
+import Control.Monad (replicateM)
+import Data.Text.Lazy qualified as T
+import Pipes
+import System.Random
+
+-- Pipe that signals an 'Event' after every value that passes through
+signalEventPipe :: MonadIO m => Event.Event -> Pipe a a m r
+signalEventPipe event = forever $ (yield =<< await) >> liftIO (Event.signal event)
+
+randomIdentifier :: MonadIO m => m Text
+randomIdentifier = liftIO $ T.pack <$> replicateM 8 randomCharacter
+  where
+    randomCharacter :: IO Char
+    randomCharacter = do
+      index <- randomRIO (0, T.length alphabet - 1)
+      return $ T.index alphabet index
+    alphabet :: T.Text
+    alphabet = T.pack $ ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9']
+
+-- |Creates a pair of consumer and producer. Both can be used multiple times in parallel.
+-- |All values send to a consumer will be sent to all currently running producers.
+mkBroadcastP :: forall a. IO (Consumer a IO (), Producer a IO ())
+mkBroadcastP = do
+  chan <- newBroadcastTChanIO
+  return (sendToStore chan, recvFromStore chan)
+  where
+    sendToStore :: TChan a -> Consumer a IO ()
+    sendToStore chan = forever $ do
+      value <- await
+      liftIO . atomically $ writeTChan chan value
+
+    -- Monad will be forked when new outputs connect
+    recvFromStore :: TChan a -> Producer a IO ()
+    recvFromStore chan = do
+      outputChan <- liftIO . atomically $ dupTChan chan
+      forever $ yield =<< (liftIO . atomically $ readTChan outputChan)
+
+-- |Creates a pair of consumer and producer. Both can be used multiple times in parallel.
+-- |All values send to a consumer will be sent to all currently running producers.
+-- |When running a new producer it will immediateley receive the latest value that was sent to a consumer.
+mkBroadcastCacheP :: forall a. a -> IO (Consumer a IO (), Producer a IO ())
+mkBroadcastCacheP initialValue = do
+  store <- (,) <$> newTVarIO initialValue <*> newBroadcastTChanIO
+  return (sendToStore store, recvFromStore store)
+  where
+    sendToStore :: (TVar a, TChan a) -> Consumer a IO ()
+    sendToStore (var, chan) = forever $ do
+      value <- await
+      liftIO . atomically $ do
+        writeTVar var value
+        writeTChan chan value
+
+    -- Monad will be forked when new outputs connect
+    recvFromStore :: (TVar a, TChan a) -> Producer a IO ()
+    recvFromStore (var, chan) = do
+      (outputChan, value) <- liftIO . atomically $ do
+        value <- readTVar var
+        outputChan <- dupTChan chan
+        return (outputChan, value)
+
+      yield value
+
+      forever $ yield =<< (liftIO . atomically $ readTChan outputChan)

test/Spec.hs → qbar/test/Spec.hs

+import Prelude
+
 main :: IO ()
 main = putStrLn "Test suite not yet implemented"

run-sway

-#!/bin/sh
-
-set -e
-
-DEFAULT_BAR_COMMAND="qbar server"
-EXECUTABLE_NAME=qbar
-SWAY_BAR_ID=bar-0
-
-stack build
-
-TEMP_DIR=$(mktemp -d)
-STDERR=$TEMP_DIR/stderr
-mkfifo $STDERR
-
-trap "swaymsg bar $SWAY_BAR_ID status_command $DEFAULT_BAR_COMMAND; rm -rf $TEMP_DIR" EXIT INT HUP TERM
-
-swaymsg bar $SWAY_BAR_ID status_command "exec $(stack path --local-install-root)/bin/$EXECUTABLE_NAME $@ -- server 2> $STDERR"
-
-# show output and run forever (use Ctrl-C to stop)
-cat $STDERR

src/QBar/Blocks.hs

-{-# LANGUAGE OverloadedStrings #-}
-
-module QBar.Blocks where
-
-import QBar.Core
-import QBar.Time
-
-import qualified Data.Text.Lazy as T
-import Data.Time.Format
-import Data.Time.LocalTime
-import Pipes
-import Pipes.Concurrent
-
-dateBlock :: IO BlockOutput
-dateBlock = do
-  zonedTime <- getZonedTime
-  let date = T.pack (formatTime defaultTimeLocale "%a %F" zonedTime)
-  let time = T.pack (formatTime defaultTimeLocale "%R" zonedTime)
-  --let text = (T.pack "📅 ") <> T.pack (formatTime defaultTimeLocale "%a %F <span color='#ffffff'>%R</span>" zonedTime)
-  let text = (T.pack "📅 ") <> date <> " " <> (coloredText activeColor time)
-  return $ setBlockName "date" $ pangoMarkup $ createBlock text
-
-dateBlockProducer :: BarUpdateChannel -> BlockProducer
-dateBlockProducer barUpdateChannel = do
-  initialDateBlock <- lift dateBlock
-  (output, input) <- lift $ spawn $ latest initialDateBlock
-  lift $ void $ forkIO $ update output
-  fromInput input
-  where
-    update :: Output BlockOutput -> IO ()
-    update output = do
-      sleepUntil =<< nextMinute
-      block <- dateBlock
-      void $ atomically $ send output block
-      updateBar barUpdateChannel
-      update output
\ No newline at end of file

src/QBar/Cli.hs

-{-# LANGUAGE ApplicativeDo #-}
-
-module QBar.Cli where
-
-import qualified Data.Text as T
-import Options.Applicative
-
-data BarCommand = BarServer | NoFilter | RainbowFilter
-
-barCommandParser :: Parser BarCommand
-barCommandParser = hsubparser
-  ( command "server" (info (pure BarServer) (progDesc "Start a new qbar server. Should be called by swaybar, i3bar or or another i3bar-protocol compatible host process.")) <>
-    command "default" (info (pure NoFilter) (progDesc "Send a message to a running qbar server.")) <>
-    command "rainbow" (info (pure RainbowFilter) (progDesc "Send a message to a running qbar server."))
-  )
-
-data MainOptions = MainOptions {
-  verbose :: Bool,
-  indicator :: Bool,
-  socketLocation :: Maybe T.Text,
-  barCommand :: BarCommand
-}
-
-mainOptionsParser :: Parser MainOptions
-mainOptionsParser = do
-  verbose <- switch $ long "verbose" <> short 'v' <> help "Print more diagnostic output to stderr (including a copy of every bar update)."
-  indicator <- switch $ long "indicator" <> short 'i' <> help "Show render indicator."
-  socketLocation <- optional $ strOption $ long "socket" <> short 's' <> metavar "SOCKET" <> help "Control socket location. By default determined by WAYLAND_SOCKET location."
-  barCommand <- barCommandParser
-  return MainOptions {verbose, indicator, socketLocation, barCommand}
-
-parser :: ParserInfo MainOptions
-parser = info (mainOptionsParser <**> helper)
-  (fullDesc <> header "q - queezles tools")
-
-parserPrefs :: ParserPrefs
-parserPrefs = prefs showHelpOnEmpty
-
-parseOptions :: IO MainOptions
-parseOptions = customExecParser parserPrefs parser
\ No newline at end of file

src/QBar/ControlSocket.hs

-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE TemplateHaskell #-}
-
-module QBar.ControlSocket where
-
-import QBar.Cli (MainOptions(..))
--- TODO: remove dependency?
-import QBar.Filter
-
-import Control.Monad (forever, void, when)
-import Control.Monad.STM (atomically)
-import Control.Concurrent (forkFinally)
-import Control.Concurrent.Async
-import Control.Concurrent.STM.TChan (TChan, writeTChan)
-import Data.Aeson.TH
-import Data.Either (either)
-import Data.Text.Lazy (Text, pack)
-import qualified Data.Text as T
-import Network.Socket
-import Pipes
-import Pipes.Parse
-import Pipes.Aeson (decode, DecodingError)
-import Pipes.Aeson.Unchecked (encode)
-import Pipes.Network.TCP (fromSocket, toSocket)
-import System.Directory (removeFile, doesFileExist)
-import System.Environment (getEnv)
-import System.FilePath ((</>))
-import System.IO
-
-type CommandChan = TChan Command
-
-data Command = SetFilter Filter
-  deriving Show
-
-data SocketResponse = Success | Error Text
-  deriving Show
-
-$(deriveJSON defaultOptions ''Command)
-$(deriveJSON defaultOptions ''SocketResponse)
-
-ipcSocketAddress :: MainOptions -> IO FilePath
-ipcSocketAddress MainOptions{socketLocation} = maybe defaultSocketPath (return . T.unpack) socketLocation
-  where
-    defaultSocketPath :: IO FilePath
-    defaultSocketPath = do
-      xdgRuntimeDir <- getEnv "XDG_RUNTIME_DIR"
-      waylandDisplay <- getEnv "WAYLAND_DISPLAY"
-      return $ xdgRuntimeDir </> waylandDisplay <> "-qbar"
-
-sendIpc :: MainOptions -> Command -> IO ()
-sendIpc options@MainOptions{verbose} request = do
-  socketPath <- ipcSocketAddress options
-  sock <- socket AF_UNIX Stream defaultProtocol
-  connect sock $ SockAddrUnix socketPath
-  runEffect $ encode request >-> toSocket sock
-
-  decodeResult <- evalStateT decode $ fromSocket sock 4096
-  maybe exitEmptyStream (either exitInvalidResult showResponse) decodeResult
-  where
-    exitEmptyStream :: IO ()
-    exitEmptyStream = hPutStrLn stderr "Empty stream"
-    exitInvalidResult :: DecodingError -> IO ()
-    exitInvalidResult = hPrint stderr
-    showResponse :: SocketResponse -> IO ()
-    showResponse Success = when verbose $ hPutStrLn stderr "Success"
-    showResponse (Error message) = hPrint stderr message
-
-listenUnixSocketAsync :: MainOptions -> CommandChan -> IO (Async ())
-listenUnixSocketAsync options commandChan = async $ listenUnixSocket options commandChan
-
-listenUnixSocket :: MainOptions -> CommandChan -> IO ()
-listenUnixSocket options commandChan = do
-  socketPath <- ipcSocketAddress options
-  hPutStrLn stderr $ "Creating control socket at " <> socketPath
-  socketExists <- doesFileExist socketPath
-  when socketExists $ removeFile socketPath
-  sock <- socket AF_UNIX Stream defaultProtocol
-  setCloseOnExecIfNeeded $ fdSocket sock
-  bind sock (SockAddrUnix socketPath)
-  listen sock 5
-  forever $ do
-    (conn, _) <- accept sock
-    void $ forkFinally (socketHandler conn) (\_ -> close conn)
-  where
-    socketHandler :: Socket -> IO ()
-    socketHandler sock = do
-      decodeResult <- evalStateT decode $ fromSocket sock 4096
-      response <- maybe (errorResponse "Empty stream") (either (errorResponse . pack . show) commandHandler) decodeResult
-      let consumer = toSocket sock
-      runEffect (encode response >-> consumer)
-    commandHandler :: Command -> IO SocketResponse
-    commandHandler command = do
-      atomically $ writeTChan commandChan command
-      return Success
-    errorResponse :: Text -> IO SocketResponse
-    errorResponse message = return $ Error message
\ No newline at end of file

src/QBar/Core.hs

-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE OverloadedStrings #-}
-
-module QBar.Core where
-
-import QBar.Pango
-
-import Control.Exception (catch, finally, IOException)
-import Control.Monad (forever)
-import Control.Concurrent (threadDelay)
-import Control.Concurrent.Async
-import Control.Concurrent.Event as Event
-import Control.Concurrent.MVar
-import Data.Aeson.TH
-import qualified Data.ByteString.Lazy.Char8 as C8
-import qualified Data.HashMap.Lazy as HM
-import Data.Int (Int64)
-import Data.Maybe (fromMaybe, catMaybes)
-import qualified Data.Text.Lazy as T
-import qualified Data.Text.Lazy.Encoding as E
-import qualified Data.Text.Lazy.IO as TIO
-import Numeric (showHex)
-import Pipes
-import Pipes.Concurrent
-import qualified Pipes.Prelude as PP
-import System.Exit
-import System.IO
-import System.Process.Typed (shell, withProcessWait, setStdin, setStdout, getStdout, closed, createPipe, readProcessStdout)
-
-import Data.Colour.RGBSpace
-
-data BlockOutput = BlockOutput {
-  values :: HM.HashMap T.Text T.Text,
-  clickAction :: Maybe (Click -> IO ())
-}
-instance Show BlockOutput where
-  show BlockOutput{values} = show values
-
-data Click = Click {
-  name :: T.Text,
-  button :: Int
-} deriving Show
-$(deriveJSON defaultOptions ''Click)
-
-type BlockProducer = Producer BlockOutput IO ()
-
-data BarUpdateChannel = BarUpdateChannel (IO ())
-type BarUpdateEvent = Event.Event
-
-defaultColor :: T.Text
-defaultColor = "#969896"
-
-activeColor :: T.Text
-activeColor = "#ffffff"
-
-updatingColor :: T.Text
---updatingColor = "#444444"
-updatingColor = "#96989677"
-
-createBlock :: T.Text -> BlockOutput
-createBlock text = setColor defaultColor $ BlockOutput {
-  values = HM.singleton "full_text" text,
-  clickAction = Nothing
-}
-
-createErrorBlock :: T.Text -> BlockOutput
-createErrorBlock = setColor "ff0000" . createBlock
-
-setValue :: T.Text -> T.Text -> BlockOutput -> BlockOutput
-setValue key val block = block {
-  values = HM.insert key val (values block)
-}
-
-getValue :: T.Text -> BlockOutput -> Maybe T.Text
-getValue key block = HM.lookup key (values block)
-
-adjustValue :: (T.Text -> T.Text) -> T.Text -> BlockOutput -> BlockOutput
-adjustValue f k block = block {
-  values = HM.adjust f k (values block)
-}
-
-emptyBlock :: BlockOutput
-emptyBlock = createBlock ""
-
-shortText :: T.Text -> BlockOutput -> BlockOutput
-shortText = setValue "short_text"
-
-fullText :: T.Text -> BlockOutput -> BlockOutput
-fullText = setValue "full_text"
-
-getFullText :: BlockOutput -> T.Text
-getFullText = fromMaybe "" . getValue "full_text"
-
-setColor :: T.Text -> BlockOutput -> BlockOutput
-setColor = setValue "color"
-
-setBlockName :: T.Text -> BlockOutput -> BlockOutput
-setBlockName = setValue "name"
-
-getBlockName :: BlockOutput -> Maybe T.Text
-getBlockName = getValue "name"
-
-pangoMarkup :: BlockOutput -> BlockOutput
-pangoMarkup = setValue "markup" "pango"
-
-adjustText :: (T.Text -> T.Text) -> BlockOutput -> BlockOutput
-adjustText f = adjustValue f "full_text" . adjustValue f "short_text"
-
-coloredText :: T.Text -> T.Text -> T.Text
-coloredText color text = "<span color='" <> color <> "'>" <> text <> "</span>"
-
-addIcon :: T.Text -> BlockOutput -> BlockOutput
-addIcon icon block = prefixIcon "full_text" $ prefixIcon "short_text" block
-  where
-    prefixIcon = adjustValue ((icon <> " ") <>)
-
-removePango :: BlockOutput -> BlockOutput
-removePango block
-  | getValue "markup" block == Just "pango" = adjustText removePangoFromText $ block {
-      values = HM.delete "markup" (values block)
-    }
-  | otherwise = block
-  where
-    removePangoFromText :: T.Text -> T.Text
-    removePangoFromText text =
-      case parsePango text of
-        Left _ -> text
-        Right parsed -> removeFormatting parsed
-
-modify :: (BlockOutput -> BlockOutput) -> Pipe BlockOutput BlockOutput IO ()
-modify = PP.map
-
-autoPadding :: Pipe BlockOutput BlockOutput IO ()
-autoPadding = autoPadding' 0 0
-  where
-    autoPadding' :: Int64 -> Int64 -> Pipe BlockOutput BlockOutput IO ()
-    autoPadding' fullLength shortLength = do
-      block <- await
-      let values' = (values block)
-      let fullLength' = T.length $ HM.lookupDefault "" "full_text" values'
-      let shortLength' = T.length $ HM.lookupDefault "" "short_text" values'
-      let values'' = HM.adjust (<> (T.take (fullLength - fullLength') $ T.repeat ' ')) "full_text" values'
-      let values''' = HM.adjust (<> (T.take (shortLength - shortLength') $ T.repeat ' ')) "short_text" values''
-      yield block { values = values''' }
-      autoPadding' (max fullLength fullLength') (max shortLength shortLength')
-
--- | Create a shared interval. Takes a BarUpdateChannel to signal bar updates and an interval (in seconds).Data.Maybe
--- Returns an IO action that can be used to attach blocks to the shared interval and an async that contains a reference to the scheduler thread.
-sharedInterval :: BarUpdateChannel -> Int -> IO (IO BlockOutput -> BlockProducer, Async ())
-sharedInterval barUpdateChannel seconds = do
-  clientsMVar <- newMVar ([] :: [(IO BlockOutput, Output BlockOutput)])
-
-  task <- async $ forever $ do
-    threadDelay $ seconds * 1000000
-    -- Updates all client blocks
-    -- If send returns 'False' the clients mailbox has been closed, so it is removed
-    modifyMVar_ clientsMVar (fmap catMaybes . mapConcurrently runAndFilterClient)
-    -- Then update the bar
-    updateBar barUpdateChannel
-
-  return (addClient clientsMVar, task)
-    where
-      runAndFilterClient :: (IO BlockOutput, Output BlockOutput) -> IO (Maybe (IO BlockOutput, Output BlockOutput))
-      runAndFilterClient client = do
-        result <- runClient client
-        return $ if result then Just client else Nothing
-      runClient :: (IO BlockOutput, Output BlockOutput) -> IO Bool
-      runClient (blockAction, output) = do
-        result <- blockAction
-        atomically $ send output result {
-          clickAction = Just (updateClickHandler result)
-        }
-        where
-          updateClickHandler :: BlockOutput -> Click -> IO ()
-          updateClickHandler block _ = do
-            -- Give user feedback that the block is updating
-            let outdatedBlock = setColor updatingColor $ removePango block
-            void $ atomically $ send output $ outdatedBlock
-            -- Notify bar about changed block state to display the feedback
-            updateBar barUpdateChannel
-            -- Run a normal block update to update the block to the new value
-            void $ runClient (blockAction, output)
-            -- Notify bar about changed block state, this is usually done by the shared interval handler
-            updateBar barUpdateChannel
-      addClient :: MVar [(IO BlockOutput, Output BlockOutput)] -> IO BlockOutput -> BlockProducer
-      addClient clientsMVar blockAction = do
-        -- Spawn the mailbox that preserves the latest block
-        (output, input) <- lift $ spawn $ latest emptyBlock
-
-        -- Generate initial block and send it to the mailbox
-        lift $ void $ runClient (blockAction, output)
-
-        -- Register the client for regular updates
-        lift $ modifyMVar_ clientsMVar $ \ clients -> return ((blockAction, output):clients)
-
-        -- Return a block producer from the mailbox
-        fromInput input
-
-blockScript :: FilePath -> IO BlockOutput
-blockScript path = do
-  -- The exit code is used for i3blocks signaling but ignored here (=not implemented)
-  -- I am trying to replace i3blocks scripts with native haskell blocks, so I do not need it
-  (exitCode, output) <- readProcessStdout $ shell path
-  case exitCode of
-    ExitSuccess -> return $ case map E.decodeUtf8 (C8.lines output) of
-      (text:short:color:_) -> setColor color $ shortText short $ createScriptBlock text
-      (text:short:_) -> shortText short $ createScriptBlock text
-      (text:_) -> createScriptBlock text
-      [] -> createScriptBlock "-"
-    (ExitFailure nr) -> return $ createErrorBlock $ "[" <> (T.pack $ show nr) <> "]"
-  where
-    createScriptBlock :: T.Text -> BlockOutput
-    createScriptBlock text = pangoMarkup $ setBlockName (T.pack path) $ createBlock text
-
-startPersistentBlockScript :: BarUpdateChannel -> FilePath -> Producer BlockOutput IO ()
-startPersistentBlockScript barUpdateChannel path = do
-  (output, input, seal) <- lift $ spawn' $ latest $ emptyBlock
-  initialDataEvent <- lift $ Event.new
-  task <- lift $ async $ do
-    let processConfig = setStdin closed $ setStdout createPipe $ shell path
-    finally (
-      catch (
-        withProcessWait processConfig $ \ process -> do
-          let handle = getStdout process
-          runEffect $ (fromHandle handle) >-> signalFirstBlock initialDataEvent >-> toOutput output
-        )
-        ( \ e ->
-          -- output error
-          runEffect $ (yield $ createErrorBlock $ "[" <> (T.pack $ show (e :: IOException)) <> "]") >-> signalFirstBlock initialDataEvent >-> toOutput output
-        )
-      )
-      (atomically seal)
-  lift $ link task
-  lift $ Event.wait initialDataEvent
-  fromInput input
-  where
-    signalFirstBlock :: Event.Event -> Pipe BlockOutput BlockOutput IO ()
-    signalFirstBlock event = do
-      -- Await first block
-      await >>= yield
-      lift $ Event.set event
-      -- Replace with cat
-      cat
-    fromHandle :: Handle -> Producer BlockOutput IO ()
-    fromHandle handle = forever $ do
-      line <- lift $ TIO.hGetLine handle
-      yield $ pangoMarkup $ createBlock line
-      lift $ updateBar barUpdateChannel
-
-pangoColor :: RGB Double -> T.Text
-pangoColor (RGB r g b) =
-  let r' = hexColorComponent r
-      g' = hexColorComponent g
-      b' = hexColorComponent b
-  in "#" <> r' <> g' <> b'
-  where
-    hexColorComponent :: Double -> T.Text
-    hexColorComponent val = paddedHexComponent $ T.pack $ showHex (max 0 $ min 255 $ (truncate (val * 255) :: Int)) ""
-    paddedHexComponent hex =
-      let len = 2 - T.length hex
-          padding = if len == 1 then "0" else ""
-      in padding <> hex
-
-updateBar :: BarUpdateChannel -> IO ()
-updateBar (BarUpdateChannel updateAction) = updateAction