{-# 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"