mirror of
https://gitlab.com/sheaf/metabrush.git
synced 2024-11-05 23:03:38 +00:00
78 lines
2.2 KiB
Haskell
78 lines
2.2 KiB
Haskell
{-# 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
|