AutoSizeImage.hs

{-# 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 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 = logM "System.Taffybar.Widget.Generic.AutoSizeImage"

borderFunctions :: [Gtk.StyleContext -> [Gtk.StateFlags] -> IO Gtk.Border]
borderFunctions =
  [ Gtk.styleContextGetPadding
  , Gtk.styleContextGetMargin
  , Gtk.styleContextGetBorder
  ]

data BorderInfo = BorderInfo
  { borderTop :: Int16
  , borderBottom :: Int16
  , borderLeft :: Int16
  , borderRight :: Int16
  } deriving (Show, Eq)

borderInfoZero :: BorderInfo
borderInfoZero = BorderInfo 0 0 0 0

borderWidth, borderHeight :: BorderInfo -> Int16
borderWidth borderInfo = borderLeft borderInfo + borderRight borderInfo
borderHeight borderInfo = borderTop borderInfo + borderBottom borderInfo

toBorderInfo :: (MonadIO m) => Gtk.Border -> m BorderInfo
toBorderInfo border =
  BorderInfo
  <$> Gtk.getBorderTop border
  <*> Gtk.getBorderBottom border
  <*> Gtk.getBorderLeft border
  <*> Gtk.getBorderRight border

addBorderInfo :: BorderInfo -> BorderInfo -> BorderInfo
addBorderInfo
  (BorderInfo t1 b1 l1 r1)
  (BorderInfo t2 b2 l2 r2)
    = BorderInfo (t1 + t2) (b1 + b2) (l1 + l2) (r1 + 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 widget = liftIO $ do
  stateFlags <- Gtk.widgetGetStateFlags widget
  styleContext <- Gtk.widgetGetStyleContext widget

  let getBorderInfoFor borderFn =
        borderFn styleContext stateFlags >>= toBorderInfo
      combineBorderInfo lastSum fn =
        addBorderInfo lastSum <$> getBorderInfoFor fn

  foldM combineBorderInfo borderInfoZero 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 widget borderInfo = do
  allocation <- Gtk.widgetGetAllocation widget
  currentWidth <- Gdk.getRectangleWidth allocation
  currentHeight <- Gdk.getRectangleHeight allocation
  currentX <- Gdk.getRectangleX allocation
  currentY <- Gdk.getRectangleX allocation

  Gdk.setRectangleWidth allocation $ max 1 $
     currentWidth - fromIntegral (borderWidth borderInfo)
  Gdk.setRectangleHeight allocation $ max 1 $
     currentHeight - fromIntegral (borderHeight borderInfo)
  Gdk.setRectangleX allocation $
     currentX + fromIntegral (borderLeft borderInfo)
  Gdk.setRectangleY allocation $
     currentY + fromIntegral (borderTop borderInfo)

  return 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 getPixbuf orientation = liftIO $ do
  case orientation of
    Gtk.OrientationHorizontal -> Gtk.widgetSetVexpand image True
    _ -> Gtk.widgetSetHexpand image True

  _ <- widgetSetClassGI image "auto-size-image"

  lastAllocation <- 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 <- getBorderInfo image

  let setPixbuf force allocation = do
        _width <- Gdk.getRectangleWidth allocation
        _height <- Gdk.getRectangleHeight allocation

        let width = max 1 $ _width - fromIntegral (borderWidth borderInfo)
            height = max 1 $ _height - fromIntegral (borderHeight borderInfo)
            size =
              case orientation of
                Gtk.OrientationHorizontal -> height
                _ -> width

        previousSize <- MV.readMVar lastAllocation

        when (size /= previousSize || force) $ do
          MV.modifyMVar_ lastAllocation $ const $ return size

          pixbuf <- getPixbuf size
          pbWidth <- fromMaybe 0 <$> traverse Gdk.getPixbufWidth pixbuf
          pbHeight <- fromMaybe 0 <$> traverse Gdk.getPixbufHeight pixbuf
          let pbSize = case orientation of
                         Gtk.OrientationHorizontal -> pbHeight
                         _ -> pbWidth
              logLevel = if pbSize <= size then DEBUG else WARNING

          imageLog logLevel $
                 printf "Allocating image: size %s, width %s, \
                         \ height %s, aw: %s, ah: %s, pbw: %s pbh: %s"
                 (show size)
                 (show width)
                 (show height)
                 (show _width)
                 (show _height)
                 (show pbWidth)
                 (show pbHeight)

          Gtk.imageSetFromPixbuf image pixbuf
          postGUIASync $ Gtk.widgetQueueResize image

  _ <- Gtk.onWidgetSizeAllocate image $ setPixbuf False
  return $ Gtk.widgetGetAllocation image >>= setPixbuf 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 getPixBuf orientation = do
  image <- Gtk.imageNew
  void $ autoSizeImage image
         (\size -> Just <$> (getPixBuf size >>= scalePixbufToSize size orientation))
         orientation
  return image