{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE CPP #-}
-----------------------------------------------------------------------------
-- |
-- 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
  EventType
click <- EventButton -> IO EventType
forall (m :: * -> *). MonadIO m => EventButton -> m EventType
D.getEventButtonType EventButton
btn
  if EventType
click EventType -> [EventType] -> Bool
forall a. Eq a => a -> [a] -> 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 a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
  else Bool -> IO Bool
forall a. a -> IO a
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 :: 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
  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 <- 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

-- | 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
  (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 :: forall self (m :: * -> *).
(IsWidget self, MonadIO m) =>
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 a. a -> m a
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 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
<$> Maybe (IO (Maybe Pixbuf)) -> IO (Maybe (Maybe Pixbuf))
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
forall (f :: * -> *) a. Applicative f => Maybe (f a) -> f (Maybe a)
sequenceA ((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
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
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 a. a -> IO a
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 :: 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
  StyleContext
context <- a -> m StyleContext
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> m StyleContext
Gtk.widgetGetStyleContext a
widget
  StyleContext -> Text -> m Bool
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsStyleContext a) =>
a -> Text -> m Bool
Gtk.styleContextHasClass StyleContext
context Text
klass m Bool -> (Bool -> 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
>>=
       (Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
`when` StyleContext -> Text -> m ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsStyleContext a) =>
a -> Text -> m ()
Gtk.styleContextAddClass StyleContext
context Text
klass) (Bool -> m ()) -> (Bool -> Bool) -> Bool -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Bool
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
  StyleContext
context <- a -> m StyleContext
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> m StyleContext
Gtk.widgetGetStyleContext a
widget
  StyleContext -> Text -> m Bool
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsStyleContext a) =>
a -> Text -> m Bool
Gtk.styleContextHasClass StyleContext
context Text
klass m Bool -> (Bool -> 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
>>=
       (Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
`when` StyleContext -> Text -> m ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsStyleContext a) =>
a -> Text -> m ()
Gtk.styleContextRemoveClass StyleContext
context Text
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
  Box
innerBox <- Orientation -> Int32 -> IO Box
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Orientation -> Int32 -> m Box
Gtk.boxNew Orientation
Gtk.OrientationHorizontal Int32
0
  Box
outerBox <- Orientation -> Int32 -> IO Box
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Orientation -> Int32 -> m Box
Gtk.boxNew Orientation
Gtk.OrientationHorizontal Int32
0
  Box -> Align -> IO ()
forall (m :: * -> *) o.
(MonadIO m, IsWidget o) =>
o -> Align -> m ()
Gtk.setWidgetValign Box
innerBox Align
Gtk.AlignFill
  Box -> Align -> IO ()
forall (m :: * -> *) o.
(MonadIO m, IsWidget o) =>
o -> Align -> m ()
Gtk.setWidgetValign Box
outerBox Align
Gtk.AlignFill
  Box -> Widget -> IO ()
forall (m :: * -> *) a b.
(HasCallStack, MonadIO m, IsContainer a, IsWidget b) =>
a -> b -> m ()
Gtk.containerAdd Box
innerBox Widget
contents
  Box -> Box -> IO ()
forall (m :: * -> *) a b.
(HasCallStack, MonadIO m, IsContainer a, IsWidget b) =>
a -> b -> m ()
Gtk.containerAdd Box
outerBox Box
innerBox
  Box
_ <- Box -> Text -> IO Box
forall b (m :: * -> *). (IsWidget b, MonadIO m) => b -> Text -> m b
widgetSetClassGI Box
innerBox Text
"inner-pad"
  Box
_ <- Box -> Text -> IO Box
forall b (m :: * -> *). (IsWidget b, MonadIO m) => b -> Text -> m b
widgetSetClassGI Box
outerBox Text
"outer-pad"
  Box -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> m ()
Gtk.widgetShow Box
outerBox
  Box -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> m ()
Gtk.widgetShow Box
innerBox
  Box -> IO Widget
forall (m :: * -> *) o. (MonadIO m, IsWidget o) => o -> m Widget
Gtk.toWidget Box
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
  Box
contents <- Orientation -> Int32 -> IO Box
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Orientation -> Int32 -> m Box
Gtk.boxNew Orientation
Gtk.OrientationHorizontal Int32
0
  Box -> Widget -> IO ()
forall (m :: * -> *) a b.
(HasCallStack, MonadIO m, IsContainer a, IsWidget b) =>
a -> b -> m ()
Gtk.containerAdd Box
contents Widget
widget
  Box
_ <- Box -> Text -> IO Box
forall b (m :: * -> *). (IsWidget b, MonadIO m) => b -> Text -> m b
widgetSetClassGI Box
contents Text
"contents"
  Box -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> m ()
Gtk.widgetShowAll Box
contents
  Box -> IO Widget
forall (m :: * -> *) o. (MonadIO m, IsWidget o) => o -> m Widget
Gtk.toWidget Box
contents IO Widget -> (Widget -> IO Widget) -> IO Widget
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Widget -> IO Widget
forall (m :: * -> *). MonadIO m => Widget -> m Widget
buildPadBox