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

import           Control.Concurrent.MVar as MV
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 qualified Data.ByteString as BS
import           Data.Coerce
import           Data.Int
import           Data.List
import qualified Data.Map.Strict as Map
import           Data.Maybe
import           Data.Ord
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.GdkPixbuf.Enums
import           GI.GdkPixbuf.Objects.Pixbuf
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 "StatusNotifier.Tray"

logItemInfo :: ItemInfo -> String -> IO ()
logItemInfo :: ItemInfo -> String -> IO ()
logItemInfo info :: ItemInfo
info message :: 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 "%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 :: ImageInfo
iconPixmaps = []})
         (Int -> String
forall a. Show a => a -> String
show (Int -> String) -> Int -> String
forall a b. (a -> b) -> a -> b
$ ImageInfo -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (ImageInfo -> Int) -> ImageInfo -> Int
forall a b. (a -> b) -> a -> b
$ ItemInfo -> ImageInfo
iconPixmaps ItemInfo
info)

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

  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 "targetW: %s, targetH: %s"
               (Int32 -> String
forall a. Show a => a -> String
show Int32
scaledWidth) (Int32 -> String
forall a. Show a => a -> String
show Int32
scaledHeight)
  IO Pixbuf -> (Pixbuf -> IO Pixbuf) -> Maybe Pixbuf -> IO Pixbuf
forall b a. b -> (a -> b) -> Maybe a -> b
maybe IO Pixbuf
warnAndReturnOrig Pixbuf -> IO Pixbuf
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Pixbuf -> IO Pixbuf) -> IO (Maybe Pixbuf) -> IO Pixbuf
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
    Pixbuf -> Int32 -> Int32 -> InterpType -> IO (Maybe Pixbuf)
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsPixbuf a) =>
a -> Int32 -> Int32 -> InterpType -> m (Maybe Pixbuf)
pixbufScaleSimple Pixbuf
pixbuf Int32
scaledWidth Int32
scaledHeight InterpType
InterpTypeBilinear

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

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

  Maybe ()
_ <- 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
    Screen
screen <- IO (Maybe Screen) -> MaybeT IO Screen
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT IO (Maybe Screen)
forall (m :: * -> *). (HasCallStack, MonadIO m) => m (Maybe Screen)
screenGetDefault
    IO () -> MaybeT IO ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> MaybeT IO ()) -> IO () -> MaybeT IO ()
forall a b. (a -> b) -> a -> b
$ IconTheme -> Screen -> IO ()
forall (m :: * -> *) a b.
(HasCallStack, MonadIO m, IsIconTheme a, IsScreen b) =>
a -> b -> m ()
iconThemeSetScreen IconTheme
themeForIcon Screen
screen

  [String]
filePaths <- IconTheme -> IO [String]
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsIconTheme a) =>
a -> m [String]
iconThemeGetSearchPath IconTheme
defaultTheme
  IconTheme -> String -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsIconTheme a) =>
a -> String -> m ()
iconThemeAppendSearchPath IconTheme
themeForIcon String
themePath
  (String -> IO ()) -> [String] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (IconTheme -> String -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsIconTheme a) =>
a -> String -> m ()
iconThemeAppendSearchPath IconTheme
themeForIcon) [String]
filePaths

  IconTheme -> IO IconTheme
forall (m :: * -> *) a. Monad m => a -> m a
return IconTheme
themeForIcon

getIconPixbufByName :: Int32 -> T.Text -> Maybe String -> IO (Maybe Pixbuf)
getIconPixbufByName :: Int32 -> Text -> Maybe String -> IO (Maybe Pixbuf)
getIconPixbufByName size :: Int32
size name :: Text
name themePath :: 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 "Getting Pixbuf from name for %s" Text
name
  let nonEmptyThemePath :: Maybe String
