-- | This is a simple text widget that updates its contents by calling
-- a callback at a set interval.
module System.Taffybar.Widget.Generic.PollingLabel where

import           Control.Concurrent
import           Control.Exception.Enclosed as E
import           Control.Monad
import           Control.Monad.IO.Class
import qualified Data.Text as T
import           GI.Gtk
import           System.Log.Logger
import           System.Taffybar.Util
import           System.Taffybar.Widget.Util
import           Text.Printf

-- | Create a new widget that updates itself at regular intervals.  The
-- function
--
-- > pollingLabelNew initialString cmd interval
--
-- returns a widget with initial text @initialString@. The widget forks a thread
-- to update its contents every @interval@ seconds. The command should return a
-- string with any HTML entities escaped. This is not checked by the function,
-- since Pango markup shouldn't be escaped. Proper input sanitization is up to
-- the caller.
--
-- If the IO action throws an exception, it will be swallowed and the label will
-- not update until the update interval expires.
pollingLabelNew
  :: MonadIO m
  => Double -- ^ Update interval (in seconds)
  -> IO T.Text -- ^ Command to run to get the input string
  -> m GI.Gtk.Widget
pollingLabelNew :: forall (m :: * -> *). MonadIO m => Double -> IO Text -> m Widget
pollingLabelNew Double
interval IO Text
cmd =
  Double -> IO (Text, Maybe Text) -> m Widget
forall (m :: * -> *).
MonadIO m =>
Double -> IO (Text, Maybe Text) -> m Widget
pollingLabelNewWithTooltip Double
interval (IO (Text, Maybe Text) -> m Widget)
-> IO (Text, Maybe Text) -> m Widget
forall a b. (a -> b) -> a -> b
$ (, Maybe Text
forall a. Maybe a
Nothing) (Text -> (Text, Maybe Text)) -> IO Text -> IO (Text, Maybe Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Text
cmd

pollingLabelNewWithTooltip
  :: MonadIO m
  => Double -- ^ Update interval (in seconds)
  -> IO (T.Text, Maybe T.Text) -- ^ Command to run to get the input string
  -> m GI.Gtk.Widget
pollingLabelNewWithTooltip :: forall (m :: * -> *).
MonadIO m =>
Double -> IO (Text, Maybe Text) -> m Widget
pollingLabelNewWithTooltip Double
interval IO (Text, Maybe Text)
action =
  IO (Text, Maybe Text, Double) -> m Widget
forall (m :: * -> *).
MonadIO m =>
IO (Text, Maybe Text, Double) -> m Widget
pollingLabelWithVariableDelay (IO (Text, Maybe Text, Double) -> m Widget)
-> IO (Text, Maybe Text, Double) -> m Widget
forall a b. (a -> b) -> a -> b
$ (Text, Maybe Text) -> (Text, Maybe Text, Double)
withInterval ((Text, Maybe Text) -> (Text, Maybe Text, Double))
-> IO (Text, Maybe Text) -> IO (Text, Maybe Text, Double)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Text, Maybe Text)
action
    where withInterval :: (Text, Maybe Text) -> (Text, Maybe Text, Double)
withInterval (Text
a, Maybe Text
b) = (Text
a, Maybe Text
b, Double
interval)

pollingLabelWithVariableDelay
  :: MonadIO m
  => IO (T.Text, Maybe T.Text, Double)
  -> m GI.Gtk.Widget
pollingLabelWithVariableDelay :: forall (m :: * -> *).
MonadIO m =>
IO (Text, Maybe Text, Double) -> m Widget
pollingLabelWithVariableDelay IO (Text, Maybe Text, Double)
action =
  IO Widget -> m Widget
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Widget -> m Widget) -> IO Widget -> m Widget
forall a b. (a -> b) -> a -> b
$ do
    Grid
grid <- IO Grid
forall (m :: * -> *). (HasCallStack, MonadIO m) => m Grid
gridNew
    Label
label <- Maybe Text -> IO Label
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Maybe Text -> m Label
labelNew Maybe Text
forall a. Maybe a
Nothing

    let updateLabel :: (Text, Maybe Text, Double) -> IO Double
