metabrush/src/app/MetaBrush/Render/Util.hs

{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE MonoLocalBinds #-}

module MetaBrush.Render.Util
  ( withRGBA, showRGBA
  , widgetAddClasses, widgetAddClass
  )
  where

-- base
import Data.Foldable
  ( for_ )
import GHC.Stack
  ( HasCallStack )

-- gi-gdk
import qualified GI.Gdk as GDK

-- gi-gtk
import qualified GI.Gtk as GTK

-- text
import Data.Text
  ( Text )

-- transformers
import Control.Monad.IO.Class
  ( MonadIO )

--------------------------------------------------------------------------------

withRGBA :: MonadIO m => GDK.RGBA -> ( Double -> Double -> Double -> Double -> m b ) -> m b
withRGBA rgba f = do
  r <- GDK.getRGBARed   rgba
  g <- GDK.getRGBAGreen rgba
  b <- GDK.getRGBABlue  rgba
  a <- GDK.getRGBAAlpha rgba
  f r g b a

showRGBA :: MonadIO m => GDK.RGBA -> m String
showRGBA rgba = withRGBA rgba \ r g b a ->
  pure $ "rgba(" ++ show r ++ "," ++ show g ++ "," ++ show b ++ "," ++ show a ++ ")"

widgetAddClasses :: ( HasCallStack, GTK.IsWidget widget, MonadIO m ) => widget -> [Text] -> m ()
widgetAddClasses widget classNames = do
  styleContext <- GTK.widgetGetStyleContext widget
  for_ classNames ( GTK.styleContextAddClass styleContext )

widgetAddClass :: ( HasCallStack, GTK.IsWidget widget, MonadIO m ) => widget -> Text -> m ()
widgetAddClass widget className = GTK.widgetGetStyleContext widget >>= ( `GTK.styleContextAddClass` className )