Create new types for different block update modes

src/QBar/Blocks.hs

@@ -11,18 +11,25 @@ import Data.Time.LocalTime
 import Pipes
 import Pipes.Concurrent
 
-dateBlock :: IO BlockOutput
-dateBlock = do
+dateBlock :: Block
+dateBlock = pushBlock producer
+  where
+    producer = do
+      yield =<< lift dateBlockOutput
+      lift $ sleepUntil =<< nextMinute
+      producer
+
+dateBlockOutput :: IO BlockOutput
+dateBlockOutput = do
   zonedTime <- getZonedTime
   let date = T.pack (formatTime defaultTimeLocale "%a %F" zonedTime)
   let time = T.pack (formatTime defaultTimeLocale "%R" zonedTime)
-  --let text = (T.pack "📅 ") <> T.pack (formatTime defaultTimeLocale "%a %F <span color='#ffffff'>%R</span>" zonedTime)
   let text = (T.pack "📅 ") <> date <> " " <> (coloredText activeColor time)
   return $ setBlockName "date" $ pangoMarkup $ createBlock text
 
 dateBlockProducer :: BarUpdateChannel -> BlockProducer
 dateBlockProducer barUpdateChannel = do
-  initialDateBlock <- lift dateBlock
+  initialDateBlock <- lift dateBlockOutput
   (output, input) <- lift $ spawn $ latest initialDateBlock
   lift $ void $ forkIO $ update output
   fromInput input
@@ -30,7 +37,7 @@ dateBlockProducer barUpdateChannel = do
     update :: Output BlockOutput -> IO ()
     update output = do
       sleepUntil =<< nextMinute
-      block <- dateBlock
+      block <- dateBlockOutput
       void $ atomically $ send output block
       updateBar barUpdateChannel
       update output
\ No newline at end of file

src/QBar/Core.hs

@@ -44,9 +44,31 @@ $(deriveJSON defaultOptions ''Click)
 
 type BlockProducer = Producer BlockOutput IO ()
 
+-- |Block that 'yield's an update whenever the block should be changed
+newtype PushBlockProducer = PushBlockProducer BlockProducer
+-- |Block that generates an update on 'yield'. Should only be pulled when an update is required.
+newtype PullBlockProducer = PullBlockProducer BlockProducer
+-- |Cached block. Always 'yield's the latest update, so it should only be pulled when the bar is rendered.
+newtype CachedBlockProducer = CachedBlockProducer BlockProducer
+
+-- |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
+
+
 defaultColor :: T.Text
 defaultColor = "#969896"
 
@@ -263,3 +285,24 @@ 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
+  where
+    withInitialBlock :: (BlockOutput, BlockProducer) -> BlockProducer
+    withInitialBlock (initialBlockOutput, blockProducer') = do
+      (output, input, seal) <- lift $ spawn' $ latest 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')
+      fromInput input
+    sendProducerToMailbox :: Output BlockOutput -> STM () -> BlockProducer -> IO ()
+    sendProducerToMailbox output seal blockProducer' = do
+      runEffect $ for blockProducer' (sendOutputToMailbox output)
+      atomically seal
+    sendOutputToMailbox :: Output BlockOutput -> BlockOutput -> Effect IO ()
+    sendOutputToMailbox output blockOutput = lift $ do
+      -- The void discarding the boolean result that indicates if the mailbox is sealed
+      -- This is ok because right now once started a cached block never stops generating output and the mailbox is never sealed
+      atomically $ void $ send output blockOutput
+      updateBar barUpdateChannel

src/QBar/Server.hs

@@ -168,7 +168,7 @@ runBarConfiguration generateBarConfig options = do
   putStrLn "{\"version\":1,\"click_events\":true}"
   putStrLn "["
 
-  date <- dateBlock
+  date <- dateBlockOutput
   let initialBlocks = [date]
 
   -- Attach spinner indicator when verbose flag is set