Re-implement animations on top of new bar server

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

src/QBar/Server.hs

 {-# 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 ()

src/QBar/Theme.hs

 {-# 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

src/QBar/Util.hs

+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'