summaryrefslogtreecommitdiff
path: root/src/WWW/Colors/QQ.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/WWW/Colors/QQ.hs')
-rw-r--r--src/WWW/Colors/QQ.hs31
1 files changed, 27 insertions, 4 deletions
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"