From f4bbea7a36ae826790f3aa0a886b6dc85ece851d Mon Sep 17 00:00:00 2001
From: Jens Nolte <jens@nightmarestudio.de>
Date: Mon, 27 Jan 2020 23:45:27 +0100
Subject: [PATCH] Refactor event handlers so BlockOutput can be serialized
---
src/QBar/BlockText.hs | 5 ++
src/QBar/Blocks/Battery.hs | 16 +++----
src/QBar/Blocks/Date.hs | 2 +-
src/QBar/ControlSocket.hs | 2 +-
src/QBar/Core.hs | 94 +++++++++++++++++++++++---------------
src/QBar/Server.hs | 91 ++++++++++++++++++------------------
6 files changed, 118 insertions(+), 92 deletions(-)
diff --git a/src/QBar/BlockText.hs b/src/QBar/BlockText.hs
index 2a58914..0a380b0 100644
--- a/src/QBar/BlockText.hs
+++ b/src/QBar/BlockText.hs
@@ -1,7 +1,9 @@
{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TemplateHaskell #-}
module QBar.BlockText where
+import Data.Aeson.TH
import qualified Data.Text.Lazy as T
import Data.Int (Int64)
import QBar.Pango
@@ -28,6 +30,9 @@ data BlockTextSegment = BlockTextSegment {
type Importance = Float
+$(deriveJSON defaultOptions ''BlockTextSegment)
+$(deriveJSON defaultOptions ''BlockText)
+
normalImportant :: Importance
normalImportant = 1
diff --git a/src/QBar/Blocks/Battery.hs b/src/QBar/Blocks/Battery.hs
index 720bd34..7dcd5ec 100644
--- a/src/QBar/Blocks/Battery.hs
+++ b/src/QBar/Blocks/Battery.hs
@@ -65,7 +65,7 @@ batteryBlock = do
batteryPaths <- liftIO $ map ((apiPath <> "/") <>) . filter (T.isPrefixOf "BAT" . T.pack) <$> getDirectoryContents apiPath
batteryStates <- liftIO $ mapM getBatteryState batteryPaths
isPlugged <- liftIO getPluggedState
- yield $ batteryBlockOutput isPlugged $ catMaybes batteryStates
+ updateBatteryBlock isPlugged $ catMaybes batteryStates
batteryBlock
where
apiPath :: FilePath
@@ -84,17 +84,15 @@ batteryBlock = do
_ -> return . return $ False
-batteryBlockOutput :: Bool -> [BatteryState] -> Maybe BlockOutput
-batteryBlockOutput isPlugged bs = (shortText.~shortText') . createBlock <$> fullText'
+updateBatteryBlock :: Bool -> [BatteryState] -> Block ()
+updateBatteryBlock _ [] = yield Nothing
+updateBatteryBlock isPlugged bs = updateBlock $ (shortText.~shortText') $ createBlock fullText'
where
- fullText' :: Maybe BlockText
- fullText'
- | null bs = Nothing
- | otherwise = Just $ normalText (batteryIcon <> " ") <> overallPercentage <> optionalEachBattery <> optionalOverallEstimate
+ fullText' :: BlockText
+ fullText' = normalText (batteryIcon <> " ") <> overallPercentage <> optionalEachBattery <> optionalOverallEstimate
shortText' :: Maybe BlockText
- | null bs = Nothing
- | otherwise = Just $ normalText (batteryIcon <> " ") <> overallPercentage
+ shortText' = Just $ normalText (batteryIcon <> " ") <> overallPercentage
batteryIcon :: T.Text
batteryIcon
diff --git a/src/QBar/Blocks/Date.hs b/src/QBar/Blocks/Date.hs
index e157602..d47cd72 100644
--- a/src/QBar/Blocks/Date.hs
+++ b/src/QBar/Blocks/Date.hs
@@ -13,7 +13,7 @@ import Control.Lens
dateBlock :: PushBlock
dateBlock = do
- yield . Just =<< liftIO dateBlockOutput
+ updateBlock =<< liftIO dateBlockOutput
liftIO $ sleepUntil =<< nextMinute
dateBlock
diff --git a/src/QBar/ControlSocket.hs b/src/QBar/ControlSocket.hs
index 500b9dd..e64fc63 100644
--- a/src/QBar/ControlSocket.hs
+++ b/src/QBar/ControlSocket.hs
@@ -128,5 +128,5 @@ handleBlockStream producer = do
where
handleParsedBlock :: Producer ByteString IO () -> String -> PushBlock
handleParsedBlock leftovers update = do
- yield $ Just . createBlock . normalText $ TL.pack update
+ updateBlock $ createBlock . normalText $ TL.pack update
handleBlockStream leftovers
diff --git a/src/QBar/Core.hs b/src/QBar/Core.hs
index e855d89..359daf0 100644
--- a/src/QBar/Core.hs
+++ b/src/QBar/Core.hs
@@ -31,26 +31,31 @@ import System.Process.Typed (Process, shell, setStdin, setStdout,
import Control.Lens
-data Click = Click {
+data BlockEvent = Click {
name :: T.Text,
button :: Int
} deriving Show
-$(deriveJSON defaultOptions ''Click)
+$(deriveJSON defaultOptions ''BlockEvent)
data BlockOutput = BlockOutput
{ _fullText :: BlockText
, _shortText :: Maybe BlockText
, _blockName :: Maybe T.Text
- , _clickAction :: Maybe (Click -> BarIO ())
, _invalid :: Bool
}
+$(deriveJSON defaultOptions ''BlockOutput)
data PushMode = PushMode
data PullMode = PullMode
data CachedMode = CachedMode
-type Block a = Producer (Maybe BlockOutput) BarIO a
+
+type BlockEventHandler = BlockEvent -> BarIO ()
+
+type BlockState = Maybe (BlockOutput, Maybe BlockEventHandler)
+
+type Block a = Producer BlockState BarIO a
-- |Block that 'yield's an update whenever the block should be changed
@@ -89,6 +94,19 @@ instance IsBlock CachedBlock where
data BarUpdateChannel = BarUpdateChannel (IO ())
type BarUpdateEvent = Event.Event
+mkBlockState :: BlockOutput -> BlockState
+mkBlockState blockOutput = Just (blockOutput, Nothing)
+
+updateBlock :: BlockOutput -> Block ()
+updateBlock blockOutput = yield $ Just (blockOutput, Nothing)
+
+updateBlock' :: BlockEventHandler -> BlockOutput -> Block ()
+updateBlock' blockEventHandler blockOutput = yield $ Just (blockOutput, Just blockEventHandler)
+
+updateEventHandler :: BlockEventHandler -> BlockState -> BlockState
+updateEventHandler _ Nothing = Nothing
+updateEventHandler eventHandler (Just (blockOutput, _)) = Just (blockOutput, Just eventHandler)
+
runBarIO :: Bar -> BarIO r -> IO r
runBarIO bar action = runReaderT (runSafeT action) bar
@@ -101,7 +119,6 @@ createBlock text = BlockOutput
{ _fullText = text
, _shortText = Nothing
, _blockName = Nothing
- , _clickAction = Nothing
, _invalid = False
}
@@ -115,20 +132,20 @@ addIcon :: T.Text -> BlockOutput -> BlockOutput
addIcon icon = over fullText $ (<>) . normalText $ icon <> " "
modify :: (BlockOutput -> BlockOutput)
- -> Pipe (Maybe BlockOutput) (Maybe BlockOutput) BarIO r
-modify x = PP.map (x <$>)
+ -> Pipe BlockState BlockState BarIO r
+modify x = PP.map (over (_Just . _1) x)
-autoPadding :: Pipe (Maybe BlockOutput) (Maybe BlockOutput) BarIO r
+autoPadding :: Pipe BlockState BlockState BarIO r
autoPadding = autoPadding' 0 0
where
- autoPadding' :: Int64 -> Int64 -> Pipe (Maybe BlockOutput) (Maybe BlockOutput) BarIO r
+ autoPadding' :: Int64 -> Int64 -> Pipe BlockState BlockState BarIO r
autoPadding' fullLength shortLength = do
maybeBlock <- await
case maybeBlock of
- Just block -> do
+ Just (block, eventHandler) -> do
let fullLength' = max fullLength . printedLength $ block^.fullText
- let shortLength' = max shortLength . printedLength $ block^.shortText._Just -- TODO: ???
- yield $ Just $ padFullText fullLength' . padShortText shortLength' $ block
+ let shortLength' = max shortLength . printedLength $ block^.shortText._Just
+ yield $ Just (padFullText fullLength' . padShortText shortLength' $ block, eventHandler)
autoPadding' fullLength' shortLength'
Nothing -> do
yield Nothing
@@ -140,14 +157,14 @@ autoPadding = autoPadding' 0 0
padShortText :: Int64 -> BlockOutput -> BlockOutput
padShortText len = over (shortText._Just) $ \s -> padString (len - printedLength s) <> s
-cacheFromInput :: Input (Maybe BlockOutput) -> CachedBlock
+cacheFromInput :: Input BlockState -> CachedBlock
cacheFromInput input = CachedMode <$ fromInput input
-- | 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 :: Int -> BarIO (PullBlock -> CachedBlock)
sharedInterval seconds = do
- clientsMVar <- liftIO $ newMVar ([] :: [(MVar PullBlock, Output (Maybe BlockOutput))])
+ clientsMVar <- liftIO $ newMVar ([] :: [(MVar PullBlock, Output BlockState)])
startEvent <- liftIO Event.new
@@ -167,49 +184,50 @@ sharedInterval seconds = do
return (addClient startEvent clientsMVar)
where
- runAndFilterClient :: (MVar PullBlock, Output (Maybe BlockOutput)) -> BarIO (Maybe (MVar PullBlock, Output (Maybe BlockOutput)))
+ runAndFilterClient :: (MVar PullBlock, Output BlockState) -> BarIO (Maybe (MVar PullBlock, Output BlockState))
runAndFilterClient client = do
result <- runClient client
return $ if result then Just client else Nothing
- runClient :: (MVar PullBlock, Output (Maybe BlockOutput)) -> BarIO Bool
- runClient (blockProducerMVar, output) = do
+ runClient :: (MVar PullBlock, Output BlockState) -> BarIO Bool
+ runClient (blockMVar, output) = do
bar <- askBar
- liftIO $ modifyMVar blockProducerMVar $ \blockProducer -> do
+ liftIO $ modifyMVar blockMVar $ \blockProducer -> do
result <- runReaderT (runSafeT $ next blockProducer) bar
case result of
Left _ -> return (exitBlock, False)
- Right (blockOutput, blockProducer') -> do
- success <- atomically $ send output $ (clickAction ?~ updateClickHandler blockOutput) <$> blockOutput
+ Right (blockState, blockProducer') -> do
+ success <- atomically $ send output $ updateEventHandler (updateClickHandler blockState) blockState
if success
-- Store new BlockProducer back into MVar
then return (blockProducer', True)
-- Mailbox is sealed, stop running producer
else return (exitBlock, False)
where
- updateClickHandler :: Maybe BlockOutput -> Click -> BarIO ()
+ updateClickHandler :: BlockState -> BlockEvent -> BarIO ()
updateClickHandler Nothing _ = return ()
- updateClickHandler (Just block) _ = do
+ updateClickHandler (Just (block, _)) _ = do
-- Give user feedback that the block is updating
let outdatedBlock = block & invalid.~True
- liftIO $ void $ atomically $ send output . Just $ outdatedBlock
+ -- The invalidated block output has no event handler
+ liftIO $ void $ atomically $ send output . Just $ (outdatedBlock, Nothing)
-- Notify bar about changed block state to display the feedback
updateBar
-- Run a normal block update to update the block to the new value
- void $ runClient (blockProducerMVar, output)
+ void $ runClient (blockMVar, output)
-- Notify bar about changed block state, this is usually done by the shared interval handler
updateBar
- addClient :: Event.Event -> MVar [(MVar PullBlock, Output (Maybe BlockOutput))] -> PullBlock -> CachedBlock
+ addClient :: Event.Event -> MVar [(MVar PullBlock, Output BlockState)] -> PullBlock -> CachedBlock
addClient startEvent clientsMVar blockProducer = do
-- Spawn the mailbox that preserves the latest block
- (output, input) <- liftIO $ spawn $ latest $ Just emptyBlock
+ (output, input) <- liftIO $ spawn $ latest Nothing
- blockProducerMVar <- liftIO $ newMVar blockProducer
+ blockMVar <- liftIO $ newMVar blockProducer
-- Generate initial block and send it to the mailbox
- lift $ void $ runClient (blockProducerMVar, output)
+ lift $ void $ runClient (blockMVar, output)
-- Register the client for regular updates
- liftIO $ modifyMVar_ clientsMVar $ \ clients -> return ((blockProducerMVar, output):clients)
+ liftIO $ modifyMVar_ clientsMVar $ \ clients -> return ((blockMVar, output):clients)
-- Start update thread (if not already started)
liftIO $ Event.set startEvent
@@ -218,7 +236,7 @@ sharedInterval seconds = do
cacheFromInput input
blockScript :: FilePath -> PullBlock
-blockScript path = forever $ yield . Just =<< (lift blockScriptAction)
+blockScript path = forever $ updateBlock =<< (lift blockScriptAction)
where
blockScriptAction :: BarIO BlockOutput
blockScriptAction = do
@@ -244,8 +262,8 @@ startPersistentBlockScript path = catchP startScriptProcess handleError
where
handleError :: IOException -> PushBlock
handleError e = do
- yield . Just . createErrorBlock $ "[" <> T.pack (show e) <> "]"
- return PushMode
+ updateBlock . createErrorBlock $ "[" <> T.pack (show e) <> "]"
+ exitBlock
handleErrorWithProcess :: (Process i o e) -> IOException -> PushBlock
handleErrorWithProcess process e = do
stopProcess process
@@ -260,7 +278,7 @@ startPersistentBlockScript path = catchP startScriptProcess handleError
blockFromHandle :: Handle -> PushBlock
blockFromHandle handle = forever $ do
line <- liftIO $ TIO.hGetLine handle
- yield $ Just . createBlock . pangoText $ line
+ updateBlock $ createBlock . pangoText $ line
lift updateBar
addBlock :: IsBlock a => a -> BarIO ()
@@ -282,26 +300,28 @@ barAsync action = do
cachePushBlock :: PushBlock -> CachedBlock
cachePushBlock pushBlock = lift (next pushBlock) >>= either (const exitBlock) withInitialBlock
where
- withInitialBlock :: (Maybe BlockOutput, PushBlock) -> CachedBlock
+ withInitialBlock :: (BlockState, PushBlock) -> CachedBlock
withInitialBlock (initialBlockOutput, pushBlock') = do
(output, input, seal) <- liftIO $ spawn' $ latest $ initialBlockOutput
-- The async could be used to stop the block later, but for now we are just linking it to catch exceptions
task <- lift $ barAsync (sendProducerToMailbox output seal pushBlock')
liftIO $ link task
terminateOnMaybe $ fromInput input
- sendProducerToMailbox :: Output (Maybe BlockOutput) -> STM () -> PushBlock -> BarIO ()
+ sendProducerToMailbox :: Output BlockState -> STM () -> PushBlock -> BarIO ()
sendProducerToMailbox output seal pushBlock' = do
+ -- Send push block output to mailbox until it terminates
void $ runEffect $ for pushBlock' (sendOutputToMailbox output)
+ -- Then clear the block and seal the mailbox
liftIO $ atomically $ void $ send output Nothing
updateBar
liftIO $ atomically seal
- sendOutputToMailbox :: Output (Maybe BlockOutput) -> Maybe BlockOutput -> Effect BarIO ()
+ sendOutputToMailbox :: Output BlockState -> BlockState -> Effect BarIO ()
sendOutputToMailbox output blockOutput = do
-- The void is discarding the boolean result that indicates if the mailbox is sealed
-- This is ok because a cached block is never sealed from the receiving side
liftIO $ atomically $ void $ send output $ blockOutput
lift updateBar
- terminateOnMaybe :: Producer (Maybe BlockOutput) BarIO () -> Producer (Maybe BlockOutput) BarIO CachedMode
+ terminateOnMaybe :: Producer BlockState BarIO () -> Producer BlockState BarIO CachedMode
terminateOnMaybe p = do
eitherMaybeValue <- lift $ next p
case eitherMaybeValue of
diff --git a/src/QBar/Server.hs b/src/QBar/Server.hs
index 452b45a..c105ce2 100644
--- a/src/QBar/Server.hs
+++ b/src/QBar/Server.hs
@@ -29,23 +29,23 @@ import System.Posix.Signals
import Control.Lens hiding (each, (.=))
data Handle = Handle {
- handleActionList :: IORef [(T.Text, Click -> BarIO ())],
+ handleActionList :: IORef [(T.Text, BlockEventHandler)],
handleActiveFilter :: IORef Filter
}
renderIndicator :: CachedBlock
-- Using 'cachedBlock' is a hack to actually get the block to update on every bar update (by doing this it will not get a cache later in the pipeline).
-renderIndicator = forever $ each $ map (Just . createBlock . normalText) ["/", "-", "\\", "|"]
+renderIndicator = forever $ each $ map (mkBlockState . createBlock . normalText) ["/", "-", "\\", "|"]
-runBlock :: CachedBlock -> BarIO (Maybe (Maybe BlockOutput, CachedBlock))
+runBlock :: CachedBlock -> BarIO (Maybe (BlockState, CachedBlock))
runBlock producer = do
next' <- next producer
return $ case next' of
Left _ -> Nothing
- Right (block, newProducer) -> Just (block, newProducer)
+ Right (blockState, newProducer) -> Just (blockState, newProducer)
-runBlocks :: [CachedBlock] -> BarIO ([Maybe BlockOutput], [CachedBlock])
-runBlocks block = unzip . catMaybes <$> mapM runBlock block
+runBlocks :: [CachedBlock] -> BarIO ([BlockState], [CachedBlock])
+runBlocks blocks = unzip . catMaybes <$> mapM runBlock blocks
data RenderBlock = RenderBlock T.Text (Maybe T.Text) (Maybe T.Text)
deriving(Show)
@@ -82,20 +82,20 @@ renderLoop options handle@Handle{handleActiveFilter} barUpdateEvent previousBarO
blocks' <- addNewBlocks blocks
- (blockOutputs, blocks'') <- runBlocks blocks'
+ (blockStates, blocks'') <- runBlocks blocks'
- currentBarOutput <- liftIO $ renderLine options handle blockFilter blockOutputs previousBarOutput'
+ currentBarOutput <- liftIO $ renderLine options handle blockFilter blockStates previousBarOutput'
-- Wait for 100ms after rendering a line to limit cpu load of rapid events
liftIO $ threadDelay 100000
renderLoop' currentBarOutput blocks''
-renderLine :: MainOptions -> Handle -> Filter -> [Maybe BlockOutput] -> BS.ByteString -> IO BS.ByteString
-renderLine MainOptions{verbose} Handle{handleActionList} blockFilter blocks' previousEncodedOutput = do
+renderLine :: MainOptions -> Handle -> Filter -> [BlockState] -> BS.ByteString -> IO BS.ByteString
+renderLine MainOptions{verbose} Handle{handleActionList} blockFilter blockStates previousEncodedOutput = do
time <- fromRational . toRational <$> getPOSIXTime
- let blocks = catMaybes blocks'
- let filteredBlocks = applyFilter blockFilter time blocks
+ let blockOutputs = map fst $ catMaybes blockStates
+ let filteredBlocks = applyFilter blockFilter time blockOutputs
-- let encodedOutput = encode $ map values filteredBlocks
let encodedOutput = encodeOutput filteredBlocks
let changed = previousEncodedOutput /= encodedOutput
@@ -111,8 +111,8 @@ renderLine MainOptions{verbose} Handle{handleActionList} blockFilter blocks' pre
when verbose $ unless changed $ hPutStrLn stderr "Output unchanged"
- -- Register click handlers regardless of bar changes, because we cannot easily check if any handler has changed
- writeIORef handleActionList clickActionList
+ -- Register all event handlers regardless of bar changes, because we cannot easily check if any handler has changed
+ writeIORef handleActionList eventHandlerList
return encodedOutput
where
@@ -122,21 +122,22 @@ renderLine MainOptions{verbose} Handle{handleActionList} blockFilter blocks' pre
encodeOutput bs = encode $ zipWith encodeBlock bs $ theme bs
encodeBlock :: BlockOutput -> (T.Text, Maybe T.Text) -> RenderBlock
encodeBlock b (fullText', shortText') = RenderBlock fullText' shortText' (b^.blockName)
- clickActionList :: [(T.Text, Click -> BarIO ())]
- clickActionList = mapMaybe getClickAction . catMaybes $ blocks'
- getClickAction :: BlockOutput -> Maybe (T.Text, Click -> BarIO ())
- getClickAction block = do
- blockName' <- block^.blockName
- clickAction' <- block^.clickAction
- return (blockName', clickAction')
+ eventHandlerList :: [(T.Text, BlockEventHandler)]
+ eventHandlerList = mapMaybe getEventHandler $ blockStates
+ getEventHandler :: BlockState -> Maybe (T.Text, BlockEventHandler)
+ getEventHandler Nothing = Nothing
+ getEventHandler (Just (_, Nothing)) = Nothing
+ getEventHandler (Just (blockOutput, Just eventHandler)) = do
+ blockName' <- blockOutput^.blockName
+ return (blockName', eventHandler)
createBarUpdateChannel :: IO (IO (), BarUpdateEvent)
createBarUpdateChannel = do
event <- Event.newSet
return (Event.set event, event)
-handleStdin :: MainOptions -> IORef [(T.Text, Click -> BarIO ())] -> BarIO ()
-handleStdin options actionListIORef = do
+handleStdin :: MainOptions -> IORef [(T.Text, BlockEventHandler)] -> BarIO ()
+handleStdin options eventHandlerListIORef = do
bar <- askBar
liftIO $ forever $ do
line <- BSSC8.hGetLine stdin
@@ -147,19 +148,19 @@ handleStdin options actionListIORef = do
BSSC8.hPutStrLn stderr line
hFlush stderr
- let maybeClick = decode $ removeComma $ BS.fromStrict line
- case maybeClick of
- Just click -> do
- clickActionList <- readIORef actionListIORef
- let maybeClickAction = getClickAction clickActionList click
- case maybeClickAction of
- Just clickAction' -> async (runBarIO bar (clickAction' click)) >>= link
+ let maybeBlockEvent = decode $ removeComma $ BS.fromStrict line
+ case maybeBlockEvent of
+ Just blockEvent -> do
+ eventHandlerList <- readIORef eventHandlerListIORef
+ let maybeEventHandler = getEventHandler eventHandlerList blockEvent
+ case maybeEventHandler of
+ Just eventHandler -> async (runBarIO bar (eventHandler blockEvent)) >>= link
Nothing -> return ()
Nothing -> return ()
where
- getClickAction :: [(T.Text, Click -> BarIO ())] -> Click -> Maybe (Click -> BarIO ())
- getClickAction clickActionList click = lookup (name click) clickActionList
+ getEventHandler :: [(T.Text, BlockEventHandler)] -> BlockEvent -> Maybe BlockEventHandler
+ getEventHandler eventHandlerList blockEvent = lookup (name blockEvent) eventHandlerList
removeComma :: C8.ByteString -> C8.ByteString
removeComma line
| C8.head line == ',' = C8.tail line
@@ -179,18 +180,15 @@ installSignalHandlers = do
renderInitialBlocks :: MainOptions -> Handle -> Filter -> IO C8.ByteString
renderInitialBlocks options handle blockFilter = do
date <- dateBlockOutput
- let initialBlocks = [Just date]
+ let initialBlocks = [mkBlockState date]
-- Attach spinner indicator when verbose flag is set
- let initialBlocks' = if indicator options then initialBlocks <> [Just . createBlock . normalText $ "*"] else initialBlocks
+ let initialBlocks' = if indicator options then initialBlocks <> [mkBlockState $ createBlock . normalText $ "*"] else initialBlocks
-- Render initial time block so the bar is not empty after startup
renderLine options handle blockFilter initialBlocks' ""
-runBarConfiguration :: BarIO () -> MainOptions -> IO ()
-runBarConfiguration defaultBarConfig options = do
- -- Create IORef to contain the active filter
- let initialBlockFilter = StaticFilter None
- activeFilter <- newIORef initialBlockFilter
+runBarServer :: BarIO () -> MainOptions -> IO ()
+runBarServer defaultBarConfig options = do
putStrLn "{\"version\":1,\"click_events\":true}"
putStrLn "["
@@ -202,10 +200,15 @@ runBarConfiguration defaultBarConfig options = do
let bar = Bar { requestBarUpdate, newBlockChan }
- -- Create IORef for mouse click callbacks
- actionList <- newIORef []
+ -- Create IORef to contain the active filter
+ let initialBlockFilter = StaticFilter None
+ activeFilter <- newIORef initialBlockFilter
+
+ -- Create IORef for event handlers
+ eventHandlerListIORef <- newIORef []
+
let handle = Handle {
- handleActionList = actionList,
+ handleActionList = eventHandlerListIORef,
handleActiveFilter = activeFilter
}
@@ -213,7 +216,7 @@ runBarConfiguration defaultBarConfig options = do
-- Fork stdin handler
- void $ forkFinally (runBarIO bar (handleStdin options actionList)) (\result -> hPutStrLn stderr $ "handleStdin failed: " <> show result)
+ void $ forkFinally (runBarIO bar (handleStdin options eventHandlerListIORef)) (\result -> hPutStrLn stderr $ "handleStdin failed: " <> show result)
runBarIO bar loadBlocks
@@ -251,6 +254,6 @@ createCommandChan = newTChanIO
runQBar :: BarIO () -> MainOptions -> IO ()
runQBar barConfiguration options@MainOptions{barCommand} = runCommand barCommand
where
- runCommand BarServer = runBarConfiguration barConfiguration options
+ runCommand BarServer = runBarServer barConfiguration options
runCommand NoFilter = sendIpc options $ SetFilter $ StaticFilter None
runCommand RainbowFilter = sendIpc options $ SetFilter $ AnimatedFilter Rainbow
--
GitLab