Writing some basic scaffolding for colors

1 files changed, 23 insertions, 0 deletions

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)