Icon.hs

-- | 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 path = liftIO $ imageNewFromFile path >>= 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 name = liftIO $ 
  imageNewFromIconName (Just name) (fromIntegral $ fromEnum IconSizeMenu) 
  >>= 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 path interval cmd =
  pollingIcon interval cmd
    (imageNewFromFile path)
    (\image path' -> imageSetFromFile image (Just 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 name interval cmd = 
  pollingIcon interval cmd
    (imageNewFromIconName (Just name) (fromIntegral $ fromEnum IconSizeMenu))
    (\image name' -> imageSetFromIconName image (Just name') $ fromIntegral $ fromEnum 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 interval doUpdateName doInitImage doSetImage = liftIO $ do
  image <- doInitImage
  _ <- onWidgetRealize image $ do
    _ <- forkIO $ forever $ do
      let tryUpdate = liftIO $ do
            name' <- doUpdateName
            postGUIASync $ doSetImage image name' >> return ()
      E.catch tryUpdate ignoreIOException
      threadDelay $ floor (interval * 1000000)
    return ()
  putInBox image

putInBox :: IsWidget child => child -> IO Widget
putInBox icon = do
  box <- boxNew OrientationHorizontal 0
  boxPackStart box icon False False 0
  widgetShowAll box
  toWidget box

ignoreIOException :: IOException -> IO ()
ignoreIOException _ = return ()