-- | An internal newtype for parsing colours
module Calamity.Internal.IntColour (
    IntColour (..),
    colourToWord64,
    colourFromWord64,
) where

import Data.Aeson
import Data.Bits
import Data.Colour
import Data.Colour.SRGB (RGB (RGB), sRGB24, toSRGB24)
import Data.Word (Word64)
import GHC.Generics
import TextShow

newtype IntColour = IntColour (Colour Double)
    deriving stock ((forall x. IntColour -> Rep IntColour x)
-> (forall x. Rep IntColour x -> IntColour) -> Generic IntColour
forall x. Rep IntColour x -> IntColour
forall x. IntColour -> Rep IntColour x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep IntColour x -> IntColour
$cfrom :: forall x. IntColour -> Rep IntColour x
Generic)
    deriving (Int -> IntColour -> ShowS
[IntColour] -> ShowS
IntColour -> String
(Int -> IntColour -> ShowS)
-> (IntColour -> String)
-> ([IntColour] -> ShowS)
-> Show IntColour
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [IntColour] -> ShowS
$cshowList :: [IntColour] -> ShowS
show :: IntColour -> String
$cshow :: IntColour -> String
showsPrec :: Int -> IntColour -> ShowS
$cshowsPrec :: Int -> IntColour -> ShowS
Show) via Colour Double
    deriving (Int -> IntColour -> Builder
Int -> IntColour -> Text
Int -> IntColour -> Text
[IntColour] -> Builder
[IntColour] -> Text
[IntColour] -> Text
IntColour -> Builder
IntColour -> Text
IntColour -> Text
(Int -> IntColour -> Builder)
-> (IntColour -> Builder)
-> ([IntColour] -> Builder)
-> (Int -> IntColour -> Text)
-> (IntColour -> Text)
-> ([IntColour] -> Text)
-> (Int -> IntColour -> Text)
-> (IntColour -> Text)
-> ([IntColour] -> Text)
-> TextShow IntColour
forall a.
(Int -> a -> Builder)
-> (a -> Builder)
-> ([a] -> Builder)
-> (Int -> a -> Text)
-> (a -> Text)
-> ([a] -> Text)
-> (Int -> a -> Text)
-> (a -> Text)
-> ([a] -> Text)
-> TextShow a
showtlList :: [IntColour] -> Text
$cshowtlList :: [IntColour] -> Text
showtl :: IntColour -> Text
$cshowtl :: IntColour -> Text
showtlPrec :: Int -> IntColour -> Text
$cshowtlPrec :: Int -> IntColour -> Text
showtList :: [IntColour] -> Text
$cshowtList :: [IntColour] -> Text
showt :: IntColour -> Text
$cshowt :: IntColour -> Text
showtPrec :: Int -> IntColour -> Text
$cshowtPrec :: Int -> IntColour -> Text
showbList :: [IntColour] -> Builder
$cshowbList :: [IntColour] -> Builder
showb :: IntColour -> Builder
$cshowb :: IntColour -> Builder
showbPrec :: Int -> IntColour -> Builder
$cshowbPrec :: Int -> IntColour -> Builder
TextShow) via FromStringShow (Colour Double)

colourToWord64 :: IntColour -> Word64
colourToWord64 :: IntColour -> Word64
colourToWord64 (IntColour Colour Double
c) =
    let RGB Word8
r Word8
g Word8
b = Colour Double -> RGB Word8
forall b. (RealFrac b, Floating b) => Colour b -> RGB Word8
toSRGB24 Colour Double
c
        i :: Word64
i = (Word8 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
r Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftL` Int
16) Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.|. (Word8 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
g Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftL` Int
8) Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.|. Word8 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
b
     in Word64
i

colourFromWord64 :: Word64 -> IntColour
colourFromWord64 :: Word64 -> IntColour
colourFromWord64 Word64
i =
    let r :: Word64
r = (Word64
i Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftR` Int
16) Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.&. Word64
0xff
        g :: Word64
g = (Word64
i Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftR` Int
8) Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.&. Word64
0xff
        b :: Word64
b = Word64
i Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.&. Word64
0xff
     in Colour Double -> IntColour
IntColour (Colour Double -> IntColour) -> Colour Double -> IntColour
forall a b. (a -> b) -> a -> b
$ Word8 -> Word8 -> Word8 -> Colour Double
forall b.
(Ord b, Floating b) =>
Word8 -> Word8 -> Word8 -> Colour b
sRGB24 (Word64 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
r) (Word64 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
g) (Word64 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
b)

instance ToJSON IntColour where
    toJSON :: IntColour -> Value
toJSON = Word64 -> Value
forall a. ToJSON a => a -> Value
toJSON (Word64 -> Value) -> (IntColour -> Word64) -> IntColour -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IntColour -> Word64
colourToWord64

instance FromJSON IntColour where
    parseJSON :: Value -> Parser IntColour
parseJSON Value
v = Word64 -> IntColour
colourFromWord64 (Word64 -> IntColour) -> Parser Word64 -> Parser IntColour
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser Word64
forall a. FromJSON a => Value -> Parser a
parseJSON Value
v