From 1bf40aade5203e317c773f77f11ff7269db5d0c1 Mon Sep 17 00:00:00 2001
From: Jens Nolte <jens@nightmarestudio.de>
Date: Thu, 28 Nov 2019 01:21:23 +0100
Subject: [PATCH] Change input type of sharedInterval to PullBlockProducer
---
src/QBar/Core.hs | 74 +++++++++++++++++++++++++++++-------------------
1 file changed, 45 insertions(+), 29 deletions(-)
diff --git a/src/QBar/Core.hs b/src/QBar/Core.hs
index 691ae37..d08f655 100644
--- a/src/QBar/Core.hs
+++ b/src/QBar/Core.hs
@@ -53,7 +53,7 @@ newtype CachedBlockProducer = CachedBlockProducer BlockProducer
-- |Generic block type that can be a block in pull-, push- or cached mode.
data Block = PushBlock PushBlockProducer
- | PullBlock PullBlockProducer
+ -- | PullBlock PullBlockProducer
| CachedBlock CachedBlockProducer
data BarUpdateChannel = BarUpdateChannel (IO ())
@@ -62,12 +62,15 @@ type BarUpdateEvent = Event.Event
pushBlock :: BlockProducer -> Block
pushBlock = PushBlock . PushBlockProducer
-pullBlock :: BlockProducer -> Block
-pullBlock = PullBlock . PullBlockProducer
+--pullBlock :: BlockProducer -> Block
+--pullBlock = PullBlock . PullBlockProducer
cachedBlock :: BlockProducer -> Block
cachedBlock = CachedBlock . CachedBlockProducer
+pullBlockProducer :: BlockProducer -> PullBlockProducer
+pullBlockProducer = PullBlockProducer
+
defaultColor :: T.Text
defaultColor = "#969896"
@@ -168,9 +171,9 @@ autoPadding = autoPadding' 0 0
-- | Create a shared interval. Takes a BarUpdateChannel to signal bar updates and an interval (in seconds).Data.Maybe
-- Returns an IO action that can be used to attach blocks to the shared interval and an async that contains a reference to the scheduler thread.
-sharedInterval :: BarUpdateChannel -> Int -> IO (IO BlockOutput -> BlockProducer, Async ())
+sharedInterval :: BarUpdateChannel -> Int -> IO (PullBlockProducer -> BlockProducer, Async ())
sharedInterval barUpdateChannel seconds = do
- clientsMVar <- newMVar ([] :: [(IO BlockOutput, Output BlockOutput)])
+ clientsMVar <- newMVar ([] :: [(MVar PullBlockProducer, Output BlockOutput)])
task <- async $ forever $ do
threadDelay $ seconds * 1000000
@@ -182,16 +185,25 @@ sharedInterval barUpdateChannel seconds = do
return (addClient clientsMVar, task)
where
- runAndFilterClient :: (IO BlockOutput, Output BlockOutput) -> IO (Maybe (IO BlockOutput, Output BlockOutput))
+ runAndFilterClient :: (MVar PullBlockProducer, Output BlockOutput) -> IO (Maybe (MVar PullBlockProducer, Output BlockOutput))
runAndFilterClient client = do
result <- runClient client
return $ if result then Just client else Nothing
- runClient :: (IO BlockOutput, Output BlockOutput) -> IO Bool
- runClient (blockAction, output) = do
- result <- blockAction
- atomically $ send output result {
- clickAction = Just (updateClickHandler result)
- }
+ runClient :: (MVar PullBlockProducer, Output BlockOutput) -> IO Bool
+ runClient (blockProducerMVar, output) =
+ modifyMVar blockProducerMVar $ \(PullBlockProducer blockProducer) -> do
+ result <- next blockProducer
+ case result of
+ Left () -> return (PullBlockProducer $ return (), False)
+ Right (blockOutput, blockProducer') -> do
+ success <- atomically $ send output blockOutput {
+ clickAction = Just (updateClickHandler blockOutput)
+ }
+ if success
+ -- store new BlockProducer back into MVar
+ then return (pullBlockProducer blockProducer', True)
+ -- mailbox is closed, stop running producer
+ else return (PullBlockProducer $ return (), False)
where
updateClickHandler :: BlockOutput -> Click -> IO ()
updateClickHandler block _ = do
@@ -201,36 +213,40 @@ sharedInterval barUpdateChannel seconds = do
-- Notify bar about changed block state to display the feedback
updateBar barUpdateChannel
-- Run a normal block update to update the block to the new value
- void $ runClient (blockAction, output)
+ void $ runClient (blockProducerMVar, output)
-- Notify bar about changed block state, this is usually done by the shared interval handler
updateBar barUpdateChannel
- addClient :: MVar [(IO BlockOutput, Output BlockOutput)] -> IO BlockOutput -> BlockProducer
- addClient clientsMVar blockAction = do
+ addClient :: MVar [(MVar PullBlockProducer, Output BlockOutput)] -> PullBlockProducer -> BlockProducer
+ addClient clientsMVar blockProducer = do
-- Spawn the mailbox that preserves the latest block
(output, input) <- lift $ spawn $ latest emptyBlock
+ blockProducerMVar <- lift $ newMVar blockProducer
+
-- Generate initial block and send it to the mailbox
- lift $ void $ runClient (blockAction, output)
+ lift $ void $ runClient (blockProducerMVar, output)
-- Register the client for regular updates
- lift $ modifyMVar_ clientsMVar $ \ clients -> return ((blockAction, output):clients)
+ lift $ modifyMVar_ clientsMVar $ \ clients -> return ((blockProducerMVar, output):clients)
-- Return a block producer from the mailbox
fromInput input
-blockScript :: FilePath -> IO BlockOutput
-blockScript path = do
- -- The exit code is used for i3blocks signaling but ignored here (=not implemented)
- -- I am trying to replace i3blocks scripts with native haskell blocks, so I do not need it
- (exitCode, output) <- readProcessStdout $ shell path
- case exitCode of
- ExitSuccess -> return $ case map E.decodeUtf8 (C8.lines output) of
- (text:short:color:_) -> setColor color $ shortText short $ createScriptBlock text
- (text:short:_) -> shortText short $ createScriptBlock text
- (text:_) -> createScriptBlock text
- [] -> createScriptBlock "-"
- (ExitFailure nr) -> return $ createErrorBlock $ "[" <> (T.pack $ show nr) <> "]"
+blockScript :: FilePath -> PullBlockProducer
+blockScript path = pullBlockProducer $ forever $ yield =<< (lift $ blockScriptAction)
where
+ blockScriptAction :: IO 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) <- readProcessStdout $ shell path
+ case exitCode of
+ ExitSuccess -> return $ case map E.decodeUtf8 (C8.lines output) of
+ (text:short:color:_) -> setColor color $ shortText short $ createScriptBlock text
+ (text:short:_) -> shortText short $ createScriptBlock text
+ (text:_) -> createScriptBlock text
+ [] -> createScriptBlock "-"
+ (ExitFailure nr) -> return $ createErrorBlock $ "[" <> (T.pack $ show nr) <> "]"
createScriptBlock :: T.Text -> BlockOutput
createScriptBlock text = pangoMarkup $ setBlockName (T.pack path) $ createBlock text
--
GitLab