nonEmptyThemePath = Maybe String
themePath Maybe String -> (String -> Maybe String) -> Maybe String
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (\x :: String
x -> if String
x String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== "" then Maybe String
forall a. Maybe a
Nothing else String -> Maybe String
forall a. a -> Maybe a
Just String
x)
  IconTheme
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 :: Text
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 "%s-panel" Text
name
  Bool
hasPanelIcon <- IconTheme -> Text -> IO Bool
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsIconTheme a) =>
a -> Text -> m Bool
iconThemeHasIcon IconTheme
themeForIcon Text
panelName
  Bool
hasIcon <- IconTheme -> Text -> IO Bool
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsIconTheme a) =>
a -> Text -> m Bool
iconThemeHasIcon IconTheme
themeForIcon Text
name

  if Bool
hasIcon Bool -> Bool -> Bool
|| Bool
hasPanelIcon

  then do
    let targetName :: Text
targetName = if Bool
hasPanelIcon then Text
panelName else Text
name
    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 "Found icon %s in theme" Text
name
    IconTheme
-> Text -> Int32 -> [IconLookupFlags] -> IO (Maybe Pixbuf)
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsIconTheme a) =>
a -> Text -> Int32 -> [IconLookupFlags] -> m (Maybe Pixbuf)
iconThemeLoadIcon IconTheme
themeForIcon Text
targetName Int32
size [IconLookupFlags]
themeLoadFlags

  else 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 "Trying to load icon %s as filepath" Text
name
    -- Try to load the icon as a filepath
    let nameString :: String
nameString = Text -> String
T.unpack Text
name
    Bool
fileExists <- String -> IO Bool
doesFileExist String
nameString
    Maybe String
maybeFile <- if Bool
fileExists
    then Maybe String -> IO (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe String -> IO (Maybe String))
-> Maybe String -> IO (Maybe String)
forall a b. (a -> b) -> a -> b
$ String -> Maybe String
forall a. a -> Maybe a
Just String
nameString
    else (Maybe (Maybe String) -> Maybe String)
-> IO (Maybe (Maybe String)) -> IO (Maybe String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe (Maybe String) -> Maybe String
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (IO (Maybe (Maybe String)) -> IO (Maybe String))
-> IO (Maybe (Maybe String)) -> IO (Maybe String)
forall a b. (a -> b) -> a -> b
$ Maybe (IO (Maybe String)) -> IO (Maybe (Maybe String))
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA (Maybe (IO (Maybe String)) -> IO (Maybe (Maybe String)))
-> Maybe (IO (Maybe String)) -> IO (Maybe (Maybe String))
forall a b. (a -> b) -> a -> b
$ String -> String -> IO (Maybe String)
getIconPathFromThemePath String
nameString (String -> IO (Maybe String))
-> Maybe String -> Maybe (IO (Maybe String))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe String
themePath
    Maybe (IO Pixbuf) -> IO (Maybe Pixbuf)
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA (Maybe (IO Pixbuf) -> IO (Maybe Pixbuf))
-> Maybe (IO Pixbuf) -> IO (Maybe Pixbuf)
forall a b. (a -> b) -> a -> b
$ String -> IO Pixbuf
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
String -> m Pixbuf
pixbufNewFromFile (String -> IO Pixbuf) -> Maybe String -> Maybe (IO Pixbuf)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe String
maybeFile

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

getIconPixbufFromByteString :: Int32 -> Int32 -> BS.ByteString -> IO Pixbuf
getIconPixbufFromByteString :: Int32 -> Int32 -> ByteString -> IO Pixbuf
getIconPixbufFromByteString width :: Int32
width height :: Int32
height byteString :: ByteString
byteString = do
  Priority -> String -> IO ()
trayLogger Priority
DEBUG "Getting Pixbuf from bytestring"
  Bytes
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
bytesPerPixel = 4
      rowStride :: Int32
rowStride = Int32
width Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
* Int32
bytesPerPixel
      sampleBits :: Int32
sampleBits = 8
  Bytes
-> Colorspace
-> Bool
-> Int32
-> Int32
-> Int32
-> Int32
-> IO Pixbuf
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Bytes
-> Colorspace
-> Bool
-> Int32
-> Int32
-> Int32
-> Int32
-> m Pixbuf
pixbufNewFromBytes Bytes
bytes Colorspace
ColorspaceRgb Bool
True Int32
sampleBits Int32
width Int32
height Int32
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 TrayParams = TrayParams
  { TrayParams -> Host
trayHost :: Host
  , TrayParams -> Client
trayClient :: Client
  , TrayParams -> Orientation
trayOrientation :: Gtk.Orientation
  , TrayParams -> TrayImageSize
trayImageSize :: TrayImageSize
  , TrayParams -> Bool
trayIconExpand :: Bool
  , TrayParams -> StrutAlignment
trayAlignment :: StrutAlignment
  , TrayParams -> Rational
trayOverlayScale :: Rational
  }

buildTray :: TrayParams -> IO Gtk.Box
buildTray :: TrayParams -> IO Box
buildTray TrayParams { trayHost :: TrayParams -> Host
trayHost = 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
                       }
                     , trayClient :: TrayParams -> Client
trayClient = Client
client
                     , 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
                     } = do
  Priority -> String -> IO ()
