{-# LANGUAGE OverloadedStrings #-}
module System.Taffybar.Widget.Generic.AutoSizeImage where

import qualified Control.Concurrent.MVar as MV
import           Control.Monad
import           Control.Monad.IO.Class
import           Data.Int
import           Data.Maybe
import qualified Data.Text as T
import qualified GI.Gdk as Gdk
import           GI.GdkPixbuf.Objects.Pixbuf as Gdk
import qualified GI.Gtk as Gtk
import           StatusNotifier.Tray (scalePixbufToSize)
import           System.Log.Logger
import           System.Taffybar.Util
import           System.Taffybar.Widget.Util
import           Text.Printf

imageLog :: Priority -> String -> IO ()
imageLog :: Priority -> String -> IO ()
imageLog = String -> Priority -> String -> IO ()
logM String
"System.Taffybar.Widget.Generic.AutoSizeImage"

borderFunctions :: [Gtk.StyleContext -> [Gtk.StateFlags] -> IO Gtk.Border]
borderFunctions :: [StyleContext -> [StateFlags] -> IO Border]
borderFunctions =
  [ StyleContext -> [StateFlags] -> IO Border
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsStyleContext a) =>
a -> [StateFlags] -> m Border
Gtk.styleContextGetPadding
  , StyleContext -> [StateFlags] -> IO Border
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsStyleContext a) =>
a -> [StateFlags] -> m Border
Gtk.styleContextGetMargin
  , StyleContext -> [StateFlags] -> IO Border
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsStyleContext a) =>
a -> [StateFlags] -> m Border
Gtk.styleContextGetBorder
  ]

data BorderInfo = BorderInfo
  { BorderInfo -> Int16
borderTop :: Int16
  , BorderInfo -> Int16
borderBottom :: Int16
  , BorderInfo -> Int16
borderLeft :: Int16
  , BorderInfo -> Int16
borderRight :: Int16
  } deriving (Int -> BorderInfo -> ShowS
[BorderInfo] -> ShowS
BorderInfo -> String
(Int -> BorderInfo -> ShowS)
-> (BorderInfo -> String)
-> ([BorderInfo] -> ShowS)
-> Show BorderInfo
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> BorderInfo -> ShowS
showsPrec :: Int -> BorderInfo -> ShowS
$cshow :: BorderInfo -> String
show :: BorderInfo -> String
$cshowList :: [BorderInfo] -> ShowS
showList :: [BorderInfo] -> ShowS
Show, BorderInfo -> BorderInfo -> Bool
(BorderInfo -> BorderInfo -> Bool)
-> (BorderInfo -> BorderInfo -> Bool) -> Eq BorderInfo
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: BorderInfo -> BorderInfo -> Bool
== :: BorderInfo -> BorderInfo -> Bool
$c/= :: BorderInfo -> BorderInfo -> Bool
/= :: BorderInfo -> BorderInfo -> Bool
Eq)

borderInfoZero :: BorderInfo
borderInfoZero :: BorderInfo
borderInfoZero = Int16 -> Int16 -> Int16 -> Int16 -> BorderInfo
BorderInfo Int16
0 Int16
0 Int16
0 Int16
0

borderWidth, borderHeight :: BorderInfo -> Int16
borderWidth :: BorderInfo -> Int16
borderWidth BorderInfo
borderInfo = BorderInfo -> Int16
borderLeft BorderInfo
borderInfo Int16 -> Int16 -> Int16
forall a. Num a => a -> a -> a
+ BorderInfo -> Int16
borderRight BorderInfo
borderInfo
borderHeight :: BorderInfo -> Int16
borderHeight BorderInfo
borderInfo = BorderInfo -> Int16
borderTop BorderInfo
borderInfo Int16 -> Int16 -> Int16
forall a. Num a => a -> a -> a
+ BorderInfo -> Int16
borderBottom BorderInfo
borderInfo

toBorderInfo :: (MonadIO m) => Gtk.Border -> m BorderInfo
toBorderInfo :: forall (m :: * -> *). MonadIO m => Border -> m BorderInfo
toBorderInfo Border
border =
  Int16 -> Int16 -> Int16 -> Int16 -> BorderInfo
