diff --git a/src/QBar/Blocks/Battery.hs b/src/QBar/Blocks/Battery.hs index 33df50516bd2e3835e32b1897e70f6ca6fb71624..6358558d4d2f5aa5cc4b3504255c950c3b833ec1 100644 --- a/src/QBar/Blocks/Battery.hs +++ b/src/QBar/Blocks/Battery.hs @@ -78,8 +78,8 @@ getBatteryState path = maybe getBatteryStateCharge (return . Just) =<< getBatter | otherwise -> BatteryOther -batteryBlock :: PullBlock -batteryBlock = forever $ do +batteryBlock :: Block +batteryBlock = pullBlock $ forever $ do batteryPaths <- liftIO $ map ((apiPath <> "/") <>) . filter (T.isPrefixOf "BAT" . T.pack) <$> getDirectoryContents apiPath batteryStates <- liftIO $ mapM getBatteryState batteryPaths isPlugged <- liftIO getPluggedState @@ -101,9 +101,9 @@ batteryBlock = forever $ do _ -> return . return $ False -updateBatteryBlock :: Bool -> [BatteryState] -> Block () -updateBatteryBlock _ [] = updateBlockEmpty -updateBatteryBlock isPlugged bs = updateBlock $ (shortText.~shortText') $ mkBlockOutput fullText' +updateBatteryBlock :: Bool -> [BatteryState] -> PullBlock' () +updateBatteryBlock _ [] = sendEmptyBlockUpdate +updateBatteryBlock isPlugged bs = sendBlockUpdate $ (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 ac31b7883d91ff9e22fe98198cd451760699060e..6364380201166079fdecc8202ecb1ae1b8d0e771 100644 --- a/src/QBar/Blocks/CpuUsage.hs +++ b/src/QBar/Blocks/CpuUsage.hs @@ -4,7 +4,7 @@ module QBar.Blocks.CpuUsage where import Control.Applicative ((<|>)) import Control.Lens -import Control.Monad.State (StateT, evalStateT) +import Control.Monad.State (StateT, evalStateT, lift) import qualified Data.Attoparsec.Text.Lazy as AT import qualified Data.Text.Lazy as T import QBar.BlockOutput @@ -112,15 +112,15 @@ data CpuBlockState makeLenses ''CpuBlockState -cpuUsageBlock :: Int -> PullBlock -cpuUsageBlock decimalPlaces = evalStateT cpuUsageBlock' createState +cpuUsageBlock :: Int -> Block +cpuUsageBlock decimalPlaces = pullBlock $ evalStateT cpuUsageBlock' createState where - cpuUsageBlock' :: StateT CpuBlockState Block PullMode - cpuUsageBlock' = do + cpuUsageBlock' :: StateT CpuBlockState PullBlock' ExitBlock + cpuUsageBlock' = forever $ do updateState importance <- cpuUsageImportance - updateBlock . mkBlockOutput . importantText importance =<< ("💻\xFE0E " <>) <$> cpuUsageText - cpuUsageBlock' + text <- ("💻\xFE0E " <>) <$> cpuUsageText + lift $ sendBlockUpdate $ mkBlockOutput $ importantText importance text createState :: CpuBlockState createState = CpuBlockState diff --git a/src/QBar/Blocks/Date.hs b/src/QBar/Blocks/Date.hs index ae124689e3e022fea0b43d8de3280474940d1923..adecf74f6047248f83cc14dd0a7120280a8c7ab2 100644 --- a/src/QBar/Blocks/Date.hs +++ b/src/QBar/Blocks/Date.hs @@ -9,10 +9,10 @@ import Data.Time.Format import Data.Time.LocalTime -dateBlock :: PushBlock -dateBlock = schedulePullBlock' (everyNSeconds 60) $ forever $ do +dateBlock :: Block +dateBlock = pullBlock' (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 - updateBlock $ mkBlockOutput text + sendBlockUpdate $ mkBlockOutput text diff --git a/src/QBar/Blocks/Pipe.hs b/src/QBar/Blocks/Pipe.hs index 826ad9a55f0b103a16f96659aeb88ba160005449..be90ebbf989ab21e9b245139c731b2e4bac566fd 100644 --- a/src/QBar/Blocks/Pipe.hs +++ b/src/QBar/Blocks/Pipe.hs @@ -1,6 +1,5 @@ module QBar.Blocks.Pipe where -import QBar.BlockOutput import QBar.ControlSocket import QBar.Core import QBar.TagParser @@ -22,16 +21,16 @@ runPipeClient enableEvents mainOptions = do void $ waitEitherCancel hostTask inputTask where -- |Special block that reads the processes stdin line-by-line and shows the latest line in the block. Must never be used in a 'server' process or when stdin/stdout is used in another way. - pipeBlock :: Producer String BarIO () -> PushBlock - pipeBlock source = PushMode <$ source >-> pack + pipeBlock :: Producer String BarIO () -> Block + pipeBlock source = ExitBlock <$ source >-> pack where pack :: Pipe String BlockUpdate BarIO () pack = forever $ do value <- await - yield (attachHandler . parseTags' . T.pack $ value, DefaultUpdate) - attachHandler :: BlockOutput -> BlockState - attachHandler = if enableEvents then mkBlockState' pipeBlockName handler else mkBlockState + let output = parseTags' . T.pack $ value + if enableEvents + then pushBlockUpdate' handler output + else pushBlockUpdate output + handler :: BlockEventHandler handler event = liftIO $ BSC.hPutStrLn stderr $ encode event - pipeBlockName :: Text - pipeBlockName = "pipe" diff --git a/src/QBar/Blocks/Script.hs b/src/QBar/Blocks/Script.hs index 8dcf0faecf6890eb4ed4e83be2c62e51074dda6a..5480853229f8927d944e3fa2eb841c1fb09f764a 100644 --- a/src/QBar/Blocks/Script.hs +++ b/src/QBar/Blocks/Script.hs @@ -17,8 +17,8 @@ import System.Process.Typed (Process, shell, setStdin, setStdout, getStdout, closed, createPipe, readProcessStdout, startProcess, stopProcess) -scriptBlock :: FilePath -> PullBlock -scriptBlock path = forever $ updateBlock =<< (lift blockScriptAction) +scriptBlock :: FilePath -> Block +scriptBlock path = pullBlock $ forever $ sendBlockUpdate =<< (lift blockScriptAction) where blockScriptAction :: BarIO BlockOutput blockScriptAction = do @@ -35,26 +35,26 @@ scriptBlock path = forever $ updateBlock =<< (lift blockScriptAction) (text:_) -> parseTags' text [] -> emptyBlock -persistentScriptBlock :: FilePath -> PushBlock +persistentScriptBlock :: FilePath -> Block -- The outer catchP only catches errors that occur during process creation persistentScriptBlock path = catchP startScriptProcess handleError where - handleError :: IOException -> PushBlock + handleError :: IOException -> Block handleError e = do - updateBlock . mkErrorOutput $ T.pack (show e) + pushBlockUpdate . mkErrorOutput $ T.pack (show e) exitBlock - handleErrorWithProcess :: (Process i o e) -> IOException -> PushBlock + handleErrorWithProcess :: (Process i o e) -> IOException -> Block handleErrorWithProcess process e = do stopProcess process handleError e - startScriptProcess :: PushBlock + startScriptProcess :: Block startScriptProcess = do let processConfig = setStdin closed $ setStdout createPipe $ shell path process <- startProcess processConfig -- The inner catchP catches errors that happen after the process has been created -- This handler will also make sure the process is stopped catchP (blockFromHandle $ getStdout process) (handleErrorWithProcess process) - blockFromHandle :: Handle -> PushBlock + blockFromHandle :: Handle -> Block blockFromHandle handle = forever $ do line <- liftIO $ TIO.hGetLine handle - updateBlock $ parseTags' line + pushBlockUpdate $ parseTags' line diff --git a/src/QBar/ControlSocket.hs b/src/QBar/ControlSocket.hs index dc5b24d9b026a651d41866a4ee1cc39527642e2a..24ae71c6cce79dbcad0746a2b90a272bf4de5ed4 100644 --- a/src/QBar/ControlSocket.hs +++ b/src/QBar/ControlSocket.hs @@ -107,7 +107,7 @@ instance IsStream BlockStream where (cache, updateCacheC, sealCache) <- newCache' (eventOutput, eventInput, eventSeal) <- liftIO $ spawn' unbounded bar <- askBar - addBlock cache + addBlockCache cache prefix <- liftIO $ (<> "_") <$> randomIdentifier let blockConsumer = updateBarP bar >-> attachHandlerP eventOutput prefix >-> updateCacheC let eventProducer = fromInput eventInput diff --git a/src/QBar/Core.hs b/src/QBar/Core.hs index cdb41bcf6bfc2267199905fd28566dd4b3603519..14312b29043f1a719c8a4a1e38da9b495e949bbb 100644 --- a/src/QBar/Core.hs +++ b/src/QBar/Core.hs @@ -21,6 +21,7 @@ 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 @@ -38,10 +39,7 @@ data BlockEvent = Click { $(deriveJSON defaultOptions ''BlockEvent) -data PushMode = PushMode -data PullMode = PullMode -data CachedMode = CachedMode - +data ExitBlock = ExitBlock type BlockEventHandler = BlockEvent -> BarIO () @@ -49,36 +47,37 @@ type BlockState = Maybe (BlockOutput, Maybe BlockEventHandler) data BlockUpdateReason = DefaultUpdate | PullUpdate | UserUpdate type BlockUpdate = (BlockState, BlockUpdateReason) -type Block = Producer BlockUpdate BarIO - - -- |Block that 'yield's an update whenever the block should be changed -type PushBlock = Block PushMode --- |Block that generates an update on 'yield'. Should only be pulled when an update is required. -type PullBlock = Block PullMode +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 CachedMode +type BlockCache = Producer [BlockState] BarIO ExitBlock class IsCachable a where toCachedBlock :: a -> BlockCache -instance IsCachable PushBlock where - toCachedBlock = cachePushBlock +instance IsCachable Block where + toCachedBlock = cacheBlock instance IsCachable PullBlock where - toCachedBlock = cachePushBlock . schedulePullBlock + toCachedBlock = cacheBlock . pullBlock instance IsCachable BlockCache where toCachedBlock = id -class IsBlockMode a where - exitBlock :: Block a -instance IsBlockMode PushMode where - exitBlock = return PushMode -instance IsBlockMode PullMode where - exitBlock = return PullMode +class IsBlock a where + exitBlock :: a +instance IsBlock Block where + exitBlock = return ExitBlock +instance IsBlock PullBlock where + exitBlock = return ExitBlock exitCache :: BlockCache -exitCache = return CachedMode +exitCache = return ExitBlock type BarIO = SafeT (ReaderT Bar IO) @@ -115,26 +114,27 @@ askBar :: MonadBarIO m => m Bar askBar = liftBarIO $ lift ask -class (MonadBarIO m) => MonadBlock m where - liftBlock :: Block a -> m a -instance MonadBlock Block where - liftBlock = id -instance (MonadBlock m) => MonadBlock (StateT a m) where - liftBlock = lift . liftBlock -instance (MonadBlock m) => MonadBlock (ReaderT a m) where - liftBlock = lift . liftBlock -instance (MonadBlock m, Monoid a) => MonadBlock (WriterT a m) where - liftBlock = lift . liftBlock +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) + -updateBlock :: MonadBlock m => BlockOutput -> m () -updateBlock blockOutput = liftBlock . yield $ (Just (blockOutput, Nothing), DefaultUpdate) +pushBlockUpdate :: BlockOutput -> Proxy a' a () BlockUpdate BarIO () +pushBlockUpdate blockOutput = void . respond $ (Just (blockOutput, Nothing), DefaultUpdate) -updateBlock' :: MonadBlock m => BlockEventHandler -> BlockOutput -> m () -updateBlock' blockEventHandler blockOutput = liftBlock . yield $ (Just (blockOutput, Just blockEventHandler), DefaultUpdate) +pushBlockUpdate' :: BlockEventHandler -> BlockOutput -> Proxy a' a () BlockUpdate BarIO () +pushBlockUpdate' blockEventHandler blockOutput = void . respond $ (Just (blockOutput, Just blockEventHandler), DefaultUpdate) -- |Update a block by removing the current output -updateBlockEmpty :: MonadBlock m => m () -updateBlockEmpty = liftBlock . yield $ (Nothing, DefaultUpdate) +pushEmptyBlockUpdate :: Proxy a' a () BlockUpdate BarIO () +pushEmptyBlockUpdate = void . respond $ (Nothing, DefaultUpdate) + mkBlockState :: BlockOutput -> BlockState @@ -162,27 +162,30 @@ runBarIO bar action = liftIO $ runReaderT (runSafeT action) bar defaultInterval :: Interval defaultInterval = everyNSeconds 10 --- |Converts a 'PullBlock' to a 'PushBlock' by running it whenever the 'defaultInterval' is triggered. -schedulePullBlock :: PullBlock -> PushBlock -schedulePullBlock = schedulePullBlock' defaultInterval +-- |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 'PushBlock' by running it whenever the 'defaultInterval' is triggered. -schedulePullBlock' :: Interval -> PullBlock -> PushBlock -schedulePullBlock' interval pullBlock = PushMode <$ pullBlock >-> sleepToNextInterval +-- |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 - sleepToNextInterval :: Pipe BlockUpdate BlockUpdate BarIO PullMode + 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, _) <- await + (state, reason) <- await if hasEventHandler state then do -- If state already has an event handler, we do not attach another one - yield (state, PullUpdate) + yield (state, reason) sleepUntilInterval interval else do -- Attach a click handler that will trigger a block update - yield (updateEventHandler (triggerOnClick event) state, PullUpdate) + yield (updateEventHandler (triggerOnClick event) state, reason) scheduler <- askSleepScheduler result <- liftIO $ do @@ -248,9 +251,10 @@ newCache'' = do Nothing -> exitCache Just value -> yield value >> cache --- |Creates a cache from a push block. -cachePushBlock :: PushBlock -> BlockCache -cachePushBlock pushBlock = newCache $ () <$ (pushBlock >-> updateBarP >-> addBlockName >-> PP.map (\a -> [a])) +-- |Creates a cache from a block. +cacheBlock :: Block -> BlockCache +-- 'Block's 'yield' an update whenever they want to update the cache. +cacheBlock pushBlock = newCache $ () <$ (pushBlock >-> updateBarP >-> addBlockName >-> PP.map (\a -> [a])) where updateBarP :: Pipe BlockUpdate BlockState BarIO r updateBarP = forever $ do @@ -292,11 +296,16 @@ autoPadding = autoPadding' 0 0 padShortText :: Int64 -> BlockOutput -> BlockOutput padShortText len = over (shortText._Just) $ \s -> padString (len - printedLength s) <> s -addBlock :: IsCachable a => a -> BarIO () +addBlock :: Block -> BarIO () addBlock block = do newBlockChan' <- newBlockChan <$> askBar liftIO $ atomically $ writeTChan newBlockChan' $ toCachedBlock block +addBlockCache :: BlockCache -> BarIO () +addBlockCache cache = do + newBlockChan' <- newBlockChan <$> askBar + liftIO $ atomically $ writeTChan newBlockChan' cache + updateBar :: MonadBarIO m => BlockUpdateReason -> m () updateBar reason = liftIO =<< requestBarUpdate <$> askBar <*> return reason