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

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

    -- | 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
      => T.Text -- ^ Initial value for the label
      -> Double -- ^ Update interval (in seconds)
      -> IO T.Text -- ^ Command to run to get the input string
      -> m GI.Gtk.Widget
    pollingLabelNew initialString interval cmd =
      pollingLabelNewWithTooltip initialString interval $ (, Nothing) <$> cmd

    pollingLabelNewWithTooltip
      :: MonadIO m
      => T.Text -- ^ Initial value for the label
      -> Double -- ^ Update interval (in seconds)
      -> IO (T.Text, Maybe T.Text) -- ^ Command to run to get the input string
      -> m GI.Gtk.Widget
    pollingLabelNewWithTooltip initialString interval cmd =
      liftIO $ do
        grid <- gridNew
        label <- labelNew $ Just initialString

        let updateLabel (labelStr, tooltipStr) =
              postGUIASync $ do
                labelSetMarkup label labelStr
                widgetSetTooltipMarkup label tooltipStr

        _ <- onWidgetRealize label $ do
          sampleThread <- foreverWithDelay interval $ E.tryAny cmd >>= either (const $ return ()) updateLabel
          void $ onWidgetUnrealize label $ killThread sampleThread

        vFillCenter label
        vFillCenter grid
        containerAdd grid label
        widgetShowAll grid
        toWidget grid