Refactor Block types

- PushBlock becomes Block.
- Block and PushBlock differentiate in their Proxy upstream type.
- Exit codes are unified as ExitBlock.

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

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

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

src/QBar/Blocks/Pipe.hs

 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"

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

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

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