trayLogger Priority
INFO "Building tray"

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

  let getContext :: BusName -> IO (Maybe ItemContext)
getContext name :: 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 -> String
showInfo info :: ItemInfo
info = ItemInfo -> String
forall a. Show a => a -> String
show ItemInfo
info { iconPixmaps :: ImageInfo
iconPixmaps = [] }

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

      getInfo :: ItemInfo -> BusName -> IO ItemInfo
getInfo def :: ItemInfo
def name :: BusName
name = ItemInfo -> Maybe ItemInfo -> ItemInfo
forall a. a -> Maybe a -> a
fromMaybe ItemInfo
def (Maybe ItemInfo -> ItemInfo)
-> (Map BusName ItemInfo -> Maybe ItemInfo)
-> Map BusName ItemInfo
-> ItemInfo
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 -> ItemInfo)
-> IO (Map BusName ItemInfo) -> IO ItemInfo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Map BusName ItemInfo)
getInfoMap

      updateIconFromInfo :: ItemInfo -> IO ()
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 (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Maybe ItemContext -> IO ()
updateIcon
        where updateIcon :: Maybe ItemContext -> IO ()
updateIcon Nothing = UpdateHandler
updateHandler UpdateType
ItemAdded ItemInfo
info
              updateIcon (Just ItemContext { contextImage :: ItemContext -> Image
contextImage = Image
image } ) = do
                Int32
size <- case TrayImageSize
imageSize of
                          TrayImageSize size :: Int32
size -> Int32 -> IO Int32
forall (m :: * -> *) a. Monad m => a -> m a
return Int32
size
                          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 (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Rectangle -> IO Int32
forall (m :: * -> *). MonadIO m => Rectangle -> m Int32
getSize
                Int32 -> ItemInfo -> IO (Maybe Pixbuf)
getScaledPixBufFromInfo Int32
size ItemInfo
info IO (Maybe Pixbuf) -> (Maybe Pixbuf -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
                                  let handlePixbuf :: Maybe b -> IO ()
handlePixbuf mpbuf :: 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 "Failed to get pixbuf for %s" (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$
                                             ItemInfo -> String
showInfo ItemInfo
info
                                  in Maybe Pixbuf -> IO ()
forall b. (IsDescendantOf Pixbuf b, GObject b) => Maybe b -> IO ()
handlePixbuf

      getTooltipText :: ItemInfo -> String
getTooltipText ItemInfo { itemToolTip :: ItemInfo -> Maybe (String, ImageInfo, String, String)
itemToolTip = Just (_, _, titleText :: String
titleText, fullText :: 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
fullText
        | String
fullText String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== "" = String
titleText
        | Bool
otherwise = String -> String -> String -> String
forall r. PrintfType r => String -> r
printf "%s: %s" String
titleText String
fullText
      getTooltipText _ = ""

      setTooltipText :: a -> ItemInfo -> m ()
setTooltipText widget :: a
widget info :: 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 :: UpdateHandler
updateHandler 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 "Adding widget for %s - %s"
                        String
serviceNameStr String
servicePathStr

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

          EventBox
button <- IO EventBox
forall (m :: * -> *). (HasCallStack, MonadIO m) => m EventBox
Gtk.eventBoxNew

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

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

                        Int32
actualWidth <- Rectangle -> IO Int32
forall (m :: * -> *). MonadIO m => Rectangle -> m Int32
Gdk.getRectangleWidth Rectangle
allocation
                        Int32
actualHeight <- Rectangle -> IO Int32
forall (m :: * -> *). MonadIO m => Rectangle -> m Int32
Gdk.getRectangleHeight Rectangle
allocation

                        Bool
requestResize <- MVar (Maybe (Int32, Int32, Int32))
-> (Maybe (Int32, Int32, Int32)
    -> IO (Maybe (Int32, Int32, Int32), Bool))
-> IO Bool
forall a b. MVar a -> (a -> IO (a, b)) -> IO b
MV.modifyMVar MVar (Maybe (Int32, Int32, Int32))
lastAllocation ((Maybe (Int32, Int32, Int32)
  -> IO (Maybe (Int32, Int32, Int32), Bool))
 -> IO Bool)
-> (Maybe (Int32, Int32, Int32)
    -> IO (Maybe (Int32, Int32, Int32), Bool))
-> IO Bool
forall a b. (a -> b) -> a -> b
$ \previous :: 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 (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)

                        Priority -> String -> IO ()
trayLogger Priority
DEBUG (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
                                   String -> String -> String -> String -> String -> String
forall r. PrintfType r => String -> r
printf "Allocating image size %s, width %s, \
                                           \ height %s, resize %s"
                                   (Int32 -> String
forall a. Show a => a -> String
show Int32
size)
                                   (Int32 -> String
forall a. Show a => a -> String
show Int32
actualWidth)
                                   (Int32 -> String
forall a. Show a => a -> String
show Int32
actualHeight)
                                   (Bool -> String
forall a. Show a => a -> String
show Bool
requestResize)

                        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
requestResize (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                          Priority -> String -> IO ()
trayLogger Priority
DEBUG "Requesting resize"
                          Maybe Pixbuf
pixBuf <- ItemInfo -> BusName -> IO ItemInfo
getInfo ItemInfo
info BusName
serviceName IO ItemInfo -> (ItemInfo -> IO (Maybe Pixbuf)) -> IO (Maybe Pixbuf)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int32 -> ItemInfo -> IO (Maybe Pixbuf)
getScaledPixBufFromInfo Int32
size
                          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe Pixbuf -> Bool
forall a. Maybe a -> Bool
isNothing Maybe Pixbuf
pixBuf) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                               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 "Got null pixbuf for info %s" (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$
                                          ItemInfo -> String
showInfo ItemInfo
info
                          Image -> Maybe Pixbuf -> IO ()
forall (m :: * -> *) a b.
(HasCallStack, MonadIO m, IsImage a, IsPixbuf b) =>
a -> Maybe b -> m ()
Gtk.imageSetFromPixbuf Image
image Maybe Pixbuf
pixBuf
                          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
$ (Pixbuf -> IO ()) -> Maybe Pixbuf -> IO (Maybe ())
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse
                                 (\pb :: Pixbuf
pb -> do
                                    Int32
width <- Pixbuf -> IO Int32
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsPixbuf a) =>
a -> m Int32
pixbufGetWidth Pixbuf
pb
                                    Int32
height <- Pixbuf -> IO Int32
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsPixbuf a) =>
a -> m Int32
pixbufGetHeight Pixbuf
pb
                                    Image -> Int32 -> Int32 -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> Int32 -> Int32 -> m ()
Gtk.widgetSetSizeRequest Image
image Int32
width Int32
height)
                                 Maybe Pixbuf
pixBuf
                          IO Word32 -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Int32 -> IO Bool -> IO Word32
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Int32 -> IO Bool -> m Word32
Gdk.threadsAddIdle Int32
GLib.PRIORITY_DEFAULT (IO Bool -> IO Word32) -> IO Bool -> IO Word32
forall a b. (a -> b) -> a -> b
$
                                   Image -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> m ()
Gtk.widgetQueueResize Image
image IO () -> IO Bool -> IO Bool
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False)

                SignalHandlerId
_ <- Image -> (Rectangle -> IO ()) -> IO SignalHandlerId
forall a (m :: * -> *).
(IsWidget a, MonadIO m) =>
a -> (Rectangle -> IO ()) -> m SignalHandlerId
Gtk.onWidgetSizeAllocate Image
image Rectangle -> IO ()
setPixbuf
                Image -> IO Image
forall (m :: * -> *) a. Monad m => a -> m a
return Image
image
              TrayImageSize size :: Int32
size -> do
                Maybe Pixbuf
pixBuf <- Int32 -> ItemInfo -> IO (Maybe Pixbuf)
getScaledPixBufFromInfo Int32
size ItemInfo
info
                Maybe Pixbuf -> IO Image
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsPixbuf a) =>
Maybe a -> m Image
Gtk.imageNewFromPixbuf Maybe Pixbuf
pixBuf

          Image -> IO StyleContext
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> m StyleContext
Gtk.widgetGetStyleContext Image
image IO StyleContext -> (StyleContext -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
             (StyleContext -> Text -> IO ()) -> Text -> StyleContext -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip StyleContext -> Text -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsStyleContext a) =>
a -> Text -> m ()
Gtk.styleContextAddClass "tray-icon-image"

          EventBox -> Image -> IO ()
forall (m :: * -> *) a b.
(HasCallStack, MonadIO m, IsContainer a, IsWidget b) =>
a -> b -> m ()
Gtk.containerAdd EventBox
button Image
image
          EventBox -> ItemInfo -> IO ()
forall a (m :: * -> *).
(IsDescendantOf Widget a, MonadIO m, GObject a) =>
a -> ItemInfo -> m ()
setTooltipText EventBox
button ItemInfo
info

          Maybe Menu
maybeMenu <- Maybe (IO Menu) -> IO (Maybe Menu)
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA (Maybe (IO Menu) -> IO (Maybe Menu))
-> Maybe (IO Menu) -> IO (Maybe Menu)
forall a b. (a -> b) -> a -> b
$ Text -> Text -> IO Menu
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Text -> Text -> m Menu
DM.menuNew (String -> Text
T.pack String
serviceNameStr) (Text -> IO Menu) -> (String -> Text) -> String -> IO Menu
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                       String -> Text
T.pack (String -> IO Menu) -> Maybe String -> Maybe (IO Menu)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe String
serviceMenuPathStr

          let context :: ItemContext
context =
                ItemContext :: BusName -> Maybe Menu -> Image -> EventBox -> ItemContext
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 -> m ()
popupItemForMenu menu :: 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
              popupItemMenu :: IO Bool
popupItemMenu =
                IO () -> (Menu -> IO ()) -> Maybe Menu -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe IO ()
activateItem Menu -> IO ()
forall a (m :: * -> *).
(IsDescendantOf Menu a, MonadIO m, GObject a) =>
a -> m ()
popupItemForMenu Maybe Menu
maybeMenu IO () -> IO Bool -> IO Bool
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
              activateItem :: IO ()
activateItem = 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 0 0

          SignalHandlerId
_ <- EventBox -> WidgetButtonPressEventCallback -> IO SignalHandlerId
forall a (m :: * -> *).
(IsWidget a, MonadIO m) =>
a -> WidgetButtonPressEventCallback -> m SignalHandlerId
Gtk.onWidgetButtonPressEvent EventBox
button (WidgetButtonPressEventCallback -> IO SignalHandlerId)
-> WidgetButtonPressEventCallback -> IO SignalHandlerId
forall a b. (a -> b) -> a -> b
$ IO Bool -> WidgetButtonPressEventCallback
forall a b. a -> b -> a
const IO Bool
popupItemMenu

          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 (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
-> ItemContext
-> Map BusName ItemContext
-> Map BusName ItemContext
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert BusName
serviceName ItemContext
context

          EventBox -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> m ()
Gtk.widgetShowAll EventBox
button
          let packFn :: Box -> EventBox -> Bool -> Bool -> Word32 -> IO ()
packFn =
                case StrutAlignment
alignment of
                  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
                  _ -> 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

          Box -> EventBox -> Bool -> Bool -> Word32 -> IO ()
packFn Box
trayBox EventBox
button Bool
shouldExpand Bool
True 0

      updateHandler ItemRemoved ItemInfo { itemServiceName :: ItemInfo -> BusName
itemServiceName = BusName
name }
        = BusName -> IO (Maybe ItemContext)
getContext BusName
name IO (Maybe ItemContext) -> (Maybe ItemContext -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Maybe ItemContext -> IO ()
removeWidget
        where removeWidget :: Maybe ItemContext -> IO ()
removeWidget Nothing =
                Priority -> String -> IO ()
trayLogger Priority
INFO "Attempt to remove widget with 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 (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 IconUpdated i :: ItemInfo
i = ItemInfo -> IO ()
updateIconFromInfo ItemInfo
i
      updateHandler OverlayIconUpdated i :: ItemInfo
i = ItemInfo -> IO ()
updateIconFromInfo ItemInfo
i

      updateHandler 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 (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)
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 _ _ = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

      maybeAddOverlayToPixbuf :: a -> ItemInfo -> b -> IO b
maybeAddOverlayToPixbuf size :: a
size info :: ItemInfo
info pixbuf :: 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 a b. (RealFrac a, Integral b) => a -> b
floor (a -> Rational
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
size Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* Rational
overlayScale)
          Pixbuf
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 (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)
traverse (Int32 -> Orientation -> Pixbuf -> IO Pixbuf
scalePixbufToSize Int32
overlayHeight Orientation
Gtk.OrientationHorizontal)
          IO () -> MaybeT IO ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> MaybeT IO ()) -> IO () -> MaybeT IO ()
forall a b. (a -> b) -> a -> b
$ do
            Int32
actualOHeight <- Pixbuf -> IO Int32
forall (m :: * -> *) o. (MonadIO m, IsPixbuf o) => o -> m Int32
getPixbufHeight Pixbuf
overlayPixbuf
            Int32
actualOWidth <- Pixbuf -> IO Int32
forall (m :: * -> *) o. (MonadIO m, IsPixbuf o) => o -> m Int32
getPixbufWidth Pixbuf
overlayPixbuf
            Int32
mainHeight <- b -> IO Int32
forall (m :: * -> *) o. (MonadIO m, IsPixbuf o) => o -> m Int32
getPixbufHeight b
pixbuf
            Int32
mainWidth <- b -> IO Int32
forall (m :: * -> *) o. (MonadIO m, IsPixbuf o) => o -> m Int32
getPixbufWidth b
pixbuf
            Pixbuf
-> b
-> Int32
-> Int32
-> Int32
-> Int32
-> Double
-> Double
-> Double
-> Double
-> InterpType
-> Int32
-> IO ()
forall (m :: * -> *) a b.
(HasCallStack, MonadIO m, IsPixbuf a, IsPixbuf b) =>
a
-> b
-> Int32
-> Int32
-> Int32
-> Int32
-> Double
-> Double
-> Double
-> Double
-> InterpType
-> Int32
-> m ()
pixbufComposite Pixbuf
overlayPixbuf b
pixbuf
              0 0                           -- Top left corner
              Int32
actualOWidth Int32
actualOHeight    -- Overlay size
              0 0                           -- Offset
              1.0 1.0                       -- Scale
              InterpType
InterpTypeBilinear            -- InterpType
              255                           -- Source image alpha
        b -> IO b
forall (m :: * -> *) a. Monad m => a -> m a
return b
pixbuf

      getScaledPixBufFromInfo :: Int32 -> ItemInfo -> IO (Maybe Pixbuf)
getScaledPixBufFromInfo size :: Int32
size info :: ItemInfo
info =
        Int32 -> ItemInfo -> IO (Maybe Pixbuf)
getPixBufFromInfo Int32
size ItemInfo
info IO (Maybe Pixbuf)
-> (Maybe Pixbuf -> IO (Maybe Pixbuf)) -> IO (Maybe Pixbuf)
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)
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 a.
(IsDescendantOf Pixbuf b, GObject b, Integral a) =>
a -> ItemInfo -> b -> IO b
maybeAddOverlayToPixbuf Int32
size ItemInfo
info)

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

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

      getPixBufFrom :: Int32 -> String -> Maybe String -> ImageInfo -> IO (Maybe Pixbuf)
getPixBufFrom size :: Int32
size name :: String
name mpath :: Maybe String
mpath pixmaps :: ImageInfo
pixmaps = do
        let tooSmall :: (Int32, Int32, c) -> Bool
tooSmall (w :: Int32
w, h :: Int32
h, _) = 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 :: ImageInfo
largeEnough = ((Int32, Int32, ByteString) -> Bool) -> ImageInfo -> ImageInfo
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) ImageInfo
pixmaps
            orderer :: (a, a, c) -> (a, a, c) -> Ordering
orderer (w1 :: a
w1, h1 :: a
h1, _) (w2 :: a
w2, h2 :: a
h2, _) =
              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
                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
                a :: Ordering
a -> Ordering
a
            selectedPixmap :: (Int32, Int32, ByteString)
selectedPixmap =
              if ImageInfo -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ImageInfo
largeEnough
              then ((Int32, Int32, ByteString)
 -> (Int32, Int32, ByteString) -> Ordering)
-> ImageInfo -> (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 ImageInfo
pixmaps
              else ((Int32, Int32, ByteString)
 -> (Int32, Int32, ByteString) -> Ordering)
-> ImageInfo -> (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 ImageInfo
largeEnough
            getFromPixmaps :: (Int32, Int32, ByteString) -> Maybe (IO Pixbuf)
getFromPixmaps (w :: Int32
w, h :: Int32
h, p :: ByteString
p) =
              if ByteString -> Int
BS.length ByteString
p Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 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 ImageInfo -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ImageInfo
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)
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 -> ItemInfo -> f ()
uiUpdateHandler updateType :: UpdateType
updateType info :: 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 (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

  Unique
handlerId <- UpdateHandler -> IO Unique
addUHandler UpdateHandler
forall (f :: * -> *). MonadIO f => UpdateType -> ItemInfo -> f ()
uiUpdateHandler
  SignalHandlerId
_ <- Box -> IO () -> IO SignalHandlerId
forall a (m :: * -> *).
(IsWidget a, MonadIO m) =>
a -> IO () -> m SignalHandlerId
Gtk.onWidgetDestroy Box
trayBox (IO () -> IO SignalHandlerId) -> IO () -> IO SignalHandlerId
forall a b. (a -> b) -> a -> b
$ Unique -> IO ()
removeUHandler Unique
handlerId
  Box -> IO Box
forall (m :: * -> *) a. Monad m => a -> m a
return Box
trayBox