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"

src/QBar/BlockText.hs

-{-# LANGUAGE ScopedTypeVariables #-}
-
-module QBar.BlockText where
-
-import qualified Data.Text.Lazy as T
-import Data.Int (Int64)
-import QBar.Pango
-
-newtype BlockText = BlockText [BlockTextSegment]
-  deriving (Show)
-instance Semigroup BlockText where
-  (BlockText a) <> (BlockText b) = BlockText (a <> b)
-instance Monoid BlockText where
-  mempty = BlockText []
-
-intercalate :: Monoid a => a -> [a] -> a
-intercalate _ [] = mempty
-intercalate _ [x] = x
-intercalate inter (x:xs) = x <> inter <> intercalate inter xs
-
-data BlockTextSegment = BlockTextSegment {
-    active :: Bool,
-    importance :: Importance,
-    text :: T.Text
-  }
-  | PangoTextSegment T.Text
-  deriving (Show)
-
-type Importance = Float
-
-
-normalImportant :: Importance
-normalImportant = 1
-warnImportant :: Importance
-warnImportant = 2
-errorImportant :: Importance
-errorImportant = 3
-criticalImportant :: Importance
-criticalImportant = 4
-
-isCritical :: Importance -> Bool
-isCritical i
-  | i >= criticalImportant = True
-  | otherwise = False
-isError :: Importance -> Bool
-isError i
-  | isCritical i = False
-  | i >= errorImportant = True
-  | otherwise = False
-isWarning :: Importance -> Bool
-isWarning i
-  | isCritical i = False
-  | isError i = False
-  | i >= warnImportant = True
-  | otherwise = False
-isNormal :: Importance -> Bool
-isNormal i
-  | isCritical i = False
-  | isError i = False
-  | isWarning i = False
-  | otherwise = True
-
-toImportance :: Real a => (a, a, a, a, a, a) -> a -> Importance
-toImportance (tMax, tCrit, tErr, tWarn, tNorm, tMin) =
-  toImportance' (Just tMax, tCrit, tErr, tWarn, tNorm, Just tMin)
-
-toImportance' :: forall a. Real a => (Maybe a, a, a, a, a, Maybe a) -> a -> Importance
-toImportance' (tMax, tCrit, tErr, tWarn, tNorm, tMin) val
-  | tCrit <= val = 4 + valueCrit      tMax  tCrit val
-  | tErr  <= val = 3 + linearMatch    tCrit tErr  val
-  | tWarn <= val = 2 + linearMatch    tErr  tWarn val
-  | tNorm <= val = 1 + linearMatch    tWarn tNorm val
-  | otherwise    = 0 + valueOtherwise tNorm tMin  val
-  where
-    e :: Importance
-    e = exp 1
-    linearMatch :: a -> a -> a -> Importance
-    linearMatch u l v = frac (v - l) (u - l)
-    logarithmicMatch :: a -> a -> Importance
-    logarithmicMatch l u = 1 - 1 / log (e + realToFrac (u - l))
-    frac :: a -> a -> Importance
-    frac a b = realToFrac a / realToFrac b
-    valueCrit :: Maybe a -> a -> a -> Importance
-    valueCrit (Just tMax') tCrit' v
-      | tMax' > v = linearMatch tMax' tCrit' v
-      | otherwise = 1
-    valueCrit Nothing tCrit' v = logarithmicMatch tCrit' v
-    valueOtherwise :: a -> Maybe a -> a -> Importance
-    valueOtherwise tNorm' (Just tMin') v
-      | tMin' < v = linearMatch tNorm' tMin' v
-      | otherwise = 0
-    valueOtherwise tNorm' Nothing v = 1 - logarithmicMatch v tNorm'
-
-
-removePango :: BlockText -> T.Text
-removePango (BlockText b) = foldr ((<>) . removePangoFromSegment) "" b
-  where
-    removePangoFromSegment :: BlockTextSegment -> T.Text
-    removePangoFromSegment BlockTextSegment { active=_active, importance=_importance, text } = text
-    removePangoFromSegment (PangoTextSegment text) =
-      case parsePango text of
-        Left _ -> text
-        Right parsed -> removeFormatting parsed
-
-printedLength :: BlockText -> Int64
-printedLength (BlockText b) = foldr ((+) . printedLength') 0 b
-  where
-    printedLength' :: BlockTextSegment -> Int64
-    printedLength' BlockTextSegment { text, active=_, importance=_ } = T.length text
-    printedLength' (PangoTextSegment _) = 0
-
-mkText :: Bool -> Importance -> T.Text -> BlockText
-mkText active importance text = BlockText [BlockTextSegment { text = pangoFriendly text, active, importance }]
-  where
-    pangoFriendly :: T.Text -> T.Text
-    pangoFriendly = T.replace "<" "&lt;" . T.replace ">" "&gt;" . T.replace "&" "&amp;"
-
-activeImportantText :: Importance -> T.Text -> BlockText
-activeImportantText = mkText True
-
-importantText :: Importance -> T.Text -> BlockText
-importantText = mkText False
-
-activeText :: T.Text -> BlockText
-activeText = mkText True normalImportant
-
-normalText :: T.Text -> BlockText
-normalText = mkText False normalImportant
-
-pangoText :: T.Text -> BlockText
-pangoText pango = BlockText [PangoTextSegment pango]
-
-surroundWith :: (T.Text -> BlockText) -> T.Text -> T.Text -> BlockText -> BlockText
-surroundWith format left right middle = format left <> middle <> format right
-
-data Color = ColorRGB Float Float Float | ColorRGBA Float Float Float Float
-colorToHex :: Color -> T.Text
-colorToHex = colorToHex'
-  where
-    colorToHex' :: Color -> T.Text
-    colorToHex' (ColorRGB r g b) = "#" <> (toDualHex . floor) (r * 255) <> (toDualHex . floor) (g * 255)  <> (toDualHex . floor) (b * 255)
-    colorToHex' (ColorRGBA r g b a) = "#" <> (toDualHex . floor) (r * 255) <> (toDualHex . floor) (g * 255)  <> (toDualHex . floor) (b * 255) <> (toDualHex . floor) (a * 255)
-    toHex :: Int -> T.Text
-    toHex 0 = "0"
-    toHex 1 = "1"
-    toHex 2 = "2"
-    toHex 3 = "3"
-    toHex 4 = "4"
-    toHex 5 = "5"
-    toHex 6 = "6"
-    toHex 7 = "7"
-    toHex 8 = "8"
-    toHex 9 = "9"
-    toHex 10 = "A"
-    toHex 11 = "B"
-    toHex 12 = "C"
-    toHex 13 = "D"
-    toHex 14 = "E"
-    toHex 15 = "F"
-    toHex x = toHex $ mod x 16
-    toDualHex :: Int -> T.Text
-    toDualHex x = toHex (div x 16) <> toHex x

src/QBar/Blocks.hs

-module QBar.Blocks (
-  module QBar.Blocks.Battery,
-  module QBar.Blocks.Date
-) where
-
-
-import QBar.Blocks.Battery
-import QBar.Blocks.Date

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 "qbar - queezles {i3,sway}bar infrastructure")
-
-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(..))
-import QBar.Core
--- TODO: remove dependency?
-import QBar.Filter
-import QBar.BlockText
-
-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.ByteString (ByteString)
-import Data.Either (either)
-import Data.Text.Lazy (Text, pack)
-import qualified Data.Text as T
-import qualified Data.Text.Lazy as TL
-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
-  | Block
-  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"
-      -- TODO: fallback to I3_SOCKET_PATH if WAYLAND_DISPLAY is not set.
-      -- If both are not set it might be useful to fall back to XDG_RUNTIME_DIR/qbar, so qbar can run headless (eg. for tests)
-      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 = streamHandler (fromSocket sock 4096) (toSocket sock)
-    streamHandler :: Producer ByteString IO () -> Consumer ByteString IO () -> IO ()
-    streamHandler producer consumer = do
-      (decodeResult, leftovers) <- runStateT decode producer
-      response <- maybe (errorResponse "Empty stream") (either handleError (handleCommand leftovers)) decodeResult
-      runEffect (encode response >-> consumer)
-    handleCommand :: Producer ByteString IO () -> Command -> IO SocketResponse
-    handleCommand _ Block = error "TODO" -- addBlock $ handleBlockStream leftovers
-    handleCommand _ command = do
-      atomically $ writeTChan commandChan command
-      return Success
-    handleError :: DecodingError -> IO SocketResponse
-    handleError = return . Error . pack . show
-    errorResponse :: Text -> IO SocketResponse
-    errorResponse message = return $ Error message
-
-handleBlockStream :: Producer ByteString IO () -> PushBlock
-handleBlockStream producer = do
-  (decodeResult, leftovers) <- liftIO $ runStateT decode producer
-  maybe exitBlock (either (\_ -> exitBlock) (handleParsedBlock leftovers)) decodeResult
-  where
-    handleParsedBlock :: Producer ByteString IO () -> String -> PushBlock
-    handleParsedBlock leftovers update = do
-      yield $ Just . createBlock . normalText $ TL.pack update
-      handleBlockStream leftovers

