Trying to write css

3 files changed, 33 insertions, 44 deletions

diff --git a/src/WWW/Colors/Hex.hs b/src/WWW/Colors/Hex.hs
deleted file mode 100644
index 1773e66..0000000
--- a/src/WWW/Colors/Hex.hs
+++ /dev/null
@@ -1,34 +0,0 @@
-{-# 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
index e071b6b..3fc7667 100644
--- a/src/WWW/Colors/Instances.hs
+++ b/src/WWW/Colors/Instances.hs
@@ -1,23 +1,23 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
 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)
 
 
+-- | Not perfect, but good enough for building what I need
 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)
+                                 in alphaColourConvert $ withOpacity rgb 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)
+        let a = alphaChannel $ alphaColourConvert col
+            RGB r g b = toInteger <$> toSRGB24 (fromAlphaColour @(Colour Double) col)
+         in Clay.rgba r g b a
diff --git a/src/WWW/Colors/QQ.hs b/src/WWW/Colors/QQ.hs
index 4a03dbb..281a93a 100644
--- a/src/WWW/Colors/QQ.hs
+++ b/src/WWW/Colors/QQ.hs
@@ -1,20 +1,43 @@
 {-# LANGUAGE TemplateHaskell #-}
 module WWW.Colors.QQ
     ( hex
+    , Color'
+    , toColor'
+    , someToColor'
     ) where
 
--- import Data.Colour
--- import Data.Colour.SRGB
+import Data.Colour
+import Data.Colour.SRGB
 import Control.Monad ((>=>))
+import Diagrams.Attributes
 import Diagrams.Backend.CmdLine (readHexColor)
+import Language.Haskell.TH.Syntax
 import Language.Haskell.TH.Quote
 
 
+-- | data type defined so we can use template haskell to get compile-time hex colors
+data Color' = Color' !Double !Double !Double !Double
+    deriving Lift
 
--- | QuasiQuoter which reads in a hex color code and ouputs a 'AlphaColour Double'.
+instance Color Color' where
+    toAlphaColour (Color' r g b a) = withOpacity (sRGB r g b) a
+    fromAlphaColour col =
+        let a = alphaChannel col
+            RGB r g b = toSRGB $ fromAlphaColour @(Colour Double) col
+         in Color' r g b a
+
+
+toColor' :: AlphaColour Double -> Color'
+toColor' = fromAlphaColour
+
+someToColor' :: SomeColor -> Color'
+someToColor' = toColor' . someToAlpha
+
+
+-- | QuasiQuoter which reads in a hex color code and outputs a 'AlphaColour Double'.
 hex :: QuasiQuoter
 hex = QuasiQuoter
-    { quoteExp = readHexColor >=> \x -> x `seq` pure [|x|]
+    { quoteExp = readHexColor >=> pure . toColor' >=> \x -> x `seq` [|x|]
     , quotePat = failure "quotePat"
     , quoteType = failure "quoteType"
     , quoteDec = failure "quoteDec"