BorderInfo
  (Int16 -> Int16 -> Int16 -> Int16 -> BorderInfo)
-> m Int16 -> m (Int16 -> Int16 -> Int16 -> BorderInfo)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Border -> m Int16
forall (m :: * -> *). MonadIO m => Border -> m Int16
Gtk.getBorderTop Border
border
  m (Int16 -> Int16 -> Int16 -> BorderInfo)
-> m Int16 -> m (Int16 -> Int16 -> BorderInfo)
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Border -> m Int16
forall (m :: * -> *). MonadIO m => Border -> m Int16
Gtk.getBorderBottom Border
border
  m (Int16 -> Int16 -> BorderInfo)
-> m Int16 -> m (Int16 -> BorderInfo)
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Border -> m Int16
forall (m :: * -> *). MonadIO m => Border -> m Int16
Gtk.getBorderLeft Border
border
  m (Int16 -> BorderInfo) -> m Int16 -> m BorderInfo
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Border -> m Int16
forall (m :: * -> *). MonadIO m => Border -> m Int16
Gtk.getBorderRight Border
border

addBorderInfo :: BorderInfo -> BorderInfo -> BorderInfo
addBorderInfo :: BorderInfo -> BorderInfo -> BorderInfo
addBorderInfo
  (BorderInfo Int16
t1 Int16
b1 Int16
l1 Int16
r1)
  (BorderInfo Int16
t2 Int16
b2 Int16
l2 Int16
r2)
    = Int16 -> Int16 -> Int16 -> Int16 -> BorderInfo
BorderInfo (Int16
t1 Int16 -> Int16 -> Int16
forall a. Num a => a -> a -> a
+ Int16
t2) (Int16
b1 Int16 -> Int16 -> Int16
forall a. Num a => a -> a -> a
+ Int16
b2) (Int16
l1 Int16 -> Int16 -> Int16
forall a. Num a => a -> a -> a
+ Int16
l2) (Int16
r1 Int16 -> Int16 -> Int16
forall a. Num a => a -> a -> a
+ Int16
r2)

-- | Get the total size of the border (the sum of its assigned margin, border
-- and padding values) that will be drawn for a widget as a "BorderInfo" record.
getBorderInfo :: (MonadIO m, Gtk.IsWidget a) => a -> m BorderInfo
getBorderInfo :: forall (m :: * -> *) a.
(MonadIO m, IsWidget a) =>
a -> m BorderInfo
getBorderInfo a
widget = IO BorderInfo -> m BorderInfo
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO BorderInfo -> m BorderInfo) -> IO BorderInfo -> m BorderInfo
forall a b. (a -> b) -> a -> b
$ do
  [StateFlags]
stateFlags <- a -> IO [StateFlags]
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> m [StateFlags]
Gtk.widgetGetStateFlags a
widget
  StyleContext
styleContext <- a -> IO StyleContext
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> m StyleContext
Gtk.widgetGetStyleContext a
widget

  let getBorderInfoFor :: (StyleContext -> [StateFlags] -> IO Border) -> IO BorderInfo
getBorderInfoFor StyleContext -> [StateFlags] -> IO Border
borderFn =
        StyleContext -> [StateFlags] -> IO Border
borderFn StyleContext
styleContext [StateFlags]
stateFlags IO Border -> (Border -> IO BorderInfo) -> IO BorderInfo
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Border -> IO BorderInfo
forall (m :: * -> *). MonadIO m => Border -> m BorderInfo
toBorderInfo
      combineBorderInfo :: BorderInfo
-> (StyleContext -> [StateFlags] -> IO Border) -> IO BorderInfo
combineBorderInfo BorderInfo
lastSum StyleContext -> [StateFlags] -> IO Border
fn =
        BorderInfo -> BorderInfo -> BorderInfo
addBorderInfo BorderInfo
lastSum (BorderInfo -> BorderInfo) -> IO BorderInfo -> IO BorderInfo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (StyleContext -> [StateFlags] -> IO Border) -> IO BorderInfo
getBorderInfoFor StyleContext -> [StateFlags] -> IO Border
fn

  (BorderInfo
 -> (StyleContext -> [StateFlags] -> IO Border) -> IO BorderInfo)
