From 8d7fd2b203969d01841f70e3d0d89b53431c4101 Mon Sep 17 00:00:00 2001
From: Jens Nolte <jens@nightmarestudio.de>
Date: Sat, 30 Nov 2019 01:47:19 +0100
Subject: [PATCH] Refactor block types to remove newtype wrappers
---
src/QBar/Blocks.hs | 12 ++--
src/QBar/Core.hs | 116 +++++++++++++++++++-------------------
src/QBar/DefaultConfig.hs | 32 +++++++----
src/QBar/Server.hs | 27 +++++----
4 files changed, 98 insertions(+), 89 deletions(-)
diff --git a/src/QBar/Blocks.hs b/src/QBar/Blocks.hs
index 4816bea..74765df 100644
--- a/src/QBar/Blocks.hs
+++ b/src/QBar/Blocks.hs
@@ -10,13 +10,11 @@ import Data.Time.Format
import Data.Time.LocalTime
import Pipes
-dateBlock :: Block
-dateBlock = pushBlock producer
- where
- producer = do
- yield =<< lift dateBlockOutput
- lift $ sleepUntil =<< nextMinute
- producer
+dateBlock :: PushBlock
+dateBlock = do
+ yield =<< lift dateBlockOutput
+ lift $ sleepUntil =<< nextMinute
+ dateBlock
dateBlockOutput :: IO BlockOutput
dateBlockOutput = do
diff --git a/src/QBar/Core.hs b/src/QBar/Core.hs
index 4250b91..f95ddbb 100644
--- a/src/QBar/Core.hs
+++ b/src/QBar/Core.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TemplateHaskell #-}
module QBar.Core where
@@ -41,35 +42,41 @@ data Click = Click {
} deriving Show
$(deriveJSON defaultOptions ''Click)
-type BlockProducer = Producer BlockOutput IO ()
+data PushMode = PushMode
+data PullMode = PullMode
+data CachedMode = CachedMode
+
-- |Block that 'yield's an update whenever the block should be changed
-newtype PushBlockProducer = PushBlockProducer BlockProducer
+type PushBlock = PushBlockProducer
+type PushBlockProducer = Producer BlockOutput IO PushMode
-- |Block that generates an update on 'yield'. Should only be pulled when an update is required.
-newtype PullBlockProducer = PullBlockProducer BlockProducer
+type PullBlock = PullBlockProducer
+type PullBlockProducer = Producer BlockOutput IO PullMode
-- |Cached block. Always 'yield's the latest update, so it should only be pulled when the bar is rendered.
-newtype CachedBlockProducer = CachedBlockProducer BlockProducer
+type CachedBlock = CachedBlockProducer
+type CachedBlockProducer = Producer BlockOutput IO CachedMode
+
+class IsBlock a where
+ toCachedBlock :: BarUpdateChannel -> a -> CachedBlock
+instance IsBlock PushBlock where
+ toCachedBlock = cachePushBlock
+instance IsBlock CachedBlock where
+ toCachedBlock _ = id
+
+class IsBlockMode a where
+ exitBlock :: Producer BlockOutput IO a
+instance IsBlockMode PushMode where
+ exitBlock = return PushMode
+instance IsBlockMode PullMode where
+ exitBlock = return PullMode
+instance IsBlockMode CachedMode where
+ exitBlock = return CachedMode
--- |Generic block type that can be a block in pull-, push- or cached mode.
-data Block = PushBlock PushBlockProducer
- -- | PullBlock PullBlockProducer
- | CachedBlock CachedBlockProducer
data BarUpdateChannel = BarUpdateChannel (IO ())
type BarUpdateEvent = Event.Event
-pushBlock :: BlockProducer -> Block
-pushBlock = PushBlock . PushBlockProducer
-
---pullBlock :: BlockProducer -> Block
---pullBlock = PullBlock . PullBlockProducer
-
-cachedBlock :: BlockProducer -> Block
-cachedBlock = CachedBlock . CachedBlockProducer
-
-pullBlockProducer :: BlockProducer -> PullBlockProducer
-pullBlockProducer = PullBlockProducer
-
defaultColor :: T.Text
defaultColor = "#969896"
@@ -151,13 +158,13 @@ removePango block
Left _ -> text
Right parsed -> removeFormatting parsed
-modify :: (BlockOutput -> BlockOutput) -> Pipe BlockOutput BlockOutput IO ()
+modify :: (BlockOutput -> BlockOutput) -> Pipe BlockOutput BlockOutput IO r
modify = PP.map
-autoPadding :: Pipe BlockOutput BlockOutput IO ()
+autoPadding :: Pipe BlockOutput BlockOutput IO r
autoPadding = autoPadding' 0 0
where
- autoPadding' :: Int64 -> Int64 -> Pipe BlockOutput BlockOutput IO ()
+ autoPadding' :: Int64 -> Int64 -> Pipe BlockOutput BlockOutput IO r
autoPadding' fullLength shortLength = do
block <- await
let values' = (values block)
@@ -168,9 +175,12 @@ autoPadding = autoPadding' 0 0
yield block { values = values''' }
autoPadding' (max fullLength fullLength') (max shortLength shortLength')
+cacheFromInput :: Input BlockOutput -> CachedBlock
+cacheFromInput input = fmap (\_ -> 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 :: BarUpdateChannel -> Int -> IO (PullBlockProducer -> Block, Async ())
+sharedInterval :: BarUpdateChannel -> Int -> IO (PullBlock -> CachedBlock, Async ())
sharedInterval barUpdateChannel seconds = do
clientsMVar <- newMVar ([] :: [(MVar PullBlockProducer, Output BlockOutput)])
@@ -190,19 +200,19 @@ sharedInterval barUpdateChannel seconds = do
return $ if result then Just client else Nothing
runClient :: (MVar PullBlockProducer, Output BlockOutput) -> IO Bool
runClient (blockProducerMVar, output) =
- modifyMVar blockProducerMVar $ \(PullBlockProducer blockProducer) -> do
+ modifyMVar blockProducerMVar $ \blockProducer -> do
result <- next blockProducer
case result of
- Left () -> return (PullBlockProducer $ return (), False)
+ Left _ -> return (exitBlock, 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)
+ then return (blockProducer', True)
-- Mailbox is sealed, stop running producer
- else return (PullBlockProducer $ return (), False)
+ else return (exitBlock, False)
where
updateClickHandler :: BlockOutput -> Click -> IO ()
updateClickHandler block _ = do
@@ -215,8 +225,8 @@ sharedInterval barUpdateChannel seconds = do
void $ runClient (blockProducerMVar, output)
-- Notify bar about changed block state, this is usually done by the shared interval handler
updateBar barUpdateChannel
- addClient :: MVar [(MVar PullBlockProducer, Output BlockOutput)] -> PullBlockProducer -> Block
- addClient clientsMVar blockProducer = cachedBlock $ do
+ addClient :: MVar [(MVar PullBlockProducer, Output BlockOutput)] -> PullBlockProducer -> CachedBlock
+ addClient clientsMVar blockProducer = do
-- Spawn the mailbox that preserves the latest block
(output, input) <- lift $ spawn $ latest emptyBlock
@@ -229,10 +239,10 @@ sharedInterval barUpdateChannel seconds = do
lift $ modifyMVar_ clientsMVar $ \ clients -> return ((blockProducerMVar, output):clients)
-- Return a block producer from the mailbox
- fromInput input
+ cacheFromInput input
-blockScript :: FilePath -> PullBlockProducer
-blockScript path = pullBlockProducer $ forever $ yield =<< (lift $ blockScriptAction)
+blockScript :: FilePath -> PullBlock
+blockScript path = forever $ yield =<< (lift $ blockScriptAction)
where
blockScriptAction :: IO BlockOutput
blockScriptAction = do
@@ -249,10 +259,10 @@ blockScript path = pullBlockProducer $ forever $ yield =<< (lift $ blockScriptAc
createScriptBlock :: T.Text -> BlockOutput
createScriptBlock text = pangoMarkup $ setBlockName (T.pack path) $ createBlock text
-startPersistentBlockScript :: BarUpdateChannel -> FilePath -> Block
--- This is only using 'cachedBlock' because the code was already written and tested
+startPersistentBlockScript :: BarUpdateChannel -> FilePath -> CachedBlock
+-- This is only using 'CachedBlock' because the code was already written and tested
-- This could probably be massively simplified by using the new 'pushBlock'
-startPersistentBlockScript barUpdateChannel path = cachedBlock $ do
+startPersistentBlockScript barUpdateChannel path = do
(output, input, seal) <- lift $ spawn' $ latest $ emptyBlock
initialDataEvent <- lift $ Event.new
task <- lift $ async $ do
@@ -271,7 +281,7 @@ startPersistentBlockScript barUpdateChannel path = cachedBlock $ do
(atomically seal)
lift $ link task
lift $ Event.wait initialDataEvent
- fromInput input
+ cacheFromInput input
where
signalFirstBlock :: Event.Event -> Pipe BlockOutput BlockOutput IO ()
signalFirstBlock event = do
@@ -303,19 +313,19 @@ pangoColor (RGB r g b) =
updateBar :: BarUpdateChannel -> IO ()
updateBar (BarUpdateChannel updateAction) = updateAction
-cachePushBlock :: BarUpdateChannel -> PushBlockProducer -> CachedBlockProducer
-cachePushBlock barUpdateChannel (PushBlockProducer blockProducer) = CachedBlockProducer $
- lift (next blockProducer) >>= either (lift . return) withInitialBlock
+cachePushBlock :: BarUpdateChannel -> PushBlock -> CachedBlock
+cachePushBlock barUpdateChannel pushBlock =
+ lift (next pushBlock) >>= either (\_ -> exitBlock) withInitialBlock
where
- withInitialBlock :: (BlockOutput, BlockProducer) -> BlockProducer
- withInitialBlock (initialBlockOutput, blockProducer') = do
+ withInitialBlock :: (BlockOutput, PushBlock) -> CachedBlock
+ withInitialBlock (initialBlockOutput, pushBlock') = do
(output, input, seal) <- lift $ spawn' $ latest $ Just initialBlockOutput
-- The async could be used to stop the block later, but for now we are just linking it to catch exceptions
- lift $ link =<< async (sendProducerToMailbox output seal blockProducer')
+ lift $ link =<< async (sendProducerToMailbox output seal pushBlock')
terminateOnMaybe $ fromInput input
- sendProducerToMailbox :: Output (Maybe BlockOutput) -> STM () -> BlockProducer -> IO ()
- sendProducerToMailbox output seal blockProducer' = do
- runEffect $ for blockProducer' (sendOutputToMailbox output)
+ sendProducerToMailbox :: Output (Maybe BlockOutput) -> STM () -> PushBlock -> IO ()
+ sendProducerToMailbox output seal pushBlock' = do
+ void $ runEffect $ for pushBlock' (sendOutputToMailbox output)
atomically $ void $ send output Nothing
updateBar barUpdateChannel
atomically seal
@@ -325,19 +335,9 @@ cachePushBlock barUpdateChannel (PushBlockProducer blockProducer) = CachedBlockP
-- This is ok because a cached block is never sealed from the receiving side
atomically $ void $ send output $ Just blockOutput
updateBar barUpdateChannel
- terminateOnMaybe :: Producer (Maybe a) IO () -> Producer a IO ()
+ terminateOnMaybe :: Producer (Maybe BlockOutput) IO () -> Producer BlockOutput IO CachedMode
terminateOnMaybe p = do
eitherMaybeValue <- lift $ next p
case eitherMaybeValue of
Right (Just value, newP) -> yield value >> terminateOnMaybe newP
- _ -> return ()
-
-
-blockToCachedBlockProducer :: BarUpdateChannel -> Block -> CachedBlockProducer
-blockToCachedBlockProducer barUpdateChannel (PushBlock pushBlockProducer) = cachePushBlock barUpdateChannel pushBlockProducer
-blockToCachedBlockProducer _ (CachedBlock cachedBlockProducer) = cachedBlockProducer
-
--- |The '>!>'-operator can be used to apply a 'Pipe' to the 'BlockProducer' contained in the 'Block'.
-(>!>) :: Block -> Pipe BlockOutput BlockOutput IO () -> Block
-(>!>) (PushBlock (PushBlockProducer blockProducer)) pipe = pushBlock $ (blockProducer >-> pipe)
-(>!>) (CachedBlock (CachedBlockProducer blockProducer)) pipe = cachedBlock $ (blockProducer >-> pipe)
+ _ -> exitBlock
diff --git a/src/QBar/DefaultConfig.hs b/src/QBar/DefaultConfig.hs
index a45c3df..39b8e27 100644
--- a/src/QBar/DefaultConfig.hs
+++ b/src/QBar/DefaultConfig.hs
@@ -4,22 +4,34 @@ import QBar.Blocks
import QBar.Core
import Control.Concurrent.Async
---import Pipes
+import Pipes
blockLocation :: String -> FilePath
blockLocation name = "~/.config/qbar/blocks/" <> name
-generateDefaultBarConfig :: BarUpdateChannel -> IO [Block]
+generateDefaultBarConfig :: BarUpdateChannel -> Producer CachedBlock IO ()
generateDefaultBarConfig barUpdateChannel = do
- (systemInfoInterval, systemInfoIntervalTask) <- sharedInterval barUpdateChannel 10
- link systemInfoIntervalTask
- --let irc = (systemInfoInterval $ blockScript "irc")
+ (systemInfoInterval, systemInfoIntervalTask) <- lift $ sharedInterval barUpdateChannel 10
+ lift $ link systemInfoIntervalTask
+
let todo = (systemInfoInterval $ blockScript $ blockLocation "todo")
- let wifi = (systemInfoInterval $ blockScript $ blockLocation "wifi2 wlan") >!> modify (addIcon "📡")
+ let wifi = (systemInfoInterval $ blockScript $ blockLocation "wifi2 wlan") >-> modify (addIcon "📡")
let networkEnvironment = (systemInfoInterval $ blockScript $ blockLocation "network-environment")
- let cpu = (systemInfoInterval $ blockScript $ blockLocation "cpu_usage") >!> modify (setBlockName "cpu" . addIcon "💻") >!> autoPadding
- let ram = (systemInfoInterval $ blockScript $ blockLocation "memory") >!> modify (addIcon "ðŸ") >!> autoPadding
- let temperature = (systemInfoInterval $ blockScript $ blockLocation "temperature") >!> autoPadding
+ let cpu = (systemInfoInterval $ blockScript $ blockLocation "cpu_usage") >-> modify (setBlockName "cpu" . addIcon "💻") >-> autoPadding
+ let ram = (systemInfoInterval $ blockScript $ blockLocation "memory") >-> modify (addIcon "ðŸ") >-> autoPadding
+ let temperature = (systemInfoInterval $ blockScript $ blockLocation "temperature") >-> autoPadding
let volumeBlock = startPersistentBlockScript barUpdateChannel $ blockLocation "volume-pulseaudio -S -F3"
let battery = (systemInfoInterval $ blockScript $ blockLocation "battery2")
- return [dateBlock, battery, volumeBlock, temperature, ram, cpu, networkEnvironment, wifi, todo]
\ No newline at end of file
+
+ addBlock dateBlock
+ addBlock battery
+ addBlock volumeBlock
+ addBlock temperature
+ addBlock ram
+ addBlock cpu
+ addBlock networkEnvironment
+ addBlock wifi
+ addBlock todo
+ where
+ addBlock :: IsBlock a => a -> Producer CachedBlock IO ()
+ addBlock block = yield $ toCachedBlock barUpdateChannel block
\ No newline at end of file
diff --git a/src/QBar/Server.hs b/src/QBar/Server.hs
index 7342892..474f59a 100644
--- a/src/QBar/Server.hs
+++ b/src/QBar/Server.hs
@@ -24,6 +24,7 @@ import Data.Maybe (isJust, fromJust, fromMaybe, catMaybes, mapMaybe)
import qualified Data.Text.Lazy as T
import Data.Time.Clock.POSIX
import Pipes
+import Pipes.Prelude (toListM)
import System.IO (stdin, stdout, stderr, hFlush, hPutStrLn)
import System.Posix.Signals
@@ -32,32 +33,30 @@ data Handle = Handle {
handleActiveFilter :: IORef Filter
}
-renderIndicator :: Block
+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 = cachedBlock $ forever $ each $ map createBlock ["/", "-", "\\", "|"]
+renderIndicator = forever $ each $ map createBlock ["/", "-", "\\", "|"]
runBlock :: CachedBlockProducer -> IO (Maybe (BlockOutput, CachedBlockProducer))
-runBlock (CachedBlockProducer producer) = do
+runBlock producer = do
next' <- next producer
return $ case next' of
Left _ -> Nothing
- Right (block, newProducer) -> Just (block, CachedBlockProducer newProducer)
+ Right (block, newProducer) -> Just (block, newProducer)
runBlocks :: [CachedBlockProducer] -> IO ([BlockOutput], [CachedBlockProducer])
runBlocks blockProducers = unzip . catMaybes <$> mapM runBlock blockProducers
-renderLoop :: MainOptions -> Handle -> BarUpdateChannel -> BarUpdateEvent -> BS.ByteString -> TChan Block -> IO ()
-renderLoop options handle@Handle{handleActiveFilter} barUpdateChannel barUpdateEvent previousBarOutput newBlockChan = renderLoop' previousBarOutput []
+renderLoop :: MainOptions -> Handle -> BarUpdateEvent -> BS.ByteString -> TChan CachedBlock -> IO ()
+renderLoop options handle@Handle{handleActiveFilter} barUpdateEvent previousBarOutput newBlockChan = renderLoop' previousBarOutput []
where
- addNewBlockProducers :: [CachedBlockProducer] -> IO [CachedBlockProducer]
+ addNewBlockProducers :: [CachedBlock] -> IO [CachedBlock]
addNewBlockProducers blockProducers = do
maybeNewBlock <- atomically $ tryReadTChan newBlockChan
case maybeNewBlock of
Nothing -> return blockProducers
- Just newBlock -> do
- let newCachedBlockProducer = blockToCachedBlockProducer barUpdateChannel newBlock
- addNewBlockProducers (newCachedBlockProducer:blockProducers)
- renderLoop' :: BS.ByteString -> [CachedBlockProducer] -> IO ()
+ Just newBlock -> addNewBlockProducers (newBlock:blockProducers)
+ renderLoop' :: BS.ByteString -> [CachedBlock] -> IO ()
renderLoop' previousBarOutput' blockProducers = do
blockFilter <- readIORef handleActiveFilter
@@ -152,7 +151,7 @@ installSignalHandlers barUpdateChannel = void $ installHandler sigCONT (Catch si
hPutStrLn stderr "SIGCONT received"
updateBar barUpdateChannel
-runBarConfiguration :: (BarUpdateChannel -> IO [Block]) -> MainOptions -> IO ()
+runBarConfiguration :: (BarUpdateChannel -> Producer CachedBlock IO ()) -> MainOptions -> IO ()
runBarConfiguration generateBarConfig options = do
-- Create IORef for mouse click callbacks
actionList <- newIORef []
@@ -182,7 +181,7 @@ runBarConfiguration generateBarConfig options = do
-- Create and initialzie blocks
(barUpdateChannel, barUpdateEvent) <- createBarUpdateChannel
- blockProducers <- generateBarConfig barUpdateChannel
+ blockProducers <- toListM $ generateBarConfig barUpdateChannel
-- Attach spinner indicator when verbose flag is set
let blockProducers' = if indicator options then (renderIndicator:blockProducers) else blockProducers
@@ -209,7 +208,7 @@ runBarConfiguration generateBarConfig options = do
updateBar barUpdateChannel
link socketUpdateAsync
- renderLoop options handle barUpdateChannel barUpdateEvent initialOutput newBlockProducers
+ renderLoop options handle barUpdateEvent initialOutput newBlockProducers
createCommandChan :: IO CommandChan
createCommandChan = newTChanIO
\ No newline at end of file
--
GitLab