{-# LANGUAGE FlexibleInstances    #-}
{-# LANGUAGE TypeFamilies         #-}
{-# LANGUAGE UndecidableInstances #-}
module Data.STBImage.Color
    ( Color(..)
    , ColorFlag(..)
    , YColor(..), YAColor(..)
    , RGBColor(..), RGBAColor(..)
    , showColor
    ) where

import           Data.Bifunctor
import           Data.STBImage.ColorTypes
import           Data.STBImage.Immutable
import qualified Data.Vector.Storable     as V
import           Data.Word
import           Foreign.Storable
import           Text.Printf

--

class (Storable a) => Color a where
    data ColorFlag a :: *
    -- | 'loadImage' reads the image (with ColorFlag 'Y', 'YA', 'RGB', or 'RGBA') at the supplied path.
    loadImage :: ColorFlag a -> FilePath -> IO (Either String (Image a))
    -- | 'writePNG' writes the image passed to it out at the path 'path' in PNG format. The path must include the extension.
    writePNG  :: FilePath -> Image a -> IO ()
    -- | 'writeBMP' writes the image passed to it out at the path 'path' in BMP format. The path must include the extension.
    writeBMP  :: FilePath -> Image a -> IO ()
    -- | 'writeTGA' writes the image passed to it out at the path 'path' in TGA format. The path must include the extension.
    writeTGA  :: FilePath -> Image a -> IO ()

    red :: a -> Word8
    green :: a -> Word8
    blue :: a -> Word8
    alpha :: a -> Word8

instance Color YColor where
    data ColorFlag YColor = Y
    loadImage :: ColorFlag YColor -> FilePath -> IO (Either FilePath (Image YColor))
loadImage Y = (Either FilePath (Image CUChar) -> Either FilePath (Image YColor))
-> IO (Either FilePath (Image CUChar))
-> IO (Either FilePath (Image YColor))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Image CUChar -> Image YColor)
-> Either FilePath (Image CUChar) -> Either FilePath (Image YColor)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second Image CUChar -> Image YColor
forall a b. (Storable a, Storable b) => Image a -> Image b
unsafeCastImage) (IO (Either FilePath (Image CUChar))
 -> IO (Either FilePath (Image YColor)))
-> (FilePath -> IO (Either FilePath (Image CUChar)))
-> FilePath
-> IO (Either FilePath (Image YColor))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> FilePath -> IO (Either FilePath (Image CUChar))
loadImageBytes 1
    writePNG :: FilePath -> Image YColor -> IO ()
writePNG = CInt -> FilePath -> Image YColor -> IO ()
forall a. Storable a => CInt -> FilePath -> Image a -> IO ()
writeNChannelPNG 1
    writeBMP :: FilePath -> Image YColor -> IO ()
writeBMP = CInt -> FilePath -> Image YColor -> IO ()
forall a. Storable a => CInt -> FilePath -> Image a -> IO ()
writeNChannelBMP 1
    writeTGA :: FilePath -> Image YColor -> IO ()
writeTGA = CInt -> FilePath -> Image YColor -> IO ()
forall a. Storable a => CInt -> FilePath -> Image a -> IO ()
writeNChannelTGA 1

    red :: YColor -> Word8
red   (YColor y :: Word8
y) = Word8
y
    green :: YColor -> Word8
green (YColor y :: Word8
y) = Word8
y
    blue :: YColor -> Word8
blue  (YColor y :: Word8
y) = Word8
y
    alpha :: YColor -> Word8
alpha _          = 255

instance Show YColor where
    show :: YColor -> FilePath
show = YColor -> FilePath
forall a. Color a => a -> FilePath
showColor

instance Show (ColorFlag YColor) where
    show :: ColorFlag YColor -> FilePath
show _ = "Y"

instance Color YAColor where
    data ColorFlag YAColor = YA
    loadImage :: ColorFlag YAColor
-> FilePath -> IO (Either FilePath (Image YAColor))
loadImage YA = (Either FilePath (Image CUChar) -> Either FilePath (Image YAColor))
-> IO (Either FilePath (Image CUChar))
-> IO (Either FilePath (Image YAColor))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Image CUChar -> Image YAColor)
-> Either FilePath (Image CUChar)
-> Either FilePath (Image YAColor)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second Image CUChar -> Image YAColor
forall a b. (Storable a, Storable b) => Image a -> Image b
unsafeCastImage) (IO (Either FilePath (Image CUChar))
 -> IO (Either FilePath (Image YAColor)))
