From d7be39cd8a16e22f6f8784fdae06c223df5864c1 Mon Sep 17 00:00:00 2001 From: Chris Wells Date: Tue, 12 Nov 2024 10:42:21 -0600 Subject: Writing some basic scaffolding for colors --- src/WWW/Colors/Instances.hs | 23 +++++++++++++++++++++++ 1 file changed, 23 insertions(+) create mode 100644 src/WWW/Colors/Instances.hs (limited to 'src/WWW/Colors/Instances.hs') diff --git a/src/WWW/Colors/Instances.hs b/src/WWW/Colors/Instances.hs new file mode 100644 index 0000000..e071b6b --- /dev/null +++ b/src/WWW/Colors/Instances.hs @@ -0,0 +1,23 @@ +module WWW.Colors.Instances where + +import Clay.Color qualified as Clay +import Data.Colour +import Data.Colour.SRGB (toSRGB24, sRGB24, RGB (..)) +import Diagrams.Attributes +import GHC.Float (double2Float, float2Double) + + +instance Color Clay.Color where + toAlphaColour :: Clay.Color -> AlphaColour Double + toAlphaColour col = case Clay.toRgba col of + Clay.Rgba r g b a -> + let rgb = sRGB24 (fromInteger r) (fromInteger g) (fromInteger b) + in withOpacity rgb (float2Double a) + _ -> error "Should not happen" + + fromAlphaColour :: AlphaColour Double -> Clay.Color + fromAlphaColour col = + let c = fromAlphaColour col :: Colour Double + a = alphaChannel col + rgb = toInteger <$> toSRGB24 c + in Clay.rgba (channelRed rgb) (channelGreen rgb) (channelBlue rgb) (double2Float a) -- cgit v1.2.3