updateLabel (Text
labelStr, Maybe Text
tooltipStr, Double
delay) = do
          IO () -> IO ()
postGUIASync (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
             Label -> Text -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsLabel a) =>
a -> Text -> m ()
labelSetMarkup Label
label Text
labelStr
             Label -> Maybe Text -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> Maybe Text -> m ()
widgetSetTooltipMarkup Label
label Maybe Text
tooltipStr
          String -> Priority -> String -> IO ()
logM String
"System.Taffybar.Widget.Generic.PollingLabel" Priority
DEBUG (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
               String -> String -> String
forall r. PrintfType r => String -> r
printf String
"Polling label delay was %s" (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ Double -> String
forall a. Show a => a -> String
show Double
delay
          Double -> IO Double
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Double
delay
        updateLabelHandlingErrors :: IO Double
updateLabelHandlingErrors =
          IO (Text, Maybe Text, Double)
-> IO (Either SomeException (Text, Maybe Text, Double))
forall (m :: * -> *) a.
MonadBaseControl IO m =>
m a -> m (Either SomeException a)
E.tryAny IO (Text, Maybe Text, Double)
action IO (Either SomeException (Text, Maybe Text, Double))
-> (Either SomeException (Text, Maybe Text, Double) -> IO Double)
-> IO Double
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (SomeException -> IO Double)
-> ((Text, Maybe Text, Double) -> IO Double)
-> Either SomeException (Text, Maybe Text, Double)
-> IO Double
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (IO Double -> SomeException -> IO Double
forall a b. a -> b -> a
const (IO Double -> SomeException -> IO Double)
-> IO Double -> SomeException -> IO Double
forall a b. (a -> b) -> a -> b
$ Double -> IO Double
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Double
1) (Text, Maybe Text, Double) -> IO Double
updateLabel

    SignalHandlerId
_ <- Label -> ((?self::Label) => IO ()) -> IO SignalHandlerId
forall a (m :: * -> *).
(IsWidget a, MonadIO m) =>
a -> ((?self::a) => IO ()) -> m SignalHandlerId
onWidgetRealize Label
label (((?self::Label) => IO ()) -> IO SignalHandlerId)
-> ((?self::Label) => IO ()) -> IO SignalHandlerId
forall a b. (a -> b) -> a -> b
$ do
      ThreadId
sampleThread <- IO Double -> IO ThreadId
forall (m :: * -> *) d.
(MonadIO m, RealFrac d) =>
IO d -> m ThreadId
foreverWithVariableDelay IO Double
updateLabelHandlingErrors
      IO SignalHandlerId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO SignalHandlerId -> IO ()) -> IO SignalHandlerId -> IO ()
forall a b. (a -> b) -> a -> b
$ Label -> ((?self::Label) => IO ()) -> IO SignalHandlerId
forall a (m :: * -> *).
(IsWidget a, MonadIO m) =>
a -> ((?self::a) => IO ()) -> m SignalHandlerId
onWidgetUnrealize Label
label (((?self::Label) => IO ()) -> IO SignalHandlerId)
-> ((?self::Label) => IO ()) -> IO SignalHandlerId
forall a b. (a -> b) -> a -> b
$ ThreadId -> IO ()
killThread ThreadId
sampleThread

    Label -> IO ()
forall o (m :: * -> *). (IsWidget o, MonadIO m) => o -> m ()
vFillCenter Label
label
    Grid -> IO ()
forall o (m :: * -> *). (IsWidget o, MonadIO m) => o -> m ()
vFillCenter Grid
grid
    Grid -> Label -> IO ()
forall (m :: * -> *) a b.
(HasCallStack, MonadIO m, IsContainer a, IsWidget b) =>
a -> b -> m ()
containerAdd Grid
grid Label
label
    Grid -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> m ()
widgetShowAll Grid
grid
    Grid -> IO Widget
forall (m :: * -> *) o. (MonadIO m, IsWidget o) => o -> m Widget
toWidget Grid
grid