{-# 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 <- a -> IO [StateFlags]
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> m [StateFlags]
Gtk.widgetGetStateFlags a
widget
  styleContext <- Gtk.widgetGetStyleContext widget

  let 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
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

  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 :: forall (m :: * -> *) a.
(MonadIO m, IsWidget a) =>
a -> BorderInfo -> m Rectangle
getContentAllocation a
widget BorderInfo
borderInfo = do
  allocation <- a -> m Rectangle
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> m Rectangle
Gtk.widgetGetAllocation a
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 :: 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 -> Text -> IO Image
forall b (m :: * -> *). (IsWidget b, MonadIO m) => b -> Text -> m b
widgetSetClassGI Image
image Text
"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 Bool
force Rectangle
allocation = do
        _width <- Rectangle -> IO Int32
forall (m :: * -> *). MonadIO m => Rectangle -> m Int32
Gdk.getRectangleWidth Rectangle
allocation
        _height <- Gdk.getRectangleHeight allocation

        let 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 -> 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 =
              case Orientation
orientation of
                Orientation
Gtk.OrientationHorizontal -> Int32
height
                Orientation
_ -> Int32
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
orientation of
                         Orientation
Gtk.OrientationHorizontal -> Int32
pbHeight
                         Orientation
_ -> Int32
pbWidth
              logLevel = if Int32
pbSize Int32 -> Int32 -> Bool
forall a. Ord a => a -> a -> Bool
<= Int32
size then Priority
DEBUG else Priority
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 :: forall (m :: * -> *).
MonadIO m =>
(Int32 -> IO Pixbuf) -> Orientation -> m Image
autoSizeImageNew Int32 -> IO Pixbuf
getPixBuf Orientation
orientation = do
  image <- m Image
forall (m :: * -> *). (HasCallStack, MonadIO m) => m Image
Gtk.imageNew
  void $ autoSizeImage 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
  return 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 <- Orientation -> Int32 -> m Box
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Orientation -> Int32 -> m Box
Gtk.boxNew Orientation
Gtk.OrientationHorizontal Int32
0
  label <- Gtk.labelNew $ Just labelText
  image <- Gtk.imageNew
  void $ autoSizeImage image pixbufGetter Gtk.OrientationHorizontal
  item <- Gtk.menuItemNew
  Gtk.containerAdd box image
  Gtk.containerAdd box label
  Gtk.containerAdd item box
  Gtk.widgetSetHalign box Gtk.AlignStart
  Gtk.widgetSetHalign image Gtk.AlignStart
  Gtk.widgetSetValign box Gtk.AlignFill
  return item