mirror of
https://gitlab.com/sheaf/metabrush.git
synced 2024-11-06 07:13:37 +00:00
106 lines
4 KiB
Haskell
106 lines
4 KiB
Haskell
{-# LANGUAGE BlockArguments #-}
|
|
{-# LANGUAGE DeriveTraversable #-}
|
|
{-# LANGUAGE DerivingStrategies #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE RecordWildCards #-}
|
|
|
|
{-# OPTIONS_GHC -fno-warn-deprecations #-}
|
|
|
|
module MetaBrush.Asset.Colours
|
|
( ColourRecord(..), ColourType
|
|
, Colours, getColours
|
|
)
|
|
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
|
|
, active :: !a
|
|
, highlight :: !a
|
|
, cursor :: !a
|
|
, cursorOutline :: !a
|
|
, plain :: !a
|
|
, base :: !a
|
|
, splash :: !a
|
|
, pathPoint :: !a
|
|
, pathPointOutline :: !a
|
|
, controlPoint :: !a
|
|
, controlPointOutline :: !a
|
|
, path :: !a
|
|
, brushStroke :: !a
|
|
, pointHover :: !a
|
|
, pointSelected :: !a
|
|
, viewport :: !a
|
|
, viewportScrollbar :: !a
|
|
, tabScrollbar :: !a
|
|
, magnifier :: !a
|
|
, glass :: !a
|
|
}
|
|
deriving stock ( Show, Functor, Foldable, Traversable )
|
|
|
|
data ColourType
|
|
= Colour
|
|
| BackgroundColour
|
|
deriving stock Show
|
|
|
|
data ColourName
|
|
= ColourName
|
|
{ colourName :: !Text
|
|
, colourType :: !ColourType
|
|
, stateFlags :: ![ GTK.StateFlags ]
|
|
}
|
|
deriving stock Show
|
|
|
|
colourNames :: ColourRecord ColourName
|
|
colourNames = Colours
|
|
{ bg = ColourName "bg" BackgroundColour [ GTK.StateFlagsNormal ]
|
|
, active = ColourName "active" BackgroundColour [ GTK.StateFlagsNormal ]
|
|
, highlight = ColourName "highlight" Colour [ GTK.StateFlagsNormal ]
|
|
, cursor = ColourName "cursor" Colour [ GTK.StateFlagsNormal ]
|
|
, cursorOutline = ColourName "cursorStroke" Colour [ GTK.StateFlagsNormal ]
|
|
, plain = ColourName "plain" Colour [ GTK.StateFlagsNormal ]
|
|
, base = ColourName "base" Colour [ GTK.StateFlagsNormal ]
|
|
, splash = ColourName "splash" Colour [ GTK.StateFlagsNormal ]
|
|
, pathPoint = ColourName "pathPoint" Colour [ GTK.StateFlagsNormal ]
|
|
, pathPointOutline = ColourName "pathPointStroke" Colour [ GTK.StateFlagsNormal ]
|
|
, controlPoint = ColourName "controlPoint" Colour [ GTK.StateFlagsNormal ]
|
|
, controlPointOutline = ColourName "controlPointStroke" Colour [ GTK.StateFlagsNormal ]
|
|
, path = ColourName "path" Colour [ GTK.StateFlagsNormal ]
|
|
, brushStroke = ColourName "brushStroke" Colour [ GTK.StateFlagsNormal ]
|
|
, pointHover = ColourName "pointHover" Colour [ GTK.StateFlagsNormal ]
|
|
, pointSelected = ColourName "pointSelected" Colour [ GTK.StateFlagsNormal ]
|
|
, viewport = ColourName "viewport" BackgroundColour [ GTK.StateFlagsNormal ]
|
|
, viewportScrollbar = ColourName "viewportScrollbar" BackgroundColour [ GTK.StateFlagsNormal ]
|
|
, tabScrollbar = ColourName "tabScrollbar" BackgroundColour [ GTK.StateFlagsNormal ]
|
|
, magnifier = ColourName "magnifier" Colour [ GTK.StateFlagsNormal ]
|
|
, glass = ColourName "glass" Colour [ GTK.StateFlagsNormal ]
|
|
}
|
|
|
|
type Colours = ColourRecord GDK.RGBA
|
|
|
|
getColours :: GTK.WidgetPath -> IO Colours
|
|
getColours windowWidgetPath =
|
|
for colourNames \ ( ColourName { .. } ) -> do
|
|
style <- GTK.styleContextNew
|
|
GTK.styleContextSetPath style windowWidgetPath
|
|
GTK.styleContextAddClass style colourName
|
|
case colourType of
|
|
BackgroundColour -> GTK.styleContextGetBackgroundColor style stateFlags
|
|
Colour -> GTK.styleContextGetColor style stateFlags
|