blob: 281a93a13ec06a88706c8e5da90a8563f2b1dc76 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
|
{-# LANGUAGE TemplateHaskell #-}
module WWW.Colors.QQ
( hex
, Color'
, toColor'
, someToColor'
) where
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
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 >=> pure . toColor' >=> \x -> x `seq` [|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"
|
