{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE OverloadedStrings #-}

-----------------------------------------------------------------------------
-- |
-- Module      : System.Taffybar.Widget.Util
-- Copyright   : (c) Ivan Malison
-- License     : BSD3-style (see LICENSE)
--
-- Maintainer  : Ivan Malison <IvanMalison@gmail.com>
-- Stability   : unstable
-- Portability : unportable
--
-- Utility functions to facilitate building GTK interfaces.
--
-----------------------------------------------------------------------------

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.GI.Base.Overloading (IsDescendantOf)
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.Environment.XDG.DesktopEntry
import           System.FilePath.Posix
import           System.Taffybar.Util
import           Text.Printf

import           Paths_taffybar ( getDataDir )

-- | Execute the given action as a response to any of the given types
-- of mouse button clicks.
onClick :: [D.EventType] -- ^ Types of button clicks to listen to.
        -> IO a    -- ^ Action to execute.
        -> D.EventButton
        -> IO Bool
onClick :: forall a. [EventType] -> IO a -> EventButton -> IO Bool
onClick [EventType]
triggers IO a
action EventButton
btn = do
  click <- EventButton -> IO EventType
forall (m :: * -> *). MonadIO m => EventButton -> m EventType
D.getEventButtonType EventButton
btn
  if click `elem` triggers
  then action >> return True
  else return False

-- | Attach the given widget as a popup with the given title to the
-- given window. The newly attached popup is not shown initially. Use
-- the 'displayPopup' function to display it.
attachPopup :: (Gtk.IsWidget w, Gtk.IsWindow wnd) =>
               w      -- ^ The widget to set as popup.
            -> T.Text -- ^ The title of the popup.
            -> wnd    -- ^ The window to attach the popup to.
            -> IO ()
attachPopup :: forall w wnd.
(IsWidget w, IsWindow wnd) =>
w -> Text -> wnd -> IO ()
attachPopup 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
  transient <- IO (Maybe Window)
getWindow
  windowSetTransientFor window transient
  windowSetKeepAbove window True
  windowStick window
  where
    getWindow :: IO (Maybe Window)
    getWindow :: IO (Maybe Window)
getWindow = do
          windowGType <- forall a. TypedObject a => IO GType
glibType @Window
          Just ancestor <- Gtk.widgetGetAncestor widget windowGType
          castTo Window ancestor

-- | Display the given popup widget (previously prepared using the
-- 'attachPopup' function) immediately beneath (or above) the given
-- window.
displayPopup :: (Gtk.IsWidget w, Gtk.IsWidget wnd, Gtk.IsWindow wnd) =>
                w   -- ^ The popup widget.
             -> wnd -- ^ The window the widget was attached to.
             -> IO ()
displayPopup :: forall w wnd.
(IsWidget w, IsWidget wnd, IsWindow wnd) =>
w -> wnd -> IO ()
displayPopup w
widget wnd
window = do
  wnd -> WindowPosition -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWindow a) =>
a -> WindowPosition -> m ()
windowSetPosition wnd
window WindowPosition
WindowPositionMouse
  (x, y ) <- wnd -> IO (Int32, Int32)
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWindow a) =>
a -> m (Int32, Int32)
windowGetPosition wnd
window
  (_, natReq) <- widgetGetPreferredSize =<< widgetGetToplevel widget
  y' <- getRequisitionHeight natReq
  widgetShowAll window
  if y > y'
    then windowMove window x (y - y')
    else windowMove window x y'

widgetGetAllocatedSize
  :: (Gtk.IsWidget self, MonadIO m)
  => self -> m (Int, Int)
widgetGetAllocatedSize :: forall self (m :: * -> *).
(IsWidget self, MonadIO m) =>
self -> m (Int, Int)
widgetGetAllocatedSize self
widget = do
  w <- self -> m Int32
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> m Int32
Gtk.widgetGetAllocatedWidth self
widget
  h <- Gtk.widgetGetAllocatedHeight widget
  return (fromIntegral w, fromIntegral h)

-- | Creates markup with the given foreground and background colors and the
-- given contents.
colorize :: String -- ^ Foreground color.
         -> String -- ^ Background color.
         -> String -- ^ Contents.
         -> 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 :: * -> *} {a} {t} {a}.
