    {-# 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 "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
    showList :: [BorderInfo] -> ShowS
    $cshowList :: [BorderInfo] -> ShowS
    show :: BorderInfo -> String
    $cshow :: BorderInfo -> String
    showsPrec :: Int -> BorderInfo -> ShowS
    $cshowsPrec :: Int -> BorderInfo -> ShowS
    Show, BorderInfo -> BorderInfo -> Bool
    (BorderInfo -> BorderInfo -> Bool)
    -> (BorderInfo -> BorderInfo -> Bool) -> Eq BorderInfo
    forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
    /= :: BorderInfo -> BorderInfo -> Bool
    $c/= :: BorderInfo -> BorderInfo -> Bool
    == :: BorderInfo -> BorderInfo -> Bool
    $c== :: BorderInfo -> BorderInfo -> Bool
    Eq)

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

    borderWidth, borderHeight :: BorderInfo -> Int16
    borderWidth :: BorderInfo -> Int16
    borderWidth borderInfo :: 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 = 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 :: Border -> m BorderInfo
    toBorderInfo border :: 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 (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 (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 (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 t1 :: Int16
    t1 b1 :: Int16
    b1 l1 :: Int16
    l1 r1 :: Int16
    r1)
      (BorderInfo t2 :: Int16
    t2 b2 :: Int16
    b2 l2 :: Int16
    l2 r2 :: 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 :: a -> m BorderInfo
    getBorderInfo widget :: a
    widget = IO BorderInfo -> m BorderInfo
    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 borderFn :: StyleContext -> [StateFlags] -> IO Border
    borderFn =
            StyleContext -> [StateFlags] -> IO Border
    borderFn StyleContext
    styleContext [StateFlags]
    stateFlags IO Border -> (Border -> IO BorderInfo) -> IO BorderInfo
    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 lastSum :: BorderInfo
    lastSum fn :: 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 :: a -> BorderInfo -> m Rectangle
    getContentAllocation widget :: a
    widget borderInfo :: 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 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 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 (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 :: Image -> (Int32 -> IO (Maybe Pixbuf)) -> Orientation -> m (IO ())
    autoSizeImage image :: Image
    image getPixbuf :: Int32 -> IO (Maybe Pixbuf)
    getPixbuf orientation :: Orientation
    orientation = IO (IO ()) -> m (IO ())
    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
        Gtk.OrientationHorizontal -> Image -> Bool -> IO ()
    forall (m :: * -> *) a.
    (HasCallStack, MonadIO m, IsWidget a) =>
    a -> Bool -> m ()
    Gtk.widgetSetVexpand Image
    image Bool
    True
        _ -> 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 "auto-size-image"

      MVar Int32
    lastAllocation <- Int32 -> IO (MVar Int32)
    forall a. a -> IO (MVar a)
    MV.newMVar 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 force :: Bool
    force allocation :: 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 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 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
                    Gtk.OrientationHorizontal -> Int32
    height
                    _ -> 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 (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 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)
    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 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)
    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
                             Gtk.OrientationHorizontal -> Int32
    pbHeight
                             _ -> 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 "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 -> (Rectangle -> IO ()) -> IO SignalHandlerId
    forall a (m :: * -> *).
    (IsWidget a, MonadIO m) =>
    a -> (Rectangle -> IO ()) -> m SignalHandlerId
    Gtk.onWidgetSizeAllocate Image
    image ((Rectangle -> IO ()) -> IO SignalHandlerId)
    -> (Rectangle -> IO ()) -> IO SignalHandlerId
    forall a b. (a -> b) -> a -> b
    $ Bool -> Rectangle -> IO ()
    setPixbuf Bool
    False
      IO () -> IO (IO ())
    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 (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 :: (Int32 -> IO Pixbuf) -> Orientation -> m Image
    autoSizeImageNew getPixBuf :: Int32 -> IO Pixbuf
    getPixBuf orientation :: 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
             (\size :: 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 (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 (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 :: Text -> (Int32 -> IO (Maybe Pixbuf)) -> m MenuItem
    imageMenuItemNew labelText :: Text
    labelText pixbufGetter :: 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 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 (m :: * -> *) a. Monad m => a -> m a
    return MenuItem
    item