metabrush/src/app/MetaBrush/Asset/Colours.hs

{-# 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