(Foldable t, IsString a, PrintfArg t, PrintfArg (t a),
 PrintfType a) =>
t -> t a -> a
attr (String
"fg" :: String) String
fg :: String) (String -> String -> String
forall {t :: * -> *} {a} {t} {a}.
(Foldable t, IsString a, PrintfArg t, PrintfArg (t a),
 PrintfType a) =>
t -> t a -> a
attr (String
"bg" :: String) String
bg :: String)
  where attr :: t -> t a -> a
attr t
name t a
value
          | t a -> Bool
forall a. t a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null t a
value = a
""
          | Bool
otherwise  = String -> t -> t a -> a
forall r. PrintfType r => String -> r
printf String
" %scolor=\"%s\"" t
name t a
value

backgroundLoop :: IO a -> IO ()
backgroundLoop :: forall a. 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 :: forall object. IsWidget object => object -> IO () -> IO object
drawOn object
drawArea IO ()
action = object -> ((?self::object) => IO ()) -> IO SignalHandlerId
forall a (m :: * -> *).
(IsWidget a, MonadIO m) =>
a -> ((?self::a) => IO ()) -> m SignalHandlerId
Gtk.onWidgetRealize object
drawArea IO ()
(?self::object) => 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 :: forall b (m :: * -> *). (IsWidget b, MonadIO m) => 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 a b. m a -> (a -> m b) -> m b
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 a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> b -> m b
forall a. a -> m a
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
<$> (Text -> IO (Maybe Pixbuf))
-> Maybe Text -> IO (Maybe (Maybe Pixbuf))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe b)
traverse (Text -> Int32 -> IO (Maybe Pixbuf)
`getImageForIconName` Int32
size) 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
iconName)
                  (String -> IO (Maybe Pixbuf)
getPixbufFromFilePath (Text -> String
T.unpack Text
iconName) IO (Maybe Pixbuf)
-> (Maybe Pixbuf -> IO (Maybe Pixbuf)) -> IO (Maybe Pixbuf)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
                   (Pixbuf -> IO Pixbuf) -> Maybe Pixbuf -> IO (Maybe Pixbuf)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe b)
traverse (Int32 -> Orientation -> Pixbuf -> IO Pixbuf
scalePixbufToSize Int32
size Orientation
Gtk.OrientationHorizontal))

loadPixbufByName :: Int32 -> T.Text -> IO (Maybe GI.Pixbuf)
loadPixbufByName :: Int32 -> Text -> IO (Maybe Pixbuf)
loadPixbufByName Int32
size Text
name = do
  iconTheme <- IO IconTheme
forall (m :: * -> *). (HasCallStack, MonadIO m) => m IconTheme
Gtk.iconThemeGetDefault
  hasIcon <- Gtk.iconThemeHasIcon iconTheme name
  if hasIcon
  then Gtk.iconThemeLoadIcon iconTheme name size themeLoadFlags
  else return Nothing

alignCenter :: (Gtk.IsWidget o, MonadIO m) => o -> m ()
alignCenter :: forall o (m :: * -> *). (IsWidget o, MonadIO m) => 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 a b. m a -> m b -> m b
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 :: forall o (m :: * -> *). (IsWidget o, MonadIO m) => 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 a b. m a -> m b -> m b
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 a b. m a -> m b -> m b
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 a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Either String (Maybe Pixbuf) -> Either String Pixbuf
forall {b}. Either String (Maybe b) -> Either String b
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 a b c. (a -> b) -> Either a c -> Either b c
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
    handleResult :: Either String (Maybe b) -> Either String b
handleResult = (Either String b
-> (b -> Either String b) -> Maybe b -> Either String b
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Either String b
forall a b. a -> Either a b
Left String
"gdk function returned NULL") b -> Either String b
forall a b. b -> Either a b
Right (Maybe b -> Either String b)
-> Either String (Maybe b) -> Either String b
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<)

