{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE CPP #-}
module StatusNotifier.Tray where

import           Control.Concurrent.MVar as MV
import           Control.Exception.Base
import           Control.Exception.Enclosed (catchAny)
import           Control.Monad
import           Control.Monad.Trans.Class
import           Control.Monad.Trans.Maybe
import           DBus.Client
import qualified DBus.Internal.Types as DBusTypes
import           Data.Bool (bool)
import qualified Data.ByteString as BS
import           Data.Coerce
import           Data.Foldable (traverse_)
import           Data.GI.Base.GError
import           Data.Int
import           Data.List
import qualified Data.Map.Strict as Map
import           Data.Maybe
import           Data.Ord
import           Data.Ratio
import qualified Data.Text as T
import qualified GI.DbusmenuGtk3.Objects.Menu as DM
import qualified GI.GLib as GLib
import           GI.GLib.Structs.Bytes
import qualified GI.Gdk as Gdk
import           GI.Gdk.Enums
import           GI.Gdk.Objects.Screen
import           GI.Gdk.Structs.EventScroll
import           GI.GdkPixbuf.Enums
import           GI.GdkPixbuf.Objects.Pixbuf as Gdk
import qualified GI.Gtk as Gtk
import           GI.Gtk.Flags
import           GI.Gtk.Objects.IconTheme
import           Graphics.UI.GIGtkStrut
import           StatusNotifier.Host.Service
import qualified StatusNotifier.Item.Client as IC
import           System.Directory
import           System.FilePath
import           System.Log.Logger
import           Text.Printf

trayLogger :: Priority -> String -> IO ()
trayLogger :: Priority -> String -> IO ()
trayLogger = String -> Priority -> String -> IO ()
logM String
"StatusNotifier.Tray"

logItemInfo :: ItemInfo -> String -> IO ()
logItemInfo :: ItemInfo -> String -> IO ()
logItemInfo ItemInfo
info String
message =
  Priority -> String -> IO ()
trayLogger Priority
INFO (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> String -> String -> String -> String
forall r. PrintfType r => String -> r
printf String
"%s - %s pixmap count: %s" String
message
         (ItemInfo -> String
forall a. Show a => a -> String
show (ItemInfo -> String) -> ItemInfo -> String
forall a b. (a -> b) -> a -> b
$ ItemInfo
info { iconPixmaps = []})
         (Int -> String
forall a. Show a => a -> String
show (Int -> String) -> Int -> String
forall a b. (a -> b) -> a -> b
$ [(Int32, Int32, ByteString)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([(Int32, Int32, ByteString)] -> Int)
-> [(Int32, Int32, ByteString)] -> Int
forall a b. (a -> b) -> a -> b
$ ItemInfo -> [(Int32, Int32, ByteString)]
iconPixmaps ItemInfo
info)

getScaledWidthHeight :: Bool -> Int32 -> Int32 -> Int32 -> (Int32, Int32)
getScaledWidthHeight :: Bool -> Int32 -> Int32 -> Int32 -> (Int32, Int32)
getScaledWidthHeight Bool
shouldTargetWidth Int32
targetSize Int32
width Int32
height =
  let getRatio :: Int32 -> Rational
      getRatio :: Int32 -> Rational
getRatio Int32
toScale =
        Int32 -> Rational
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
targetSize Rational -> Rational -> Rational
forall a. Fractional a => a -> a -> a
/ Int32 -> Rational
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
toScale
      getOther :: Int32 -> Int32 -> Int32
      getOther :: Int32 -> Int32 -> Int32
getOther Int32
toScale Int32
other = Rational -> Int32
forall b. Integral b => Rational -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor (Rational -> Int32) -> Rational -> Int32
forall a b. (a -> b) -> a -> b
$ Int32 -> Rational
getRatio Int32
toScale Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* Int32 -> Rational
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
other
  in
    if Bool
shouldTargetWidth
    then (Int32
targetSize, Int32 -> Int32 -> Int32
getOther Int32
width Int32
height)
    else (Int32 -> Int32 -> Int32
getOther Int32
height Int32
width, Int32
targetSize)

scalePixbufToSize :: Int32 -> Gtk.Orientation -> Pixbuf -> IO Pixbuf
scalePixbufToSize :: Int32 -> Orientation -> Pixbuf -> IO Pixbuf
scalePixbufToSize Int32
size Orientation
orientation Pixbuf
pixbuf = do
  width <- Pixbuf -> IO Int32
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsPixbuf a) =>
a -> m Int32
pixbufGetWidth Pixbuf
pixbuf
  height <- pixbufGetHeight pixbuf
  let warnAndReturnOrig =
        Priority -> String -> IO ()
trayLogger Priority
WARNING String
"Unable to scale pixbuf" IO () -> IO Pixbuf -> IO Pixbuf
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Pixbuf -> IO Pixbuf
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Pixbuf
pixbuf
      targetWidth = case Orientation
orientation of
                      Orientation
Gtk.OrientationHorizontal -> Bool
False
                      Orientation
_ -> Bool
True
      (scaledWidth, scaledHeight) =
        getScaledWidthHeight targetWidth size width height
  trayLogger DEBUG $
             printf
             "Scaling pb to %s, actualW: %s, actualH: %s, scaledW: %s, scaledH: %s"
             (show size) (show width) (show height)
             (show scaledWidth) (show scaledHeight)

  trayLogger DEBUG $ printf "targetW: %s, targetH: %s"
               (show scaledWidth) (show scaledHeight)
  maybe warnAndReturnOrig return =<<
    pixbufScaleSimple pixbuf scaledWidth scaledHeight InterpTypeBilinear

themeLoadFlags :: [IconLookupFlags]
themeLoadFlags :: [IconLookupFlags]
themeLoadFlags = [IconLookupFlags
IconLookupFlagsGenericFallback, IconLookupFlags
IconLookupFlagsUseBuiltin]

getThemeWithDefaultFallbacks :: String -> IO IconTheme
getThemeWithDefaultFallbacks :: String -> IO IconTheme
getThemeWithDefaultFallbacks String
themePath = do
  themeForIcon <- IO IconTheme
forall (m :: * -> *). (HasCallStack, MonadIO m) => m IconTheme
iconThemeNew
  defaultTheme <- iconThemeGetDefault

  _ <- runMaybeT $ do
    screen <- MaybeT screenGetDefault
    lift $ iconThemeSetScreen themeForIcon screen

  filePaths <- iconThemeGetSearchPath defaultTheme
  iconThemeAppendSearchPath themeForIcon themePath
  mapM_ (iconThemeAppendSearchPath themeForIcon) filePaths

  return themeForIcon

catchGErrorsAsLeft :: IO a -> IO (Either GError a)
catchGErrorsAsLeft :: forall a. IO a -> IO (Either GError a)
catchGErrorsAsLeft IO a
action = IO (Either GError a)
-> (GError -> IO (Either GError a)) -> IO (Either GError a)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch (a -> Either GError a
forall a b. b -> Either a b
Right (a -> Either GError a) -> IO a -> IO (Either GError a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO a
action) (Either GError a -> IO (Either GError a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either GError a -> IO (Either GError a))
-> (GError -> Either GError a) -> GError -> IO (Either GError a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GError -> Either GError a
forall a b. a -> Either a b
Left)

catchGErrorsAsNothing :: IO a -> IO (Maybe a)
catchGErrorsAsNothing :: forall a. IO a -> IO (Maybe a)
catchGErrorsAsNothing IO a
action = IO a -> IO (Either GError a)
forall a. IO a -> IO (Either GError a)
catchGErrorsAsLeft IO a
action IO (Either GError a)
-> (Either GError a -> IO (Maybe a)) -> IO (Maybe a)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Either GError a -> IO (Maybe a)
forall {a} {a}. Show a => Either a a -> IO (Maybe a)
rightToJustLogLeft
       where rightToJustLogLeft :: Either a a -> IO (Maybe a)
rightToJustLogLeft (Right a
value) = Maybe a -> IO (Maybe a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe a -> IO (Maybe a)) -> Maybe a -> IO (Maybe a)
forall a b. (a -> b) -> a -> b
$ a -> Maybe a
forall a. a -> Maybe a
Just a
value
             rightToJustLogLeft (Left a
error) = do
               Priority -> String -> IO ()
trayLogger Priority
WARNING (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> String -> String
forall r. PrintfType r => String -> r
printf String
"Encountered error: %s" (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ a -> String
forall a. Show a => a -> String
show a
error
               Maybe a -> IO (Maybe a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing

safePixbufNewFromFile :: FilePath -> IO (Maybe Gdk.Pixbuf)
safePixbufNewFromFile :: String -> IO (Maybe Pixbuf)
safePixbufNewFromFile =
  IO (Maybe (Maybe Pixbuf)) -> IO (Maybe Pixbuf)
forall {a}. IO (Maybe (Maybe a)) -> IO (Maybe a)
handleResult (IO (Maybe (Maybe Pixbuf)) -> IO (Maybe Pixbuf))
-> (String -> IO (Maybe (Maybe Pixbuf)))
-> String
-> IO (Maybe Pixbuf)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO (Maybe Pixbuf) -> IO (Maybe (Maybe Pixbuf))
forall a. IO a -> IO (Maybe a)
catchGErrorsAsNothing (IO (Maybe Pixbuf) -> IO (Maybe (Maybe Pixbuf)))
-> (String -> IO (Maybe Pixbuf))
-> String
-> IO (Maybe (Maybe Pixbuf))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO (Maybe Pixbuf)
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
String -> m (Maybe Pixbuf)
Gdk.pixbufNewFromFile
  where
#if MIN_VERSION_gi_gdkpixbuf(2,0,26)
    handleResult :: IO (Maybe (Maybe a)) -> IO (Maybe a)
handleResult = (Maybe (Maybe a) -> Maybe a)
-> IO (Maybe (Maybe a)) -> IO (Maybe a)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe (Maybe a) -> Maybe a
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join
#else
    handleResult = id
#endif

getIconPixbufByName :: Int32 -> T.Text -> Maybe String -> IO (Maybe Pixbuf)
getIconPixbufByName :: Int32 -> Text -> Maybe String -> IO (Maybe Pixbuf)
getIconPixbufByName Int32
size Text
name Maybe String
themePath = do
  Priority -> String -> IO ()
trayLogger Priority
DEBUG (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> Text -> String
forall r. PrintfType r => String -> r
printf String
"Getting Pixbuf from name for %s" Text
name
  let nonEmptyThemePath :: Maybe String
nonEmptyThemePath = Maybe String
themePath Maybe String -> (String -> Maybe String) -> Maybe String
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (\String
x -> if String
x String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"" then Maybe String
forall a. Maybe a
Nothing else String -> Maybe String
forall a. a -> Maybe a
Just String
x)
  themeForIcon <-
    IO IconTheme
-> (String -> IO IconTheme) -> Maybe String -> IO IconTheme
forall b a. b -> (a -> b) -> Maybe a -> b
maybe IO IconTheme
forall (m :: * -> *). (HasCallStack, MonadIO m) => m IconTheme
iconThemeGetDefault String -> IO IconTheme
getThemeWithDefaultFallbacks Maybe String
nonEmptyThemePath

  let panelName = String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String -> Text -> String
forall r. PrintfType r => String -> r
printf String
"%s-panel" Text
name
  hasPanelIcon <- iconThemeHasIcon themeForIcon panelName
  hasIcon <- iconThemeHasIcon themeForIcon name

  if hasIcon || hasPanelIcon

  then do
    let targetName = if Bool
hasPanelIcon then Text
panelName else Text
name
    trayLogger DEBUG $ printf "Found icon %s in theme" name
    catchAny (iconThemeLoadIcon themeForIcon targetName size themeLoadFlags)
             (const $ pure Nothing)

  else do
    trayLogger DEBUG $ printf "Trying to load icon %s as filepath" name
    -- Try to load the icon as a filepath
    let nameString = Text -> String
T.unpack Text
name
    fileExists <- doesFileExist nameString
    maybeFile <- if fileExists
    then return $ Just nameString
    else fmap join $ sequenceA $ getIconPathFromThemePath nameString <$> themePath
#if MIN_VERSION_gi_gdkpixbuf(2,0,26)
    let handleResult = (Maybe (Maybe a) -> Maybe a)
-> IO (Maybe (Maybe a)) -> IO (Maybe a)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe (Maybe a) -> Maybe a
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (IO (Maybe (Maybe a)) -> IO (Maybe a))
-> (Maybe (IO (Maybe a)) -> IO (Maybe (Maybe a)))
-> Maybe (IO (Maybe a))
-> IO (Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe (IO (Maybe a)) -> IO (Maybe (Maybe a))
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
forall (f :: * -> *) a. Applicative f => Maybe (f a) -> f (Maybe a)
sequenceA
#else
    let handleResult = sequenceA
#endif
    handleResult $ safePixbufNewFromFile <$> maybeFile

getIconPathFromThemePath :: String -> String -> IO (Maybe String)
getIconPathFromThemePath :: String -> String -> IO (Maybe String)
getIconPathFromThemePath String
name String
themePath = if String
name String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"" then Maybe String -> IO (Maybe String)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
Nothing else do
  Priority -> String -> IO ()
trayLogger Priority
DEBUG (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> String -> String -> String
forall r. PrintfType r => String -> r
printf
    String
"Trying to load icon %s as filepath with theme path %s"
    String
name String
themePath
  pathExists <- String -> IO Bool
doesDirectoryExist String
themePath
  if pathExists
  then do
    fileNames <- catchAny (listDirectory themePath) (const $ return [])
    trayLogger DEBUG $ printf
      "Found files in theme path %s" (show fileNames)
    return $ (themePath </>) <$> find (isPrefixOf name) fileNames
  else return Nothing

getIconPixbufFromByteString :: Int32 -> Int32 -> BS.ByteString -> IO Pixbuf
getIconPixbufFromByteString :: Int32 -> Int32 -> ByteString -> IO Pixbuf
getIconPixbufFromByteString Int32
width Int32
height ByteString
byteString = do
  Priority -> String -> IO ()
trayLogger Priority
DEBUG String
"Getting Pixbuf from bytestring"
  bytes <- Maybe ByteString -> IO Bytes
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Maybe ByteString -> m Bytes
bytesNew (Maybe ByteString -> IO Bytes) -> Maybe ByteString -> IO Bytes
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
byteString
  let bytesPerPixel = Int32
4
      rowStride = Int32
width Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
* Int32
bytesPerPixel
      sampleBits = Int32
8
  pixbufNewFromBytes bytes ColorspaceRgb True sampleBits width height rowStride

data ItemContext = ItemContext
  { ItemContext -> BusName
contextName :: DBusTypes.BusName
  , ItemContext -> Maybe Menu
contextMenu :: Maybe DM.Menu
  , ItemContext -> Image
contextImage :: Gtk.Image
  , ItemContext -> EventBox
contextButton :: Gtk.EventBox
  }

data TrayImageSize = Expand | TrayImageSize Int32

data TrayClickAction = Activate | SecondaryActivate | PopupMenu

data TrayParams = TrayParams
  { TrayParams -> Orientation
trayOrientation :: Gtk.Orientation
  , TrayParams -> TrayImageSize
trayImageSize :: TrayImageSize
  , TrayParams -> Bool
trayIconExpand :: Bool
  , TrayParams -> StrutAlignment
trayAlignment :: StrutAlignment
  , TrayParams -> Rational
trayOverlayScale :: Rational
  , TrayParams -> TrayClickAction
trayLeftClickAction :: TrayClickAction
  , TrayParams -> TrayClickAction
trayMiddleClickAction :: TrayClickAction
  , TrayParams -> TrayClickAction
trayRightClickAction :: TrayClickAction
  }

defaultTrayParams :: TrayParams
defaultTrayParams = TrayParams
  { trayOrientation :: Orientation
trayOrientation = Orientation
Gtk.OrientationHorizontal
  , trayImageSize :: TrayImageSize
trayImageSize = TrayImageSize
Expand
  , trayIconExpand :: Bool
trayIconExpand = Bool
False
  , trayAlignment :: StrutAlignment
trayAlignment = StrutAlignment
End
  , trayOverlayScale :: Rational
trayOverlayScale = Integer
3 Integer -> Integer -> Rational
forall a. Integral a => a -> a -> Ratio a
% Integer
5
  , trayLeftClickAction :: TrayClickAction
trayLeftClickAction = TrayClickAction
Activate
  , trayMiddleClickAction :: TrayClickAction
trayMiddleClickAction = TrayClickAction
SecondaryActivate
  , trayRightClickAction :: TrayClickAction
trayRightClickAction = TrayClickAction
PopupMenu
  }

buildTray :: Host -> Client -> TrayParams -> IO Gtk.Box
buildTray :: Host -> Client -> TrayParams -> IO Box
buildTray Host
            { itemInfoMap :: Host -> IO (Map BusName ItemInfo)
itemInfoMap = IO (Map BusName ItemInfo)
getInfoMap
            , addUpdateHandler :: Host -> UpdateHandler -> IO Unique
addUpdateHandler = UpdateHandler -> IO Unique
addUHandler
            , removeUpdateHandler :: Host -> Unique -> IO ()
removeUpdateHandler = Unique -> IO ()
removeUHandler
            }
          Client
client
          TrayParams { trayOrientation :: TrayParams -> Orientation
trayOrientation = Orientation
orientation
                     , trayImageSize :: TrayParams -> TrayImageSize
trayImageSize = TrayImageSize
imageSize
                     , trayIconExpand :: TrayParams -> Bool
trayIconExpand = Bool
shouldExpand
                     , trayAlignment :: TrayParams -> StrutAlignment
trayAlignment = StrutAlignment
alignment
                     , trayOverlayScale :: TrayParams -> Rational
trayOverlayScale = Rational
overlayScale
                     , trayLeftClickAction :: TrayParams -> TrayClickAction
trayLeftClickAction = TrayClickAction
leftClickAction
                     , trayMiddleClickAction :: TrayParams -> TrayClickAction
trayMiddleClickAction = TrayClickAction
middleClickAction
                     , trayRightClickAction :: TrayParams -> TrayClickAction
trayRightClickAction = TrayClickAction
rightClickAction
                     } = do
  Priority -> String -> IO ()
trayLogger Priority
INFO String
"Building tray"

  trayBox <- Orientation -> Int32 -> IO Box
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Orientation -> Int32 -> m Box
Gtk.boxNew Orientation
orientation Int32
0
  contextMap <- MV.newMVar Map.empty

  let getContext BusName
name = BusName -> Map BusName ItemContext -> Maybe ItemContext
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup BusName
name (Map BusName ItemContext -> Maybe ItemContext)
-> IO (Map BusName ItemContext) -> IO (Maybe ItemContext)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MVar (Map BusName ItemContext) -> IO (Map BusName ItemContext)
forall a. MVar a -> IO a
MV.readMVar MVar (Map BusName ItemContext)
contextMap
      showInfo ItemInfo
info = ItemInfo -> String
forall a. Show a => a -> String
show ItemInfo
info { iconPixmaps = [] }

      getSize Rectangle
rectangle =
        case Orientation
orientation of
          Orientation
Gtk.OrientationHorizontal ->
            Rectangle -> m Int32
forall (m :: * -> *). MonadIO m => Rectangle -> m Int32
Gdk.getRectangleHeight Rectangle
rectangle
          Orientation
_ ->
            Rectangle -> m Int32
forall (m :: * -> *). MonadIO m => Rectangle -> m Int32
Gdk.getRectangleWidth Rectangle
rectangle

      getInfoAttr ItemInfo -> b
fn b
def BusName
name = b -> (ItemInfo -> b) -> Maybe ItemInfo -> b
forall b a. b -> (a -> b) -> Maybe a -> b
maybe b
def ItemInfo -> b
fn (Maybe ItemInfo -> b)
-> (Map BusName ItemInfo -> Maybe ItemInfo)
-> Map BusName ItemInfo
-> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BusName -> Map BusName ItemInfo -> Maybe ItemInfo
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup BusName
name (Map BusName ItemInfo -> b) -> IO (Map BusName ItemInfo) -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Map BusName ItemInfo)
getInfoMap

      getInfo :: ItemInfo -> DBusTypes.BusName -> IO ItemInfo
      getInfo = (ItemInfo -> ItemInfo) -> ItemInfo -> BusName -> IO ItemInfo
forall {b}. (ItemInfo -> b) -> b -> BusName -> IO b
getInfoAttr ItemInfo -> ItemInfo
forall a. a -> a
id

      updateIconFromInfo info :: ItemInfo
info@ItemInfo { itemServiceName :: ItemInfo -> BusName
itemServiceName = BusName
name } =
        BusName -> IO (Maybe ItemContext)
getContext BusName
name IO (Maybe ItemContext) -> (Maybe ItemContext -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Maybe ItemContext -> IO ()
updateIcon
        where updateIcon :: Maybe ItemContext -> IO ()
updateIcon Maybe ItemContext
Nothing = UpdateHandler
updateHandler UpdateType
ItemAdded ItemInfo
info
              updateIcon (Just ItemContext { contextImage :: ItemContext -> Image
contextImage = Image
image } ) = do
                size <- case TrayImageSize
imageSize of
                          TrayImageSize Int32
size -> Int32 -> IO Int32
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Int32
size
                          TrayImageSize
Expand -> Image -> IO Rectangle
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> m Rectangle
Gtk.widgetGetAllocation Image
image IO Rectangle -> (Rectangle -> IO Int32) -> IO Int32
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Rectangle -> IO Int32
forall (m :: * -> *). MonadIO m => Rectangle -> m Int32
getSize
                getScaledPixBufFromInfo size info >>=
                                  let handlePixbuf Maybe b
mpbuf =
                                        if Maybe b -> Bool
forall a. Maybe a -> Bool
isJust Maybe b
mpbuf
                                        then Image -> Maybe b -> IO ()
forall (m :: * -> *) a b.
(HasCallStack, MonadIO m, IsImage a, IsPixbuf b) =>
a -> Maybe b -> m ()
Gtk.imageSetFromPixbuf Image
image Maybe b
mpbuf
                                        else Priority -> String -> IO ()
trayLogger Priority
WARNING (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
                                             String -> String -> String
forall r. PrintfType r => String -> r
printf String
"Failed to get pixbuf for %s" (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$
                                             ItemInfo -> String
showInfo ItemInfo
info
                                  in handlePixbuf

      getTooltipText ItemInfo { itemToolTip :: ItemInfo
-> Maybe (String, [(Int32, Int32, ByteString)], String, String)
itemToolTip = Just (String
_, [(Int32, Int32, ByteString)]
_, String
titleText, String
fullText )}
        | String
titleText String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
fullText = String
fullText
        | String
titleText String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"" = String
fullText
        | String
fullText String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"" = String
titleText
        | Bool
otherwise = String -> String -> String -> String
forall r. PrintfType r => String -> r
printf String
"%s: %s" String
titleText String
fullText
      getTooltipText ItemInfo
_ = String
""

      setTooltipText a
widget ItemInfo
info =
        a -> Maybe Text -> m ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> Maybe Text -> m ()
Gtk.widgetSetTooltipText a
widget (Maybe Text -> m ()) -> Maybe Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ ItemInfo -> String
getTooltipText ItemInfo
info

      updateHandler UpdateType
ItemAdded
                    info :: ItemInfo
info@ItemInfo { menuPath :: ItemInfo -> Maybe ObjectPath
menuPath = Maybe ObjectPath
pathForMenu
                                  , itemServiceName :: ItemInfo -> BusName
itemServiceName = BusName
serviceName
                                  , itemServicePath :: ItemInfo -> ObjectPath
itemServicePath = ObjectPath
servicePath
                                  } =
        do
          let serviceNameStr :: String
serviceNameStr = BusName -> String
forall a b. Coercible a b => a -> b
coerce BusName
serviceName
              servicePathStr :: String
servicePathStr = ObjectPath -> String
forall a b. Coercible a b => a -> b
coerce ObjectPath
servicePath :: String
              serviceMenuPathStr :: Maybe String
serviceMenuPathStr = ObjectPath -> String
forall a b. Coercible a b => a -> b
coerce (ObjectPath -> String) -> Maybe ObjectPath -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe ObjectPath
pathForMenu
              logText :: String
logText = String -> String -> String -> String
forall r. PrintfType r => String -> r
printf String
"Adding widget for %s - %s"
                        String
serviceNameStr String
servicePathStr

          Priority -> String -> IO ()
trayLogger Priority
INFO String
logText

          button <- IO EventBox
forall (m :: * -> *). (HasCallStack, MonadIO m) => m EventBox
Gtk.eventBoxNew
          Gtk.widgetAddEvents button [Gdk.EventMaskScrollMask]

          image <-
            case imageSize of
              TrayImageSize
Expand -> do
                image <- IO Image
forall (m :: * -> *). (HasCallStack, MonadIO m) => m Image
Gtk.imageNew
                lastAllocation <- MV.newMVar Nothing

                let setPixbuf Rectangle
allocation =
                      do
                        size <- Rectangle -> IO Int32
forall (m :: * -> *). MonadIO m => Rectangle -> m Int32
getSize Rectangle
allocation

                        actualWidth <- Gdk.getRectangleWidth allocation
                        actualHeight <- Gdk.getRectangleHeight allocation

                        requestResize <- MV.modifyMVar lastAllocation $ \Maybe (Int32, Int32, Int32)
previous ->
                          let thisTime :: Maybe (Int32, Int32, Int32)
thisTime = (Int32, Int32, Int32) -> Maybe (Int32, Int32, Int32)
forall a. a -> Maybe a
Just (Int32
size, Int32
actualWidth, Int32
actualHeight)
                          in (Maybe (Int32, Int32, Int32), Bool)
-> IO (Maybe (Int32, Int32, Int32), Bool)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Int32, Int32, Int32)
thisTime, Maybe (Int32, Int32, Int32)
thisTime Maybe (Int32, Int32, Int32) -> Maybe (Int32, Int32, Int32) -> Bool
forall a. Eq a => a -> a -> Bool
/= Maybe (Int32, Int32, Int32)
previous)

                        trayLogger DEBUG $
                                   printf
                                   ("Allocating image size %s, width %s," <>
                                    " height %s, resize %s")
                                   (show size)
                                   (show actualWidth)
                                   (show actualHeight)
                                   (show requestResize)

                        when requestResize $ do
                          trayLogger DEBUG "Requesting resize"
                          pixBuf <- getInfo info serviceName >>=
                                    getScaledPixBufFromInfo size
                          when (isNothing pixBuf) $
                               trayLogger WARNING $
                                          printf "Got null pixbuf for info %s" $
                                          showInfo info
                          Gtk.imageSetFromPixbuf image pixBuf
                          void $ traverse
                                 (\Pixbuf
pb -> do
                                    width <- Pixbuf -> IO Int32
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsPixbuf a) =>
a -> m Int32
pixbufGetWidth Pixbuf
pb
                                    height <- pixbufGetHeight pb
                                    Gtk.widgetSetSizeRequest image width height)
                                 pixBuf
                          void (Gdk.threadsAddIdle GLib.PRIORITY_DEFAULT $
                                   Gtk.widgetQueueResize image >> return False)

                _ <- Gtk.onWidgetSizeAllocate image setPixbuf
                return image
              TrayImageSize Int32
size -> do
                pixBuf <- Int32 -> ItemInfo -> IO (Maybe Pixbuf)
getScaledPixBufFromInfo Int32
size ItemInfo
info
                Gtk.imageNewFromPixbuf pixBuf

          Gtk.widgetGetStyleContext image >>=
             flip Gtk.styleContextAddClass "tray-icon-image"

          Gtk.containerAdd button image
          setTooltipText button info

          maybeMenu <- sequenceA $ DM.menuNew (T.pack serviceNameStr) .
                       T.pack <$> serviceMenuPathStr

          let context =
                ItemContext { contextName :: BusName
contextName = BusName
serviceName
                            , contextMenu :: Maybe Menu
contextMenu = Maybe Menu
maybeMenu
                            , contextImage :: Image
contextImage = Image
image
                            , contextButton :: EventBox
contextButton = EventBox
button
                            }
              popupItemForMenu a
menu =
                a -> Image -> Gravity -> Gravity -> Maybe Event -> m ()
forall (m :: * -> *) a b.
(HasCallStack, MonadIO m, IsMenu a, IsWidget b) =>
a -> b -> Gravity -> Gravity -> Maybe Event -> m ()
Gtk.menuPopupAtWidget a
menu Image
image
                   Gravity
GravitySouthWest Gravity
GravityNorthWest Maybe Event
forall a. Maybe a
Nothing

          _ <- Gtk.onWidgetButtonPressEvent button $ \EventButton
event -> do
            button <- EventButton -> IO Word32
forall (m :: * -> *). MonadIO m => EventButton -> m Word32
Gdk.getEventButtonButton EventButton
event
            x <- round <$> Gdk.getEventButtonXRoot event
            y <- round <$> Gdk.getEventButtonYRoot event
            action <- case button of
              Word32
1 -> TrayClickAction -> TrayClickAction -> Bool -> TrayClickAction
forall a. a -> a -> Bool -> a
bool TrayClickAction
leftClickAction TrayClickAction
PopupMenu (Bool -> TrayClickAction) -> IO Bool -> IO TrayClickAction
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ItemInfo -> Bool) -> Bool -> BusName -> IO Bool
forall {b}. (ItemInfo -> b) -> b -> BusName -> IO b
getInfoAttr
                   ItemInfo -> Bool
itemIsMenu Bool
True BusName
serviceName
              Word32
2 -> TrayClickAction -> IO TrayClickAction
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return TrayClickAction
middleClickAction
              Word32
_ -> TrayClickAction -> IO TrayClickAction
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return TrayClickAction
rightClickAction
            case action of
              TrayClickAction
Activate -> IO (Either MethodError ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Either MethodError ()) -> IO ())
-> IO (Either MethodError ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ Client
-> BusName
-> ObjectPath
-> Int32
-> Int32
-> IO (Either MethodError ())
IC.activate Client
client BusName
serviceName ObjectPath
servicePath Int32
x Int32
y
              TrayClickAction
SecondaryActivate -> IO (Either MethodError ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Either MethodError ()) -> IO ())
-> IO (Either MethodError ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ Client
-> BusName
-> ObjectPath
-> Int32
-> Int32
-> IO (Either MethodError ())
IC.secondaryActivate Client
client
                                   BusName
serviceName ObjectPath
servicePath Int32
x Int32
y
              TrayClickAction
PopupMenu -> IO () -> (Menu -> IO ()) -> Maybe Menu -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()) Menu -> IO ()
forall {a} {m :: * -> *}.
(IsDescendantOf Menu a, MonadIO m, GObject a) =>
a -> m ()
popupItemForMenu Maybe Menu
maybeMenu
            return False
          _ <- Gtk.onWidgetScrollEvent button $ \EventScroll
event -> do
            direction <- EventScroll -> IO ScrollDirection
forall (m :: * -> *). MonadIO m => EventScroll -> m ScrollDirection
getEventScrollDirection EventScroll
event
            let direction' = case ScrollDirection
direction of
                               ScrollDirection
ScrollDirectionUp -> String -> Maybe String
forall a. a -> Maybe a
Just String
"vertical"
                               ScrollDirection
ScrollDirectionDown -> String -> Maybe String
forall a. a -> Maybe a
Just String
"vertical"
                               ScrollDirection
ScrollDirectionLeft -> String -> Maybe String
forall a. a -> Maybe a
Just String
"horizontal"
                               ScrollDirection
ScrollDirectionRight -> String -> Maybe String
forall a. a -> Maybe a
Just String
"horizontal"
                               ScrollDirection
_ -> Maybe String
forall a. Maybe a
Nothing
                -- deltaX/deltaY are provided only in case of smooth scrolling which
                -- is enabled via additional flag, we don't to enable/handle it
                delta = case ScrollDirection
direction of
                          ScrollDirection
ScrollDirectionUp -> -Int32
1
                          ScrollDirection
ScrollDirectionDown -> Int32
1
                          ScrollDirection
ScrollDirectionLeft -> -Int32
1
                          ScrollDirection
ScrollDirectionRight -> Int32
1
                          ScrollDirection
_ -> Int32
0
            traverse_ (IC.scroll client serviceName servicePath delta) direction'
            return False

          MV.modifyMVar_ contextMap $ return . Map.insert serviceName context

          Gtk.widgetShowAll button
          let packFn =
                case StrutAlignment
alignment of
                  StrutAlignment
End -> Box -> EventBox -> Bool -> Bool -> Word32 -> IO ()
forall (m :: * -> *) a b.
(HasCallStack, MonadIO m, IsBox a, IsWidget b) =>
a -> b -> Bool -> Bool -> Word32 -> m ()
Gtk.boxPackEnd
                  StrutAlignment
_ -> Box -> EventBox -> Bool -> Bool -> Word32 -> IO ()
forall (m :: * -> *) a b.
(HasCallStack, MonadIO m, IsBox a, IsWidget b) =>
a -> b -> Bool -> Bool -> Word32 -> m ()
Gtk.boxPackStart

          packFn trayBox button shouldExpand True 0

      updateHandler UpdateType
ItemRemoved ItemInfo { itemServiceName :: ItemInfo -> BusName
itemServiceName = BusName
name }
        = BusName -> IO (Maybe ItemContext)
getContext BusName
name IO (Maybe ItemContext) -> (Maybe ItemContext -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Maybe ItemContext -> IO ()
removeWidget
        where removeWidget :: Maybe ItemContext -> IO ()
removeWidget Maybe ItemContext
Nothing =
                Priority -> String -> IO ()
trayLogger Priority
WARNING String
"removeWidget: unrecognized service name."
              removeWidget (Just ItemContext { contextButton :: ItemContext -> EventBox
contextButton = EventBox
widgetToRemove }) =
                do
                  Box -> EventBox -> IO ()
forall (m :: * -> *) a b.
(HasCallStack, MonadIO m, IsContainer a, IsWidget b) =>
a -> b -> m ()
Gtk.containerRemove Box
trayBox EventBox
widgetToRemove
                  MVar (Map BusName ItemContext)
-> (Map BusName ItemContext -> IO (Map BusName ItemContext))
-> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
MV.modifyMVar_ MVar (Map BusName ItemContext)
contextMap ((Map BusName ItemContext -> IO (Map BusName ItemContext))
 -> IO ())
-> (Map BusName ItemContext -> IO (Map BusName ItemContext))
-> IO ()
forall a b. (a -> b) -> a -> b
$ Map BusName ItemContext -> IO (Map BusName ItemContext)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Map BusName ItemContext -> IO (Map BusName ItemContext))
-> (Map BusName ItemContext -> Map BusName ItemContext)
-> Map BusName ItemContext
-> IO (Map BusName ItemContext)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BusName -> Map BusName ItemContext -> Map BusName ItemContext
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete BusName
name

      updateHandler UpdateType
IconUpdated ItemInfo
i = ItemInfo -> IO ()
updateIconFromInfo ItemInfo
i
      updateHandler UpdateType
OverlayIconUpdated ItemInfo
i = ItemInfo -> IO ()
updateIconFromInfo ItemInfo
i

      updateHandler UpdateType
ToolTipUpdated info :: ItemInfo
info@ItemInfo { itemServiceName :: ItemInfo -> BusName
itemServiceName = BusName
name } =
        IO (Maybe ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Maybe ()) -> IO ()) -> IO (Maybe ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ BusName -> IO (Maybe ItemContext)
getContext BusName
name IO (Maybe ItemContext)
-> (Maybe ItemContext -> IO (Maybe ())) -> IO (Maybe ())
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
             (ItemContext -> IO ()) -> Maybe ItemContext -> IO (Maybe ())
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe b)
traverse ((EventBox -> ItemInfo -> IO ()) -> ItemInfo -> EventBox -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip EventBox -> ItemInfo -> IO ()
forall {a} {m :: * -> *}.
(IsDescendantOf Widget a, MonadIO m, GObject a) =>
a -> ItemInfo -> m ()
setTooltipText ItemInfo
info (EventBox -> IO ())
-> (ItemContext -> EventBox) -> ItemContext -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ItemContext -> EventBox
contextButton)

      updateHandler UpdateType
_ ItemInfo
_ = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

      maybeAddOverlayToPixbuf p
size ItemInfo
info b
pixbuf = do
        MaybeT IO () -> IO (Maybe ())
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT IO () -> IO (Maybe ())) -> MaybeT IO () -> IO (Maybe ())
forall a b. (a -> b) -> a -> b
$ do
          let overlayHeight :: Int32
overlayHeight = Rational -> Int32
forall b. Integral b => Rational -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor (p -> Rational
forall a b. (Integral a, Num b) => a -> b
fromIntegral p
size Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* Rational
overlayScale)
          overlayPixbuf <-
            IO (Maybe Pixbuf) -> MaybeT IO Pixbuf
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (IO (Maybe Pixbuf) -> MaybeT IO Pixbuf)
-> IO (Maybe Pixbuf) -> MaybeT IO Pixbuf
forall a b. (a -> b) -> a -> b
$ Int32 -> ItemInfo -> IO (Maybe Pixbuf)
getOverlayPixBufFromInfo Int32
overlayHeight ItemInfo
info IO (Maybe Pixbuf)
-> (Maybe Pixbuf -> IO (Maybe Pixbuf)) -> IO (Maybe Pixbuf)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
            (Pixbuf -> IO Pixbuf) -> Maybe Pixbuf -> IO (Maybe Pixbuf)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe b)
traverse (Int32 -> Orientation -> Pixbuf -> IO Pixbuf
scalePixbufToSize Int32
overlayHeight Orientation
Gtk.OrientationHorizontal)
          lift $ do
            actualOHeight <- getPixbufHeight overlayPixbuf
            actualOWidth <- getPixbufWidth overlayPixbuf
            mainHeight <- getPixbufHeight pixbuf
            mainWidth <- getPixbufWidth pixbuf
            pixbufComposite overlayPixbuf pixbuf
              0 0                           -- Top left corner
              actualOWidth actualOHeight    -- Overlay size
              0 0                           -- Offset
              1.0 1.0                       -- Scale
              InterpTypeBilinear            -- InterpType
              255                           -- Source image alpha
        b -> IO b
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return b
pixbuf

      getScaledPixBufFromInfo Int32
size ItemInfo
info =
        Int32 -> ItemInfo -> IO (Maybe Pixbuf)
getPixBufFromInfo Int32
size ItemInfo
info IO (Maybe Pixbuf)
-> (Maybe Pixbuf -> IO (Maybe Pixbuf)) -> IO (Maybe Pixbuf)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
        (Pixbuf -> IO Pixbuf) -> Maybe Pixbuf -> IO (Maybe Pixbuf)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe b)
traverse (Int32 -> Orientation -> Pixbuf -> IO Pixbuf
scalePixbufToSize Int32
size Orientation
orientation (Pixbuf -> IO Pixbuf)
-> (Pixbuf -> IO Pixbuf) -> Pixbuf -> IO Pixbuf
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=>
                  Int32 -> ItemInfo -> Pixbuf -> IO Pixbuf
forall {b} {p}.
(IsDescendantOf Pixbuf b, GObject b, Integral p) =>
p -> ItemInfo -> b -> IO b
maybeAddOverlayToPixbuf Int32
size ItemInfo
info)

      getPixBufFromInfo Int32
size
                        info :: ItemInfo
info@ItemInfo { iconName :: ItemInfo -> String
iconName = String
name
                                      , iconThemePath :: ItemInfo -> Maybe String
iconThemePath = Maybe String
mpath
                                      , iconPixmaps :: ItemInfo -> [(Int32, Int32, ByteString)]
iconPixmaps = [(Int32, Int32, ByteString)]
pixmaps
                                      } = Int32
-> String
-> Maybe String
-> [(Int32, Int32, ByteString)]
-> IO (Maybe Pixbuf)
getPixBufFrom Int32
size String
name Maybe String
mpath [(Int32, Int32, ByteString)]
pixmaps

      getOverlayPixBufFromInfo Int32
size
                               info :: ItemInfo
info@ItemInfo
                                     { overlayIconName :: ItemInfo -> Maybe String
overlayIconName = Maybe String
name
                                     , iconThemePath :: ItemInfo -> Maybe String
iconThemePath = Maybe String
mpath
                                     , overlayIconPixmaps :: ItemInfo -> [(Int32, Int32, ByteString)]
overlayIconPixmaps = [(Int32, Int32, ByteString)]
pixmaps
                                     } = Int32
-> String
-> Maybe String
-> [(Int32, Int32, ByteString)]
-> IO (Maybe Pixbuf)
getPixBufFrom Int32
size (String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"" Maybe String
name)
                               Maybe String
mpath [(Int32, Int32, ByteString)]
pixmaps

      getPixBufFrom Int32
size String
name Maybe String
mpath [(Int32, Int32, ByteString)]
pixmaps = do
        let tooSmall :: (Int32, Int32, c) -> Bool
tooSmall (Int32
w, Int32
h, c
_) = Int32
w Int32 -> Int32 -> Bool
forall a. Ord a => a -> a -> Bool
< Int32
size Bool -> Bool -> Bool
|| Int32
h Int32 -> Int32 -> Bool
forall a. Ord a => a -> a -> Bool
< Int32
size
            largeEnough :: [(Int32, Int32, ByteString)]
largeEnough = ((Int32, Int32, ByteString) -> Bool)
-> [(Int32, Int32, ByteString)] -> [(Int32, Int32, ByteString)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> ((Int32, Int32, ByteString) -> Bool)
-> (Int32, Int32, ByteString)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int32, Int32, ByteString) -> Bool
forall {c}. (Int32, Int32, c) -> Bool
tooSmall) [(Int32, Int32, ByteString)]
pixmaps
            orderer :: (a, a, c) -> (a, a, c) -> Ordering
orderer (a
w1, a
h1, c
_) (a
w2, a
h2, c
_) =
              case (a -> a) -> a -> a -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing a -> a
forall a. a -> a
id a
w1 a
w2 of
                Ordering
EQ -> (a -> a) -> a -> a -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing a -> a
forall a. a -> a
id a
h1 a
h2
                Ordering
a -> Ordering
a
            selectedPixmap :: (Int32, Int32, ByteString)
selectedPixmap =
              if [(Int32, Int32, ByteString)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Int32, Int32, ByteString)]
largeEnough
              then ((Int32, Int32, ByteString)
 -> (Int32, Int32, ByteString) -> Ordering)
-> [(Int32, Int32, ByteString)] -> (Int32, Int32, ByteString)
forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
maximumBy (Int32, Int32, ByteString)
-> (Int32, Int32, ByteString) -> Ordering
forall {a} {a} {c} {c}.
(Ord a, Ord a) =>
(a, a, c) -> (a, a, c) -> Ordering
orderer [(Int32, Int32, ByteString)]
pixmaps
              else ((Int32, Int32, ByteString)
 -> (Int32, Int32, ByteString) -> Ordering)
-> [(Int32, Int32, ByteString)] -> (Int32, Int32, ByteString)
forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
minimumBy (Int32, Int32, ByteString)
-> (Int32, Int32, ByteString) -> Ordering
forall {a} {a} {c} {c}.
(Ord a, Ord a) =>
(a, a, c) -> (a, a, c) -> Ordering
orderer [(Int32, Int32, ByteString)]
largeEnough
            getFromPixmaps :: (Int32, Int32, ByteString) -> Maybe (IO Pixbuf)
getFromPixmaps (Int32
w, Int32
h, ByteString
p) =
              if ByteString -> Int
BS.length ByteString
p Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
              then Maybe (IO Pixbuf)
forall a. Maybe a
Nothing
              else IO Pixbuf -> Maybe (IO Pixbuf)
forall a. a -> Maybe a
Just (IO Pixbuf -> Maybe (IO Pixbuf)) -> IO Pixbuf -> Maybe (IO Pixbuf)
forall a b. (a -> b) -> a -> b
$ Int32 -> Int32 -> ByteString -> IO Pixbuf
getIconPixbufFromByteString Int32
w Int32
h ByteString
p
        if [(Int32, Int32, ByteString)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Int32, Int32, ByteString)]
