mirror of
https://gitlab.com/sheaf/metabrush.git
synced 2024-11-06 07:13:37 +00:00
95 lines
3.4 KiB
Haskell
95 lines
3.4 KiB
Haskell
|
{-# LANGUAGE BlockArguments #-}
|
||
|
|
{-# LANGUAGE DeriveFunctor #-}
|
||
|
|
{-# LANGUAGE DeriveFoldable #-}
|
||
|
|
{-# LANGUAGE DeriveTraversable #-}
|
||
|
|
{-# LANGUAGE DerivingStrategies #-}
|
||
|
|
{-# LANGUAGE OverloadedStrings #-}
|
||
|
|
{-# LANGUAGE RecordWildCards #-}
|
||
|
|
|
||
|
|
{-# OPTIONS_GHC -fno-warn-deprecations #-}
|
||
|
|
|
||
|
|
module MetaBrush.Asset.Colours
|
||
|
|
( ColourRecord(..), ColourType
|
||
|
|
, colours
|
||
|
|
)
|
||
|
|
where
|
||
|
|
|
||
|
|
-- base
|
||
|
|
import Data.Traversable
|
||
|
|
( for )
|
||
|
|
|
||
|
|
-- gi-gdk
|
||
|
|
import qualified GI.Gdk as GDK
|
||
|
|
|
||
|
|
-- gi-gtk
|
||
|
|
import qualified GI.Gtk as GTK
|
||
|
|
|
||
|
|
-- text
|
||
|
|
import Data.Text
|
||
|
|
( Text )
|
||
|
|
|
||
|
|
--------------------------------------------------------------------------------
|
||
|
|
|
||
|
|
data ColourRecord a
|
||
|
|
= Colours
|
||
|
|
{ bg :: !a
|
||
|
|
, viewport_bg :: !a
|
||
|
|
, plain :: !a
|
||
|
|
, contrast :: !a
|
||
|
|
, highlight :: !a
|
||
|
|
, logo_base :: !a
|
||
|
|
, logo_highlight :: !a
|
||
|
|
, viewport_scrollbar :: !a
|
||
|
|
, tab_scrollbar :: !a
|
||
|
|
, ruler :: !a
|
||
|
|
, magnifier :: !a
|
||
|
|
, glass :: !a
|
||
|
|
, cursor :: !a
|
||
|
|
, point :: !a
|
||
|
|
, control :: !a
|
||
|
|
}
|
||
|
|
deriving stock ( Show, Functor, Foldable, Traversable )
|
||
|
|
|
||
|
|
data ColourType
|
||
|
|
= Color
|
||
|
|
| BackgroundColor
|
||
|
|
deriving stock Show
|
||
|
|
|
||
|
|
data ColourName
|
||
|
|
= ColourName
|
||
|
|
{ colourName :: !Text
|
||
|
|
, colourType :: !ColourType
|
||
|
|
, stateFlags :: ![ GTK.StateFlags ]
|
||
|
|
}
|
||
|
|
deriving stock Show
|
||
|
|
|
||
|
|
colourNames :: ColourRecord ColourName
|
||
|
|
colourNames = Colours
|
||
|
|
{ bg = ColourName "bg" BackgroundColor [ GTK.StateFlagsNormal ]
|
||
|
|
, viewport_bg = ColourName "viewport_bg" BackgroundColor [ GTK.StateFlagsNormal ]
|
||
|
|
, plain = ColourName "plain" Color [ GTK.StateFlagsNormal ]
|
||
|
|
, contrast = ColourName "contrast" Color [ GTK.StateFlagsNormal ]
|
||
|
|
, highlight = ColourName "highlight" Color [ GTK.StateFlagsNormal ]
|
||
|
|
, logo_base = ColourName "logo_base" Color [ GTK.StateFlagsNormal ]
|
||
|
|
, logo_highlight = ColourName "logo_highlight" Color [ GTK.StateFlagsNormal ]
|
||
|
|
, viewport_scrollbar = ColourName "viewport_scrollbar" Color [ GTK.StateFlagsNormal ]
|
||
|
|
, tab_scrollbar = ColourName "tab_scrollbar" Color [ GTK.StateFlagsNormal ]
|
||
|
|
, ruler = ColourName "ruler" BackgroundColor [ GTK.StateFlagsNormal ]
|
||
|
|
, magnifier = ColourName "magnifier" Color [ GTK.StateFlagsNormal ]
|
||
|
|
, glass = ColourName "glass" Color [ GTK.StateFlagsNormal ]
|
||
|
|
, cursor = ColourName "cursor" Color [ GTK.StateFlagsNormal ]
|
||
|
|
, point = ColourName "point" Color [ GTK.StateFlagsNormal ]
|
||
|
|
, control = ColourName "control" Color [ GTK.StateFlagsNormal ]
|
||
|
|
}
|
||
|
|
|
||
|
|
type Colours = ColourRecord GDK.RGBA
|
||
|
|
|
||
|
|
colours :: GTK.WidgetPath -> IO Colours
|
||
|
|
colours windowWidgetPath = for colourNames \ ( ColourName { .. } ) -> do
|
||
|
|
style <- GTK.styleContextNew
|
||
|
|
GTK.styleContextSetPath style windowWidgetPath
|
||
|
|
GTK.styleContextAddClass style colourName
|
||
|
|
case colourType of
|
||
|
|
BackgroundColor -> GTK.styleContextGetBackgroundColor style stateFlags
|
||
|
|
Color -> GTK.styleContextGetColor style stateFlags
|