loadIcon :: Int32 -> String -> IO (Either String PB.Pixbuf)
loadIcon :: Int32 -> String -> IO (Either String Pixbuf)
loadIcon Int32
height String
name =
  IO String
getDataDir IO String
-> (String -> IO (Either String Pixbuf))
-> IO (Either String Pixbuf)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
  Int32 -> String -> IO (Either String Pixbuf)
pixbufNewFromFileAtScaleByHeight Int32
height (String -> IO (Either String Pixbuf))
-> (String -> String) -> String -> IO (Either String Pixbuf)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> String -> String
</> String
"icons" String -> String -> String
</> String
name)

setMinWidth :: (Gtk.IsWidget w, MonadIO m) => Int -> w -> m w
setMinWidth :: forall w (m :: * -> *). (IsWidget w, MonadIO m) => Int -> w -> m w
setMinWidth Int
width w
widget = IO w -> m w
forall a. IO a -> m a
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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return w
widget

addClassIfMissing ::
  (IsDescendantOf Widget a, MonadIO m, GObject a) => T.Text -> a -> m ()
addClassIfMissing :: forall a (m :: * -> *).
(IsDescendantOf Widget a, MonadIO m, GObject a) =>
Text -> a -> m ()
addClassIfMissing Text
klass a
widget = do
  context <- a -> m StyleContext
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> m StyleContext
Gtk.widgetGetStyleContext a
widget
  Gtk.styleContextHasClass context klass >>=
       (`when` Gtk.styleContextAddClass context klass) . not

removeClassIfPresent ::
  (IsDescendantOf Widget a, MonadIO m, GObject a) => T.Text -> a -> m ()
removeClassIfPresent :: forall a (m :: * -> *).
(IsDescendantOf Widget a, MonadIO m, GObject a) =>
Text -> a -> m ()
removeClassIfPresent Text
klass a
widget = do
  context <- a -> m StyleContext
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> m StyleContext
Gtk.widgetGetStyleContext a
widget
  Gtk.styleContextHasClass context klass >>=
       (`when` Gtk.styleContextRemoveClass context klass)

-- | Wrap a widget with two container boxes. The inner box will have the class
-- "inner-pad", and the outer box will have the class "outer-pad". These boxes
-- can be used to add padding between the outline of the widget and its
-- contents, or for the purpose of displaying a different background behind the
-- widget.
buildPadBox :: MonadIO m => Gtk.Widget -> m Gtk.Widget
buildPadBox :: forall (m :: * -> *). MonadIO m => Widget -> m Widget
buildPadBox Widget
contents = IO Widget -> m Widget
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Widget -> m Widget) -> IO Widget -> m Widget
forall a b. (a -> b) -> a -> b
$ do
  innerBox <- Orientation -> Int32 -> IO Box
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Orientation -> Int32 -> m Box
Gtk.boxNew Orientation
Gtk.OrientationHorizontal Int32
0
  outerBox <- Gtk.boxNew Gtk.OrientationHorizontal 0
  Gtk.setWidgetValign innerBox Gtk.AlignFill
  Gtk.setWidgetValign outerBox Gtk.AlignFill
  Gtk.containerAdd innerBox contents
  Gtk.containerAdd outerBox innerBox
  _ <- widgetSetClassGI innerBox "inner-pad"
  _ <- widgetSetClassGI outerBox "outer-pad"
  Gtk.widgetShow outerBox
  Gtk.widgetShow innerBox
  Gtk.toWidget outerBox

buildContentsBox :: MonadIO m => Gtk.Widget -> m Gtk.Widget
buildContentsBox :: forall (m :: * -> *). MonadIO m => Widget -> m Widget
buildContentsBox Widget
widget = IO Widget -> m Widget
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Widget -> m Widget) -> IO Widget -> m Widget
forall a b. (a -> b) -> a -> b
$ do
  contents <- Orientation -> Int32 -> IO Box
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Orientation -> Int32 -> m Box
Gtk.boxNew Orientation
Gtk.OrientationHorizontal Int32
0
  Gtk.containerAdd contents widget
  _ <- widgetSetClassGI contents "contents"
  Gtk.widgetShowAll contents
  Gtk.toWidget contents >>= buildPadBox