{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}

{-# HLINT ignore "Redundant bracket due to operator fixities" #-}

-- | 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 TextShow

newtype IntColour = IntColour
  { IntColour -> Colour Double
fromIntColour :: Colour Double
  }
  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
$cshowsPrec :: Int -> IntColour -> ShowS
showsPrec :: Int -> IntColour -> ShowS
$cshow :: IntColour -> String
show :: IntColour -> String
$cshowList :: [IntColour] -> ShowS
showList :: [IntColour] -> ShowS
Show) via Colour Double
  deriving (Int -> IntColour -> Text
Int -> IntColour -> Builder
Int -> IntColour -> Text
[IntColour] -> Text
[IntColour] -> Builder
[IntColour] -> Text
IntColour -> Text
IntColour -> Builder
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
$cshowbPrec :: Int -> IntColour -> Builder
showbPrec :: Int -> IntColour -> Builder
$cshowb :: IntColour -> Builder
showb :: IntColour -> Builder
$cshowbList :: [IntColour] -> Builder
showbList :: [IntColour] -> Builder
$cshowtPrec :: Int -> IntColour -> Text
showtPrec :: Int -> IntColour -> Text
$cshowt :: IntColour -> Text
showt :: IntColour -> Text
$cshowtList :: [IntColour] -> Text
showtList :: [IntColour] -> Text
$cshowtlPrec :: Int -> IntColour -> Text
showtlPrec :: Int -> IntColour -> Text
$cshowtl :: IntColour -> Text
showtl :: IntColour -> Text
$cshowtlList :: [IntColour] -> Text
showtlList :: [IntColour] -> Text
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