metabrush/src/app/MetaBrush/Util.hs

{-# LANGUAGE BlockArguments      #-}
{-# LANGUAGE ConstraintKinds     #-}
{-# LANGUAGE GADTs               #-}
{-# LANGUAGE MonoLocalBinds      #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications    #-}

module MetaBrush.Util
  ( withRGBA, showRGBA
  , widgetAddClasses, widgetAddClass
  , (>=?=>), (>>?=)
  , Exists(..)
  )
  where

-- base
import Control.Monad
  ( (>=>) )
import Data.Coerce
  ( coerce )
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 )
import Control.Monad.Trans.Maybe
  ( MaybeT(..) )

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

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 )

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

infixr 1 >=?=>
(>=?=>) :: forall m a b c. Monad m => ( a -> m ( Maybe b ) ) -> ( b -> m ( Maybe c ) ) -> ( a -> m ( Maybe c ) )
(>=?=>) = coerce ( (>=>) @( MaybeT m ) @a @b @c )

infixl 1 >>?=
(>>?=) :: forall m a b. Monad m => m ( Maybe a ) -> ( a -> m ( Maybe b ) ) -> m ( Maybe b )
(>>?=) = coerce ( (>>=) @( MaybeT m ) @a @b )

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

data Exists c where
  Exists :: c a => a -> Exists c