From debd83a370e7d7391bb33c2915fb3ccce218493d Mon Sep 17 00:00:00 2001
From: "J. Konrad Tegtmeier-Rottach" <jktr@0x16.de>
Date: Wed, 10 Jun 2020 02:50:42 +0200
Subject: [PATCH] Add support for specifying script block poll interval
---
src/QBar/Blocks/Script.hs | 5 +++--
src/QBar/Cli.hs | 15 +++++++++++++--
src/QBar/Time.hs | 5 ++++-
3 files changed, 20 insertions(+), 5 deletions(-)
diff --git a/src/QBar/Blocks/Script.hs b/src/QBar/Blocks/Script.hs
index 79d20d9..d274d0a 100644
--- a/src/QBar/Blocks/Script.hs
+++ b/src/QBar/Blocks/Script.hs
@@ -4,6 +4,7 @@ import QBar.BlockHelper
import QBar.BlockOutput
import QBar.Core
import QBar.TagParser
+import QBar.Time
import Control.Exception (IOException)
import qualified Data.ByteString.Lazy.Char8 as C8
@@ -18,8 +19,8 @@ import System.Process.Typed (Process, shell, setStdin, setStdout,
getStdout, closed, createPipe, readProcessStdout, startProcess, stopProcess)
-pollScriptBlock :: FilePath -> Block
-pollScriptBlock path = runPollBlock $ forever $ yieldBlockUpdate =<< (lift blockScriptAction)
+pollScriptBlock :: Interval -> FilePath -> Block
+pollScriptBlock interval path = runPollBlock' interval $ forever $ yieldBlockUpdate =<< (lift blockScriptAction)
where
blockScriptAction :: BarIO BlockOutput
blockScriptAction = do
diff --git a/src/QBar/Cli.hs b/src/QBar/Cli.hs
index 4a30501..d45ca9c 100644
--- a/src/QBar/Cli.hs
+++ b/src/QBar/Cli.hs
@@ -9,8 +9,10 @@ import QBar.Core
import QBar.DefaultConfig
import QBar.Server
import QBar.Theme
+import QBar.Time
import Control.Monad (join)
+import Data.Maybe (fromMaybe)
import qualified Data.Text.Lazy as T
import Options.Applicative
@@ -92,6 +94,15 @@ blockParser =
scriptBlockParser :: Parser (BarIO ())
scriptBlockParser = helper <*> do
- poll <- switch $ long "poll" <> short 'p' <> help "Run script in poll mode (every line of output updates the block)."
+ poll <- switch $ long "poll" <> short 'p' <> help "Run script in poll mode (at regular intervals)"
+ -- HACK optparse-applicative does not support options of style --poll[=INTERVAL],
+ -- so we add a second option to specify the interval explicitly instead
+ -- https://github.com/pcapriotti/optparse-applicative/issues/243
+ pollInterval <- fromMaybe defaultInterval <$> (optional $ IntervalSeconds <$> option auto (
+ long "interval" <>
+ short 'i' <>
+ metavar "SECONDS" <>
+ (help $ "Interval to use for --poll mode (default: " <> humanReadableInterval defaultInterval <> ")")
+ ))
script <- strArgument (metavar "SCRIPT" <> help "The script that will be executed with a shell.")
- return $ (if poll then addBlock . pollScriptBlock else addBlock . scriptBlock) script
+ return $ (if poll then addBlock . pollScriptBlock pollInterval else addBlock . scriptBlock) script
diff --git a/src/QBar/Time.hs b/src/QBar/Time.hs
index 9add243..8bf03fd 100644
--- a/src/QBar/Time.hs
+++ b/src/QBar/Time.hs
@@ -1,6 +1,6 @@
{-# LANGUAGE OverloadedLists #-}
-module QBar.Time (SleepScheduler, HasSleepScheduler(..), Interval, createSleepScheduler, sleepUntil, sleepUntil', sleepUntilInterval, sleepUntilInterval', everyMinute, everyNSeconds, nextIntervalTime) where
+module QBar.Time (SleepScheduler, HasSleepScheduler(..), Interval(..), createSleepScheduler, sleepUntil, sleepUntil', sleepUntilInterval, sleepUntilInterval', everyMinute, everyNSeconds, nextIntervalTime, humanReadableInterval) where
import Control.Concurrent.Async
import Control.Concurrent.MVar
@@ -10,6 +10,7 @@ import Data.SortedList (SortedList, toSortedList, fromSortedList, singleton, par
import Data.Ord (comparing)
newtype Interval = IntervalSeconds Integer
+ deriving (Read, Show)
-- |Describes an interval that is run every "n" seconds after midnight.
everyNSeconds :: Integer -> Interval
@@ -29,6 +30,8 @@ nextIntervalTime (IntervalSeconds intervalSeconds) = liftIO $ do
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 {
--
GitLab