-- | This is a simple static image widget, and a polling image widget that
-- updates its contents by calling a callback at a set interval.
module System.Taffybar.Widget.Generic.Icon
  ( iconImageWidgetNew
  , pollingIconImageWidgetNew
  ) where

import Control.Concurrent ( forkIO, threadDelay )
import Control.Exception as E
import Control.Monad ( forever )
import Control.Monad.IO.Class
import GI.Gtk
import System.Taffybar.Util

-- | Create a new widget that displays a static image
--
-- > iconImageWidgetNew path
--
-- returns a widget with icon at @path@.
iconImageWidgetNew :: MonadIO m => FilePath -> m Widget
iconImageWidgetNew :: FilePath -> m Widget
iconImageWidgetNew path :: FilePath
path = 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
$ FilePath -> IO Image
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
FilePath -> m Image
imageNewFromFile FilePath
path IO Image -> (Image -> IO Widget) -> IO Widget
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Image -> IO Widget
forall child. IsWidget child => child -> IO Widget
putInBox

-- | Create a new widget that updates itself at regular intervals.  The
-- function
--
-- > pollingIconImageWidgetNew path interval cmd
--
-- returns a widget with initial icon at @path@.  The widget
-- forks a thread to update its contents every @interval@ seconds.
-- The command should return a FilePath of a valid icon.
--
-- If the IO action throws an exception, it will be swallowed and the
-- label will not update until the update interval expires.
pollingIconImageWidgetNew
  :: MonadIO m
  => FilePath -- ^ Initial file path of the icon
  -> Double -- ^ Update interval (in seconds)
  -> IO FilePath -- ^ Command to run to get the input filepath
  -> m Widget
pollingIconImageWidgetNew :: FilePath -> Double -> IO FilePath -> m Widget
pollingIconImageWidgetNew path :: FilePath
path interval :: Double
interval cmd :: IO FilePath
cmd = 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
  Image
icon <- FilePath -> IO Image
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
FilePath -> m Image
imageNewFromFile FilePath
path
  SignalHandlerId
_ <- Image -> WidgetRealizeCallback -> IO SignalHandlerId
forall a (m :: * -> *).
(IsWidget a, MonadIO m) =>
a -> WidgetRealizeCallback -> m SignalHandlerId
onWidgetRealize Image
icon (WidgetRealizeCallback -> IO SignalHandlerId)
-> WidgetRealizeCallback -> IO SignalHandlerId
forall a b. (a -> b) -> a -> b
$ do
    ThreadId
_ <- WidgetRealizeCallback -> IO ThreadId
forkIO (WidgetRealizeCallback -> IO ThreadId)
-> WidgetRealizeCallback -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ WidgetRealizeCallback -> WidgetRealizeCallback
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (WidgetRealizeCallback -> WidgetRealizeCallback)
-> WidgetRealizeCallback -> WidgetRealizeCallback
forall a b. (a -> b) -> a -> b
$ do
      let tryUpdate :: WidgetRealizeCallback
tryUpdate = do
            FilePath
str <- IO FilePath
cmd
            WidgetRealizeCallback -> WidgetRealizeCallback
postGUIASync (WidgetRealizeCallback -> WidgetRealizeCallback)
-> WidgetRealizeCallback -> WidgetRealizeCallback
forall a b. (a -> b) -> a -> b
$ Image -> Maybe FilePath -> WidgetRealizeCallback
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsImage a) =>
a -> Maybe FilePath -> m ()
imageSetFromFile Image
icon (FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
str)
      WidgetRealizeCallback
-> (IOException -> WidgetRealizeCallback) -> WidgetRealizeCallback
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
E.catch WidgetRealizeCallback
tryUpdate IOException -> WidgetRealizeCallback
ignoreIOException
      Int -> WidgetRealizeCallback
threadDelay (Int -> WidgetRealizeCallback) -> Int -> WidgetRealizeCallback
forall a b. (a -> b) -> a -> b
$ Double -> Int
forall a b. (RealFrac a, Integral b) => a -> b
floor (Double
interval Double -> Double -> Double
forall a. Num a => a -> a -> a
* 1000000)
    () -> WidgetRealizeCallback
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  Image -> IO Widget
forall child. IsWidget child => child -> IO Widget
putInBox Image
icon

putInBox :: IsWidget child => child -> IO Widget
putInBox :: child -> IO Widget
putInBox icon :: child
icon = do
  Box
box <- Orientation -> Int32 -> IO Box
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Orientation -> Int32 -> m Box
boxNew Orientation
OrientationHorizontal 0
  Box -> child -> Bool -> Bool -> Word32 -> WidgetRealizeCallback
forall (m :: * -> *) a b.
(HasCallStack, MonadIO m, IsBox a, IsWidget b) =>
a -> b -> Bool -> Bool -> Word32 -> m ()
boxPackStart Box
box child
icon Bool
False Bool
False 0
  Box -> WidgetRealizeCallback
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> m ()
widgetShowAll Box
box
  Box -> IO Widget
forall (m :: * -> *) o. (MonadIO m, IsWidget o) => o -> m Widget
toWidget Box
box

ignoreIOException :: IOException -> IO ()
ignoreIOException :: IOException -> WidgetRealizeCallback
ignoreIOException _ = () -> WidgetRealizeCallback
forall (m :: * -> *) a. Monad m => a -> m a
return ()