-> BorderInfo
-> [StyleContext -> [StateFlags] -> IO Border]
-> IO BorderInfo
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM BorderInfo
-> (StyleContext -> [StateFlags] -> IO Border) -> IO BorderInfo
combineBorderInfo BorderInfo
borderInfoZero [StyleContext -> [StateFlags] -> IO Border]
borderFunctions

-- | Get the actual allocation for a "Gtk.Widget", accounting for the size of
-- its CSS assined margin, border and padding values.
getContentAllocation
  :: (MonadIO m, Gtk.IsWidget a)
  => a -> BorderInfo -> m Gdk.Rectangle
getContentAllocation :: forall (m :: * -> *) a.
(MonadIO m, IsWidget a) =>
a -> BorderInfo -> m Rectangle
getContentAllocation a
widget BorderInfo
borderInfo = do
  Rectangle
allocation <- a -> m Rectangle
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> m Rectangle
Gtk.widgetGetAllocation a
widget
  Int32
currentWidth <- Rectangle -> m Int32
forall (m :: * -> *). MonadIO m => Rectangle -> m Int32
Gdk.getRectangleWidth Rectangle
allocation
  Int32
currentHeight <- Rectangle -> m Int32
forall (m :: * -> *). MonadIO m => Rectangle -> m Int32
Gdk.getRectangleHeight Rectangle
allocation
  Int32
currentX <- Rectangle -> m Int32
forall (m :: * -> *). MonadIO m => Rectangle -> m Int32
Gdk.getRectangleX Rectangle
allocation
  Int32
currentY <- Rectangle -> m Int32
forall (m :: * -> *). MonadIO m => Rectangle -> m Int32
Gdk.getRectangleX Rectangle
allocation

  Rectangle -> Int32 -> m ()
forall (m :: * -> *). MonadIO m => Rectangle -> Int32 -> m ()
Gdk.setRectangleWidth Rectangle
allocation (Int32 -> m ()) -> Int32 -> m ()
forall a b. (a -> b) -> a -> b
$ Int32 -> Int32 -> Int32
forall a. Ord a => a -> a -> a
max Int32
1 (Int32 -> Int32) -> Int32 -> Int32
forall a b. (a -> b) -> a -> b
$
     Int32
currentWidth Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
- Int16 -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (BorderInfo -> Int16
borderWidth BorderInfo
borderInfo)
  Rectangle -> Int32 -> m ()
forall (m :: * -> *). MonadIO m => Rectangle -> Int32 -> m ()
Gdk.setRectangleHeight Rectangle
allocation (Int32 -> m ()) -> Int32 -> m ()
forall a b. (a -> b) -> a -> b
$ Int32 -> Int32 -> Int32
forall a. Ord a => a -> a -> a
max Int32
1 (Int32 -> Int32) -> Int32 -> Int32
forall a b. (a -> b) -> a -> b
$
     Int32
currentHeight Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
- Int16 -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (BorderInfo -> Int16
borderHeight BorderInfo
borderInfo)
  Rectangle -> Int32 -> m ()
forall (m :: * -> *). MonadIO m => Rectangle -> Int32 -> m ()
Gdk.setRectangleX Rectangle
allocation (Int32 -> m ()) -> Int32 -> m ()
forall a b. (a -> b) -> a -> b
$
     Int32
currentX Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
+ Int16 -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (BorderInfo -> Int16
borderLeft BorderInfo
borderInfo)
  Rectangle -> Int32 -> m ()
forall (m :: * -> *). MonadIO m => Rectangle -> Int32 -> m ()
Gdk.setRectangleY Rectangle
allocation (Int32 -> m ()) -> Int32 -> m ()
forall a b. (a -> b) -> a -> b
$
     Int32
currentY Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
+ Int16 -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (BorderInfo -> Int16
borderTop BorderInfo
borderInfo)

  Rectangle -> m Rectangle
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Rectangle
allocation

