{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE CPP #-}
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.Foldable (traverse_)
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
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 :: 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 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 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
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 String
"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
Orientation
Gtk.OrientationHorizontal -> Bool
False
Orientation
_ -> Bool
True
(Int32
scaledWidth, 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
String
"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 String
"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 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 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 (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)
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 String
"%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 String
"Found icon %s in theme" Text
name
IO (Maybe Pixbuf)
-> (SomeException -> IO (Maybe Pixbuf)) -> IO (Maybe Pixbuf)
forall (m :: * -> *) a.
MonadBaseControl IO m =>
m a -> (SomeException -> m a) -> m a
catchAny (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)
(IO (Maybe Pixbuf) -> SomeException -> IO (Maybe Pixbuf)
forall a b. a -> b -> a
const (IO (Maybe Pixbuf) -> SomeException -> IO (Maybe Pixbuf))
-> IO (Maybe Pixbuf) -> SomeException -> IO (Maybe Pixbuf)
forall a b. (a -> b) -> a -> b
$ Maybe Pixbuf -> IO (Maybe Pixbuf)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Pixbuf
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 -> Text -> String
forall r. PrintfType r => String -> r
printf String
"Trying to load icon %s as filepath" Text
name
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
#if MIN_VERSION_gi_gdkpixbuf(2,0,26)
let handleResult :: Maybe (IO (Maybe a)) -> IO (Maybe a)
handleResult = (Maybe (Maybe a) -> Maybe a)
-> IO (Maybe (Maybe a)) -> IO (Maybe a)
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)
sequenceA
#else
let handleResult = sequenceA
#endif
Maybe (IO (Maybe Pixbuf)) -> IO (Maybe Pixbuf)
forall {a}. Maybe (IO (Maybe a)) -> IO (Maybe a)
handleResult (Maybe (IO (Maybe Pixbuf)) -> IO (Maybe Pixbuf))
-> Maybe (IO (Maybe Pixbuf)) -> IO (Maybe Pixbuf)
forall a b. (a -> b) -> a -> b
$ String -> IO (Maybe Pixbuf)
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
String -> m (Maybe Pixbuf)
pixbufNewFromFile (String -> IO (Maybe Pixbuf))
-> Maybe String -> Maybe (IO (Maybe 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 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 (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
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
String
"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 Int32
width Int32
height ByteString
byteString = do
Priority -> String -> IO ()
trayLogger Priority
DEBUG String
"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 = Int32
4
rowStride :: Int32
rowStride = Int32
width Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
* Int32
bytesPerPixel
sampleBits :: Int32
sampleBits = Int32
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
, :: Maybe DM.Menu
, ItemContext -> Image
contextImage :: Gtk.Image
, ItemContext -> EventBox
contextButton :: Gtk.EventBox
}
data TrayImageSize = Expand | TrayImageSize Int32
data TrayClickAction = Activate | SecondaryActivate |
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 :: Orientation
-> TrayImageSize
-> Bool
-> StrutAlignment
-> Rational
-> TrayClickAction
-> TrayClickAction
-> TrayClickAction
-> TrayParams
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"
Box
trayBox <- Orientation -> Int32 -> IO Box
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Orientation -> Int32 -> m Box
Gtk.boxNew Orientation
orientation Int32
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 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 ItemInfo
info = ItemInfo -> String
forall a. Show a => a -> String
show ItemInfo
info { iconPixmaps :: ImageInfo
iconPixmaps = [] }
getSize :: Rectangle -> m Int32
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) -> b -> BusName -> IO b
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 -> 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 :: 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 Maybe ItemContext
Nothing = UpdateHandler
updateHandler UpdateType
ItemAdded ItemInfo
info
updateIcon (Just ItemContext { contextImage :: ItemContext -> Image
contextImage = Image
image } ) = do
Int32
size <- case TrayImageSize
imageSize of
TrayImageSize Int32
size -> Int32 -> IO Int32
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 (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 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 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 (String
_, ImageInfo
_, 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 -> ItemInfo -> m ()
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 :: UpdateHandler
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
coerce BusName
serviceName
servicePathStr :: String
servicePathStr = ObjectPath -> String
coerce ObjectPath
servicePath :: String
serviceMenuPathStr :: Maybe String
serviceMenuPathStr = ObjectPath -> String
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
EventBox
button <- IO EventBox
forall (m :: * -> *). (HasCallStack, MonadIO m) => m EventBox
Gtk.eventBoxNew
EventBox -> [EventMask] -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> [EventMask] -> m ()
Gtk.widgetAddEvents EventBox
button [EventMask
Gdk.EventMaskScrollMask]
Image
image <-
case TrayImageSize
imageSize of
TrayImageSize
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 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
$ \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
(String
"Allocating image size %s, width %s," String -> String -> String
forall a. Semigroup a => a -> a -> a
<>
String
" 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 String
"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 String
"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
(\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
-> ((?self::Image) => Rectangle -> IO ()) -> IO SignalHandlerId
forall a (m :: * -> *).
(IsWidget a, MonadIO m) =>
a -> ((?self::a) => Rectangle -> IO ()) -> m SignalHandlerId
Gtk.onWidgetSizeAllocate Image
image (?self::Image) => Rectangle -> IO ()
Rectangle -> IO ()
setPixbuf
Image -> IO Image
forall (m :: * -> *) a. Monad m => a -> m a
return Image
image
TrayImageSize 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 Text
"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 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
SignalHandlerId
_ <- EventBox
-> ((?self::EventBox) => WidgetButtonPressEventCallback)
-> IO SignalHandlerId
forall a (m :: * -> *).
(IsWidget a, MonadIO m) =>
a
-> ((?self::a) => WidgetButtonPressEventCallback)
-> m SignalHandlerId
Gtk.onWidgetButtonPressEvent EventBox
button (((?self::EventBox) => WidgetButtonPressEventCallback)
-> IO SignalHandlerId)
-> ((?self::EventBox) => WidgetButtonPressEventCallback)
-> IO SignalHandlerId
forall a b. (a -> b) -> a -> b
$ \EventButton
event -> do
Word32
button <- EventButton -> IO Word32
forall (m :: * -> *). MonadIO m => EventButton -> m Word32
Gdk.getEventButtonButton EventButton
event
Int32
x <- Double -> Int32
forall a b. (RealFrac a, Integral b) => a -> b
round (Double -> Int32) -> IO Double -> IO Int32
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> EventButton -> IO Double
forall (m :: * -> *). MonadIO m => EventButton -> m Double
Gdk.getEventButtonXRoot EventButton
event
Int32
y <- Double -> Int32
forall a b. (RealFrac a, Integral b) => a -> b
round (Double -> Int32) -> IO Double -> IO Int32
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> EventButton -> IO Double
forall (m :: * -> *). MonadIO m => EventButton -> m Double
Gdk.getEventButtonYRoot EventButton
event
Bool
isMenu <- (ItemInfo -> Bool) -> Bool -> BusName -> IO Bool
forall {b}. (ItemInfo -> b) -> b -> BusName -> IO b
getInfoAttr ItemInfo -> Bool
itemIsMenu Bool
False BusName
serviceName
let action :: TrayClickAction
action = if Bool
isMenu then TrayClickAction
PopupMenu else
case Word32
button of
Word32
1 -> TrayClickAction
leftClickAction
Word32
2 -> TrayClickAction
middleClickAction
Word32
3 -> TrayClickAction
rightClickAction
case TrayClickAction
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 (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
Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
SignalHandlerId
_ <- EventBox
-> ((?self::EventBox) => WidgetScrollEventCallback)
-> IO SignalHandlerId
forall a (m :: * -> *).
(IsWidget a, MonadIO m) =>
a -> ((?self::a) => WidgetScrollEventCallback) -> m SignalHandlerId
Gtk.onWidgetScrollEvent EventBox
button (((?self::EventBox) => WidgetScrollEventCallback)
-> IO SignalHandlerId)
-> ((?self::EventBox) => WidgetScrollEventCallback)
-> IO SignalHandlerId
forall a b. (a -> b) -> a -> b
$ \EventScroll
event -> do
ScrollDirection
direction <- EventScroll -> IO ScrollDirection
forall (m :: * -> *). MonadIO m => EventScroll -> m ScrollDirection
getEventScrollDirection EventScroll
event
let direction' :: Maybe String
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
delta :: Int32
delta = case ScrollDirection
direction of
ScrollDirection
ScrollDirectionUp -> -Int32
1
ScrollDirection
ScrollDirectionDown -> Int32
1
ScrollDirection
ScrollDirectionLeft -> -Int32
1
ScrollDirection
ScrollDirectionRight -> Int32
1
ScrollDirection
_ -> Int32
0
(String -> IO (Either MethodError ())) -> Maybe String -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (Client
-> BusName
-> ObjectPath
-> Int32
-> String
-> IO (Either MethodError ())
IC.scroll Client
client BusName
serviceName ObjectPath
servicePath Int32
delta) Maybe String
direction'
Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
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
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
Box -> EventBox -> Bool -> Bool -> Word32 -> IO ()
packFn Box
trayBox EventBox
button Bool
shouldExpand Bool
True Word32
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 (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
INFO String
"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 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 (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 UpdateType
_ ItemInfo
_ = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
maybeAddOverlayToPixbuf :: p -> ItemInfo -> b -> IO b
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 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)
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
Int32
0 Int32
0
Int32
actualOWidth Int32
actualOHeight
Double
0 Double
0
Double
1.0 Double
1.0
InterpType
InterpTypeBilinear
Int32
255
b -> IO b
forall (m :: * -> *) a. Monad m => a -> m a
return b
pixbuf
getScaledPixBufFromInfo :: Int32 -> ItemInfo -> IO (Maybe 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 (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} {p}.
(IsDescendantOf Pixbuf b, GObject b, Integral p) =>
p -> ItemInfo -> b -> IO b
maybeAddOverlayToPixbuf Int32
size ItemInfo
info)
getPixBufFromInfo :: Int32 -> ItemInfo -> IO (Maybe Pixbuf)
getPixBufFromInfo 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 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 String
"" Maybe String
name)
Maybe String
mpath ImageInfo
pixmaps
getPixBufFrom :: Int32 -> String -> Maybe String -> ImageInfo -> IO (Maybe Pixbuf)
getPixBufFrom Int32
size String
name Maybe String
mpath ImageInfo
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 :: 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 (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 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 (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 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 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 -> ((?self::Box) => IO ()) -> IO SignalHandlerId
forall a (m :: * -> *).
(IsWidget a, MonadIO m) =>
a -> ((?self::a) => IO ()) -> m SignalHandlerId
Gtk.onWidgetDestroy Box
trayBox (((?self::Box) => IO ()) -> IO SignalHandlerId)
-> ((?self::Box) => 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