    {-# LANGUAGE TypeApplications #-}
    -----------------------------------------------------------------------------
    -- |
    -- 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.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 )

    -- | 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 :: [EventType] -> IO a -> EventButton -> IO Bool
    onClick triggers :: [EventType]
    triggers action :: IO a
    action btn :: 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

    -- | 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 :: w -> Text -> wnd -> IO ()
    attachPopup widget :: w
    widget title :: Text
    title window :: 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 ancestor :: 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

    -- | 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 :: w -> wnd -> IO ()
    displayPopup widget :: w
    widget window :: wnd
    window = do
      wnd -> WindowPosition -> IO ()
    forall (m :: * -> *) a.
    (HasCallStack, MonadIO m, IsWindow a) =>
    a -> WindowPosition -> m ()
    windowSetPosition wnd
    window WindowPosition
    WindowPositionMouse
      (x :: Int32
    x, y :: Int32
    y ) <- wnd -> IO (Int32, Int32)
    forall (m :: * -> *) a.
    (HasCallStack, MonadIO m, IsWindow a) =>
    a -> m (Int32, Int32)
    windowGetPosition wnd
    window
      (_, natReq :: 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 widget :: 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)

    -- | 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 fg :: String
    fg bg :: String
    bg = String -> String -> String -> String -> String
    forall r. PrintfType r => String -> r
    printf "<span%s%s>%s</span>" (String -> String -> String
    forall (t :: * -> *) t a.
    (Foldable t, PrintfArg t, PrintfArg (t a)) =>
    t -> t a -> String
    attr "fg" String
    fg) (String -> String -> String
    forall (t :: * -> *) t a.
    (Foldable t, PrintfArg t, PrintfArg (t a)) =>
    t -> t a -> String
    attr "bg" String
    bg)
      where attr :: t -> t a -> String
    attr name :: t
    name value :: t a
    value
              | t a -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null t a
    value = ""
              | Bool
    otherwise  = String -> t -> t a -> String
    forall r. PrintfType r => String -> r
    printf " %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 drawArea :: object
    drawArea action :: 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 widget :: b
    widget klass :: 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 size :: Int32
    size de :: 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 mIconName :: Maybe Text
    mIconName size :: 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 iconName :: Text
    iconName size :: 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 size :: Int32
    size name :: 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 widget :: 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 widget :: 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 PB.Pixbuf
    pixbufNewFromFileAtScaleByHeight :: Int32 -> String -> IO Pixbuf
    pixbufNewFromFileAtScaleByHeight height :: Int32
    height name :: String
    name =
      String -> Int32 -> Int32 -> Bool -> IO Pixbuf
    forall (m :: * -> *).
    (HasCallStack, MonadIO m) =>
    String -> Int32 -> Int32 -> Bool -> m Pixbuf
    PB.pixbufNewFromFileAtScale String
    name (-1) Int32
    height Bool
    True

    loadIcon :: Int32 -> String -> IO PB.Pixbuf
    loadIcon :: Int32 -> String -> IO Pixbuf
    loadIcon height :: Int32
    height name :: String
    name =
      ((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 Pixbuf) -> IO Pixbuf
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>=
      Int32 -> String -> IO Pixbuf
    pixbufNewFromFileAtScaleByHeight Int32
    height

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