-- | Automatically update the "Gdk.Pixbuf" of a "Gtk.Image" using the provided
-- action whenever the "Gtk.Image" is allocated. Returns an action that forces a
-- refresh of the image through the provided action.
autoSizeImage
  :: MonadIO m
  => Gtk.Image
  -> (Int32 -> IO (Maybe Gdk.Pixbuf))
  -> Gtk.Orientation
  -> m (IO ())
autoSizeImage :: forall (m :: * -> *).
MonadIO m =>
Image -> (Int32 -> IO (Maybe Pixbuf)) -> Orientation -> m (IO ())
autoSizeImage Image
image Int32 -> IO (Maybe Pixbuf)
getPixbuf Orientation
orientation = IO (IO ()) -> m (IO ())
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IO ()) -> m (IO ())) -> IO (IO ()) -> m (IO ())
forall a b. (a -> b) -> a -> b
$ do
  case Orientation
orientation of
    Orientation
Gtk.OrientationHorizontal -> Image -> Bool -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> Bool -> m ()
Gtk.widgetSetVexpand Image
image Bool
True
    Orientation
_ -> Image -> Bool -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> Bool -> m ()
Gtk.widgetSetHexpand Image
image Bool
True

  Image
_ <- Image -> Text -> IO Image
forall b (m :: * -> *). (IsWidget b, MonadIO m) => b -> Text -> m b
widgetSetClassGI Image
image Text
"auto-size-image"

  MVar Int32
lastAllocation <- Int32 -> IO (MVar Int32)
forall a. a -> IO (MVar a)
MV.newMVar Int32
0
  -- XXX: Gtk seems to report information about padding etc inconsistently,
  -- which is why we look it up once, at startup. This means that we won't
  -- properly react to changes to these values, which could be a pretty nasty
  -- gotcha for someone down the line. :(
  BorderInfo
borderInfo <- Image -> IO BorderInfo
forall (m :: * -> *) a.
(MonadIO m, IsWidget a) =>
a -> m BorderInfo
getBorderInfo Image
image

  let setPixbuf :: Bool -> Rectangle -> IO ()
setPixbuf Bool
force Rectangle
allocation = do
        Int32
_width <- Rectangle -> IO Int32
forall (m :: * -> *). MonadIO m => Rectangle -> m Int32
Gdk.getRectangleWidth Rectangle
allocation
        Int32
_height <- Rectangle -> IO Int32
forall (m :: * -> *). MonadIO m => Rectangle -> m Int32
Gdk.getRectangleHeight Rectangle
allocation

        let width :: Int32
width = Int32 -> Int32 -> Int32
forall a. Ord a => a -> a -> a
max Int32
1 (Int32 -> Int32) -> Int32 -> Int32
forall a b. (a -> b) -> a -> b
$ Int32
_width Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
- Int16 -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (BorderInfo -> Int16
borderWidth BorderInfo
borderInfo)
            height :: Int32
height = Int32 -> Int32 -> Int32
forall a. Ord a => a -> a -> a
max Int32
1 (Int32 -> Int32) -> Int32 -> Int32
forall a b. (a -> b) -> a -> b
$ Int32
_height Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
- Int16 -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (BorderInfo -> Int16
borderHeight BorderInfo
borderInfo)
            size :: Int32
size =
              case Orientation
orientation of
                Orientation
Gtk.OrientationHorizontal -> Int32
height
                Orientation
_ -> Int32
width

        Int32
previousSize <- MVar Int32 -> IO Int32
forall a. MVar a -> IO a
MV.readMVar MVar Int32
lastAllocation

        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int32
size Int32 -> Int32 -> Bool
forall a. Eq a => a -> a -> Bool
/= Int32
previousSize Bool -> Bool -> Bool
|| Bool
force) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
          MVar Int32 -> (Int32 -> IO Int32) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
MV.modifyMVar_ MVar Int32
lastAllocation ((Int32 -> IO Int32) -> IO ()) -> (Int32 -> IO Int32) -> IO ()
forall a b. (a -> b) -> a -> b
$ IO Int32 -> Int32 -> IO Int32
forall a b. a -> b -> a
const (IO Int32 -> Int32 -> IO Int32) -> IO Int32 -> Int32 -> IO Int32
forall a b. (a -> b) -> a -> b
$ Int32 -> IO Int32
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Int32
size

          Maybe Pixbuf
