From d75b2d5b186e2155ef6c41b5565f994f1b99e11a Mon Sep 17 00:00:00 2001
From: Jens Nolte <jens@nightmarestudio.de>
Date: Mon, 9 Mar 2020 23:15:03 +0100
Subject: [PATCH] Implement SignalBlock
Renames PullBlock to PollBlock and moves it to the SignalBlock in
QBar.BlockHelper.
The script block is now in linewise mode by default and can be
configured into polling mode with '--poll'.
---
src/QBar/BlockHelper.hs | 215 ++++++++++++++++++++++++++++++++++++
src/QBar/Blocks.hs | 2 +-
src/QBar/Blocks/Battery.hs | 11 +-
src/QBar/Blocks/CpuUsage.hs | 8 +-
src/QBar/Blocks/Date.hs | 5 +-
src/QBar/Blocks/Script.hs | 12 +-
src/QBar/Cli.hs | 5 +-
src/QBar/Core.hs | 87 +++------------
src/QBar/DefaultConfig.hs | 12 +-
src/QBar/Host.hs | 4 +-
src/QBar/Server.hs | 2 +-
11 files changed, 260 insertions(+), 103 deletions(-)
create mode 100644 src/QBar/BlockHelper.hs
diff --git a/src/QBar/BlockHelper.hs b/src/QBar/BlockHelper.hs
new file mode 100644
index 0000000..0fda979
--- /dev/null
+++ b/src/QBar/BlockHelper.hs
@@ -0,0 +1,215 @@
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TupleSections #-}
+
+module QBar.BlockHelper where
+
+import QBar.BlockOutput
+import QBar.Core
+import QBar.Time
+
+import Control.Concurrent.Async
+import qualified Control.Concurrent.Event as Event
+import Control.Concurrent.STM.TChan
+import Data.Either (isRight)
+import Pipes
+import Pipes.Core
+import Pipes.Concurrent
+
+
+data Signal a = RegularSignal | UserSignal a | EventSignal BlockEvent
+ deriving (Show, Eq)
+
+type SignalBlock a = (Signal a -> Server (Signal a) BlockUpdate BarIO ExitBlock)
+
+-- |Block that 'respond's with an update whenever it receives a 'PollSignal'.
+type PollBlock' = Server PollSignal BlockUpdate BarIO
+type PollBlock = Server PollSignal BlockUpdate BarIO ExitBlock
+data PollSignal = PollSignal
+
+respondBlockUpdate :: BlockOutput -> Server' (Signal s) BlockUpdate BarIO (Signal s)
+respondBlockUpdate blockOutput = respond (Just (blockOutput, Nothing), DefaultUpdate)
+
+respondBlockUpdate' :: BlockEventHandler -> BlockOutput -> Server' (Signal s) BlockUpdate BarIO (Signal s)
+respondBlockUpdate' blockEventHandler blockOutput = respond (Just (blockOutput, Just blockEventHandler), PollUpdate)
+
+-- |Update a block by removing the current output
+respondEmptyBlockUpdate :: Server' (Signal s) BlockUpdate BarIO (Signal s)
+respondEmptyBlockUpdate = respond (Nothing, PollUpdate)
+
+
+yieldBlockUpdate :: BlockOutput -> Server' PollSignal BlockUpdate BarIO ()
+yieldBlockUpdate blockOutput = void . respond $ (Just (blockOutput, Nothing), PollUpdate)
+
+yieldBlockUpdate' :: BlockEventHandler -> BlockOutput -> Server' PollSignal BlockUpdate BarIO ()
+yieldBlockUpdate' blockEventHandler blockOutput = void . respond $ (Just (blockOutput, Just blockEventHandler), PollUpdate)
+
+-- |Update a block by removing the current output
+yieldEmptyBlockUpdate :: Server' PollSignal BlockUpdate BarIO ()
+yieldEmptyBlockUpdate = void . respond $ (Nothing, PollUpdate)
+
+
+runSignalBlock :: forall a. Maybe Interval -> Maybe ((a -> IO ()) -> BarIO ()) -> SignalBlock a -> Block
+runSignalBlock maybeInterval maybeSignalSourceThread signalBlock' = runSignalBlockConfiguration $ SignalBlockConfiguration {
+ initialize = const $ return (),
+ signalThread = const <$> maybeSignalSourceThread,
+ signalBlock = const signalBlock',
+ interval = maybeInterval,
+ finalize = return
+}
+
+
+runSignalBlockFn :: forall a. Maybe Interval -> ((a -> IO ()) -> BarIO ()) -> ((a, Maybe BlockEvent) -> BarIO BlockState) -> Block
+runSignalBlockFn maybeInterval signalSourceThread renderFn = runSignalBlock maybeInterval (Just signalSourceThread) signalBlock
+ where
+ signalBlock :: (Signal a -> Server (Signal a) BlockUpdate BarIO ExitBlock)
+ signalBlock (UserSignal value) = signalBlock' value (UserSignal value)
+ signalBlock _ = signalBlock =<< respondEmptyBlockUpdate
+ signalBlock' :: a -> (Signal a -> Server (Signal a) BlockUpdate BarIO ExitBlock)
+ signalBlock' state RegularSignal = signalBlock' state =<< respond =<< (, PollUpdate) <$> lift (renderFn (state, Nothing))
+ signalBlock' _ (UserSignal value) = signalBlock' value =<< respond =<< (, DefaultUpdate) <$> lift (renderFn (value, Nothing))
+ signalBlock' state (EventSignal event) = signalBlock' state =<< respond =<< (, DefaultUpdate) <$> lift (renderFn (state, Just event))
+
+runSignalBlockFn' :: Maybe Interval -> (Maybe BlockEvent -> BarIO BlockState) -> Block
+runSignalBlockFn' maybeInterval renderFn = runSignalBlockConfiguration $ SignalBlockConfiguration {
+ initialize = const $ return (),
+ signalThread = Nothing,
+ signalBlock = const eventBlock,
+ interval = maybeInterval,
+ finalize = return
+}
+ where
+ eventBlock :: (Signal a -> Server (Signal a) BlockUpdate BarIO ExitBlock)
+ eventBlock (EventSignal event) = eventBlock =<< respond =<< (, DefaultUpdate) <$> lift (renderFn (Just event))
+ eventBlock _ = eventBlock =<< respond =<< (, PollUpdate) <$> lift (renderFn Nothing)
+
+
+
+data SignalBlockConfiguration c p = SignalBlockConfiguration {
+ initialize :: (p -> IO ()) -> BarIO c,
+ signalThread :: Maybe (c -> (p -> IO ()) -> BarIO ()),
+ signalBlock :: c -> SignalBlock p,
+ interval :: Maybe Interval,
+ finalize :: c -> IO ()
+}
+
+runSignalBlockConfiguration :: forall c p. SignalBlockConfiguration c p -> Block
+runSignalBlockConfiguration SignalBlockConfiguration{initialize, signalThread, signalBlock, interval, finalize} = do
+ -- Initialize
+ signalChan <- liftIO newTChanIO
+ signalEvent <- liftIO Event.new
+
+ runSignalBlockWithThreadInternal signalChan signalEvent
+ where
+ runSignalBlockWithThreadInternal :: TChan (Signal p) -> Event.Event -> Block
+ runSignalBlockWithThreadInternal signalChan signalEvent = do
+ context <- lift $ initialize userSignalAction
+ -- Start signalSource thread
+ userTask <- liftBarIO $ barAsync $
+ case signalThread of
+ Just signalThread' -> signalThread' context userSignalAction
+ Nothing -> return ()
+ intervalTask <- liftBarIO $ barAsync intervalTimer
+
+ -- Run block
+ void (signalBlock context +>> signalPipe >-> attachEventHandlerP)
+
+ -- Cancel threads when the block terminates
+ -- TODO: use bracketP?
+ liftIO $ do
+ cancel userTask
+ cancel intervalTask
+ finalize context
+
+ exitBlock
+
+ where
+ userSignalAction :: p -> IO ()
+ userSignalAction value = do
+ liftIO . atomically $ writeTChan signalChan $ UserSignal value
+ Event.set signalEvent
+
+ signalPipe :: Proxy (Signal p) BlockUpdate () BlockUpdate BarIO ExitBlock
+ signalPipe = forever $ do
+ -- Handle all queued events
+ eventHandled <- sendQueuedEvents
+
+ -- If there was no queued event signal a regular event
+ unless eventHandled $ yield =<< request RegularSignal
+
+ -- Wait for next event
+ liftIO $ Event.wait signalEvent
+ liftIO $ Event.clear signalEvent
+
+ where
+ sendQueuedEvents :: Proxy (Signal p) BlockUpdate () BlockUpdate BarIO Bool
+ sendQueuedEvents = do
+ maybeSignal <- liftIO . atomically $ tryReadTChan signalChan
+ case maybeSignal of
+ Just signal -> (yield =<< request signal) >> sendQueuedEvents >> return True
+ Nothing -> return False
+
+
+ intervalTimer :: BarIO ()
+ intervalTimer = do
+ scheduler <- askSleepScheduler
+ case interval of
+ Just interval' -> forever $ do
+ sleepUntilInterval' scheduler interval'
+ liftIO $ Event.set signalEvent
+ Nothing -> return ()
+
+ attachEventHandlerP :: Pipe BlockUpdate BlockUpdate BarIO ExitBlock
+ attachEventHandlerP = forever $ do
+ (state, reason) <- await
+ let state' = if hasEventHandler state
+ -- If state already has an event handler, we do not attach another one
+ then state
+ -- Attach a click handler that will trigger a block update
+ else updateEventHandler signalEventHandler state
+ yield (state', reason)
+ where
+ signalEventHandler :: BlockEventHandler
+ signalEventHandler event = do
+ liftIO . atomically $ writeTChan signalChan $ EventSignal event
+ liftIO $ Event.set signalEvent
+
+
+
+
+-- |Converts a 'PollBlock' to a 'Block' by running it whenever the 'defaultInterval' is triggered.
+runPollBlock :: PollBlock -> Block
+runPollBlock = runPollBlock' defaultInterval
+
+-- |Converts a 'PollBlock' to a 'Block' by running it whenever the provided 'Interval' is triggered.
+runPollBlock' :: Interval -> PollBlock -> Block
+runPollBlock' interval pb = pb >>~ addPollSignal >-> sleepToNextInterval
+ where
+ addPollSignal :: BlockUpdate -> Proxy PollSignal BlockUpdate () BlockUpdate BarIO ExitBlock
+ addPollSignal = respond >=> const (request PollSignal) >=> addPollSignal
+
+ sleepToNextInterval :: Pipe BlockUpdate BlockUpdate BarIO ExitBlock
+ sleepToNextInterval = do
+ event <- liftIO Event.new
+ forever $ do
+ (state, reason) <- await
+ if hasEventHandler state
+ then do
+ -- If state already has an event handler, we do not attach another one
+ yield (state, reason)
+ sleepUntilInterval interval
+ else do
+ -- Attach a click handler that will trigger a block update
+ yield (updateEventHandler (triggerOnClick event) state, reason)
+
+ scheduler <- askSleepScheduler
+ result <- liftIO $ do
+ timerTask <- async $ sleepUntilInterval' scheduler defaultInterval
+ eventTask <- async $ Event.wait event
+ waitEitherCancel timerTask eventTask
+
+ when (isRight result) $ do
+ liftIO $ Event.clear event
+ yield (invalidateBlockState state, UserUpdate)
+
+ triggerOnClick :: Event.Event -> BlockEvent -> BarIO ()
+ triggerOnClick event _ = liftIO $ Event.set event
diff --git a/src/QBar/Blocks.hs b/src/QBar/Blocks.hs
index 21d0cbd..8df8ca3 100644
--- a/src/QBar/Blocks.hs
+++ b/src/QBar/Blocks.hs
@@ -3,7 +3,7 @@ module QBar.Blocks
QBar.Blocks.CpuUsage.cpuUsageBlock,
QBar.Blocks.Date.dateBlock,
QBar.Blocks.Script.scriptBlock,
- QBar.Blocks.Script.persistentScriptBlock,
+ QBar.Blocks.Script.pollScriptBlock,
)
where
diff --git a/src/QBar/Blocks/Battery.hs b/src/QBar/Blocks/Battery.hs
index 5d33ecb..9941954 100644
--- a/src/QBar/Blocks/Battery.hs
+++ b/src/QBar/Blocks/Battery.hs
@@ -1,10 +1,9 @@
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE ScopedTypeVariables #-}
-
module QBar.Blocks.Battery where
-
+import QBar.BlockHelper
import QBar.Core
import QBar.Blocks.Utils
import QBar.BlockOutput
@@ -79,7 +78,7 @@ getBatteryState path = maybe getBatteryStateCharge (return . Just) =<< getBatter
batteryBlock :: Block
-batteryBlock = pullBlock $ forever $ do
+batteryBlock = runPollBlock $ forever $ do
batteryPaths <- liftIO $ map ((apiPath <> "/") <>) . filter (T.isPrefixOf "BAT" . T.pack) <$> getDirectoryContents apiPath
batteryStates <- liftIO $ mapM getBatteryState batteryPaths
isPlugged <- liftIO getPluggedState
@@ -101,9 +100,9 @@ batteryBlock = pullBlock $ forever $ do
_ -> return . return $ False
-updateBatteryBlock :: Bool -> [BatteryState] -> PullBlock' ()
-updateBatteryBlock _ [] = sendEmptyBlockUpdate
-updateBatteryBlock isPlugged bs = sendBlockUpdate $ (shortText.~shortText') $ mkBlockOutput fullText'
+updateBatteryBlock :: Bool -> [BatteryState] -> PollBlock' ()
+updateBatteryBlock _ [] = yieldEmptyBlockUpdate
+updateBatteryBlock isPlugged bs = yieldBlockUpdate $ (shortText.~shortText') $ mkBlockOutput fullText'
where
fullText' :: BlockText
fullText' = overallPercentage <> optionalEachBattery <> optionalOverallEstimate
diff --git a/src/QBar/Blocks/CpuUsage.hs b/src/QBar/Blocks/CpuUsage.hs
index 66505ad..505ed4e 100644
--- a/src/QBar/Blocks/CpuUsage.hs
+++ b/src/QBar/Blocks/CpuUsage.hs
@@ -2,6 +2,8 @@
module QBar.Blocks.CpuUsage where
+import QBar.BlockHelper
+
import Control.Applicative ((<|>))
import Control.Lens
import Control.Monad.State (StateT, evalStateT, lift)
@@ -113,14 +115,14 @@ data CpuBlockState
makeLenses ''CpuBlockState
cpuUsageBlock :: Int -> Block
-cpuUsageBlock decimalPlaces = pullBlock $ evalStateT cpuUsageBlock' createState
+cpuUsageBlock decimalPlaces = runPollBlock $ evalStateT cpuUsageBlock' createState
where
- cpuUsageBlock' :: StateT CpuBlockState PullBlock' ExitBlock
+ cpuUsageBlock' :: StateT CpuBlockState PollBlock' ExitBlock
cpuUsageBlock' = forever $ do
updateState
importance <- cpuUsageImportance
text <- ("💻\xFE0E " <>) <$> cpuUsageText
- lift $ sendBlockUpdate $ mkBlockOutput $ importantText importance text
+ lift $ yieldBlockUpdate $ mkBlockOutput $ importantText importance text
createState :: CpuBlockState
createState =
CpuBlockState
diff --git a/src/QBar/Blocks/Date.hs b/src/QBar/Blocks/Date.hs
index adecf74..dbb867f 100644
--- a/src/QBar/Blocks/Date.hs
+++ b/src/QBar/Blocks/Date.hs
@@ -1,5 +1,6 @@
module QBar.Blocks.Date where
+import QBar.BlockHelper
import QBar.BlockOutput
import QBar.Core
import QBar.Time
@@ -10,9 +11,9 @@ import Data.Time.LocalTime
dateBlock :: Block
-dateBlock = pullBlock' (everyNSeconds 60) $ forever $ do
+dateBlock = runPollBlock' (everyNSeconds 60) $ forever $ do
zonedTime <- liftIO getZonedTime
let date = T.pack (formatTime defaultTimeLocale "%a %F" zonedTime)
let time = T.pack (formatTime defaultTimeLocale "%R" zonedTime)
let text = normalText ("📅\xFE0E " <> date <> " ") <> activeText time
- sendBlockUpdate $ mkBlockOutput text
+ yieldBlockUpdate $ mkBlockOutput text
diff --git a/src/QBar/Blocks/Script.hs b/src/QBar/Blocks/Script.hs
index 5480853..79d20d9 100644
--- a/src/QBar/Blocks/Script.hs
+++ b/src/QBar/Blocks/Script.hs
@@ -1,5 +1,6 @@
module QBar.Blocks.Script where
+import QBar.BlockHelper
import QBar.BlockOutput
import QBar.Core
import QBar.TagParser
@@ -17,8 +18,8 @@ import System.Process.Typed (Process, shell, setStdin, setStdout,
getStdout, closed, createPipe, readProcessStdout, startProcess, stopProcess)
-scriptBlock :: FilePath -> Block
-scriptBlock path = pullBlock $ forever $ sendBlockUpdate =<< (lift blockScriptAction)
+pollScriptBlock :: FilePath -> Block
+pollScriptBlock path = runPollBlock $ forever $ yieldBlockUpdate =<< (lift blockScriptAction)
where
blockScriptAction :: BarIO BlockOutput
blockScriptAction = do
@@ -27,17 +28,16 @@ scriptBlock path = pullBlock $ forever $ sendBlockUpdate =<< (lift blockScriptAc
(exitCode, output) <- liftIO $ readProcessStdout $ shell path
return $ case exitCode of
ExitSuccess -> createScriptBlockOutput output
- (ExitFailure nr) -> case nr of
- _ -> mkErrorOutput $ "exit code " <> T.pack (show nr) <> ""
+ (ExitFailure nr) -> mkErrorOutput $ "exit code " <> T.pack (show nr) <> ""
createScriptBlockOutput :: C8.ByteString -> BlockOutput
createScriptBlockOutput output = case map E.decodeUtf8 (C8.lines output) of
(text:short:_) -> parseTags'' text short
(text:_) -> parseTags' text
[] -> emptyBlock
-persistentScriptBlock :: FilePath -> Block
+scriptBlock :: FilePath -> Block
-- The outer catchP only catches errors that occur during process creation
-persistentScriptBlock path = catchP startScriptProcess handleError
+scriptBlock path = catchP startScriptProcess handleError
where
handleError :: IOException -> Block
handleError e = do
diff --git a/src/QBar/Cli.hs b/src/QBar/Cli.hs
index f1f213c..a547117 100644
--- a/src/QBar/Cli.hs
+++ b/src/QBar/Cli.hs
@@ -78,10 +78,11 @@ blockParser =
command "date" (info (pure $ addBlock dateBlock) (progDesc "Load the date and time block.")) <>
command "cpu" (info (pure $ addBlock $ cpuUsageBlock 1) (progDesc "Load the cpu usage block.")) <>
command "battery" (info (pure $ addBlock $ batteryBlock) (progDesc "Load the battery block.")) <>
+ command "script" (info scriptBlockParser (progDesc "Display the output of an external script as a block."))
)
scriptBlockParser :: Parser (BarIO ())
scriptBlockParser = helper <*> do
- persistent <- switch $ long "persistent" <> short 'p' <> help "Run script in persistent mode (every line of output updates the block)."
+ poll <- switch $ long "poll" <> short 'p' <> help "Run script in poll mode (every line of output updates the block)."
script <- strArgument (metavar "SCRIPT" <> help "The script that will be executed with a shell.")
- return $ (if persistent then addBlock . persistentScriptBlock else addBlock . scriptBlock) script
+ return $ (if poll then addBlock . pollScriptBlock else addBlock . scriptBlock) script
diff --git a/src/QBar/Core.hs b/src/QBar/Core.hs
index 14312b2..b8b0f85 100644
--- a/src/QBar/Core.hs
+++ b/src/QBar/Core.hs
@@ -1,5 +1,6 @@
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE RankNTypes #-}
module QBar.Core where
@@ -8,20 +9,18 @@ import QBar.Time
import QBar.Util
import Control.Concurrent.Async
-import Control.Concurrent.Event as Event
+import qualified Control.Concurrent.Event as Event
import Control.Concurrent.MVar
-import Control.Concurrent.STM.TChan (TChan, writeTChan)
+import Control.Concurrent.STM.TChan
import Control.Lens
import Control.Monad.Reader (ReaderT, runReaderT, ask)
import Control.Monad.State (StateT)
import Control.Monad.Writer (WriterT)
import Data.Aeson.TH
-import Data.Either (isRight)
import Data.Int (Int64)
import Data.Maybe (fromMaybe)
import qualified Data.Text.Lazy as T
import Pipes
-import Pipes.Core
import Pipes.Concurrent
import Pipes.Safe (SafeT, runSafeT)
import qualified Pipes.Prelude as PP
@@ -35,7 +34,7 @@ data MainOptions = MainOptions {
data BlockEvent = Click {
name :: T.Text,
button :: Int
-} deriving Show
+} deriving (Eq, Show)
$(deriveJSON defaultOptions ''BlockEvent)
@@ -44,18 +43,13 @@ data ExitBlock = ExitBlock
type BlockEventHandler = BlockEvent -> BarIO ()
type BlockState = Maybe (BlockOutput, Maybe BlockEventHandler)
-data BlockUpdateReason = DefaultUpdate | PullUpdate | UserUpdate
+data BlockUpdateReason = DefaultUpdate | PollUpdate | UserUpdate
type BlockUpdate = (BlockState, BlockUpdateReason)
-- |Block that 'yield's an update whenever the block should be changed
type Block' = Producer BlockUpdate BarIO
type Block = Producer BlockUpdate BarIO ExitBlock
--- |Block that 'respond's with an update whenever it receives a 'PullSignal'.
-type PullBlock' = Server PullSignal BlockUpdate BarIO
-type PullBlock = Server PullSignal BlockUpdate BarIO ExitBlock
-data PullSignal = PullSignal
-
-- |Cache that holds multiple BlockStates. When iterated it always immediately 'yield's the latest update, so it should only be pulled when a bar update has been requested.
type BlockCache = Producer [BlockState] BarIO ExitBlock
@@ -64,17 +58,11 @@ class IsCachable a where
instance IsCachable Block where
toCachedBlock = cacheBlock
-instance IsCachable PullBlock where
- toCachedBlock = cacheBlock . pullBlock
instance IsCachable BlockCache where
toCachedBlock = id
-class IsBlock a where
- exitBlock :: a
-instance IsBlock Block where
- exitBlock = return ExitBlock
-instance IsBlock PullBlock where
- exitBlock = return ExitBlock
+exitBlock :: Functor m => Proxy a' a b' b m ExitBlock
+exitBlock = return ExitBlock
exitCache :: BlockCache
exitCache = return ExitBlock
@@ -114,27 +102,15 @@ askBar :: MonadBarIO m => m Bar
askBar = liftBarIO $ lift ask
-sendBlockUpdate :: BlockOutput -> Proxy a' a PullSignal BlockUpdate BarIO ()
-sendBlockUpdate blockOutput = void . respond $ (Just (blockOutput, Nothing), PullUpdate)
-
-sendBlockUpdate' :: BlockEventHandler -> BlockOutput -> Proxy a' a PullSignal BlockUpdate BarIO ()
-sendBlockUpdate' blockEventHandler blockOutput = void . respond $ (Just (blockOutput, Just blockEventHandler), PullUpdate)
-
--- |Update a block by removing the current output
-sendEmptyBlockUpdate :: Proxy a' a PullSignal BlockUpdate BarIO ()
-sendEmptyBlockUpdate = void . respond $ (Nothing, PullUpdate)
-
-
-pushBlockUpdate :: BlockOutput -> Proxy a' a () BlockUpdate BarIO ()
-pushBlockUpdate blockOutput = void . respond $ (Just (blockOutput, Nothing), DefaultUpdate)
+pushBlockUpdate :: BlockOutput -> Producer' BlockUpdate BarIO ()
+pushBlockUpdate blockOutput = yield (Just (blockOutput, Nothing), DefaultUpdate)
-pushBlockUpdate' :: BlockEventHandler -> BlockOutput -> Proxy a' a () BlockUpdate BarIO ()
-pushBlockUpdate' blockEventHandler blockOutput = void . respond $ (Just (blockOutput, Just blockEventHandler), DefaultUpdate)
+pushBlockUpdate' :: BlockEventHandler -> BlockOutput -> Producer' BlockUpdate BarIO ()
+pushBlockUpdate' blockEventHandler blockOutput = yield (Just (blockOutput, Just blockEventHandler), DefaultUpdate)
-- |Update a block by removing the current output
-pushEmptyBlockUpdate :: Proxy a' a () BlockUpdate BarIO ()
-pushEmptyBlockUpdate = void . respond $ (Nothing, DefaultUpdate)
-
+pushEmptyBlockUpdate :: Producer' BlockUpdate BarIO ()
+pushEmptyBlockUpdate = yield (Nothing, DefaultUpdate)
mkBlockState :: BlockOutput -> BlockState
@@ -162,43 +138,6 @@ runBarIO bar action = liftIO $ runReaderT (runSafeT action) bar
defaultInterval :: Interval
defaultInterval = everyNSeconds 10
--- |Converts a 'PullBlock' to a 'Block' by running it whenever the 'defaultInterval' is triggered.
-pullBlock :: PullBlock -> Block
-pullBlock = pullBlock' defaultInterval
-
--- |Converts a 'PullBlock' to a 'Block' by running it whenever the 'defaultInterval' is triggered.
-pullBlock' :: Interval -> PullBlock -> Block
-pullBlock' interval pb = pb >>~ addPullSignal >-> sleepToNextInterval
- where
- addPullSignal :: BlockUpdate -> Proxy PullSignal BlockUpdate () BlockUpdate BarIO ExitBlock
- addPullSignal = respond >=> const (request PullSignal) >=> addPullSignal
-
- sleepToNextInterval :: Pipe BlockUpdate BlockUpdate BarIO ExitBlock
- sleepToNextInterval = do
- event <- liftIO Event.new
- forever $ do
- (state, reason) <- await
- if hasEventHandler state
- then do
- -- If state already has an event handler, we do not attach another one
- yield (state, reason)
- sleepUntilInterval interval
- else do
- -- Attach a click handler that will trigger a block update
- yield (updateEventHandler (triggerOnClick event) state, reason)
-
- scheduler <- askSleepScheduler
- result <- liftIO $ do
- timerTask <- async $ sleepUntilInterval' scheduler defaultInterval
- eventTask <- async $ Event.wait event
- waitEitherCancel timerTask eventTask
-
- when (isRight result) $ do
- liftIO $ Event.clear event
- yield (invalidateBlockState state, UserUpdate)
-
- triggerOnClick :: Event -> BlockEvent -> BarIO ()
- triggerOnClick event _ = liftIO $ Event.set event
-- |Creates a new cache from a producer that automatically seals itself when the producer terminates.
newCache :: Producer [BlockState] BarIO () -> BlockCache
diff --git a/src/QBar/DefaultConfig.hs b/src/QBar/DefaultConfig.hs
index e7ce594..85b02a4 100644
--- a/src/QBar/DefaultConfig.hs
+++ b/src/QBar/DefaultConfig.hs
@@ -19,12 +19,12 @@ defaultBarConfig = do
legacyBarConfig :: BarIO ()
legacyBarConfig = do
- let todo = scriptBlock $ blockLocation "todo"
- let wifi = (scriptBlock $ blockLocation "wifi2") >-> modify (addIcon "📡\xFE0E")
- let networkEnvironment = scriptBlock $ blockLocation "network-environment"
- let ram = (scriptBlock $ blockLocation "memory") >-> modify (addIcon "ðŸ\xFE0E") >-> autoPadding
- let temperature = (scriptBlock $ blockLocation "temperature") >-> autoPadding
- let volumeBlock = persistentScriptBlock $ blockLocation "volume-pulseaudio -S -F3"
+ let todo = pollScriptBlock $ blockLocation "todo"
+ let wifi = (pollScriptBlock $ blockLocation "wifi2") >-> modify (addIcon "📡\xFE0E")
+ let networkEnvironment = pollScriptBlock $ blockLocation "network-environment"
+ let ram = (pollScriptBlock $ blockLocation "memory") >-> modify (addIcon "ðŸ\xFE0E") >-> autoPadding
+ let temperature = (pollScriptBlock $ blockLocation "temperature") >-> autoPadding
+ let volumeBlock = scriptBlock $ blockLocation "volume-pulseaudio -S -F3"
addBlock dateBlock
addBlock batteryBlock
diff --git a/src/QBar/Host.hs b/src/QBar/Host.hs
index c730da3..f7a04b6 100644
--- a/src/QBar/Host.hs
+++ b/src/QBar/Host.hs
@@ -138,12 +138,12 @@ filterDuplicates = do
followupEventWaitTime :: BlockUpdateReason -> Int
followupEventWaitTime DefaultUpdate = 10000
-followupEventWaitTime PullUpdate = 50000
+followupEventWaitTime PollUpdate = 50000
-- 'followupEventWaitTime' for 'UserUpdate' has to be zero, or blocks would be blocked blocked for this time when sending a 'UserUpdate'.
followupEventWaitTime UserUpdate = 0
followupEventWaitTimeDefault :: Int
-followupEventWaitTimeDefault = followupEventWaitTime PullUpdate
+followupEventWaitTimeDefault = followupEventWaitTime PollUpdate
requestBarUpdateHandler :: HostHandle -> BlockUpdateReason -> IO ()
requestBarUpdateHandler HostHandle{barUpdateEvent, barUpdatedEvent, followupEventWaitTimeMVar} blockUpdateReason = do
diff --git a/src/QBar/Server.hs b/src/QBar/Server.hs
index 324d2ae..234ccb0 100644
--- a/src/QBar/Server.hs
+++ b/src/QBar/Server.hs
@@ -146,7 +146,7 @@ runBarServer loadBlocks options = runBarHost barServer loadBlocks
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.
- return (signalPipe renderEvent >-> toOutput output, swayBarInput options)
+ return (signalEventPipe renderEvent >-> toOutput output, swayBarInput options)
renderLoop :: Event.Event -> MVar (Producer [ThemedBlockOutput] IO (), Bool) -> IO ()
renderLoop renderEvent themedBlockProducerMVar = runEffect $
--
GitLab