diff --git a/src/QBar/Host.hs b/src/QBar/Host.hs
index 5cc2fe82de50918a5ad58eb714679dd36c5e3fa7..637a8dd9a09ee5e190ffd72ef78d548520a53d08 100644
--- a/src/QBar/Host.hs
+++ b/src/QBar/Host.hs
@@ -34,13 +34,12 @@ installSignalHandlers bar = void $ installHandler sigCONT (Catch sigContAction)
hPutStrLn stderr "SIGCONT received"
updateBar' bar
-eventDispatcher :: IORef [(T.Text, BlockEventHandler)] -> Consumer BlockEvent BarIO ()
-eventDispatcher eventHandlerListIORef = eventDispatcher'
+eventDispatcher :: Bar -> IORef [(T.Text, BlockEventHandler)] -> Consumer BlockEvent IO ()
+eventDispatcher bar eventHandlerListIORef = eventDispatcher'
where
- eventDispatcher' :: Consumer BlockEvent BarIO ()
+ eventDispatcher' :: Consumer BlockEvent IO ()
eventDispatcher' = do
blockEvent <- await
- bar <- askBar
eventHandlerList <- liftIO $ readIORef eventHandlerListIORef
let maybeEventHandler = getEventHandler eventHandlerList blockEvent
case maybeEventHandler of
@@ -51,10 +50,10 @@ eventDispatcher eventHandlerListIORef = eventDispatcher'
getEventHandler eventHandlerList blockEvent = lookup (name blockEvent) eventHandlerList
-runBlocks :: HostHandle -> Producer [BlockOutput] BarIO ()
-runBlocks HostHandle{barUpdateEvent, newBlockChan, eventHandlerListIORef} = runBlocks' []
+runBlocks :: Bar -> HostHandle -> Producer [BlockOutput] IO ()
+runBlocks bar HostHandle{barUpdateEvent, newBlockChan, eventHandlerListIORef} = runBlocks' []
where
- runBlocks' :: [CachedBlock] -> Producer [BlockOutput] BarIO ()
+ runBlocks' :: [CachedBlock] -> Producer [BlockOutput] IO ()
runBlocks' blocks = do
liftIO $ do
-- Wait for an update request
@@ -64,9 +63,9 @@ runBlocks HostHandle{barUpdateEvent, newBlockChan, eventHandlerListIORef} = runB
threadDelay 10000
Event.clear barUpdateEvent
- blocks' <- lift $ addNewBlocks blocks
+ blocks' <- liftIO $ runBarIO bar $ addNewBlocks blocks
- (blockStates, blocks'') <- lift $ getBlockStates blocks'
+ (blockStates, blocks'') <- liftIO $ runBarIO bar $ getBlockStates blocks'
-- Pass blocks to output
yield $ map fst $ catMaybes blockStates
@@ -125,10 +124,11 @@ filterDuplicates = do
filterDuplicates' value
-runBarHost :: Consumer [BlockOutput] BarIO ()
- -> Producer BlockEvent BarIO ()
+runBarHost :: Consumer [BlockOutput] IO ()
+ -> Producer BlockEvent IO ()
+ -> BarIO ()
-> IO ()
-runBarHost host barEventProducer = do
+runBarHost host barEventProducer loadBlocks = do
-- Create an event used to signal bar updates
barUpdateEvent <- Event.newSet
let requestBarUpdate = Event.set barUpdateEvent
@@ -150,10 +150,12 @@ runBarHost host barEventProducer = do
eventHandlerListIORef
}
- let handleStdin = runEffect $ barEventProducer >-> eventDispatcher eventHandlerListIORef
+ runBarIO bar loadBlocks
+
+ let handleStdin = liftIO $ runEffect $ barEventProducer >-> eventDispatcher bar eventHandlerListIORef
-- Fork stdin handler
void $ forkFinally (runBarIO bar handleStdin) (\result -> hPutStrLn stderr $ "handleStdin failed: " <> show result)
-- Run bar host
- runBarIO bar $ runEffect $ runBlocks hostHandle >-> filterDuplicates >-> host
+ runEffect $ runBlocks bar hostHandle >-> filterDuplicates >-> host
diff --git a/src/QBar/Server.hs b/src/QBar/Server.hs
index ec09b0d67f0051f0648c46df7570fe3aad1e7d5f..4e4150396360affa91eee9c41cfbb79c9724f65c 100644
--- a/src/QBar/Server.hs
+++ b/src/QBar/Server.hs
@@ -52,10 +52,10 @@ instance ToJSON PangoBlock where
-- |A producer that reads swaybar/i3bar-input events from stdin and emits them as 'BlockEvent's.
-swayBarInput :: MainOptions -> Producer BlockEvent BarIO ()
+swayBarInput :: MainOptions -> Producer BlockEvent IO ()
swayBarInput MainOptions{verbose} = swayBarInput'
where
- swayBarInput' :: Producer BlockEvent BarIO ()
+ swayBarInput' :: Producer BlockEvent IO ()
swayBarInput' = do
line <- liftIO $ BSSC8.hGetLine stdin
@@ -77,20 +77,32 @@ swayBarInput MainOptions{verbose} = swayBarInput'
| otherwise = line
-outputLine :: MainOptions -> [ThemedBlockOutput] -> IO ()
-outputLine MainOptions{verbose} themedBlocks = do
- let encodedOutput = encodeOutput themedBlocks
-
+swayBarOutput :: MainOptions -> Consumer [ThemedBlockOutput] IO ()
+swayBarOutput options = do
+ -- Print header
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
+ putStrLn "{\"version\":1,\"click_events\":true}"
+ putStrLn "["
+
+ swayBarOutput'
where
+ swayBarOutput' :: Consumer [ThemedBlockOutput] IO ()
+ swayBarOutput' = do
+ await >>= (liftIO . outputLine options)
+ swayBarOutput'
+ 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
encodeOutput :: [ThemedBlockOutput] -> BS.ByteString
encodeOutput blocks = encode $ map renderPangoBlock $ blocks
renderPangoBlock :: ThemedBlockOutput -> PangoBlock
@@ -101,16 +113,16 @@ outputLine MainOptions{verbose} themedBlocks = do
}
runBarServer :: BarIO () -> MainOptions -> IO ()
-runBarServer defaultBarConfig options = runBarHost barServer (swayBarInput options)
+runBarServer defaultBarConfig options = runBarHost barServer (swayBarInput options) loadBlocks
where
- barServer :: Consumer [BlockOutput] BarIO ()
- barServer = do
+ loadBlocks :: BarIO ()
+ loadBlocks = do
-- Load blocks
- lift $ do
- when (indicator options) $ addBlock renderIndicator
- defaultBarConfig
-
+ when (indicator options) $ addBlock renderIndicator
+ defaultBarConfig
+ barServer :: Consumer [BlockOutput] IO ()
+ barServer = do
-- Event to render the bar (fired when block output or theme is changed)
renderEvent <- liftIO Event.new
@@ -118,7 +130,7 @@ runBarServer defaultBarConfig options = runBarHost barServer (swayBarInput optio
(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)
+ (themedBlockProducerMVar :: MVar (Producer [ThemedBlockOutput] IO (), Bool)) <- liftIO $ newMVar $ throw $ userError "Unexpected behavior: Default theme not set"
-- Create control socket
@@ -143,9 +155,6 @@ runBarServer defaultBarConfig options = runBarHost barServer (swayBarInput optio
-- 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)
@@ -153,21 +162,29 @@ runBarServer defaultBarConfig options = runBarHost barServer (swayBarInput optio
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
+ renderLoop renderEvent themedBlockProducerMVar = runEffect $
+ themeAnimator renderEvent themedBlockProducerMVar >-> filterDuplicates >-> swayBarOutput options
+
+ themeAnimator :: Event.Event -> MVar (Producer [ThemedBlockOutput] IO (), Bool) -> Producer [ThemedBlockOutput] IO ()
+ themeAnimator renderEvent themedBlockProducerMVar = themeAnimator'
+ where
+ themeAnimator' :: Producer [ThemedBlockOutput] IO ()
+ themeAnimator' = do
+ (themedBlocks, isAnimated'') <- liftIO $ 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 output cache mailbox should never return"
+ Right (themedBlocks, nextThemedBlockProducer) ->
+ return ((nextThemedBlockProducer, isAnimated'), (themedBlocks, isAnimated'))
+ )
+ yield themedBlocks
+ liftIO $ 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
+ themeAnimator'
setTheme :: Input [BlockOutput] -> MVar (Producer [ThemedBlockOutput] IO (), Bool) -> Theme -> IO ()
setTheme blockOutputInput themedBlockProducerMVar (StaticTheme theme) =