pixbuf <- Int32 -> IO (Maybe Pixbuf)
getPixbuf Int32
size
          Int32
pbWidth <- Int32 -> Maybe Int32 -> Int32
forall a. a -> Maybe a -> a
fromMaybe Int32
0 (Maybe Int32 -> Int32) -> IO (Maybe Int32) -> IO Int32
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Pixbuf -> IO Int32) -> Maybe Pixbuf -> IO (Maybe Int32)
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 Pixbuf -> IO Int32
forall (m :: * -> *) o. (MonadIO m, IsPixbuf o) => o -> m Int32
Gdk.getPixbufWidth Maybe Pixbuf
pixbuf
          Int32
pbHeight <- Int32 -> Maybe Int32 -> Int32
forall a. a -> Maybe a -> a
fromMaybe Int32
0 (Maybe Int32 -> Int32) -> IO (Maybe Int32) -> IO Int32
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Pixbuf -> IO Int32) -> Maybe Pixbuf -> IO (Maybe Int32)
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 Pixbuf -> IO Int32
forall (m :: * -> *) o. (MonadIO m, IsPixbuf o) => o -> m Int32
Gdk.getPixbufHeight Maybe Pixbuf
pixbuf
          let pbSize :: Int32
pbSize = case Orientation
orientation of
                         Orientation
Gtk.OrientationHorizontal -> Int32
pbHeight
                         Orientation
_ -> Int32
pbWidth
              logLevel :: Priority
logLevel = if Int32
pbSize Int32 -> Int32 -> Bool
forall a. Ord a => a -> a -> Bool
<= Int32
size then Priority
DEBUG else Priority
WARNING

          Priority -> String -> IO ()
imageLog Priority
logLevel (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
                 String
-> String
-> String
-> String
-> String
-> String
-> String
-> ShowS
forall r. PrintfType r => String -> r
printf String
"Allocating image: size %s, width %s, \
                         \ height %s, aw: %s, ah: %s, pbw: %s pbh: %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
_width)
                 (Int32 -> String
forall a. Show a => a -> String
show Int32
_height)
                 (Int32 -> String
forall a. Show a => a -> String
show Int32
pbWidth)
                 (Int32 -> String
forall a. Show a => a -> String
show Int32
pbHeight)

          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 () -> IO ()
