diff --git a/src/QBar/Blocks/Battery.hs b/src/QBar/Blocks/Battery.hs index 470d17f121862d82c552ab6a9ff049e6ab586ea8..2edd8f7be0e5e4eae176cb67a4ae5cee9662e04d 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 $ fromMaybe emptyBlock (batteryBlockOutput isPlugged $ catMaybes batteryStates) + yield $ batteryBlockOutput isPlugged $ catMaybes batteryStates batteryBlock where apiPath :: FilePath diff --git a/src/QBar/Blocks/Date.hs b/src/QBar/Blocks/Date.hs index a70df4b7fa82aa7b006c60f0c8ae196e800642b3..e157602d672d7fbace60315ec8d385fc9121c6a5 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 =<< liftIO dateBlockOutput + yield . Just =<< liftIO dateBlockOutput liftIO $ sleepUntil =<< nextMinute dateBlock diff --git a/src/QBar/ControlSocket.hs b/src/QBar/ControlSocket.hs index eb1f20d4fd2b68386e1d3b1b49c9a7ccba34ac08..ef5de6977fb9f8b2b9963b3c1c7675cee58e955b 100644 --- a/src/QBar/ControlSocket.hs +++ b/src/QBar/ControlSocket.hs @@ -113,5 +113,5 @@ handleBlockStream producer = do where handleParsedBlock :: Producer ByteString IO () -> String -> PushBlock handleParsedBlock leftovers update = do - yield $ createBlock . normalText $ TL.pack update + yield $ Just . createBlock . normalText $ TL.pack update handleBlockStream leftovers diff --git a/src/QBar/Core.hs b/src/QBar/Core.hs index 7615b4d0eae4a9527c66f2616a7bab0f31898059..310c5c37ee9ee00f38008e0fc6cb1777469ae419 100644 --- a/src/QBar/Core.hs +++ b/src/QBar/Core.hs @@ -48,7 +48,7 @@ data PushMode = PushMode data PullMode = PullMode data CachedMode = CachedMode -type Block a = Producer BlockOutput BarIO a +type Block a = Producer (Maybe BlockOutput) BarIO a -- |Block that 'yield's an update whenever the block should be changed @@ -106,8 +106,9 @@ emptyBlock = createBlock mempty addIcon :: T.Text -> BlockOutput -> BlockOutput addIcon icon = over fullText $ (<>) . normalText $ icon <> " " -modify :: (BlockOutput -> BlockOutput) -> Pipe BlockOutput BlockOutput BarIO r -modify = PP.map +modify :: (BlockOutput -> BlockOutput) + -> Pipe (Maybe BlockOutput) (Maybe BlockOutput) BarIO r +modify x = PP.map (x <$>) autoPadding :: Pipe BlockOutput BlockOutput BarIO r autoPadding = autoPadding' 0 0 @@ -126,14 +127,14 @@ autoPadding = autoPadding' 0 0 padShortText :: Int64 -> BlockOutput -> BlockOutput padShortText len = over (shortText._Just) $ \s -> padString (len - printedLength s) <> s -cacheFromInput :: Input BlockOutput -> CachedBlock +cacheFromInput :: Input (Maybe BlockOutput) -> 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 BlockOutput)]) + clientsMVar <- liftIO $ newMVar ([] :: [(MVar PullBlock, Output (Maybe BlockOutput))]) startEvent <- liftIO Event.new @@ -153,11 +154,11 @@ sharedInterval seconds = do return (addClient startEvent clientsMVar) where - runAndFilterClient :: (MVar PullBlock, Output BlockOutput) -> BarIO (Maybe (MVar PullBlock, Output BlockOutput)) + runAndFilterClient :: (MVar PullBlock, Output (Maybe BlockOutput)) -> BarIO (Maybe (MVar PullBlock, Output (Maybe BlockOutput))) runAndFilterClient client = do result <- runClient client return $ if result then Just client else Nothing - runClient :: (MVar PullBlock, Output BlockOutput) -> BarIO Bool + runClient :: (MVar PullBlock, Output (Maybe BlockOutput)) -> BarIO Bool runClient (blockProducerMVar, output) = do bar <- ask liftIO $ modifyMVar blockProducerMVar $ \blockProducer -> do @@ -165,30 +166,29 @@ sharedInterval seconds = do case result of Left _ -> return (exitBlock, False) Right (blockOutput, blockProducer') -> do - success <- atomically $ send output blockOutput { - _clickAction = Just (updateClickHandler blockOutput) - } + success <- atomically $ send output $ (clickAction ?~ updateClickHandler blockOutput) <$> blockOutput if success -- Store new BlockProducer back into MVar then return (blockProducer', True) -- Mailbox is sealed, stop running producer else return (exitBlock, False) where - updateClickHandler :: BlockOutput -> Click -> BarIO () - updateClickHandler block _ = do + updateClickHandler :: Maybe BlockOutput -> Click -> BarIO () + updateClickHandler Nothing _ = return () + updateClickHandler (Just block) _ = do -- Give user feedback that the block is updating let outdatedBlock = block & invalid.~True - liftIO $ void $ atomically $ send output outdatedBlock + liftIO $ void $ atomically $ send output . Just $ outdatedBlock -- 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) -- Notify bar about changed block state, this is usually done by the shared interval handler updateBar - addClient :: Event.Event -> MVar [(MVar PullBlock, Output BlockOutput)] -> PullBlock -> CachedBlock + addClient :: Event.Event -> MVar [(MVar PullBlock, Output (Maybe BlockOutput))] -> PullBlock -> CachedBlock addClient startEvent clientsMVar blockProducer = do -- Spawn the mailbox that preserves the latest block - (output, input) <- liftIO $ spawn $ latest emptyBlock + (output, input) <- liftIO $ spawn $ latest $ Just emptyBlock blockProducerMVar <- liftIO $ newMVar blockProducer @@ -205,7 +205,7 @@ sharedInterval seconds = do cacheFromInput input blockScript :: FilePath -> PullBlock -blockScript path = forever $ yield =<< (lift blockScriptAction) +blockScript path = forever $ yield . Just =<< (lift blockScriptAction) where blockScriptAction :: BarIO BlockOutput blockScriptAction = do @@ -231,7 +231,7 @@ startPersistentBlockScript :: FilePath -> CachedBlock startPersistentBlockScript path = do bar <- lift ask do - (output, input, seal) <- liftIO $ spawn' $ latest emptyBlock + (output, input, seal) <- liftIO $ spawn' $ latest $ Just emptyBlock initialDataEvent <- liftIO Event.new task <- liftIO $ async $ do let processConfig = setStdin closed $ setStdout createPipe $ shell path @@ -243,7 +243,7 @@ startPersistentBlockScript path = do ) ( \ e -> -- output error - runEffect $ yield (createErrorBlock $ "[" <> T.pack (show (e :: IOException)) <> "]") >-> signalFirstBlock initialDataEvent >-> toOutput output + runEffect $ yield (Just . createErrorBlock $ "[" <> T.pack (show (e :: IOException)) <> "]") >-> signalFirstBlock initialDataEvent >-> toOutput output ) ) (atomically seal) @@ -251,17 +251,17 @@ startPersistentBlockScript path = do liftIO $ Event.wait initialDataEvent cacheFromInput input where - signalFirstBlock :: Event.Event -> Pipe BlockOutput BlockOutput IO () + signalFirstBlock :: Event.Event -> Pipe (Maybe BlockOutput) (Maybe BlockOutput) IO () signalFirstBlock event = do -- Await first block await >>= yield lift $ Event.set event -- Replace with cat cat - fromHandle :: Bar -> Handle -> Producer BlockOutput IO () + fromHandle :: Bar -> Handle -> Producer (Maybe BlockOutput) IO () fromHandle bar handle = forever $ do line <- lift $ TIO.hGetLine handle - yield $ createBlock . pangoText $ line + yield $ Just . createBlock . pangoText $ line lift $ updateBar' bar @@ -284,9 +284,9 @@ barAsync action = do cachePushBlock :: PushBlock -> CachedBlock cachePushBlock pushBlock = lift (next pushBlock) >>= either (const exitBlock) withInitialBlock where - withInitialBlock :: (BlockOutput, PushBlock) -> CachedBlock + withInitialBlock :: (Maybe BlockOutput, PushBlock) -> CachedBlock withInitialBlock (initialBlockOutput, pushBlock') = do - (output, input, seal) <- liftIO $ spawn' $ latest $ Just initialBlockOutput + (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 @@ -297,15 +297,15 @@ cachePushBlock pushBlock = lift (next pushBlock) >>= either (const exitBlock) wi liftIO $ atomically $ void $ send output Nothing updateBar liftIO $ atomically seal - sendOutputToMailbox :: Output (Maybe BlockOutput) -> BlockOutput -> Effect BarIO () + sendOutputToMailbox :: Output (Maybe BlockOutput) -> Maybe BlockOutput -> 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 $ Just blockOutput + liftIO $ atomically $ void $ send output $ blockOutput lift updateBar - terminateOnMaybe :: Producer (Maybe BlockOutput) BarIO () -> Producer BlockOutput BarIO CachedMode + terminateOnMaybe :: Producer (Maybe BlockOutput) BarIO () -> Producer (Maybe BlockOutput) BarIO CachedMode terminateOnMaybe p = do eitherMaybeValue <- lift $ next p case eitherMaybeValue of - Right (Just value, newP) -> yield value >> terminateOnMaybe newP + Right (Just value, newP) -> yield (Just value) >> terminateOnMaybe newP _ -> exitBlock diff --git a/src/QBar/Server.hs b/src/QBar/Server.hs index 12c663646312530f0e5825c109ad32d9d6679f2a..24ea3eb7f3c93b17ee9beb6a4d318e6f701723f3 100644 --- a/src/QBar/Server.hs +++ b/src/QBar/Server.hs @@ -36,16 +36,16 @@ data Handle = Handle { 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 (createBlock . normalText) ["/", "-", "\\", "|"] +renderIndicator = forever $ each $ map (Just . createBlock . normalText) ["/", "-", "\\", "|"] -runBlock :: CachedBlock -> BarIO (Maybe (BlockOutput, CachedBlock)) +runBlock :: CachedBlock -> BarIO (Maybe (Maybe BlockOutput, CachedBlock)) runBlock producer = do next' <- next producer return $ case next' of Left _ -> Nothing Right (block, newProducer) -> Just (block, newProducer) -runBlocks :: [CachedBlock] -> BarIO ([BlockOutput], [CachedBlock]) +runBlocks :: [CachedBlock] -> BarIO ([Maybe BlockOutput], [CachedBlock]) runBlocks block = unzip . catMaybes <$> mapM runBlock block data RenderBlock = RenderBlock T.Text (Maybe T.Text) (Maybe T.Text) @@ -92,9 +92,10 @@ renderLoop options handle@Handle{handleActiveFilter} barUpdateEvent previousBarO renderLoop' currentBarOutput blocks'' -renderLine :: MainOptions -> Handle -> Filter -> [BlockOutput] -> BS.ByteString -> IO BS.ByteString -renderLine MainOptions{verbose} Handle{handleActionList} blockFilter blocks previousEncodedOutput = do +renderLine :: MainOptions -> Handle -> Filter -> [Maybe BlockOutput] -> BS.ByteString -> IO BS.ByteString +renderLine MainOptions{verbose} Handle{handleActionList} blockFilter blocks' previousEncodedOutput = do time <- fromRational . toRational <$> getPOSIXTime + let blocks = catMaybes blocks' let filteredBlocks = applyFilter blockFilter time blocks -- let encodedOutput = encode $ map values filteredBlocks let encodedOutput = encodeOutput filteredBlocks @@ -123,7 +124,7 @@ renderLine MainOptions{verbose} Handle{handleActionList} blockFilter blocks prev 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 blocks + clickActionList = mapMaybe getClickAction . catMaybes $ blocks' getClickAction :: BlockOutput -> Maybe (T.Text, Click -> BarIO ()) getClickAction block = do blockName' <- block^.blockName @@ -179,9 +180,9 @@ installSignalHandlers = do renderInitialBlocks :: MainOptions -> Handle -> Filter -> IO C8.ByteString renderInitialBlocks options handle blockFilter = do date <- dateBlockOutput - let initialBlocks = [date] + let initialBlocks = [Just date] -- Attach spinner indicator when verbose flag is set - let initialBlocks' = if indicator options then initialBlocks <> [createBlock . normalText $ "*"] else initialBlocks + let initialBlocks' = if indicator options then initialBlocks <> [Just . createBlock . normalText $ "*"] else initialBlocks -- Render initial time block so the bar is not empty after startup renderLine options handle blockFilter initialBlocks' ""