diff --git a/src/QBar/ControlSocket.hs b/src/QBar/ControlSocket.hs
index 17ea5df4b848b1f4920695fff9b7dba144f89f86..9b3bc85f56e22cdecdefc3ac066b5e6e914ab7f3 100644
--- a/src/QBar/ControlSocket.hs
+++ b/src/QBar/ControlSocket.hs
@@ -12,7 +12,7 @@ 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 Control.Concurrent.STM.TChan (TChan, newTChanIO, writeTChan)
import Data.Aeson.TH
import Data.ByteString (ByteString)
import System.FilePath ((</>))
@@ -33,7 +33,7 @@ import System.Environment (getEnv)
type CommandChan = TChan Command
-data Command = SetTheme T.Text
+data Command = SetTheme TL.Text
deriving Show
data SocketResponse = Success | Error Text
@@ -42,6 +42,9 @@ data SocketResponse = Success | Error Text
$(deriveJSON defaultOptions ''Command)
$(deriveJSON defaultOptions ''SocketResponse)
+createCommandChan :: IO CommandChan
+createCommandChan = newTChanIO
+
ipcSocketAddress :: MainOptions -> IO FilePath
ipcSocketAddress MainOptions{socketLocation} = maybe defaultSocketPath (return . T.unpack) socketLocation
where
diff --git a/src/QBar/Server.hs b/src/QBar/Server.hs
index fb42fe2b04371845690d10b76ed3dd93bc4ff2c1..ec09b0d67f0051f0648c46df7570fe3aad1e7d5f 100644
--- a/src/QBar/Server.hs
+++ b/src/QBar/Server.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE ScopedTypeVariables #-}
module QBar.Server where
@@ -9,10 +10,15 @@ import QBar.ControlSocket
import QBar.Host
import QBar.Pango
import QBar.Theme
+import QBar.Util
import Control.Monad (forever, when, unless, forM_)
--- import Control.Concurrent.Async
-import Control.Concurrent.STM.TChan (newTChanIO)
+import Control.Concurrent.Async (async, link)
+import Control.Concurrent.Event as Event
+import Control.Concurrent.MVar (MVar, newMVar, modifyMVar, modifyMVar_)
+import Control.Concurrent.STM (atomically)
+import Control.Concurrent.STM.TChan (readTChan)
+import Control.Exception (throw)
import Data.Aeson (encode, decode, ToJSON, toJSON, object, (.=))
import Data.ByteString.Lazy (hPut)
import qualified Data.ByteString.Char8 as BSSC8
@@ -20,7 +26,10 @@ import qualified Data.ByteString.Lazy as BS
import qualified Data.ByteString.Lazy.Char8 as C8
import Data.Maybe (fromMaybe)
import qualified Data.Text.Lazy as T
+import qualified Data.Text.Lazy.IO as TIO
import Pipes
+import Pipes.Concurrent (Input, spawn, latest, toOutput, fromInput)
+import qualified Pipes.Prelude as PP
import System.IO (stdin, stdout, stderr, hFlush)
renderIndicator :: CachedBlock
@@ -42,43 +51,6 @@ instance ToJSON PangoBlock where
pango' = [ "markup" .= ("pango" :: T.Text) ]
--- |A consumer that accepts lists of 'BlockOutput' and renders them to stdout using the {sway,i3}bar-protocol.
-swayBarOutput :: MainOptions -> Consumer [BlockOutput] BarIO ()
-swayBarOutput MainOptions{verbose} = do
- -- Output header
- liftIO $ do
- putStrLn "{\"version\":1,\"click_events\":true}"
- putStrLn "["
-
- swayBarOutput'
- where
- swayBarOutput' :: Consumer [BlockOutput] BarIO ()
- swayBarOutput' = do
- blocks <- await
-
- let themedOutput = defaultTheme blocks
- let encodedOutput = encodeOutput themedOutput
-
- liftIO $ 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
-
- swayBarOutput'
- encodeOutput :: [ThemedBlockOutput] -> BS.ByteString
- encodeOutput blocks = encode $ map renderPangoBlock $ blocks
- renderPangoBlock :: ThemedBlockOutput -> PangoBlock
- renderPangoBlock ThemedBlockOutput{_fullText, _shortText, _blockName} = PangoBlock {
- pangoBlockFullText = renderPango _fullText,
- pangoBlockShortText = renderPango <$> _shortText,
- pangoBlockName = _blockName
- }
-
-- |A producer that reads swaybar/i3bar-input events from stdin and emits them as 'BlockEvent's.
swayBarInput :: MainOptions -> Producer BlockEvent BarIO ()
swayBarInput MainOptions{verbose} = swayBarInput'
@@ -105,6 +77,29 @@ swayBarInput MainOptions{verbose} = swayBarInput'
| otherwise = line
+outputLine :: MainOptions -> [ThemedBlockOutput] -> IO ()
+outputLine MainOptions{verbose} themedBlocks = do
+ let encodedOutput = encodeOutput themedBlocks
+
+ liftIO $ 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
+ where
+ encodeOutput :: [ThemedBlockOutput] -> BS.ByteString
+ encodeOutput blocks = encode $ map renderPangoBlock $ blocks
+ renderPangoBlock :: ThemedBlockOutput -> PangoBlock
+ renderPangoBlock ThemedBlockOutput{_fullText, _shortText, _blockName} = PangoBlock {
+ pangoBlockFullText = renderPango _fullText,
+ pangoBlockShortText = renderPango <$> _shortText,
+ pangoBlockName = _blockName
+ }
+
runBarServer :: BarIO () -> MainOptions -> IO ()
runBarServer defaultBarConfig options = runBarHost barServer (swayBarInput options)
where
@@ -115,24 +110,71 @@ runBarServer defaultBarConfig options = runBarHost barServer (swayBarInput optio
when (indicator options) $ addBlock renderIndicator
defaultBarConfig
- -- Create control socket
- -- commandChan <- liftIO createCommandChan
- -- controlSocketAsync <- liftIO $ listenUnixSocketAsync options commandChan
- -- liftIO $ link controlSocketAsync
- -- bar <- askBar
+ -- Event to render the bar (fired when block output or theme is changed)
+ renderEvent <- liftIO Event.new
+
+ -- Mailbox to store the latest 'BlockOutput's
+ (output, input) <- liftIO $ spawn $ latest []
+
+ -- MVar that holds the current theme, linked to the input from the above mailbox
+ (themedBlockProducerMVar :: MVar (Producer [ThemedBlockOutput] IO (), Bool)) <- liftIO $ newMVar $ (return (), False)
+
+
+ -- Create control socket
+ commandChan <- liftIO createCommandChan
+ controlSocketAsync <- liftIO $ listenUnixSocketAsync options commandChan
+ liftIO $ link controlSocketAsync
-- Update bar on control socket messages
- -- socketUpdateAsync <- liftIO $ async $ forever $ do
- -- -- command <- atomically $ readTChan commandChan
- -- void $ error "TODO"
- -- updateBar' bar
- -- liftIO $ link socketUpdateAsync
+ socketUpdateAsync <- liftIO $ async $ forever $ do
+ command <- atomically $ readTChan commandChan
+ case command of
+ SetTheme name -> do
+ let result = findTheme name
+ case result of
+ Left err -> TIO.hPutStrLn stderr err
+ Right theme -> do
+ setTheme input themedBlockProducerMVar theme
+ Event.signal renderEvent
+ liftIO $ link socketUpdateAsync
- swayBarOutput options
+ liftIO $ do
+ -- Set default theme
+ setTheme input themedBlockProducerMVar defaultTheme
+
+ -- Print header
+ putStrLn "{\"version\":1,\"click_events\":true}"
+ putStrLn "["
+ -- Run render loop
+ liftIO $ link =<< async (renderLoop renderEvent themedBlockProducerMVar)
+
+ -- Return a consumer that accepts BlockOutputs from the bar host, moves them to the mailbox and signals the renderer to update the bar.
+ signalPipe renderEvent >-> toOutput output
+
+ renderLoop :: Event.Event -> MVar (Producer [ThemedBlockOutput] IO (), Bool) -> IO ()
+ renderLoop renderEvent themedBlockProducerMVar = forever $ do
+ (themedBlocks, isAnimated'') <- modifyMVar themedBlockProducerMVar (\(themedBlockProducer, isAnimated') -> do
+ result <- next themedBlockProducer
+ case result of
+ -- TODO: fix type safety on this somehow?
+ Left _ -> throw $ userError "Unexpected behavior: themes and mailboxes should never return"
+ Right (themedBlocks, nextThemedBlockProducer) ->
+ return ((nextThemedBlockProducer, isAnimated'), (themedBlocks, isAnimated'))
+ )
+ outputLine options themedBlocks
+ if isAnimated''
+ -- Limit to 10 FPS because swaybar rendering is surprisingly expensive
+ -- TODO: make FPS configurable
+ then void $ Event.waitTimeout renderEvent 100000
+ else Event.wait renderEvent
+
+ setTheme :: Input [BlockOutput] -> MVar (Producer [ThemedBlockOutput] IO (), Bool) -> Theme -> IO ()
+ setTheme blockOutputInput themedBlockProducerMVar (StaticTheme theme) =
+ modifyMVar_ themedBlockProducerMVar (\_ -> return (fromInput blockOutputInput >-> PP.map theme, False))
+ setTheme blockOutputInput themedBlockProducerMVar (AnimatedTheme theme) =
+ modifyMVar_ themedBlockProducerMVar (\_ -> return (fromInput blockOutputInput >-> theme, True))
-createCommandChan :: IO CommandChan
-createCommandChan = newTChanIO
-- |Entry point.
runQBar :: BarIO () -> MainOptions -> IO ()
diff --git a/src/QBar/Theme.hs b/src/QBar/Theme.hs
index e890636ebb030408384aa538364e9f2af869e485..cc589390116e8b8c5dfd976a464d6a8b6e69102b 100644
--- a/src/QBar/Theme.hs
+++ b/src/QBar/Theme.hs
@@ -1,4 +1,6 @@
{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE Rank2Types #-}
+
module QBar.Theme where
import QBar.BlockOutput
@@ -37,13 +39,25 @@ data ThemedBlockTextSegment = ThemedBlockTextSegment {
deriving (Eq, Show)
-type Theme = [BlockOutput] -> [ThemedBlockOutput]
+data Theme = StaticTheme StaticTheme | AnimatedTheme AnimatedTheme
+
+type StaticTheme = [BlockOutput] -> [ThemedBlockOutput]
type SimplifiedTheme = Bool -> Importance -> (Color, Maybe Color)
-type AnimatedTheme = Pipe [BlockOutput] [ThemedBlockOutput] IO ()
+type AnimatedTheme = forall r. Pipe [BlockOutput] [ThemedBlockOutput] IO r
+
+isAnimated :: Theme -> Bool
+isAnimated (AnimatedTheme _) = True
+isAnimated _ = False
+
+
+findTheme :: Text -> Either Text Theme
+findTheme "default" = Right defaultTheme
+findTheme "rainbow" = Right rainbowTheme
+findTheme name = Left $ "Invalid theme: " <> name
mkTheme :: SimplifiedTheme -> Theme
-mkTheme theming' = map themeBlock
+mkTheme theming' = StaticTheme $ map themeBlock
where
themeBlock :: BlockOutput -> ThemedBlockOutput
themeBlock block@BlockOutput{_blockName} = ThemedBlockOutput{_fullText = fullText', _shortText = shortText', _blockName}
@@ -68,15 +82,9 @@ mkThemedSegment (color, backgroundColor) text = ThemedBlockTextSegment{themedSeg
invalidColor :: Color
invalidColor = ColorRGBA (RGB (0x96 / 255) (0x98 / 255) (0x96 / 255)) (0x77 / 255)
-
invalidSimplifiedTheme :: SimplifiedTheme
invalidSimplifiedTheme _ _ = (invalidColor, Nothing)
-
-invalidTheme :: Theme
-invalidTheme = mkTheme invalidSimplifiedTheme
-
-
defaultTheme :: Theme
defaultTheme = mkTheme defaultTheme'
where
@@ -92,13 +100,16 @@ defaultTheme = mkTheme defaultTheme'
| otherwise = (ColorRGB (RGB (0x96 / 255) (0x98 / 255) (0x96 / 255)), Nothing)
-rainbowTheme :: AnimatedTheme
-rainbowTheme = do
- time <- liftIO $ fromRational . toRational <$> getPOSIXTime
- yield =<< rainbowTheme' time <$> await
+rainbowTheme :: Theme
+rainbowTheme = AnimatedTheme rainbowThemePipe
where
- rainbowTheme' :: Double -> Theme
- rainbowTheme' time blocks = reverse $ evalState (mapM rainbowBlock $ reverse blocks) 0
+ 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
diff --git a/src/QBar/Util.hs b/src/QBar/Util.hs
new file mode 100644
index 0000000000000000000000000000000000000000..72d211f30bd78c6f114feedeb268abb1e0c18b7f
--- /dev/null
+++ b/src/QBar/Util.hs
@@ -0,0 +1,15 @@
+module QBar.Util where
+
+import Control.Concurrent.Event as Event
+import Pipes
+
+-- Pipe that signals an 'Event' after every value that passes through
+signalPipe :: MonadIO m => Event.Event -> Pipe a a m r
+signalPipe event = signalPipe'
+ where
+ signalPipe' :: MonadIO m => Pipe a a m r
+ signalPipe' = do
+ value <- await
+ yield value
+ liftIO $ Event.signal event
+ signalPipe'