src/QBar/Time.hs → qbar/src/QBar/Time.hs

 {-# LANGUAGE OverloadedLists #-}
 
-module QBar.Time (SleepScheduler, HasSleepScheduler(..), Interval, createSleepScheduler, sleepUntil, sleepUntil', sleepUntilInterval, sleepUntilInterval', everyMinute, everyNSeconds, nextIntervalTime) where
+module QBar.Time (
+  HasSleepScheduler(..),
+  Interval(..),
+  SleepScheduler,
+  createSleepScheduler,
+  everyMinute,
+  everyNSeconds,
+  humanReadableInterval,
+  nextIntervalTime,
+  sleepUntil',
+  sleepUntil,
+  sleepUntilInterval',
+  sleepUntilInterval,
+) where
+
+import QBar.Prelude
 
 import Control.Concurrent.Async
+import Control.Concurrent.Event qualified as Event
 import Control.Concurrent.MVar
-import qualified Control.Concurrent.Event as Event
-import Data.Time.Clock (UTCTime, getCurrentTime, diffUTCTime, utctDayTime, addUTCTime)
-import Data.SortedList (SortedList, toSortedList, fromSortedList, singleton, partition, insert)
 import Data.Ord (comparing)
+import Data.SortedList (SortedList, toSortedList, fromSortedList, singleton, partition, insert)
+import Data.Time.Clock (UTCTime, getCurrentTime, diffUTCTime, utctDayTime, addUTCTime)
 
 newtype Interval = IntervalSeconds Integer
+  deriving (Read, Show)
 
 -- |Describes an interval that is run every "n" seconds after midnight.
 everyNSeconds :: Integer -> Interval
@@ -23,12 +39,14 @@ nextIntervalTime :: MonadIO m => Interval -> m UTCTime
 nextIntervalTime (IntervalSeconds intervalSeconds) = liftIO $ do
   now <- getCurrentTime
   let dayTime = utctDayTime now
-  let daySeconds = floor dayTime
+  let daySeconds :: Integer = floor dayTime
   let intervalId = daySeconds `div` intervalSeconds
   return now {
     utctDayTime = fromInteger $ (intervalId + 1) * intervalSeconds
   }
 
+humanReadableInterval :: Interval -> String
+humanReadableInterval (IntervalSeconds i) = show i <> "s"
 
 data SleepScheduler = SleepScheduler (MVar (SortedList ScheduledEvent, [ScheduledEvent])) Event.Event
 data ScheduledEvent = ScheduledEvent {
@@ -45,7 +63,7 @@ class HasSleepScheduler m where
 createSleepScheduler :: MonadIO m => m SleepScheduler
 createSleepScheduler = liftIO $ do
   scheduler <- SleepScheduler <$> newMVar ([], []) <*> Event.new
-  link =<< (async $ schedulerThread scheduler)
+  link =<< async (schedulerThread scheduler)
   return scheduler
   where
     schedulerThread :: SleepScheduler -> IO ()
@@ -69,7 +87,7 @@ createSleepScheduler = liftIO $ do
 
           schedulerThread' start
 
-        -- |Waits for the next event, with a timeout. A return value of 'False' indicates a timeout occured.
+        -- Waits for the next event, with a timeout. A return value of 'False' indicates a timeout occured.
         waitForEvent :: UTCTime -> IO Bool
         waitForEvent eventTime = do
           now <- getCurrentTime
@@ -91,7 +109,7 @@ createSleepScheduler = liftIO $ do
             Event.clear trigger
             return (futureEvents, [])
 
-        -- |Predicate to check if an event should be fired.
+        -- Predicate to check if an event should be fired.
         checkEvent :: UTCTime -> ScheduledEvent -> Bool
         checkEvent now ScheduledEvent{time} = now >= time
 

qbar/src/QBar/Utils.hs

+module QBar.Utils (
+  mkBroadcastCacheP,
+  mkBroadcastP,
+  randomIdentifier,
+  signalEventPipe,
+) where
+
+import QBar.Prelude
+
+import Control.Concurrent.Event as Event
+import Control.Concurrent.STM (atomically)
+import Control.Concurrent.STM.TChan
+import Control.Concurrent.STM.TVar
+import Control.Monad (replicateM)
+import Data.Text.Lazy qualified as T
+import Pipes
+import System.Random
+
+-- Pipe that signals an 'Event' after every value that passes through
+signalEventPipe :: MonadIO m => Event.Event -> Pipe a a m r
+signalEventPipe event = forever $ (yield =<< await) >> liftIO (Event.signal event)
+
+randomIdentifier :: MonadIO m => m Text
+randomIdentifier = liftIO $ T.pack <$> replicateM 8 randomCharacter
+  where
+    randomCharacter :: IO Char
+    randomCharacter = do
+      index <- randomRIO (0, T.length alphabet - 1)
+      return $ T.index alphabet index
+    alphabet :: T.Text
+    alphabet = T.pack $ ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9']
+
+-- |Creates a pair of consumer and producer. Both can be used multiple times in parallel.
+-- |All values send to a consumer will be sent to all currently running producers.
+mkBroadcastP :: forall a. IO (Consumer a IO (), Producer a IO ())
+mkBroadcastP = do
+  chan <- newBroadcastTChanIO
+  return (sendToStore chan, recvFromStore chan)
+  where
+    sendToStore :: TChan a -> Consumer a IO ()
+    sendToStore chan = forever $ do
+      value <- await
+      liftIO . atomically $ writeTChan chan value
+
+    -- Monad will be forked when new outputs connect
+    recvFromStore :: TChan a -> Producer a IO ()
+    recvFromStore chan = do
+      outputChan <- liftIO . atomically $ dupTChan chan
+      forever $ yield =<< (liftIO . atomically $ readTChan outputChan)
+
+-- |Creates a pair of consumer and producer. Both can be used multiple times in parallel.
+-- |All values send to a consumer will be sent to all currently running producers.
+-- |When running a new producer it will immediateley receive the latest value that was sent to a consumer.
+mkBroadcastCacheP :: forall a. a -> IO (Consumer a IO (), Producer a IO ())
+mkBroadcastCacheP initialValue = do
+  store <- (,) <$> newTVarIO initialValue <*> newBroadcastTChanIO
+  return (sendToStore store, recvFromStore store)
+  where
+    sendToStore :: (TVar a, TChan a) -> Consumer a IO ()
+    sendToStore (var, chan) = forever $ do
+      value <- await
+      liftIO . atomically $ do
+        writeTVar var value
+        writeTChan chan value
+
+    -- Monad will be forked when new outputs connect
+    recvFromStore :: (TVar a, TChan a) -> Producer a IO ()
+    recvFromStore (var, chan) = do
+      (outputChan, value) <- liftIO . atomically $ do
+        value <- readTVar var
+        outputChan <- dupTChan chan
+        return (outputChan, value)
+
+      yield value
+
+      forever $ yield =<< (liftIO . atomically $ readTChan outputChan)

test/Spec.hs → qbar/test/Spec.hs

+import Prelude
+
 main :: IO ()
 main = putStrLn "Test suite not yet implemented"

shell.nix

-{ pkgs ? import <nixpkgs> {} }:
-
-pkgs.mkShell {
-  buildInputs = with pkgs; [
-    stack
-    zsh
-    jq
-  ];
-}

src/BasePrelude.hs

-{-# LANGUAGE PackageImports #-}
-{-# LANGUAGE NoImplicitPrelude #-}
-
-module BasePrelude
-  ( module Prelude,
-  )
-where
-
-import "base" Prelude

src/QBar/Blocks.hs

-module QBar.Blocks
-  ( QBar.Blocks.Battery.batteryBlock,
-    QBar.Blocks.CpuUsage.cpuUsageBlock,
-    QBar.Blocks.Date.dateBlock,
-    QBar.Blocks.NetworkManager.networkManagerBlock,
-    QBar.Blocks.Script.scriptBlock,
-    QBar.Blocks.Script.pollScriptBlock,
-  )
-where
-
-import qualified QBar.Blocks.Battery
-import qualified QBar.Blocks.CpuUsage
-import qualified QBar.Blocks.Date
-import qualified QBar.Blocks.NetworkManager
-import qualified QBar.Blocks.Script

src/QBar/Blocks/Script.hs

-module QBar.Blocks.Script where
-
-import QBar.BlockHelper
-import QBar.BlockOutput
-import QBar.Core
-import QBar.TagParser
-
-import Control.Exception (IOException)
-import qualified Data.ByteString.Lazy.Char8 as C8
-import qualified Data.Text.Lazy as T
-import qualified Data.Text.Lazy.Encoding as E
-import qualified Data.Text.Lazy.IO as TIO
-import Pipes
-import Pipes.Safe (catchP)
-import System.Exit
-import System.IO
-import System.Process.Typed (Process, shell, setStdin, setStdout,
-  getStdout, closed, createPipe, readProcessStdout, startProcess, stopProcess)
-
-
-pollScriptBlock :: FilePath -> Block
-pollScriptBlock path = runPollBlock $ forever $ yieldBlockUpdate =<< (lift blockScriptAction)
-  where
-    blockScriptAction :: BarIO BlockOutput
-    blockScriptAction = do
-      -- The exit code is used for i3blocks signaling but ignored here (=not implemented)
-      -- I am trying to replace i3blocks scripts with native haskell blocks, so I do not need it
-      (exitCode, output) <- liftIO $ readProcessStdout $ shell path
-      return $ case exitCode of
-        ExitSuccess -> createScriptBlockOutput output
-        (ExitFailure nr) -> mkErrorOutput $ "exit code " <> T.pack (show nr) <> ""
-    createScriptBlockOutput :: C8.ByteString -> BlockOutput
-    createScriptBlockOutput output = case map E.decodeUtf8 (C8.lines output) of
-      (text:short:_) -> parseTags'' text short
-      (text:_) -> parseTags' text
-      [] -> emptyBlock
-
-scriptBlock :: FilePath -> Block
--- The outer catchP only catches errors that occur during process creation
-scriptBlock path = catchP startScriptProcess handleError
-  where
-    handleError :: IOException -> Block
-    handleError e = do
-      pushBlockUpdate . mkErrorOutput $ T.pack (show e)
-      exitBlock
-    handleErrorWithProcess :: (Process i o e) -> IOException -> Block
-    handleErrorWithProcess process e = do
-      stopProcess process
-      handleError e
-    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 -> Block
-    blockFromHandle handle = forever $ do
-      line <- liftIO $ TIO.hGetLine handle
-      pushBlockUpdate $ parseTags' line

src/QBar/Util.hs

-module QBar.Util where
-
-import Control.Concurrent.Event as Event
-import Control.Monad (replicateM)
-import qualified Data.Text.Lazy as T
-import Pipes
-import System.Random
-
--- Pipe that signals an 'Event' after every value that passes through
-signalEventPipe :: MonadIO m => Event.Event -> Pipe a a m r
-signalEventPipe event = forever $ (yield =<< await) >> liftIO (Event.signal event)
-
-randomIdentifier :: MonadIO m => m Text
-randomIdentifier = liftIO $ T.pack <$> replicateM 8 randomCharacter
-  where
-    randomCharacter :: IO Char
-    randomCharacter = do
-      index <- randomRIO (0, T.length alphabet - 1)
-      return $ T.index alphabet index
-    alphabet :: T.Text
-    alphabet = T.pack $ ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9']

stack.yaml

-# This file was automatically generated by 'stack init'
-#
-# Some commonly used options have been documented as comments in this file.
-# For advanced use and comprehensive documentation of the format, please see:
-# https://docs.haskellstack.org/en/stable/yaml_configuration/
-
-# Resolver to choose a 'specific' stackage snapshot or a compiler version.
-# A snapshot resolver dictates the compiler version and the set of packages
-# to be used for project dependencies. For example:
-#
-# resolver: lts-3.5
-# resolver: nightly-2015-09-21
-# resolver: ghc-7.10.2
-#
-# The location of a snapshot can be provided as a file or url. Stack assumes
-# a snapshot provided as a file might change, whereas a url resource does not.
-#
-# resolver: ./custom-snapshot.yaml
-# resolver: https://example.com/snapshots/2018-01-01.yaml
-resolver: lts-15.1
-
-# User packages to be built.
-# Various formats can be used as shown in the example below.
-#
-# packages:
-# - some-directory
-# - https://example.com/foo/bar/baz-0.0.2.tar.gz
-# - location:
-#    git: https://github.com/commercialhaskell/stack.git
-#    commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
-# - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a
-#  subdirs:
-#  - auto-update
-#  - wai
-packages:
-- .
-# Dependency packages to be pulled from upstream that are not in the resolver
-# using the same syntax as the packages field.
-# (e.g., acme-missiles-0.3)
-# extra-deps: []
-
-# Disable pure nix-shell environment on NixOS, because access to XDG_RUNTIME_DIR is needed for the control socket
-nix:
-  pure: false
-  packages: [ zlib ]
-
-# Override default flag values for local packages and extra-deps
-# flags: {}
-
-# Extra package databases containing global packages
-# extra-package-dbs: []
-
-# Control whether we use the GHC we find on the path
-# system-ghc: true
-#
-# Require a specific version of stack, using version ranges
-# require-stack-version: -any # Default
-# require-stack-version: ">=1.9"
-#
-# Override the architecture used by stack, especially useful on Windows
-# arch: i386
-# arch: x86_64
-#
-# Extra directories used by stack for building
-# extra-include-dirs: [/path/to/dir]
-# extra-lib-dirs: [/path/to/dir]
-#
-# Allow a newer minor version of GHC than the snapshot specifies
-# compiler-check: newer-minor