-> (FilePath -> IO (Either FilePath (Image CUChar)))
-> FilePath
-> IO (Either FilePath (Image YAColor))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> FilePath -> IO (Either FilePath (Image CUChar))
loadImageBytes 2
    writePNG :: FilePath -> Image YAColor -> IO ()
writePNG = CInt -> FilePath -> Image YAColor -> IO ()
forall a. Storable a => CInt -> FilePath -> Image a -> IO ()
writeNChannelPNG 2
    writeBMP :: FilePath -> Image YAColor -> IO ()
writeBMP = CInt -> FilePath -> Image YAColor -> IO ()
forall a. Storable a => CInt -> FilePath -> Image a -> IO ()
writeNChannelBMP 2
    writeTGA :: FilePath -> Image YAColor -> IO ()
writeTGA = CInt -> FilePath -> Image YAColor -> IO ()
forall a. Storable a => CInt -> FilePath -> Image a -> IO ()
writeNChannelTGA 2

    red :: YAColor -> Word8
red   (YAColor y :: Word8
y _) = Word8
y
    green :: YAColor -> Word8
green (YAColor y :: Word8
y _) = Word8
y
    blue :: YAColor -> Word8
blue  (YAColor y :: Word8
y _) = Word8
y
    alpha :: YAColor -> Word8
alpha (YAColor _ a :: Word8
a) = Word8
a

instance Show YAColor where
    show :: YAColor -> FilePath
show = YAColor -> FilePath
forall a. Color a => a -> FilePath
showColor

instance Show (ColorFlag YAColor) where
    show :: ColorFlag YAColor -> FilePath
show _ = "YA"

instance Color RGBColor where
    data ColorFlag RGBColor = RGB
    loadImage :: ColorFlag RGBColor
-> FilePath -> IO (Either FilePath (Image RGBColor))
loadImage RGB = (Either FilePath (Image CUChar)
 -> Either FilePath (Image RGBColor))
-> IO (Either FilePath (Image CUChar))
-> IO (Either FilePath (Image RGBColor))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Image CUChar -> Image RGBColor)
-> Either FilePath (Image CUChar)
-> Either FilePath (Image RGBColor)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second Image CUChar -> Image RGBColor
forall a b. (Storable a, Storable b) => Image a -> Image b
unsafeCastImage) (IO (Either FilePath (Image CUChar))
 -> IO (Either FilePath (Image RGBColor)))
-> (FilePath -> IO (Either FilePath (Image CUChar)))
-> FilePath
-> IO (Either FilePath (Image RGBColor))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> FilePath -> IO (Either FilePath (Image CUChar))
loadImageBytes 3
    writePNG :: FilePath -> Image RGBColor -> IO ()
writePNG = CInt -> FilePath -> Image RGBColor -> IO ()
forall a. Storable a => CInt -> FilePath -> Image a -> IO ()
writeNChannelPNG 3
    writeBMP :: FilePath -> Image RGBColor -> IO ()
writeBMP = CInt -> FilePath -> Image RGBColor -> IO ()
forall a. Storable a => CInt -> FilePath -> Image a -> IO ()
writeNChannelBMP 3
    writeTGA :: FilePath -> Image RGBColor -> IO ()
writeTGA = CInt -> FilePath -> Image RGBColor -> IO ()
forall a. Storable a => CInt -> FilePath -> Image a -> IO ()
writeNChannelTGA 3

    red :: RGBColor -> Word8
