{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE CPP #-}
module System.Taffybar.Widget.Util where
import Control.Concurrent ( forkIO )
import Control.Monad
import Control.Monad.IO.Class
import Data.Bifunctor ( first )
import Data.Functor ( ($>) )
import Data.Int
import qualified Data.Text as T
import qualified GI.Gdk as D
import qualified GI.GdkPixbuf.Objects.Pixbuf as GI
import qualified GI.GdkPixbuf.Objects.Pixbuf as PB
import GI.Gtk as Gtk
import StatusNotifier.Tray (scalePixbufToSize)
import System.FilePath.Posix
import System.Environment.XDG.DesktopEntry
import System.Taffybar.Util
import Text.Printf
import Paths_taffybar ( getDataDir )
onClick :: [D.EventType]
-> IO a
-> D.EventButton
-> IO Bool
onClick :: [EventType] -> IO a -> EventButton -> IO Bool
onClick [EventType]
triggers IO a
action EventButton
btn = do
EventType
click <- EventButton -> IO EventType
forall (m :: * -> *). MonadIO m => EventButton -> m EventType
D.getEventButtonType EventButton
btn
if EventType
click EventType -> [EventType] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [EventType]
triggers
then IO a
action IO a -> 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
True
else Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
attachPopup :: (Gtk.IsWidget w, Gtk.IsWindow wnd) =>
w
-> T.Text
-> wnd
-> IO ()
w
widget Text
title wnd
window = do
wnd -> Text -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWindow a) =>
a -> Text -> m ()
windowSetTitle wnd
window Text
title
wnd -> WindowTypeHint -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWindow a) =>
a -> WindowTypeHint -> m ()
windowSetTypeHint wnd
window WindowTypeHint
D.WindowTypeHintTooltip
wnd -> Bool -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWindow a) =>
a -> Bool -> m ()
windowSetSkipTaskbarHint wnd
window Bool
True
wnd -> Bool -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWindow a) =>
a -> Bool -> m ()
windowSetSkipPagerHint wnd
window Bool
True
Maybe Window
transient <- IO (Maybe Window)
getWindow
wnd -> Maybe Window -> IO ()
forall (m :: * -> *) a b.
(HasCallStack, MonadIO m, IsWindow a, IsWindow b) =>
a -> Maybe b -> m ()
windowSetTransientFor wnd
window Maybe Window
transient
wnd -> Bool -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWindow a) =>
a -> Bool -> m ()
windowSetKeepAbove wnd
window Bool
True
wnd -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWindow a) =>
a -> m ()
windowStick wnd
window
where
getWindow :: IO (Maybe Window)
getWindow :: IO (Maybe Window)
getWindow = do
GType
windowGType <- TypedObject Window => IO GType
forall a. TypedObject a => IO GType
glibType @Window
Just Widget
ancestor <- w -> GType -> IO (Maybe Widget)
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> GType -> m (Maybe Widget)
Gtk.widgetGetAncestor w
widget GType
windowGType
(ManagedPtr Window -> Window) -> Widget -> IO (Maybe Window)
forall o o'.
(HasCallStack, ManagedPtrNewtype o, TypedObject o,
ManagedPtrNewtype o', TypedObject o', GObject o') =>
(ManagedPtr o' -> o') -> o -> IO (Maybe o')
castTo ManagedPtr Window -> Window
Window Widget
ancestor
displayPopup :: (Gtk.IsWidget w, Gtk.IsWidget wnd, Gtk.IsWindow wnd) =>
w
-> wnd
-> IO ()
w
widget wnd
window = do
wnd -> WindowPosition -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWindow a) =>
a -> WindowPosition -> m ()
windowSetPosition wnd
window WindowPosition
WindowPositionMouse
(Int32
x, Int32
y ) <- wnd -> IO (Int32, Int32)
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWindow a) =>
a -> m (Int32, Int32)
windowGetPosition wnd
window
(Requisition
_, Requisition
natReq) <- Widget -> IO (Requisition, Requisition)
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> m (Requisition, Requisition)
widgetGetPreferredSize (Widget -> IO (Requisition, Requisition))
-> IO Widget -> IO (Requisition, Requisition)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< w -> IO Widget
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> m Widget
widgetGetToplevel w
widget
Int32
y' <- Requisition -> IO Int32
forall (m :: * -> *). MonadIO m => Requisition -> m Int32
getRequisitionHeight Requisition
natReq
wnd -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> m ()
widgetShowAll wnd
window
if Int32
y Int32 -> Int32 -> Bool
forall a. Ord a => a -> a -> Bool
> Int32
y'
then wnd -> Int32 -> Int32 -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWindow a) =>
a -> Int32 -> Int32 -> m ()
windowMove wnd
window Int32
x (Int32
y Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
- Int32
y')
else wnd -> Int32 -> Int32 -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWindow a) =>
a -> Int32 -> Int32 -> m ()
windowMove wnd
window Int32
x Int32
y'
widgetGetAllocatedSize
:: (Gtk.IsWidget self, MonadIO m)
=> self -> m (Int, Int)
widgetGetAllocatedSize :: self -> m (Int, Int)
widgetGetAllocatedSize self
widget = do
Int32
w <- self -> m Int32
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> m Int32
Gtk.widgetGetAllocatedWidth self
widget
Int32
h <- self -> m Int32
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> m Int32
Gtk.widgetGetAllocatedHeight self
widget
(Int, Int) -> m (Int, Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
w, Int32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
h)
colorize :: String
-> String
-> String
-> String
colorize :: String -> String -> String -> String
colorize String
fg String
bg = String -> String -> String -> String -> String
forall r. PrintfType r => String -> r
printf String
"<span%s%s>%s</span>" (String -> String -> String
forall (t :: * -> *) t a.
(Foldable t, PrintfArg t, PrintfArg (t a)) =>
t -> t a -> String
attr String
"fg" String
fg) (String -> String -> String
forall (t :: * -> *) t a.
(Foldable t, PrintfArg t, PrintfArg (t a)) =>
t -> t a -> String
attr String
"bg" String
bg)
where attr :: t -> t a -> String
attr t
name t a
value
| t a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null t a
value = String
""
| Bool
otherwise = String -> t -> t a -> String
forall r. PrintfType r => String -> r
printf String
" %scolor=\"%s\"" t
name t a
value
backgroundLoop :: IO a -> IO ()
backgroundLoop :: IO a -> IO ()
backgroundLoop = IO ThreadId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ThreadId -> IO ()) -> (IO a -> IO ThreadId) -> IO a -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> (IO a -> IO ()) -> IO a -> IO ThreadId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO a -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever
drawOn :: Gtk.IsWidget object => object -> IO () -> IO object
drawOn :: object -> IO () -> IO object
drawOn object
drawArea IO ()
action = object -> IO () -> IO SignalHandlerId
forall a (m :: * -> *).
(IsWidget a, MonadIO m) =>
a -> IO () -> m SignalHandlerId
Gtk.onWidgetRealize object
drawArea IO ()
action IO SignalHandlerId -> object -> IO object
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> object
drawArea
widgetSetClassGI :: (Gtk.IsWidget b, MonadIO m) => b -> T.Text -> m b
widgetSetClassGI :: b -> Text -> m b
widgetSetClassGI b
widget Text
klass =
b -> m StyleContext
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> m StyleContext
Gtk.widgetGetStyleContext b
widget m StyleContext -> (StyleContext -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
(StyleContext -> Text -> m ()) -> Text -> StyleContext -> m ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip StyleContext -> Text -> m ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsStyleContext a) =>
a -> Text -> m ()
Gtk.styleContextAddClass Text
klass m () -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> b -> m b
forall (m :: * -> *) a. Monad m => a -> m a
return b
widget
themeLoadFlags :: [Gtk.IconLookupFlags]
themeLoadFlags :: [IconLookupFlags]
themeLoadFlags =
[ IconLookupFlags
Gtk.IconLookupFlagsGenericFallback
, IconLookupFlags
Gtk.IconLookupFlagsUseBuiltin
]
getImageForDesktopEntry :: Int32 -> DesktopEntry -> IO (Maybe GI.Pixbuf)
getImageForDesktopEntry :: Int32 -> DesktopEntry -> IO (Maybe Pixbuf)
getImageForDesktopEntry Int32
size DesktopEntry
de = Maybe Text -> Int32 -> IO (Maybe Pixbuf)
getImageForMaybeIconName (String -> Text
T.pack (String -> Text) -> Maybe String -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DesktopEntry -> Maybe String
deIcon DesktopEntry
de) Int32
size
getImageForMaybeIconName :: Maybe T.Text -> Int32 -> IO (Maybe GI.Pixbuf)
getImageForMaybeIconName :: Maybe Text -> Int32 -> IO (Maybe Pixbuf)
getImageForMaybeIconName Maybe Text
mIconName Int32
size =
Maybe (Maybe Pixbuf) -> Maybe Pixbuf
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Maybe (Maybe Pixbuf) -> Maybe Pixbuf)
-> IO (Maybe (Maybe Pixbuf)) -> IO (Maybe Pixbuf)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Maybe (IO (Maybe Pixbuf)) -> IO (Maybe (Maybe Pixbuf))
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA (Maybe (IO (Maybe Pixbuf)) -> IO (Maybe (Maybe Pixbuf)))
-> Maybe (IO (Maybe Pixbuf)) -> IO (Maybe (Maybe Pixbuf))
forall a b. (a -> b) -> a -> b
$ (Text -> Int32 -> IO (Maybe Pixbuf))
-> Int32 -> Text -> IO (Maybe Pixbuf)
forall a b c. (a -> b -> c) -> b -> a -> c
flip Text -> Int32 -> IO (Maybe Pixbuf)
getImageForIconName Int32
size (Text -> IO (Maybe Pixbuf))
-> Maybe Text -> Maybe (IO (Maybe Pixbuf))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
mIconName)
getImageForIconName :: T.Text -> Int32 -> IO (Maybe GI.Pixbuf)
getImageForIconName :: Text -> Int32 -> IO (Maybe Pixbuf)
getImageForIconName Text
iconName Int32
size =
IO (Maybe Pixbuf) -> IO (Maybe Pixbuf) -> IO (Maybe Pixbuf)
forall (m :: * -> *) a.
Monad m =>
m (Maybe a) -> m (Maybe a) -> m (Maybe a)
maybeTCombine (Int32 -> Text -> IO (Maybe Pixbuf)
loadPixbufByName Int32
size (Text -> IO (Maybe Pixbuf)) -> Text -> IO (Maybe Pixbuf)
forall a b. (a -> b) -> a -> b
$ Text
iconName)
(String -> IO (Maybe Pixbuf)
getPixbufFromFilePath (Text -> String
T.unpack Text
iconName) 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
Gtk.OrientationHorizontal))
loadPixbufByName :: Int32 -> T.Text -> IO (Maybe GI.Pixbuf)
loadPixbufByName :: Int32 -> Text -> IO (Maybe Pixbuf)
loadPixbufByName Int32
size Text
name = do
IconTheme
iconTheme <- IO IconTheme
forall (m :: * -> *). (HasCallStack, MonadIO m) => m IconTheme
Gtk.iconThemeGetDefault
Bool
hasIcon <- IconTheme -> Text -> IO Bool
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsIconTheme a) =>
a -> Text -> m Bool
Gtk.iconThemeHasIcon IconTheme
iconTheme Text
name
if Bool
hasIcon
then IconTheme
-> Text -> Int32 -> [IconLookupFlags] -> IO (Maybe Pixbuf)
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsIconTheme a) =>
a -> Text -> Int32 -> [IconLookupFlags] -> m (Maybe Pixbuf)
Gtk.iconThemeLoadIcon IconTheme
iconTheme Text
name Int32
size [IconLookupFlags]
themeLoadFlags
else Maybe Pixbuf -> IO (Maybe Pixbuf)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Pixbuf
forall a. Maybe a
Nothing
alignCenter :: (Gtk.IsWidget o, MonadIO m) => o -> m ()
alignCenter :: o -> m ()
alignCenter o
widget =
o -> Align -> m ()
forall (m :: * -> *) o.
(MonadIO m, IsWidget o) =>
o -> Align -> m ()
Gtk.setWidgetValign o
widget Align
Gtk.AlignCenter m () -> m () -> m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
o -> Align -> m ()
forall (m :: * -> *) o.
(MonadIO m, IsWidget o) =>
o -> Align -> m ()
Gtk.setWidgetHalign o
widget Align
Gtk.AlignCenter
vFillCenter :: (Gtk.IsWidget o, MonadIO m) => o -> m ()
vFillCenter :: o -> m ()
vFillCenter o
widget =
o -> Bool -> m ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> Bool -> m ()
Gtk.widgetSetVexpand o
widget Bool
True m () -> m () -> m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
o -> Align -> m ()
forall (m :: * -> *) o.
(MonadIO m, IsWidget o) =>
o -> Align -> m ()
Gtk.setWidgetValign o
widget Align
Gtk.AlignFill m () -> m () -> m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
o -> Align -> m ()
forall (m :: * -> *) o.
(MonadIO m, IsWidget o) =>
o -> Align -> m ()
Gtk.setWidgetHalign o
widget Align
Gtk.AlignCenter
pixbufNewFromFileAtScaleByHeight :: Int32 -> String -> IO (Either String PB.Pixbuf)
pixbufNewFromFileAtScaleByHeight :: Int32 -> String -> IO (Either String Pixbuf)
pixbufNewFromFileAtScaleByHeight Int32
height String
name =
(Either GError (Maybe Pixbuf) -> Either String Pixbuf)
-> IO (Either GError (Maybe Pixbuf)) -> IO (Either String Pixbuf)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Either String (Maybe Pixbuf) -> Either String Pixbuf
forall a. Either String (Maybe a) -> Either String a
handleResult (Either String (Maybe Pixbuf) -> Either String Pixbuf)
-> (Either GError (Maybe Pixbuf) -> Either String (Maybe Pixbuf))
-> Either GError (Maybe Pixbuf)
-> Either String Pixbuf
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GError -> String)
-> Either GError (Maybe Pixbuf) -> Either String (Maybe Pixbuf)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first GError -> String
forall a. Show a => a -> String
show) (IO (Either GError (Maybe Pixbuf)) -> IO (Either String Pixbuf))
-> IO (Either GError (Maybe Pixbuf)) -> IO (Either String Pixbuf)
forall a b. (a -> b) -> a -> b
$ IO (Maybe Pixbuf) -> IO (Either GError (Maybe Pixbuf))
forall a. IO a -> IO (Either GError a)
catchGErrorsAsLeft (IO (Maybe Pixbuf) -> IO (Either GError (Maybe Pixbuf)))
-> IO (Maybe Pixbuf) -> IO (Either GError (Maybe Pixbuf))
forall a b. (a -> b) -> a -> b
$
String -> Int32 -> Int32 -> Bool -> IO (Maybe Pixbuf)
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
String -> Int32 -> Int32 -> Bool -> m (Maybe Pixbuf)
PB.pixbufNewFromFileAtScale String
name (-Int32
1) Int32
height Bool
True
where
#if MIN_VERSION_gi_gdkpixbuf(2,0,26)
handleResult :: Either String (Maybe a) -> Either String a
handleResult = Either String (Either String a) -> Either String a
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Either String (Either String a) -> Either String a)
-> (Either String (Maybe a) -> Either String (Either String a))
-> Either String (Maybe a)
-> Either String a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe a -> Either String a)
-> Either String (Maybe a) -> Either String (Either String a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Either String a
-> (a -> Either String a) -> Maybe a -> Either String a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Either String a
forall a b. a -> Either a b
Left String
"gdk function returned NULL") a -> Either String a
forall a b. b -> Either a b
Right)
#else
handleResult = id
#endif
loadIcon :: Int32 -> String -> IO (Either String PB.Pixbuf)
loadIcon :: Int32 -> String -> IO (Either String Pixbuf)
loadIcon Int32
height String
name =
((String -> String -> String
</> String
"icons" String -> String -> String
</> String
name) (String -> String) -> IO String -> IO String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO String
getDataDir) IO String
-> (String -> IO (Either String Pixbuf))
-> IO (Either String Pixbuf)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
Int32 -> String -> IO (Either String Pixbuf)
pixbufNewFromFileAtScaleByHeight Int32
height
setMinWidth :: (Gtk.IsWidget w, MonadIO m) => Int -> w -> m w
setMinWidth :: Int -> w -> m w
setMinWidth Int
width w
widget = IO w -> m w
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO w -> m w) -> IO w -> m w
forall a b. (a -> b) -> a -> b
$ do
w -> Int32 -> Int32 -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> Int32 -> Int32 -> m ()
Gtk.widgetSetSizeRequest w
widget (Int -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
width) (-Int32
1)
w -> IO w
forall (m :: * -> *) a. Monad m => a -> m a
return w
widget