-- | 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
  , iconImageWidgetNewFromName
  , pollingIconImageWidgetNew
  , pollingIconImageWidgetNewFromName
  ) where

import Control.Concurrent ( forkIO, threadDelay )
import qualified Data.Text as T
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 :: forall (m :: * -> *). MonadIO m => FilePath -> m Widget
iconImageWidgetNew FilePath
path = 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
$ FilePath -> IO Image
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
FilePath -> m Image
imageNewFromFile FilePath
path IO Image -> (Image -> IO Widget) -> IO Widget
forall a b. IO a -> (a -> IO b) -> IO b
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 displays a static image
--
-- > iconWidgetNewFromName name
--
-- returns a widget with the icon named @name@. Icon
-- names are sourced from the current GTK theme. 
iconImageWidgetNewFromName :: MonadIO m => T.Text -> m Widget
iconImageWidgetNewFromName :: forall (m :: * -> *). MonadIO m => Text -> m Widget
iconImageWidgetNewFromName Text
name = 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
$ 
  Maybe Text -> Int32 -> IO Image
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Maybe Text -> Int32 -> m Image
imageNewFromIconName (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
name) (Int -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int32) -> Int -> Int32
forall a b. (a -> b) -> a -> b
$ IconSize -> Int
forall a. Enum a => a -> Int
fromEnum IconSize
IconSizeMenu) 
  IO Image -> (Image -> IO Widget) -> IO Widget
forall a b. IO a -> (a -> IO b) -> IO b
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 :: forall (m :: * -> *).
MonadIO m =>
FilePath -> Double -> IO FilePath -> m Widget
pollingIconImageWidgetNew FilePath
path Double
interval IO FilePath
cmd =
  Double
-> IO FilePath
-> IO Image
-> (Image -> FilePath -> IO ())
-> m Widget
forall (m :: * -> *) name b.
MonadIO m =>
Double
-> IO name -> IO Image -> (Image -> name -> IO b) -> m Widget
pollingIcon Double
interval IO FilePath
cmd
    (FilePath -> IO Image
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
FilePath -> m Image
imageNewFromFile FilePath
path)
    (\Image
image FilePath
path' -> Image -> Maybe FilePath -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsImage a) =>
a -> Maybe FilePath -> m ()
imageSetFromFile Image
image (FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
path'))

-- | Create a new widget that updates itself at regular intervals.  The
-- function
--
-- > pollingIconImageWidgetNewFromName name interval cmd
--
-- returns a widget with initial icon whose name is @name@.  The widget
-- forks a thread to update its contents every @interval@ seconds.
-- The command should return the name 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.
pollingIconImageWidgetNewFromName
  :: MonadIO m
  => T.Text    -- ^ Icon Name
  -> Double    -- ^ Update interval (in seconds)
  -> IO T.Text -- ^ Command to run update the icon name
  -> m Widget
pollingIconImageWidgetNewFromName :: forall (m :: * -> *).
MonadIO m =>
Text -> Double -> IO Text -> m Widget
pollingIconImageWidgetNewFromName Text
name Double
interval IO Text
cmd = 
  Double
-> IO Text -> IO Image -> (Image -> Text -> IO ()) -> m Widget
forall (m :: * -> *) name b.
MonadIO m =>
Double
-> IO name -> IO Image -> (Image -> name -> IO b) -> m Widget
pollingIcon Double
interval IO Text
cmd
    (Maybe Text -> Int32 -> IO Image
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Maybe Text -> Int32 -> m Image
imageNewFromIconName (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
name) (Int -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int32) -> Int -> Int32
forall a b. (a -> b) -> a -> b
$ IconSize -> Int
forall a. Enum a => a -> Int
fromEnum IconSize
IconSizeMenu))
    (\Image
image Text
name' -> Image -> Maybe Text -> Int32 -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsImage a) =>
a -> Maybe Text -> Int32 -> m ()
imageSetFromIconName Image
image (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
name') (Int32 -> IO ()) -> Int32 -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int32) -> Int -> Int32
forall a b. (a -> b) -> a -> b
$ IconSize -> Int
forall a. Enum a => a -> Int
fromEnum IconSize
IconSizeMenu)

-- | Creates a polling icon. 
pollingIcon 
  :: MonadIO m
  => Double   -- ^ Update Interval (in seconds)
  -> IO name  -- ^ IO action that updates image's icon-name/filepath 
  -> IO Image -- ^ MonadIO action that creates the initial image.
  -> (Image -> name -> IO b)
              -- ^ MonadIO action that updates the image.
  -> m Widget -- ^ Polling Icon
pollingIcon :: forall (m :: * -> *) name b.
MonadIO m =>
Double
-> IO name -> IO Image -> (Image -> name -> IO b) -> m Widget
pollingIcon Double
interval IO name
doUpdateName IO Image
doInitImage Image -> name -> IO b
doSetImage = 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
  Image
image <- IO Image
doInitImage
  SignalHandlerId
_ <- Image -> ((?self::Image) => IO ()) -> IO SignalHandlerId
forall a (m :: * -> *).
(IsWidget a, MonadIO m) =>
a -> ((?self::a) => IO ()) -> m SignalHandlerId
onWidgetRealize Image
image (((?self::Image) => IO ()) -> IO SignalHandlerId)
-> ((?self::Image) => IO ()) -> IO SignalHandlerId
forall a b. (a -> b) -> a -> b
$ do
    ThreadId
_ <- IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      let tryUpdate :: IO ()
tryUpdate = IO () -> IO ()
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            name
name' <- IO name
doUpdateName
            IO () -> IO ()
postGUIASync (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Image -> name -> IO b
doSetImage Image
image name
name' IO b -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      IO () -> (IOException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
E.catch IO ()
tryUpdate IOException -> IO ()
ignoreIOException
      Int -> IO ()
threadDelay (Int -> IO ()) -> Int -> IO ()
forall a b. (a -> b) -> a -> b
$ Double -> Int
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor (Double
interval Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
1000000)
    () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  Image -> IO Widget
forall child. IsWidget child => child -> IO Widget
putInBox Image
image

putInBox :: IsWidget child => child -> IO Widget
putInBox :: forall child. IsWidget child => child -> IO Widget
putInBox child
icon = do
  Box
box <- Orientation -> Int32 -> IO Box
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Orientation -> Int32 -> m Box
boxNew Orientation
OrientationHorizontal Int32
0
  Box -> child -> Bool -> Bool -> Word32 -> IO ()
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 Word32
0
  Box -> IO ()
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 -> IO ()
ignoreIOException IOException
_ = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()