src/QBar/Core.hs

-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE TemplateHaskell #-}
-
-module QBar.Core where
-
-import QBar.BlockText
-
-import Control.Exception (catch, finally, IOException)
-import Control.Monad (forever)
-import Control.Monad.Reader (ReaderT, runReaderT, ask, asks)
-import Control.Concurrent (threadDelay)
-import Control.Concurrent.Async
-import Control.Concurrent.Event as Event
-import Control.Concurrent.MVar
-import Control.Concurrent.STM.TChan (TChan, writeTChan)
-import Data.Aeson.TH
-import qualified Data.ByteString.Lazy.Char8 as C8
-import Data.Int (Int64)
-import Data.Maybe (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 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 Control.Lens
-
-
-data Click = Click {
-  name :: T.Text,
-  button :: Int
-} deriving Show
-$(deriveJSON defaultOptions ''Click)
-
-data BlockOutput = BlockOutput
-  { _fullText :: BlockText
-  , _shortText :: Maybe BlockText
-  , _blockName :: Maybe T.Text
-  , _clickAction :: Maybe (Click -> BarIO ())
-  , _invalid :: Bool
-  }
-
-
-data PushMode = PushMode
-data PullMode = PullMode
-data CachedMode = CachedMode
-
-type Block a = Producer (Maybe BlockOutput) BarIO a
-
-
--- |Block that 'yield's an update whenever the block should be changed
-type PushBlock = Block PushMode
--- |Block that generates an update on 'yield'. Should only be pulled when an update is required.
-type PullBlock = Block PullMode
--- |Cached block. Always 'yield's the latest update, so it should only be pulled when the bar is rendered.
-type CachedBlock = Block CachedMode
-
-class IsBlock a where
-  toCachedBlock :: a -> CachedBlock
-
-class IsBlockMode a where
-  exitBlock :: Block a
-instance IsBlockMode PushMode where
-  exitBlock = return PushMode
-instance IsBlockMode PullMode where
-  exitBlock = return PullMode
-instance IsBlockMode CachedMode where
-  exitBlock = return CachedMode
-
-
-type BarIO = ReaderT Bar IO
-
-data Bar = Bar {
-  requestBarUpdate :: IO (),
-  newBlockChan :: TChan CachedBlock
-}
-makeLenses ''BlockOutput
-
-instance IsBlock PushBlock where
-  toCachedBlock = cachePushBlock
-instance IsBlock CachedBlock where
-  toCachedBlock = id
-
-data BarUpdateChannel = BarUpdateChannel (IO ())
-type BarUpdateEvent = Event.Event
-
-
-runBarIO :: Bar -> BarIO r -> IO r
-runBarIO bar action = runReaderT action bar
-
-createBlock :: BlockText -> BlockOutput
-createBlock text = BlockOutput
-  { _fullText = text
-  , _shortText = Nothing
-  , _blockName = Nothing
-  , _clickAction = Nothing
-  , _invalid = False
-  }
-
-createErrorBlock :: T.Text -> BlockOutput
-createErrorBlock = createBlock . importantText criticalImportant
-
-emptyBlock :: BlockOutput
-emptyBlock = createBlock mempty
-
-addIcon :: T.Text -> BlockOutput -> BlockOutput
-addIcon icon = over fullText $ (<>) . normalText $ icon <> " "
-
-modify :: (BlockOutput -> BlockOutput)
-       -> Pipe (Maybe BlockOutput) (Maybe BlockOutput) BarIO r
-modify x = PP.map (x <$>)
-
-autoPadding :: Pipe (Maybe BlockOutput) (Maybe BlockOutput) BarIO r
-autoPadding = autoPadding' 0 0
-  where
-    autoPadding' :: Int64 -> Int64 -> Pipe (Maybe BlockOutput) (Maybe BlockOutput) BarIO r
-    autoPadding' fullLength shortLength = do
-      maybeBlock <- await
-      case maybeBlock of
-        Just block -> do
-          let fullLength' = max fullLength . printedLength $ block^.fullText
-          let shortLength' = max shortLength . printedLength $ block^.shortText._Just -- TODO: ???
-          yield $ Just $ padFullText fullLength' . padShortText shortLength' $ block
-          autoPadding' fullLength' shortLength'
-        Nothing -> do
-          yield Nothing
-          autoPadding' 0 0
-    padString :: Int64 -> BlockText
-    padString len = normalText . T.take len . T.repeat $ ' '
-    padFullText :: Int64 -> BlockOutput -> BlockOutput
-    padFullText len = over fullText $ \s -> padString (len - printedLength s) <> s
-    padShortText :: Int64 -> BlockOutput -> BlockOutput
-    padShortText len = over (shortText._Just) $ \s -> padString (len - printedLength s) <> s
-
-cacheFromInput :: Input (Maybe BlockOutput) -> CachedBlock
-cacheFromInput input = CachedMode <$ fromInput input
-
--- | 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 :: Int -> BarIO (PullBlock -> CachedBlock)
-sharedInterval seconds = do
-  clientsMVar <- liftIO $ newMVar ([] :: [(MVar PullBlock, Output (Maybe BlockOutput))])
-
-  startEvent <- liftIO Event.new
-
-  task <- barAsync $ do
-    -- Wait for at least one subscribed client
-    liftIO $ Event.wait startEvent
-    forever $ do
-      liftIO $ threadDelay $ seconds * 1000000
-      -- Updates all client blocks
-      -- If send returns 'False' the clients mailbox has been closed, so it is removed
-      bar <- ask
-      liftIO $ modifyMVar_ clientsMVar $ fmap catMaybes . mapConcurrently (\r -> runBarIO bar $ runAndFilterClient r)
-      -- Then update the bar
-      updateBar
-
-  liftIO $ link task
-
-  return (addClient startEvent clientsMVar)
-  where
-    runAndFilterClient :: (MVar PullBlock, Output (Maybe BlockOutput)) -> BarIO (Maybe (MVar PullBlock, Output (Maybe BlockOutput)))
-    runAndFilterClient client = do
-      result <- runClient client
-      return $ if result then Just client else Nothing
-    runClient :: (MVar PullBlock, Output (Maybe BlockOutput)) -> BarIO Bool
-    runClient (blockProducerMVar, output) = do
-      bar <- ask
-      liftIO $ modifyMVar blockProducerMVar $ \blockProducer -> do
-        result <- runReaderT (next blockProducer) bar
-        case result of
-          Left _ -> return (exitBlock, False)
-          Right (blockOutput, blockProducer') -> do
-            success <- atomically $ send output $ (clickAction ?~ updateClickHandler blockOutput) <$> blockOutput
-            if success
-              -- Store new BlockProducer back into MVar
-              then return (blockProducer', True)
-              -- Mailbox is sealed, stop running producer
-              else return (exitBlock, False)
-      where
-        updateClickHandler :: Maybe BlockOutput -> Click -> BarIO ()
-        updateClickHandler Nothing _ = return ()
-        updateClickHandler (Just block) _ = do
-          -- Give user feedback that the block is updating
-          let outdatedBlock = block & invalid.~True
-          liftIO $ void $ atomically $ send output . Just $ outdatedBlock
-          -- Notify bar about changed block state to display the feedback
-          updateBar
-          -- Run a normal block update to update the block to the new value
-          void $ runClient (blockProducerMVar, output)
-          -- Notify bar about changed block state, this is usually done by the shared interval handler
-          updateBar
-    addClient :: Event.Event -> MVar [(MVar PullBlock, Output (Maybe BlockOutput))] -> PullBlock -> CachedBlock
-    addClient startEvent clientsMVar blockProducer = do
-      -- Spawn the mailbox that preserves the latest block
-      (output, input) <- liftIO $ spawn $ latest $ Just emptyBlock
-
-      blockProducerMVar <- liftIO $ newMVar blockProducer
-
-      -- Generate initial block and send it to the mailbox
-      lift $ void $ runClient (blockProducerMVar, output)
-
-      -- Register the client for regular updates
-      liftIO $ modifyMVar_ clientsMVar $ \ clients -> return ((blockProducerMVar, output):clients)
-
-      -- Start update thread (if not already started)
-      liftIO $ Event.set startEvent
-
-      -- Return a block producer from the mailbox
-      cacheFromInput input
-
-blockScript :: FilePath -> PullBlock
-blockScript path = forever $ yield . Just =<< (lift blockScriptAction)
-  where
-    blockScriptAction :: BarIO BlockOutput
-    blockScriptAction = 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) <- liftIO $ readProcessStdout $ shell path
-      case exitCode of
-        ExitSuccess -> return $ case map E.decodeUtf8 (C8.lines output) of
-          -- TODO: Fix this, but how?
-          --   PangoSegments cannot have external formatting, so either allow that here,
-          --   or duplicate the function into ango and nonPango variants.
-          -- (text:short:color:_) -> setColor color $ shortText short $ createScriptBlock text
-          (text:short:_) -> shortText ?~ pangoText short $ createScriptBlock text
-          (text:_) -> createScriptBlock text
-          [] -> createScriptBlock "-"
-        (ExitFailure nr) -> return $ createErrorBlock $ "[" <> T.pack (show nr) <> "]"
-    createScriptBlock :: T.Text -> BlockOutput
-    createScriptBlock text = blockName ?~ T.pack path $ createBlock . pangoText $ text
-
-startPersistentBlockScript :: FilePath -> CachedBlock
--- This is only using 'CachedBlock' because the code was already written and tested
--- This could probably be massively simplified by using the new 'pushBlock'
-startPersistentBlockScript path = do
-  bar <- lift ask
-  do
-    (output, input, seal) <- liftIO $ spawn' $ latest $ Just emptyBlock
-    initialDataEvent <- liftIO Event.new
-    task <- liftIO $ async $ do
-      let processConfig = setStdin closed $ setStdout createPipe $ shell path
-      finally (
-        catch (
-          withProcessWait processConfig $ \ process -> do
-            let handle = getStdout process
-            runEffect $ fromHandle bar handle >-> signalFirstBlock initialDataEvent >-> toOutput output
-          )
-          ( \ e ->
-            -- output error
-            runEffect $ yield (Just . createErrorBlock $ "[" <> T.pack (show (e :: IOException)) <> "]") >-> signalFirstBlock initialDataEvent >-> toOutput output
-          )
-        )
-        (atomically seal)
-    liftIO $ link task
-    liftIO $ Event.wait initialDataEvent
-    cacheFromInput input
-  where
-    signalFirstBlock :: Event.Event -> Pipe (Maybe BlockOutput) (Maybe BlockOutput) IO ()
-    signalFirstBlock event = do
-      -- Await first block
-      await >>= yield
-      lift $ Event.set event
-      -- Replace with cat
-      cat
-    fromHandle :: Bar -> Handle -> Producer (Maybe BlockOutput) IO ()
-    fromHandle bar handle = forever $ do
-      line <- lift $ TIO.hGetLine handle
-      yield $ Just . createBlock . pangoText $ line
-      lift $ updateBar' bar
-
-
-addBlock :: IsBlock a => a -> BarIO ()
-addBlock block = do
-  newBlockChan' <- asks newBlockChan
-  liftIO $ atomically $ writeTChan newBlockChan' $ toCachedBlock block
-
-updateBar :: BarIO ()
-updateBar = liftIO =<< asks requestBarUpdate
-
-updateBar' :: Bar -> IO ()
-updateBar' = runReaderT updateBar
-
-barAsync :: BarIO a -> BarIO (Async a)
-barAsync action = do
-  bar <- ask
-  lift $ async $ runReaderT action bar
-
-cachePushBlock :: PushBlock -> CachedBlock
-cachePushBlock pushBlock = lift (next pushBlock) >>= either (const exitBlock) withInitialBlock
-  where
-    withInitialBlock :: (Maybe BlockOutput, PushBlock) -> CachedBlock
-    withInitialBlock (initialBlockOutput, pushBlock') = do
-      (output, input, seal) <- liftIO $ spawn' $ latest $ initialBlockOutput
-      -- The async could be used to stop the block later, but for now we are just linking it to catch exceptions
-      task <- lift $ barAsync (sendProducerToMailbox output seal pushBlock')
-      liftIO $ link task
-      terminateOnMaybe $ fromInput input
-    sendProducerToMailbox :: Output (Maybe BlockOutput) -> STM () -> PushBlock -> BarIO ()
-    sendProducerToMailbox output seal pushBlock' = do
-      void $ runEffect $ for pushBlock' (sendOutputToMailbox output)
-      liftIO $ atomically $ void $ send output Nothing
-      updateBar
-      liftIO $ atomically seal
-    sendOutputToMailbox :: Output (Maybe BlockOutput) -> Maybe BlockOutput -> Effect BarIO ()
-    sendOutputToMailbox output blockOutput = do
-      -- The void is discarding the boolean result that indicates if the mailbox is sealed
-      -- This is ok because a cached block is never sealed from the receiving side
-      liftIO $ atomically $ void $ send output $ blockOutput
-      lift updateBar
-    terminateOnMaybe :: Producer (Maybe BlockOutput) BarIO () -> Producer (Maybe BlockOutput) BarIO CachedMode
-    terminateOnMaybe p = do
-      eitherMaybeValue <- lift $ next p
-      case eitherMaybeValue of
-        Right (Just value, newP) -> yield (Just value) >> terminateOnMaybe newP
-        _ -> exitBlock

src/QBar/DefaultConfig.hs

-module QBar.DefaultConfig where
-
-import QBar.Blocks
-import QBar.Core
-
-import Pipes
-
-import Control.Lens
-
-blockLocation :: String -> FilePath
-blockLocation name = "~/.config/qbar/blocks/" <> name
-
-generateDefaultBarConfig :: BarIO ()
-generateDefaultBarConfig = do
-  systemInfoInterval <- sharedInterval 10
-
-  let todo = systemInfoInterval (blockScript $ blockLocation "todo")
-  let wifi = systemInfoInterval (blockScript $ blockLocation "wifi2 wlan") >-> modify (addIcon "📡\xFE0E")
-  let networkEnvironment = systemInfoInterval (blockScript $ blockLocation "network-environment")
-  let cpu = systemInfoInterval (blockScript $ blockLocation "cpu_usage") >-> modify ((blockName?~"cpu") . addIcon "💻\xFE0E") >-> autoPadding
-  let ram = systemInfoInterval (blockScript $ blockLocation "memory") >-> modify (addIcon "🐏\xFE0E") >-> autoPadding
-  let temperature = systemInfoInterval (blockScript $ blockLocation "temperature") >-> autoPadding
-  let volumeBlock = startPersistentBlockScript $ blockLocation "volume-pulseaudio -S -F3"
-  let battery = systemInfoInterval $ batteryBlock >-> modify (blockName?~"battery")
-
-  addBlock dateBlock
-  addBlock battery
-  addBlock volumeBlock
-  addBlock temperature
-  addBlock ram
-  addBlock cpu
-  addBlock networkEnvironment
-  addBlock wifi
-  addBlock todo

src/QBar/Filter.hs

-{-# LANGUAGE TemplateHaskell #-}
-
-module QBar.Filter where
-
-import QBar.Core
-import QBar.BlockText
-
-import Control.Monad.State.Lazy (State, evalState, get, put)
-import Data.Aeson.TH
-import Data.Colour.RGBSpace.HSV (hsv)
-import qualified Data.Text.Lazy as T
-import Control.Lens hiding (index)
-
-import Numeric (showHex)
-import Data.Colour.RGBSpace
-
-
-data Filter = StaticFilter StaticFilter
-  | AnimatedFilter AnimatedFilter
-  deriving Show
-
-data StaticFilter = None
-  deriving Show
-
-data AnimatedFilter = Rainbow
-  deriving Show
-
-$(deriveJSON defaultOptions ''Filter)
-$(deriveJSON defaultOptions ''StaticFilter)
-$(deriveJSON defaultOptions ''AnimatedFilter)
-
-isAnimatedFilter :: Filter -> Bool
-isAnimatedFilter (AnimatedFilter _) = True
-isAnimatedFilter _ = False
-
-applyFilter :: Filter -> Double -> [BlockOutput] -> [BlockOutput]
-applyFilter (StaticFilter None) = static id
-applyFilter (AnimatedFilter Rainbow) = rainbow
-
-static :: a -> Double -> a
-static fn _ = fn
-
-
-coloredText :: T.Text -> T.Text -> T.Text
-coloredText color text = "<span color='" <> color <> "'>" <> text <> "</span>"
-
-
-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
-
-
-rainbow :: Double -> [BlockOutput] -> [BlockOutput]
-rainbow time blocks = reverse $ evalState (mapM rainbowBlock $ reverse blocks) 0
-  where
-    rainbowBlock :: BlockOutput -> State Integer BlockOutput
-    rainbowBlock block = do
-      let text = removePango $ block^.fullText
-      let chars = T.unpack . T.reverse $ text
-      coloredChars <- mapM rainbowChar chars
-      let rainbowText = T.concat . reverse $ coloredChars
-      return $ fullText .~ pangoText rainbowText $ block
-    rainbowChar :: Char -> State Integer T.Text
-    rainbowChar char = do
-      color <- nextRainbowColor
-      return $ coloredText color $ T.singleton char
-    nextRainbowColor :: State Integer T.Text
-    -- nextRainbowColor = state $ \index -> (rainbowColor (fromInteger index), index + 1)
-    nextRainbowColor = do
-      index <- get
-      put $ index + 1
-      return $ rainbowColor (fromInteger index + time * 10)
-
-
-rainbowColor :: Double -> T.Text
-rainbowColor position =
-  let hue' = position * 3
-      color = hsv hue' 0.8 1.0
-  in pangoColor color

src/QBar/Pango.hs

-{-# LANGUAGE OverloadedStrings #-}
-
-module QBar.Pango (Pango, parsePango, removeFormatting) where
-
-import Control.Applicative ((<|>))
-import Control.Monad (void)
-import qualified Data.Text.Lazy as T
-import Data.Attoparsec.Text.Lazy as A
-
-data Pango = PText T.Text
-  | PTag T.Text [(T.Text, T.Text)] Pango
-  | PList [Pango]
-  deriving Show
-
-pList :: [Pango] -> Pango
-pList [one] = one
-pList more = PList more
-
-pangoParser :: Parser Pango
-pangoParser = pList <$> many' (choice [normalTextParser, tagParser])
-  where
-    normalTextParser :: Parser Pango
-    normalTextParser  = PText . T.fromStrict <$> A.takeWhile1 (notInClass "<>")
-
-    tagParser :: Parser Pango
-    tagParser = do
-      tagName <- char '<' >> identifier
-      attributes <- many' $ do
-        space >> skipSpace
-        attributeName <- identifier
-        void $ char '='
-        value <- char '\'' *> many' (notChar '\'') <* char '\''
-          <|> char '"' *> many' (notChar '"') <* char '"'
-        return (attributeName, T.pack value)
-      void $ char '>'
-      content <- pangoParser
-      -- close tag
-      void $ string $ T.toStrict $ "</" <> tagName <> ">"
-      return $ PTag tagName attributes content
-
-    identifier :: Parser T.Text
-    identifier = T.pack <$> many1 (letter <|> digit)
-
-parsePango :: T.Text -> Either String Pango
-parsePango text = parseOnly (pangoParser <* endOfInput) (T.toStrict text)
-
-removeFormatting :: Pango -> T.Text
-removeFormatting (PText text) = text
-removeFormatting (PTag _ _ child) = removeFormatting child
-removeFormatting (PList list) = mconcat $ map removeFormatting list
\ No newline at end of file

src/QBar/Server.hs

-module QBar.Server where
-
-import QBar.Blocks
-import QBar.Core
-import QBar.Cli
-import QBar.ControlSocket
-import QBar.Filter
-import QBar.BlockText
-import QBar.Themes
-
-import Control.Monad (forever, when, unless)
-import Control.Monad.Reader (ask)
-import Control.Monad.STM (atomically)
-import Control.Concurrent (threadDelay, forkFinally)
-import Control.Concurrent.Async
-import Control.Concurrent.Event as Event
-import Control.Concurrent.STM.TChan (TChan, newTChanIO, readTChan, tryReadTChan)
-import Data.Aeson (encode, decode, ToJSON, toJSON, object, (.=))
-import Data.ByteString.Lazy (hPut)
-import qualified Data.ByteString.Char8 as BSSC8
-import qualified Data.ByteString.Lazy as BS
-import qualified Data.ByteString.Lazy.Char8 as C8
-import Data.IORef
-import Data.Maybe (catMaybes, mapMaybe, fromMaybe)
-import qualified Data.Text.Lazy as T
-import Data.Time.Clock.POSIX
-import Pipes
-import System.IO (stdin, stdout, stderr, hFlush, hPutStrLn)
-import System.Posix.Signals
-import Control.Lens hiding (each, (.=))
-
-data Handle = Handle {
-  handleActionList :: IORef [(T.Text, Click -> BarIO ())],
-  handleActiveFilter :: IORef Filter
-}
-
-renderIndicator :: CachedBlock
--- Using 'cachedBlock' is a hack to actually get the block to update on every bar update (by doing this it will not get a cache later in the pipeline).
-renderIndicator = forever $ each $ map (Just . createBlock . normalText) ["/", "-", "\\", "|"]
-
-runBlock :: CachedBlock -> BarIO (Maybe (Maybe BlockOutput, CachedBlock))
-runBlock producer = do
-  next' <- next producer
-  return $ case next' of
-    Left _ -> Nothing
-    Right (block, newProducer) -> Just (block, newProducer)
-
-runBlocks :: [CachedBlock] -> BarIO ([Maybe BlockOutput], [CachedBlock])
-runBlocks block = unzip . catMaybes <$> mapM runBlock block
-
-data RenderBlock = RenderBlock T.Text (Maybe T.Text) (Maybe T.Text)
-  deriving(Show)
-instance ToJSON RenderBlock where
-  toJSON (RenderBlock fullText' shortText' blockName') = object $
-    fullText'' <> shortText'' <> blockName'' <> pango''
-    where
-      fullText'' = [ "full_text" .= fullText' ]
-      shortText'' = fromMaybe (\s -> ["short_text".=s]) mempty shortText'
-      blockName'' = fromMaybe (\s -> ["name".=s]) mempty blockName'
-      pango'' = [ "markup" .= ("pango" :: T.Text) ]
-
-
-
-renderLoop :: MainOptions -> Handle -> BarUpdateEvent -> BS.ByteString -> TChan CachedBlock -> BarIO ()
-renderLoop options handle@Handle{handleActiveFilter} barUpdateEvent previousBarOutput newBlockChan = renderLoop' previousBarOutput []
-  where
-    addNewBlocks :: [CachedBlock] -> BarIO [CachedBlock]
-    addNewBlocks blocks = do
-      maybeNewBlock <- liftIO $ atomically $ tryReadTChan newBlockChan
-      case maybeNewBlock of
-        Nothing -> return blocks
-        Just newBlock -> addNewBlocks (newBlock:blocks)
-    renderLoop' :: BS.ByteString -> [CachedBlock] -> BarIO ()
-    renderLoop' previousBarOutput' blocks = do
-      blockFilter <- liftIO $ readIORef handleActiveFilter
-
-      -- Wait for an event (unless the filter is animated)
-      unless (isAnimatedFilter blockFilter) $ liftIO $ Event.wait barUpdateEvent
-
-      -- Wait for 10ms after first events to catch (almost-)simultaneous event updates
-      liftIO $ threadDelay 10000
-      liftIO $ Event.clear barUpdateEvent
-
-      blocks' <- addNewBlocks blocks
-
-      (blockOutputs, blocks'') <- runBlocks blocks'
-
-      currentBarOutput <- liftIO $ renderLine options handle blockFilter blockOutputs previousBarOutput'
-
-      -- Wait for 100ms after rendering a line to limit cpu load of rapid events
-      liftIO $ threadDelay 100000
-
-      renderLoop' currentBarOutput blocks''
-
-renderLine :: MainOptions -> Handle -> Filter -> [Maybe BlockOutput] -> BS.ByteString -> IO BS.ByteString
-renderLine MainOptions{verbose} Handle{handleActionList} blockFilter blocks' previousEncodedOutput = do
-  time <- fromRational . toRational <$> getPOSIXTime
-  let blocks = catMaybes blocks'
-  let filteredBlocks = applyFilter blockFilter time blocks
-  -- let encodedOutput = encode $ map values filteredBlocks
-  let encodedOutput = encodeOutput filteredBlocks
-  let changed = previousEncodedOutput /= encodedOutput
-  when changed $ do
-    hPut stdout encodedOutput
-    putStrLn ","
-    hFlush stdout
-    -- Echo output to stderr when verbose flag is set
-    when verbose $ do
-      hPut stderr encodedOutput
-      hPut stderr "\n"
-      hFlush stderr
-
-  when verbose $ unless changed $ hPutStrLn stderr "Output unchanged"
-
-  -- Register click handlers regardless of bar changes, because we cannot easily check if any handler has changed
-  writeIORef handleActionList clickActionList
-
-  return encodedOutput
-  where
-    theme :: Theme
-    theme = defaultTheme
-    encodeOutput :: [BlockOutput] -> BS.ByteString
-    encodeOutput bs = encode $ zipWith encodeBlock bs $ theme bs
-    encodeBlock :: BlockOutput -> (T.Text, Maybe T.Text) -> RenderBlock
-    encodeBlock b (fullText', shortText') = RenderBlock fullText' shortText' (b^.blockName)
-    clickActionList :: [(T.Text, Click -> BarIO ())]
-    clickActionList = mapMaybe getClickAction . catMaybes $ blocks'
-    getClickAction :: BlockOutput -> Maybe (T.Text, Click -> BarIO ())
-    getClickAction block = do
-      blockName' <- block^.blockName
-      clickAction' <- block^.clickAction
-      return (blockName', clickAction')
-
-createBarUpdateChannel :: IO (IO (), BarUpdateEvent)
-createBarUpdateChannel = do
-  event <- Event.newSet
-  return (Event.set event, event)
-
-handleStdin :: MainOptions -> IORef [(T.Text, Click -> BarIO ())] -> BarIO ()
-handleStdin options actionListIORef = do
-  bar <- ask
-  liftIO $ forever $ do
-    line <- BSSC8.hGetLine stdin
-
-    unless (line == "[") $ do
-      -- Echo input to stderr when verbose flag is set
-      when (verbose options) $ do
-        BSSC8.hPutStrLn stderr line
-        hFlush stderr
-
-      let maybeClick = decode $ removeComma $ BS.fromStrict line
-      case maybeClick of
-        Just click -> do
-          clickActionList <- readIORef actionListIORef
-          let maybeClickAction = getClickAction clickActionList click
-          case maybeClickAction of
-            Just clickAction' -> async (runBarIO bar (clickAction' click)) >>= link
-            Nothing -> return ()
-        Nothing -> return ()
-
-  where
-    getClickAction :: [(T.Text, Click -> BarIO ())] -> Click -> Maybe (Click -> BarIO ())
-    getClickAction clickActionList click = lookup (name click) clickActionList
-    removeComma :: C8.ByteString -> C8.ByteString
-    removeComma line
-      | C8.head line == ',' = C8.tail line
-      | C8.last line == ',' = C8.init line
-      | otherwise = line
-
-installSignalHandlers :: BarIO ()
-installSignalHandlers = do
-  bar <- ask
-  liftIO $ void $ installHandler sigCONT (Catch (sigContAction bar)) Nothing
-  where
-    sigContAction :: Bar -> IO ()
-    sigContAction bar = do
-      hPutStrLn stderr "SIGCONT received"
-      updateBar' bar
-
-renderInitialBlocks :: MainOptions -> Handle -> Filter -> IO C8.ByteString
-renderInitialBlocks options handle blockFilter = do
-  date <- dateBlockOutput
-  let initialBlocks = [Just date]
-  -- Attach spinner indicator when verbose flag is set
-  let initialBlocks' = if indicator options then initialBlocks <> [Just . createBlock . normalText $ "*"] else initialBlocks
-  -- Render initial time block so the bar is not empty after startup
-  renderLine options handle blockFilter initialBlocks' ""
-
-
-runBarConfiguration :: BarIO () -> MainOptions -> IO ()
-runBarConfiguration defaultBarConfig options = do
-  -- Create IORef to contain the active filter
-  let initialBlockFilter = StaticFilter None
-  activeFilter <- newIORef initialBlockFilter
-
-  putStrLn "{\"version\":1,\"click_events\":true}"
-  putStrLn "["
-
-  (requestBarUpdate, barUpdateEvent) <- createBarUpdateChannel
-
-  -- Create channel to send new block producers to render loop
-  newBlockChan <- newTChanIO
-
-  let bar = Bar { requestBarUpdate, newBlockChan }
-
-  -- Create IORef for mouse click callbacks
-  actionList <- newIORef []
-  let handle = Handle {
-    handleActionList = actionList,
-    handleActiveFilter = activeFilter
-  }
-
-  initialOutput <- renderInitialBlocks options handle initialBlockFilter
-
-
-  -- Fork stdin handler
-  void $ forkFinally (runBarIO bar (handleStdin options actionList)) (\result -> hPutStrLn stderr $ "handleStdin failed: " <> show result)
-
-
-  runBarIO bar loadBlocks
-
-  -- Install signal handler for SIGCONT
-  runBarIO bar installSignalHandlers
-
-  -- Create control socket
-  commandChan <- createCommandChan
-  controlSocketAsync <- listenUnixSocketAsync options commandChan
-  link controlSocketAsync
-
-  -- Update bar on control socket messages
-  socketUpdateAsync <- async $ forever $ do
-    command <- atomically $ readTChan commandChan
-    case command of
-      SetFilter blockFilter -> atomicWriteIORef activeFilter blockFilter
-      Block -> error "TODO"
-    updateBar' bar
-  link socketUpdateAsync
-
-  runBarIO bar (renderLoop options handle barUpdateEvent initialOutput newBlockChan)
-  where
-    loadBlocks :: BarIO ()
-    loadBlocks = do
-      when (indicator options) $ addBlock renderIndicator
-
-      defaultBarConfig
-
-
-createCommandChan :: IO CommandChan
-createCommandChan = newTChanIO
-
--- |Entry point.
-runQBar :: BarIO () -> MainOptions -> IO ()
-runQBar barConfiguration options@MainOptions{barCommand} = runCommand barCommand
-  where
-    runCommand BarServer = runBarConfiguration barConfiguration options
-    runCommand NoFilter = sendIpc options $ SetFilter $ StaticFilter None
-    runCommand RainbowFilter = sendIpc options $ SetFilter $ AnimatedFilter Rainbow

src/QBar/Themes.hs

-module QBar.Themes where
-
-
-import QBar.BlockText
-import QBar.Core
-
-import qualified Data.Text.Lazy as T
-
-import Control.Lens
-
-
-type Theme = [BlockOutput] -> [(T.Text, Maybe T.Text)]
-type SimplifiedTheme = Bool -> Importance -> (Color, Maybe Color)
-type AnimatedTheme = Double -> Theme
-
-
-mkTheme :: SimplifiedTheme -> Theme
-mkTheme theming' = map themeBlock
-  where
-    themeBlock :: BlockOutput -> (T.Text, Maybe T.Text)
-    themeBlock block = (fullText', shortText')
-      where
-        theming :: SimplifiedTheme
-        theming
-          | block^.invalid = invalidSimplifiedTheme
-          | otherwise = theming'
-        fullText' :: T.Text
-        fullText' = themeBlockText theming $ block^.fullText
-        shortText' :: Maybe T.Text
-        shortText' = themeBlockText theming <$> block^.shortText
-    themeBlockText :: SimplifiedTheme -> BlockText -> T.Text
-    themeBlockText theming (BlockText b) = foldr ((<>) . themeSegment theming) "" b
-    themeSegment :: SimplifiedTheme -> BlockTextSegment -> T.Text
-    themeSegment theming BlockTextSegment {active, importance, text} = (applyTheme $ theming active importance) text
-    themeSegment _ (PangoTextSegment text) = text
-    applyTheme :: (Color, Maybe Color) -> T.Text -> T.Text
-    applyTheme (fc, Just bc) s = "<span color='" <> colorToHex fc <> "' background='" <> colorToHex bc <> "'>" <> s <> "</span>"
-    applyTheme (fc, Nothing) s = "<span color='" <> colorToHex fc <> "'>" <> s <> "</span>"
-
-
-invalidColor :: Color
-invalidColor = ColorRGBA (0x96/255) (0x98/255) (0x96/255) (0x77/255)
-
-
-invalidSimplifiedTheme :: SimplifiedTheme
-invalidSimplifiedTheme _ _ = (invalidColor, Nothing)
-
-
-invalidTheme :: Theme
-invalidTheme = mkTheme invalidSimplifiedTheme
-
-
-defaultTheme :: Theme
-defaultTheme = mkTheme defaultTheme'
-  where
-    defaultTheme' :: SimplifiedTheme
-    defaultTheme' active importance
-      | isCritical importance, active = (ColorRGB 0 0 0, Just $ ColorRGB 1 0 0)
-      | isCritical importance         = (ColorRGB 0.8 0.15 0.15, Nothing)
-      | isError importance, active    = (ColorRGB 1 0.3 0, Nothing)
-      | isError importance            = (ColorRGB 0.7 0.35 0.2, Nothing)
-      | isWarning importance,active   = (ColorRGB 1 0.9 0, Nothing)
-      | isWarning importance          = (ColorRGB 0.6 0.6 0, Nothing)
-      | otherwise, active             = (ColorRGB 1 1 1, Nothing)
-      | otherwise                     = (ColorRGB (0x96/255) (0x98/255) (0x96/255), Nothing)

src/QBar/Time.hs

-module QBar.Time (sleepUntil, nextMinute) where
-
-import Control.Concurrent (threadDelay)
-import Control.Monad (when)
-import Data.Time.Clock (UTCTime, getCurrentTime, diffUTCTime, utctDayTime)
-
-sleepUntil :: UTCTime -> IO ()
-sleepUntil time = do
-  now <- getCurrentTime
-  let timeUntil = diffUTCTime time now
-  when (timeUntil > 0) $
-    if timeUntil > 1
-      then threadDelay 1000000 >> sleepUntil time
-      else threadDelay $ ceiling $ toRational timeUntil * 1000000
-
-nextMinute :: IO UTCTime
-nextMinute = do
-  now <- getCurrentTime
-  let dayTime = utctDayTime now
-  let daySeconds = floor dayTime
-  let dayMinute = daySeconds `div` 60
-  return now {
-    utctDayTime = fromInteger $ (dayMinute + 1) * 60
-  }
\ No newline at end of file

stack.yaml

-# This file was automatically generated by 'stack init'
-#
-# Some commonly used options have been documented as comments in this file.
-# For advanced use and comprehensive documentation of the format, please see:
-# https://docs.haskellstack.org/en/stable/yaml_configuration/
-
-# Resolver to choose a 'specific' stackage snapshot or a compiler version.
-# A snapshot resolver dictates the compiler version and the set of packages
-# to be used for project dependencies. For example:
-#
-# resolver: lts-3.5
-# resolver: nightly-2015-09-21
-# resolver: ghc-7.10.2
-#
-# The location of a snapshot can be provided as a file or url. Stack assumes
-# a snapshot provided as a file might change, whereas a url resource does not.
-#
-# resolver: ./custom-snapshot.yaml
-# resolver: https://example.com/snapshots/2018-01-01.yaml
-resolver: lts-14.11
-
-# User packages to be built.
-# Various formats can be used as shown in the example below.
-#
-# packages:
-# - some-directory
-# - https://example.com/foo/bar/baz-0.0.2.tar.gz
-# - location:
-#    git: https://github.com/commercialhaskell/stack.git
-#    commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
-# - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a
-#  subdirs:
-#  - auto-update
-#  - wai
-packages:
-- .
-# Dependency packages to be pulled from upstream that are not in the resolver
-# using the same syntax as the packages field.
-# (e.g., acme-missiles-0.3)
-# extra-deps: []
-
-# Disable pure nix-shell environment on NixOS, because access to XDG_RUNTIME_DIR is needed for the control socket
-nix:
-  pure: false
-
-# Override default flag values for local packages and extra-deps
-# flags: {}
-
-# Extra package databases containing global packages
-# extra-package-dbs: []
-
-# Control whether we use the GHC we find on the path
-# system-ghc: true
-#
-# Require a specific version of stack, using version ranges
-# require-stack-version: -any # Default
-# require-stack-version: ">=1.9"
-#
-# Override the architecture used by stack, especially useful on Windows
-# arch: i386
-# arch: x86_64
-#
-# Extra directories used by stack for building
-# extra-include-dirs: [/path/to/dir]
-# extra-lib-dirs: [/path/to/dir]
-#
-# Allow a newer minor version of GHC than the snapshot specifies
-# compiler-check: newer-minor