red   (RGBColor r :: Word8
r _ _) = Word8
r
    green :: RGBColor -> Word8
green (RGBColor _ g :: Word8
g _) = Word8
g
    blue :: RGBColor -> Word8
blue  (RGBColor _ _ b :: Word8
b) = Word8
b
    alpha :: RGBColor -> Word8
alpha _                = 255

instance Show RGBColor where
    show :: RGBColor -> FilePath
show = RGBColor -> FilePath
forall a. Color a => a -> FilePath
showColor

instance Show (ColorFlag RGBColor) where
    show :: ColorFlag RGBColor -> FilePath
show _ = "RGB"

instance Color RGBAColor where
    data ColorFlag RGBAColor = RGBA
    loadImage :: ColorFlag RGBAColor
-> FilePath -> IO (Either FilePath (Image RGBAColor))
loadImage RGBA = (Either FilePath (Image CUChar)
 -> Either FilePath (Image RGBAColor))
-> IO (Either FilePath (Image CUChar))
-> IO (Either FilePath (Image RGBAColor))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Image CUChar -> Image RGBAColor)
-> Either FilePath (Image CUChar)
-> Either FilePath (Image RGBAColor)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second Image CUChar -> Image RGBAColor
forall a b. (Storable a, Storable b) => Image a -> Image b
unsafeCastImage) (IO (Either FilePath (Image CUChar))
 -> IO (Either FilePath (Image RGBAColor)))
-> (FilePath -> IO (Either FilePath (Image CUChar)))
-> FilePath
-> IO (Either FilePath (Image RGBAColor))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> FilePath -> IO (Either FilePath (Image CUChar))
loadImageBytes 4
    writePNG :: FilePath -> Image RGBAColor -> IO ()
writePNG = CInt -> FilePath -> Image RGBAColor -> IO ()
forall a. Storable a => CInt -> FilePath -> Image a -> IO ()
writeNChannelPNG 4
    writeBMP :: FilePath -> Image RGBAColor -> IO ()
writeBMP = CInt -> FilePath -> Image RGBAColor -> IO ()
forall a. Storable a => CInt -> FilePath -> Image a -> IO ()
writeNChannelBMP 4
    writeTGA :: FilePath -> Image RGBAColor -> IO ()
writeTGA = CInt -> FilePath -> Image RGBAColor -> IO ()
forall a. Storable a => CInt -> FilePath -> Image a -> IO ()
writeNChannelTGA 4

    red :: RGBAColor -> Word8
red   (RGBAColor r :: Word8
r _ _ _) = Word8
r
    green :: RGBAColor -> Word8
green (RGBAColor _ g :: Word8
g _ _) = Word8
g
    blue :: RGBAColor -> Word8
blue  (RGBAColor _ _ b :: Word8
b _) = Word8
b
    alpha :: RGBAColor -> Word8
alpha (RGBAColor _ _ _ a :: Word8
a) = Word8
a

instance Show RGBAColor where
    show :: RGBAColor -> FilePath
show = RGBAColor -> FilePath
forall a. Color a => a -> FilePath
showColor

instance Show (ColorFlag RGBAColor) where
    show :: ColorFlag RGBAColor -> FilePath
show _ = "RGBA"

-- | 'showColor' is a default implementation of 'Show' for any instance
--   of the 'Color' typeclass.
showColor :: (Color a) => a -> String
showColor :: a -> FilePath
showColor color :: a
color = FilePath -> Word8 -> Word8 -> Word8 -> Word8 -> FilePath
forall r. PrintfType r => FilePath -> r
printf "(#%02X%02X%02X%02X)" (a -> Word8
forall a. Color a => a -> Word8
red a
color) (a -> Word8
forall a. Color a => a -> Word8
green a
color) (a -> Word8
forall a. Color a => a -> Word8
blue a
color) (a -> Word8
forall a. Color a => a -> Word8
alpha a
color)