    -- | 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 :: Double -> IO Text -> m Widget
    pollingLabelNew interval :: Double
    interval cmd :: 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 :: Double -> IO (Text, Maybe Text) -> m Widget
    pollingLabelNewWithTooltip interval :: Double
    interval action :: 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 (a :: Text
    a, b :: 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 :: IO (Text, Maybe Text, Double) -> m Widget
    pollingLabelWithVariableDelay action :: IO (Text, Maybe Text, Double)
    action =
      IO Widget -> m Widget
    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 (labelStr :: Text
    labelStr, tooltipStr :: Maybe Text
    tooltipStr, delay :: 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 "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 "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 (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 (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 (m :: * -> *) a. Monad m => a -> m a
    return 1) (Text, Maybe Text, Double) -> IO Double
    updateLabel

        SignalHandlerId
    _ <- Label -> IO () -> IO SignalHandlerId
    forall a (m :: * -> *).
    (IsWidget a, MonadIO m) =>
    a -> IO () -> m SignalHandlerId
    onWidgetRealize Label
    label (IO () -> IO SignalHandlerId) -> IO () -> IO SignalHandlerId
    forall a b. (a -> b) -> a -> b
    $ do
          ThreadId
    sampleThread <- IO Double -> IO ThreadId
    forall d. RealFrac d => IO d -> IO 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 -> IO () -> IO SignalHandlerId
    forall a (m :: * -> *).
    (IsWidget a, MonadIO m) =>
    a -> IO () -> m SignalHandlerId
    onWidgetUnrealize Label
    label (IO () -> IO SignalHandlerId) -> 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