Writing some basic scaffolding for colors

3 files changed, 84 insertions, 0 deletions

diff --git a/src/WWW/Colors/Hex.hs b/src/WWW/Colors/Hex.hs
new file mode 100644
index 0000000..1773e66
--- /dev/null
+++ b/src/WWW/Colors/Hex.hs
@@ -0,0 +1,34 @@
+{-# LANGUAGE TemplateHaskell #-}
+module WWW.Colors.Hex
+    ( HexColor
+    ) where
+
+import Data.Colour
+import Digrams.Attributes
+import Language.Haskell.TH.Quote
+
+
+newtype HexColor = HexColor ByteString
+    deriving (Eq, Generic, Ord)
+
+instance Bounded HexColor where
+    maxBound = HexColor "\255\255\255"
+    minBound = HexColor "\NUL\NUL\NUL"
+
+
+instance Color HexColor where
+
+
+
+
+hex :: QuasiQuoter
+hex = QuasiQuoter
+    { quoteExp = parseit
+    , quotePat = failure "quotePat"
+    , quoteType = failure "quoteType"
+    , quoteDec = failure "quoteDec"
+    } where
+        failure s = const $ fail $ "No " <> s <> " defined for the hexcolor quasiquoter."
+        parseit s = case undefined of
+                      Nothing -> fail $ "Can't understand " <> s <> " as a valid hex color."
+                      Just h -> h `seq` [|h|]
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)
diff --git a/src/WWW/Colors/QQ.hs b/src/WWW/Colors/QQ.hs
new file mode 100644
index 0000000..4a03dbb
--- /dev/null
+++ b/src/WWW/Colors/QQ.hs
@@ -0,0 +1,27 @@
+{-# LANGUAGE TemplateHaskell #-}
+module WWW.Colors.QQ
+    ( hex
+    ) where
+
+-- import Data.Colour
+-- import Data.Colour.SRGB
+import Control.Monad ((>=>))
+import Diagrams.Backend.CmdLine (readHexColor)
+import Language.Haskell.TH.Quote
+
+
+
+-- | QuasiQuoter which reads in a hex color code and ouputs a 'AlphaColour Double'.
+hex :: QuasiQuoter
+hex = QuasiQuoter
+    { quoteExp = readHexColor >=> \x -> x `seq` pure [|x|]
+    , quotePat = failure "quotePat"
+    , quoteType = failure "quoteType"
+    , quoteDec = failure "quoteDec"
+    } where
+        failure s = const $ fail $ "No " <> s <> " defined for the hexcolor quasiquoter."
+        -- readit = sRGB24reads :: ReadS (Colour Double)
+        -- parseit s =
+        --     case readit s of
+        --       [(x,[])] -> x `seq` [|x|]
+        --       _ -> fail $ "Can't understand " <> s <> " as a valid hex color"