{-# 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
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
, :: 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
Int32
actualOWidth Int32
actualOHeight
0 0
1.0 1.0
InterpType
InterpTypeBilinear
255
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