postGUIASync (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Image -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> m ()
Gtk.widgetQueueResize Image
image

  SignalHandlerId
_ <- Image
-> ((?self::Image) => Rectangle -> IO ()) -> IO SignalHandlerId
forall a (m :: * -> *).
(IsWidget a, MonadIO m) =>
a -> ((?self::a) => Rectangle -> IO ()) -> m SignalHandlerId
Gtk.onWidgetSizeAllocate Image
image (((?self::Image) => Rectangle -> IO ()) -> IO SignalHandlerId)
-> ((?self::Image) => Rectangle -> IO ()) -> IO SignalHandlerId
forall a b. (a -> b) -> a -> b
$ Bool -> Rectangle -> IO ()
setPixbuf Bool
False
  IO () -> IO (IO ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (IO () -> IO (IO ())) -> IO () -> IO (IO ())
forall a b. (a -> b) -> a -> b
$ Image -> IO Rectangle
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> m Rectangle
Gtk.widgetGetAllocation Image
image IO Rectangle -> (Rectangle -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Bool -> Rectangle -> IO ()
setPixbuf Bool
True

-- | Make a new "Gtk.Image" and call "autoSizeImage" on it. Automatically scale
-- the "Gdk.Pixbuf" returned from the provided getter to the appropriate size
-- using "scalePixbufToSize".
autoSizeImageNew
  :: MonadIO m
  => (Int32 -> IO Gdk.Pixbuf) -> Gtk.Orientation -> m Gtk.Image
autoSizeImageNew :: forall (m :: * -> *).
MonadIO m =>
(Int32 -> IO Pixbuf) -> Orientation -> m Image
autoSizeImageNew Int32 -> IO Pixbuf
getPixBuf Orientation
orientation = do
  Image
image <- m Image
forall (m :: * -> *). (HasCallStack, MonadIO m) => m Image
Gtk.imageNew
  m (IO ()) -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m (IO ()) -> m ()) -> m (IO ()) -> m ()
forall a b. (a -> b) -> a -> b
$ Image -> (Int32 -> IO (Maybe Pixbuf)) -> Orientation -> m (IO ())
forall (m :: * -> *).
MonadIO m =>
Image -> (Int32 -> IO (Maybe Pixbuf)) -> Orientation -> m (IO ())
autoSizeImage Image
image
         (\Int32
size -> Pixbuf -> Maybe Pixbuf
forall a. a -> Maybe a
Just (Pixbuf -> Maybe Pixbuf) -> IO Pixbuf -> IO (Maybe Pixbuf)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int32 -> IO Pixbuf
getPixBuf Int32
size IO Pixbuf -> (Pixbuf -> IO Pixbuf) -> IO 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 -> Orientation -> Pixbuf -> IO Pixbuf
scalePixbufToSize Int32
size Orientation
orientation))
         Orientation
orientation
  Image -> m Image
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Image
image

-- | Make a new "Gtk.MenuItem" that has both a label and an icon.
imageMenuItemNew
  :: MonadIO m
  => T.Text -> (Int32 -> IO (Maybe Gdk.Pixbuf)) -> m Gtk.MenuItem
imageMenuItemNew :: forall (m :: * -> *).
MonadIO m =>
Text -> (Int32 -> IO (Maybe Pixbuf)) -> m MenuItem
imageMenuItemNew Text
labelText Int32 -> IO (Maybe Pixbuf)
pixbufGetter = do
  Box
box <- Orientation -> Int32 -> m Box
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Orientation -> Int32 -> m Box
Gtk.boxNew Orientation
Gtk.OrientationHorizontal Int32
0
  Label
label <- Maybe Text -> m Label
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Maybe Text -> m Label
Gtk.labelNew (Maybe Text -> m Label) -> Maybe Text -> m Label
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text
forall a. a -> Maybe a
Just Text
labelText
  Image
image <- m Image
forall (m :: * -> *). (HasCallStack, MonadIO m) => m Image
Gtk.imageNew
  m (IO ()) -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m (IO ()) -> m ()) -> m (IO ()) -> m ()
forall a b. (a -> b) -> a -> b
$ Image -> (Int32 -> IO (Maybe Pixbuf)) -> Orientation -> m (IO ())
forall (m :: * -> *).
MonadIO m =>
Image -> (Int32 -> IO (Maybe Pixbuf)) -> Orientation -> m (IO ())
autoSizeImage Image
image Int32 -> IO (Maybe Pixbuf)
pixbufGetter Orientation
Gtk.OrientationHorizontal
  MenuItem
item <- m MenuItem
forall (m :: * -> *). (HasCallStack, MonadIO m) => m MenuItem
Gtk.menuItemNew
  Box -> Image -> m ()
forall (m :: * -> *) a b.
(HasCallStack, MonadIO m, IsContainer a, IsWidget b) =>
a -> b -> m ()
Gtk.containerAdd Box
box Image
image
  Box -> Label -> m ()
forall (m :: * -> *) a b.
(HasCallStack, MonadIO m, IsContainer a, IsWidget b) =>
a -> b -> m ()
Gtk.containerAdd Box
box Label
label
  MenuItem -> Box -> m ()
forall (m :: * -> *) a b.
(HasCallStack, MonadIO m, IsContainer a, IsWidget b) =>
a -> b -> m ()
Gtk.containerAdd MenuItem
item Box
box
  Box -> Align -> m ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> Align -> m ()
Gtk.widgetSetHalign Box
box Align
Gtk.AlignStart
  Image -> Align -> m ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> Align -> m ()
Gtk.widgetSetHalign Image
image Align
Gtk.AlignStart
  Box -> Align -> m ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> Align -> m ()
Gtk.widgetSetValign Box
box Align
Gtk.AlignFill
  MenuItem -> m MenuItem
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return MenuItem
item