{-# LANGUAGE OverloadedStrings #-}

-- | 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 qualified GI.Gdk as Gdk
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 (Text, Maybe Text, Double) -> Bool -> m Widget
forall (m :: * -> *).
MonadIO m =>
IO (Text, Maybe Text, Double) -> Bool -> m Widget
pollingLabelWithVariableDelayAndRefresh IO (Text, Maybe Text, Double)
action Bool
False

-- TODO: Customize the delay and message on mouse click
pollingLabelWithVariableDelayAndRefresh
  :: MonadIO m
  => IO (T.Text, Maybe T.Text, Double)
  -> Bool -- ^ Whether to refresh the label on mouse click
  -> m GI.Gtk.Widget
pollingLabelWithVariableDelayAndRefresh :: forall (m :: * -> *).
MonadIO m =>
IO (Text, Maybe Text, Double) -> Bool -> m Widget
pollingLabelWithVariableDelayAndRefresh IO (Text, Maybe Text, Double)
action Bool
refreshOnClick =
  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 <- IO Grid
forall (m :: * -> *). (HasCallStack, MonadIO m) => m Grid
gridNew
    label <- labelNew Nothing
    ebox <- eventBoxNew

    when refreshOnClick $ void $ onWidgetButtonPressEvent ebox $ onClick [Gdk.EventTypeButtonPress] $ do
      postGUIASync $ labelSetMarkup label "Refreshing..."
      forkIO $ do
        newLavelStr <- E.tryAny action >>= \case
          Left SomeException
_                  -> Text -> IO Text
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Text
"Error"
          Right (Text
_labelStr, Maybe Text
_, Double
_) -> Text -> IO Text
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Text
_labelStr
        postGUIASync $ labelSetMarkup label newLavelStr

    let 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 (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

    _ <- onWidgetRealize label $ do
      sampleThread <- foreverWithVariableDelay updateLabelHandlingErrors
      void $ onWidgetUnrealize label $ killThread sampleThread

    vFillCenter label
    vFillCenter grid
    containerAdd grid label
    containerAdd ebox grid
    widgetShowAll ebox
    toWidget ebox