pixmaps
        then Int32 -> Text -> Maybe String -> IO (Maybe Pixbuf)
getIconPixbufByName Int32
size (String -> Text
T.pack String
name) Maybe String
mpath
        else Maybe (IO Pixbuf) -> IO (Maybe Pixbuf)
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
forall (f :: * -> *) a. Applicative f => Maybe (f a) -> f (Maybe a)
sequenceA (Maybe (IO Pixbuf) -> IO (Maybe Pixbuf))
-> Maybe (IO Pixbuf) -> IO (Maybe Pixbuf)
forall a b. (a -> b) -> a -> b
$ (Int32, Int32, ByteString) -> Maybe (IO Pixbuf)
getFromPixmaps (Int32, Int32, ByteString)
selectedPixmap

      uiUpdateHandler UpdateType
updateType ItemInfo
info =
        f Word32 -> f ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (f Word32 -> f ()) -> f Word32 -> f ()
forall a b. (a -> b) -> a -> b
$ Int32 -> IO Bool -> f Word32
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Int32 -> IO Bool -> m Word32
Gdk.threadsAddIdle Int32
GLib.PRIORITY_DEFAULT (IO Bool -> f Word32) -> IO Bool -> f Word32
forall a b. (a -> b) -> a -> b
$
             UpdateHandler
updateHandler UpdateType
updateType ItemInfo
info IO () -> IO Bool -> IO Bool
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

  handlerId <- addUHandler uiUpdateHandler
  _ <- Gtk.onWidgetDestroy trayBox $ removeUHandler handlerId
  return trayBox