module Gamgine.Image.PNG
(
PNGImage, Width, Height
, loadPNGFile
, dimensions
, imageData
, hasAlphaChannel
) where
import Codec.Compression.Zlib
import Text.Parsec.Combinator
import Text.Parsec.Prim
import Data.Array.Unboxed
import Data.Array.Storable
import Data.Word
import Data.List
import Data.Int
import Data.Char
import System.IO
import Control.Monad.Except
import Control.Monad (when, liftM3)
import Gamgine.Image.PNG.Internal.Parser
import Gamgine.Image.PNG.Internal.CRC
import Gamgine.Image.PNG.Internal.Filters
import qualified Gamgine.Image.PNG.Internal.LBS as LBS
import Gamgine.Image.PNG.Internal.LBS (LBS)
import Gamgine.Utils ()
data RawPNGChunk = RawPNGChunk {
RawPNGChunk -> String
rawPngChunk_type :: !String,
RawPNGChunk -> LBS
rawPngChunk_data :: !LBS
} deriving (Int -> RawPNGChunk -> ShowS
[RawPNGChunk] -> ShowS
RawPNGChunk -> String
(Int -> RawPNGChunk -> ShowS)
-> (RawPNGChunk -> String)
-> ([RawPNGChunk] -> ShowS)
-> Show RawPNGChunk
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RawPNGChunk -> ShowS
showsPrec :: Int -> RawPNGChunk -> ShowS
$cshow :: RawPNGChunk -> String
show :: RawPNGChunk -> String
$cshowList :: [RawPNGChunk] -> ShowS
showList :: [RawPNGChunk] -> ShowS
Show)
type Width = Word32
type Height = Word32
type Rgb = (Word8, Word8, Word8)
data PNGChunk =
IHDR {
PNGChunk -> Word32
ihdr_width :: !Width
, PNGChunk -> Word32
ihdr_height :: !Height
, PNGChunk -> BitDepth
ihdr_bitDepth :: !BitDepth
, PNGChunk -> ColorType
ihdr_colorType :: !ColorType
, PNGChunk -> CompressionMethod
ihdr_compressionMethod :: !CompressionMethod
, PNGChunk -> FilterMethod
ihdr_filterMethod :: !FilterMethod
, PNGChunk -> InterlaceMethod
ihdr_interlaceMethod :: !InterlaceMethod }
| PLTE {
PNGChunk -> Array Word8 Rgb
plte_entries :: !(Array Word8 Rgb) }
| IDAT {
PNGChunk -> LBS
idat_data :: !LBS }
| UnknownChunk RawPNGChunk
| IEND
deriving (Int -> PNGChunk -> ShowS
[PNGChunk] -> ShowS
PNGChunk -> String
(Int -> PNGChunk -> ShowS)
-> (PNGChunk -> String) -> ([PNGChunk] -> ShowS) -> Show PNGChunk
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PNGChunk -> ShowS
showsPrec :: Int -> PNGChunk -> ShowS
$cshow :: PNGChunk -> String
show :: PNGChunk -> String
$cshowList :: [PNGChunk] -> ShowS
showList :: [PNGChunk] -> ShowS
Show)
data ColorType = Ct0 | Ct2 | Ct3 | Ct4 | Ct6 deriving (Int -> ColorType -> ShowS
[ColorType] -> ShowS
ColorType -> String
(Int -> ColorType -> ShowS)
-> (ColorType -> String)
-> ([ColorType] -> ShowS)
-> Show ColorType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ColorType -> ShowS
showsPrec :: Int -> ColorType -> ShowS
$cshow :: ColorType -> String
show :: ColorType -> String
$cshowList :: [ColorType] -> ShowS
showList :: [ColorType] -> ShowS
Show,ColorType -> ColorType -> Bool
(ColorType -> ColorType -> Bool)
-> (ColorType -> ColorType -> Bool) -> Eq ColorType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ColorType -> ColorType -> Bool
== :: ColorType -> ColorType -> Bool
$c/= :: ColorType -> ColorType -> Bool
/= :: ColorType -> ColorType -> Bool
Eq)
data BitDepth = Bd1 | Bd2 | Bd4 | Bd8 | Bd16 deriving (Int -> BitDepth -> ShowS
[BitDepth] -> ShowS
BitDepth -> String
(Int -> BitDepth -> ShowS)
-> (BitDepth -> String) -> ([BitDepth] -> ShowS) -> Show BitDepth
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> BitDepth -> ShowS
showsPrec :: Int -> BitDepth -> ShowS
$cshow :: BitDepth -> String
show :: BitDepth -> String
$cshowList :: [BitDepth] -> ShowS
showList :: [BitDepth] -> ShowS
Show,BitDepth -> BitDepth -> Bool
(BitDepth -> BitDepth -> Bool)
-> (BitDepth -> BitDepth -> Bool) -> Eq BitDepth
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: BitDepth -> BitDepth -> Bool
== :: BitDepth -> BitDepth -> Bool
$c/= :: BitDepth -> BitDepth -> Bool
/= :: BitDepth -> BitDepth -> Bool
Eq)
data CompressionMethod = Deflate deriving (Int -> CompressionMethod -> ShowS
[CompressionMethod] -> ShowS
CompressionMethod -> String
(Int -> CompressionMethod -> ShowS)
-> (CompressionMethod -> String)
-> ([CompressionMethod] -> ShowS)
-> Show CompressionMethod
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CompressionMethod -> ShowS
showsPrec :: Int -> CompressionMethod -> ShowS
$cshow :: CompressionMethod -> String
show :: CompressionMethod -> String
$cshowList :: [CompressionMethod] -> ShowS
showList :: [CompressionMethod] -> ShowS
Show,CompressionMethod -> CompressionMethod -> Bool
(CompressionMethod -> CompressionMethod -> Bool)
-> (CompressionMethod -> CompressionMethod -> Bool)
-> Eq CompressionMethod
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CompressionMethod -> CompressionMethod -> Bool
== :: CompressionMethod -> CompressionMethod -> Bool
$c/= :: CompressionMethod -> CompressionMethod -> Bool
/= :: CompressionMethod -> CompressionMethod -> Bool
Eq)
data FilterMethod = Adaptive deriving (Int -> FilterMethod -> ShowS
[FilterMethod] -> ShowS
FilterMethod -> String
(Int -> FilterMethod -> ShowS)
-> (FilterMethod -> String)
-> ([FilterMethod] -> ShowS)
-> Show FilterMethod
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> FilterMethod -> ShowS
showsPrec :: Int -> FilterMethod -> ShowS
$cshow :: FilterMethod -> String
show :: FilterMethod -> String
$cshowList :: [FilterMethod] -> ShowS
showList :: [FilterMethod] -> ShowS
Show,FilterMethod -> FilterMethod -> Bool
(FilterMethod -> FilterMethod -> Bool)
-> (FilterMethod -> FilterMethod -> Bool) -> Eq FilterMethod
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: FilterMethod -> FilterMethod -> Bool
== :: FilterMethod -> FilterMethod -> Bool
$c/= :: FilterMethod -> FilterMethod -> Bool
/= :: FilterMethod -> FilterMethod -> Bool
Eq)
data InterlaceMethod = NoInterlace | Adam7 deriving (Int -> InterlaceMethod -> ShowS
[InterlaceMethod] -> ShowS
InterlaceMethod -> String
(Int -> InterlaceMethod -> ShowS)
-> (InterlaceMethod -> String)
-> ([InterlaceMethod] -> ShowS)
-> Show InterlaceMethod
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> InterlaceMethod -> ShowS
showsPrec :: Int -> InterlaceMethod -> ShowS
$cshow :: InterlaceMethod -> String
show :: InterlaceMethod -> String
$cshowList :: [InterlaceMethod] -> ShowS
showList :: [InterlaceMethod] -> ShowS
Show,InterlaceMethod -> InterlaceMethod -> Bool
(InterlaceMethod -> InterlaceMethod -> Bool)
-> (InterlaceMethod -> InterlaceMethod -> Bool)
-> Eq InterlaceMethod
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: InterlaceMethod -> InterlaceMethod -> Bool
== :: InterlaceMethod -> InterlaceMethod -> Bool
$c/= :: InterlaceMethod -> InterlaceMethod -> Bool
/= :: InterlaceMethod -> InterlaceMethod -> Bool
Eq)
isIDAT :: PNGChunk -> Bool
isIDAT :: PNGChunk -> Bool
isIDAT (IDAT LBS
_) = Bool
True
isIDAT PNGChunk
_ = Bool
False
data PNGImage = PNGImage {
:: !PNGChunk
, PNGImage -> [PNGChunk]
pngImg_otherChunks :: ![PNGChunk]
, PNGImage -> StorableArray (Int, Int) Word8
pngImg_imageData :: !(StorableArray (Int,Int) Word8)
}
instance Show PNGImage where
show :: PNGImage -> String
show PNGImage
_ = String
"PNGImage"
pngHeaderBytes :: LBS
= [Word8] -> LBS
LBS.pack [Word8
137, Word8
80, Word8
78, Word8
71, Word8
13, Word8
10, Word8
26, Word8
10]
pngFile :: Parser [RawPNGChunk]
pngFile :: Parser [RawPNGChunk]
pngFile = do
LBS -> ParsecT LBS () Identity LBS
forall (m :: * -> *) u. Monad m => LBS -> ParsecT LBS u m LBS
string LBS
pngHeaderBytes
RawPNGChunk
hdr <- Parser RawPNGChunk
rawPngChunk
Bool -> ParsecT LBS () Identity () -> ParsecT LBS () Identity ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (RawPNGChunk -> String
rawPngChunk_type RawPNGChunk
hdr String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
"IHDR") (ParsecT LBS () Identity () -> ParsecT LBS () Identity ())
-> ParsecT LBS () Identity () -> ParsecT LBS () Identity ()
forall a b. (a -> b) -> a -> b
$
String -> ParsecT LBS () Identity ()
forall a. String -> ParsecT LBS () Identity a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"expecting IHDR as the first chunk"
[RawPNGChunk]
rest <- Parser RawPNGChunk -> Parser [RawPNGChunk]
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 Parser RawPNGChunk
rawPngChunk
[RawPNGChunk] -> Parser [RawPNGChunk]
forall a. a -> ParsecT LBS () Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (RawPNGChunk
hdrRawPNGChunk -> [RawPNGChunk] -> [RawPNGChunk]
forall a. a -> [a] -> [a]
:[RawPNGChunk]
rest)
rawPngChunk :: Parser RawPNGChunk
rawPngChunk :: Parser RawPNGChunk
rawPngChunk = do
Word32
len <- ParsecT LBS () Identity Word32
forall (m :: * -> *) u. Monad m => ParsecT LBS u m Word32
anyWord32
LBS
chunkType <- Int -> ParsecT LBS () Identity LBS
forall (m :: * -> *) u. Monad m => Int -> ParsecT LBS u m LBS
block Int
4
LBS
chunkData <- Int -> ParsecT LBS () Identity LBS
forall (m :: * -> *) u. Monad m => Int -> ParsecT LBS u m LBS
block (Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
len)
let expectedCrc :: Word32
expectedCrc = LBS -> Word32
crc ([LBS] -> LBS
LBS.concat [LBS
chunkType,LBS
chunkData])
Word32 -> ParsecT LBS () Identity Word32
forall (m :: * -> *) u. Monad m => Word32 -> ParsecT LBS u m Word32
word32 Word32
expectedCrc ParsecT LBS () Identity Word32
-> String -> ParsecT LBS () Identity Word32
forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
"valid crc"
RawPNGChunk -> Parser RawPNGChunk
forall a. a -> ParsecT LBS () Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (RawPNGChunk -> Parser RawPNGChunk)
-> RawPNGChunk -> Parser RawPNGChunk
forall a b. (a -> b) -> a -> b
$ String -> LBS -> RawPNGChunk
RawPNGChunk (LBS -> String
LBS.unpackToString LBS
chunkType) LBS
chunkData
parsePlte :: Parser PNGChunk
parsePlte :: Parser PNGChunk
parsePlte = do
[Rgb]
paletteEntries <- ParsecT LBS () Identity Rgb -> ParsecT LBS () Identity [Rgb]
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 ParsecT LBS () Identity Rgb
forall {u}. ParsecT LBS u Identity Rgb
paletteEntry
PNGChunk -> Parser PNGChunk
forall a. a -> ParsecT LBS () Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (PNGChunk -> Parser PNGChunk)
-> (Array Word8 Rgb -> PNGChunk)
-> Array Word8 Rgb
-> Parser PNGChunk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Array Word8 Rgb -> PNGChunk
PLTE (Array Word8 Rgb -> Parser PNGChunk)
-> Array Word8 Rgb -> Parser PNGChunk
forall a b. (a -> b) -> a -> b
$ (Word8, Word8) -> [Rgb] -> Array Word8 Rgb
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
(i, i) -> [e] -> a i e
listArray (Word8
0, Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([Rgb] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Rgb]
paletteEntriesInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)) [Rgb]
paletteEntries
where
paletteEntry :: ParsecT LBS u Identity Rgb
paletteEntry = (Word8 -> Word8 -> Word8 -> Rgb)
-> ParsecT LBS u Identity Word8
-> ParsecT LBS u Identity Word8
-> ParsecT LBS u Identity Word8
-> ParsecT LBS u Identity Rgb
forall (m :: * -> *) a1 a2 a3 r.
Monad m =>
(a1 -> a2 -> a3 -> r) -> m a1 -> m a2 -> m a3 -> m r
liftM3 (,,) ParsecT LBS u Identity Word8
forall (m :: * -> *) u. Monad m => ParsecT LBS u m Word8
anyWord8 ParsecT LBS u Identity Word8
forall (m :: * -> *) u. Monad m => ParsecT LBS u m Word8
anyWord8 ParsecT LBS u Identity Word8
forall (m :: * -> *) u. Monad m => ParsecT LBS u m Word8
anyWord8
parseIhdr :: Parser PNGChunk
parseIhdr :: Parser PNGChunk
parseIhdr = do
Word32
width <- ParsecT LBS () Identity Word32
forall (m :: * -> *) u. Monad m => ParsecT LBS u m Word32
anyWord32
Word32
height <- ParsecT LBS () Identity Word32
forall (m :: * -> *) u. Monad m => ParsecT LBS u m Word32
anyWord32
BitDepth
bitDepth <- (Word8 -> Parser Word8) -> [(Word8, BitDepth)] -> Parser BitDepth
forall a b. (a -> Parser a) -> [(a, b)] -> Parser b
allowedValues Word8 -> Parser Word8
forall (m :: * -> *) u. Monad m => Word8 -> ParsecT LBS u m Word8
word8 [(Word8
8,BitDepth
Bd8)]
Parser BitDepth -> String -> Parser BitDepth
forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
"valid bit depth (supported: Bd8)"
ColorType
colorType <- (Word8 -> Parser Word8) -> [(Word8, ColorType)] -> Parser ColorType
forall a b. (a -> Parser a) -> [(a, b)] -> Parser b
allowedValues Word8 -> Parser Word8
forall (m :: * -> *) u. Monad m => Word8 -> ParsecT LBS u m Word8
word8 [(Word8
2,ColorType
Ct2), (Word8
6,ColorType
Ct6)]
Parser ColorType -> String -> Parser ColorType
forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
"valid colorType: supported Ct2,Ct6"
CompressionMethod
compressionMethod <- (Word8 -> Parser Word8)
-> [(Word8, CompressionMethod)] -> Parser CompressionMethod
forall a b. (a -> Parser a) -> [(a, b)] -> Parser b
allowedValues Word8 -> Parser Word8
forall (m :: * -> *) u. Monad m => Word8 -> ParsecT LBS u m Word8
word8 [(Word8
0, CompressionMethod
Deflate)]
Parser CompressionMethod -> String -> Parser CompressionMethod
forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
"valid compression method: supported Deflate"
FilterMethod
filterMethod <- (Word8 -> Parser Word8)
-> [(Word8, FilterMethod)] -> Parser FilterMethod
forall a b. (a -> Parser a) -> [(a, b)] -> Parser b
allowedValues Word8 -> Parser Word8
forall (m :: * -> *) u. Monad m => Word8 -> ParsecT LBS u m Word8
word8 [(Word8
0, FilterMethod
Adaptive)]
Parser FilterMethod -> String -> Parser FilterMethod
forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
"valid filter method: supported Adaptive"
InterlaceMethod
interlaceMethod <- (Word8 -> Parser Word8)
-> [(Word8, InterlaceMethod)] -> Parser InterlaceMethod
forall a b. (a -> Parser a) -> [(a, b)] -> Parser b
allowedValues Word8 -> Parser Word8
forall (m :: * -> *) u. Monad m => Word8 -> ParsecT LBS u m Word8
word8 [(Word8
0, InterlaceMethod
NoInterlace)]
Parser InterlaceMethod -> String -> Parser InterlaceMethod
forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
"valid interlace method: supported NoInterlace"
PNGChunk -> Parser PNGChunk
forall a. a -> ParsecT LBS () Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (PNGChunk -> Parser PNGChunk) -> PNGChunk -> Parser PNGChunk
forall a b. (a -> b) -> a -> b
$ IHDR {
ihdr_width :: Word32
ihdr_width = Word32
width
, ihdr_height :: Word32
ihdr_height = Word32
height
, ihdr_bitDepth :: BitDepth
ihdr_bitDepth = BitDepth
bitDepth
, ihdr_colorType :: ColorType
ihdr_colorType = ColorType
colorType
, ihdr_compressionMethod :: CompressionMethod
ihdr_compressionMethod = CompressionMethod
compressionMethod
, ihdr_filterMethod :: FilterMethod
ihdr_filterMethod = FilterMethod
filterMethod
, ihdr_interlaceMethod :: InterlaceMethod
ihdr_interlaceMethod = InterlaceMethod
interlaceMethod
}
toPngChunk :: RawPNGChunk -> Either String PNGChunk
toPngChunk :: RawPNGChunk -> Either String PNGChunk
toPngChunk RawPNGChunk
raw =
case String
chunkName of
String
"IHDR" -> Parser PNGChunk -> Either String PNGChunk
forall {m :: * -> *} {a}. MonadFail m => Parsec LBS () a -> m a
parseChunkData Parser PNGChunk
parseIhdr
String
"PLTE" -> Parser PNGChunk -> Either String PNGChunk
forall {m :: * -> *} {a}. MonadFail m => Parsec LBS () a -> m a
parseChunkData Parser PNGChunk
parsePlte
String
"IEND" -> PNGChunk -> Either String PNGChunk
forall a. a -> Either String a
forall (m :: * -> *) a. Monad m => a -> m a
return PNGChunk
IEND
String
"IDAT" -> PNGChunk -> Either String PNGChunk
forall a. a -> Either String a
forall (m :: * -> *) a. Monad m => a -> m a
return (PNGChunk -> Either String PNGChunk)
-> PNGChunk -> Either String PNGChunk
forall a b. (a -> b) -> a -> b
$ LBS -> PNGChunk
IDAT (RawPNGChunk -> LBS
rawPngChunk_data RawPNGChunk
raw)
String
_ -> PNGChunk -> Either String PNGChunk
forall a. a -> Either String a
forall (m :: * -> *) a. Monad m => a -> m a
return (PNGChunk -> Either String PNGChunk)
-> PNGChunk -> Either String PNGChunk
forall a b. (a -> b) -> a -> b
$ RawPNGChunk -> PNGChunk
UnknownChunk RawPNGChunk
raw
where
parseChunkData :: Parsec LBS () a -> m a
parseChunkData Parsec LBS () a
a =
case Parsec LBS () a -> () -> String -> LBS -> Either ParseError a
forall s t u a.
Stream s Identity t =>
Parsec s u a -> u -> String -> s -> Either ParseError a
runP Parsec LBS () a
a () String
"" (RawPNGChunk -> LBS
rawPngChunk_data RawPNGChunk
raw) of
Left ParseError
e -> String -> m a
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m a) -> String -> m a
forall a b. (a -> b) -> a -> b
$ String
"failed to parse chunk " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> String
show String
chunkName String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
", " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ParseError -> String
forall a. Show a => a -> String
show ParseError
e
Right a
x -> a -> m a
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x
chunkName :: String
chunkName = RawPNGChunk -> String
rawPngChunk_type RawPNGChunk
raw
toPngImage :: [RawPNGChunk] -> IO (Either String PNGImage)
toPngImage :: [RawPNGChunk] -> IO (Either String PNGImage)
toPngImage [RawPNGChunk]
chunks = do
case (RawPNGChunk -> Either String PNGChunk)
-> [RawPNGChunk] -> Either String [PNGChunk]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM RawPNGChunk -> Either String PNGChunk
toPngChunk [RawPNGChunk]
chunks Either String [PNGChunk]
-> ([PNGChunk] -> Either String ([PNGChunk], [PNGChunk]))
-> Either String ([PNGChunk], [PNGChunk])
forall a b.
Either String a -> (a -> Either String b) -> Either String b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ([PNGChunk], [PNGChunk]) -> Either String ([PNGChunk], [PNGChunk])
forall a. a -> Either String a
forall (m :: * -> *) a. Monad m => a -> m a
return (([PNGChunk], [PNGChunk])
-> Either String ([PNGChunk], [PNGChunk]))
-> ([PNGChunk] -> ([PNGChunk], [PNGChunk]))
-> [PNGChunk]
-> Either String ([PNGChunk], [PNGChunk])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PNGChunk -> Bool) -> [PNGChunk] -> ([PNGChunk], [PNGChunk])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition PNGChunk -> Bool
isIDAT of
Right ([PNGChunk]
_, []) -> Either String PNGImage -> IO (Either String PNGImage)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String PNGImage -> IO (Either String PNGImage))
-> Either String PNGImage -> IO (Either String PNGImage)
forall a b. (a -> b) -> a -> b
$ String -> Either String PNGImage
forall a b. a -> Either a b
Left String
"File has no chunks!"
Right ([PNGChunk]
dataChunks, PNGChunk
hdr:[PNGChunk]
otherChunks) -> do
let dataDecompressed :: ByteString
dataDecompressed = ByteString -> ByteString
decompress (ByteString -> ByteString)
-> ([PNGChunk] -> ByteString) -> [PNGChunk] -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LBS -> ByteString
LBS.unLBS (LBS -> ByteString)
-> ([PNGChunk] -> LBS) -> [PNGChunk] -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [LBS] -> LBS
LBS.concat ([LBS] -> LBS) -> ([PNGChunk] -> [LBS]) -> [PNGChunk] -> LBS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PNGChunk -> LBS) -> [PNGChunk] -> [LBS]
forall a b. (a -> b) -> [a] -> [b]
map PNGChunk -> LBS
idat_data ([PNGChunk] -> ByteString) -> [PNGChunk] -> ByteString
forall a b. (a -> b) -> a -> b
$ [PNGChunk]
dataChunks
bpp :: Int
bpp = ColorType -> BitDepth -> Int
bytesPerPixel (PNGChunk -> ColorType
ihdr_colorType PNGChunk
hdr) (PNGChunk -> BitDepth
ihdr_bitDepth PNGChunk
hdr)
w :: Int
w = Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (PNGChunk -> Word32
ihdr_width PNGChunk
hdr)
h :: Int
h = Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (PNGChunk -> Word32
ihdr_height PNGChunk
hdr)
StorableArray (Int, Int) Word8
sls <- (Int, Int)
-> Int -> ByteString -> IO (StorableArray (Int, Int) Word8)
defilter_scanlines_arr (Int
w,Int
h) (Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
bpp) ByteString
dataDecompressed
Either String PNGImage -> IO (Either String PNGImage)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String PNGImage -> IO (Either String PNGImage))
-> Either String PNGImage -> IO (Either String PNGImage)
forall a b. (a -> b) -> a -> b
$ PNGImage -> Either String PNGImage
forall a b. b -> Either a b
Right (PNGChunk
-> [PNGChunk] -> StorableArray (Int, Int) Word8 -> PNGImage
PNGImage PNGChunk
hdr [PNGChunk]
otherChunks StorableArray (Int, Int) Word8
sls)
Left String
x -> Either String PNGImage -> IO (Either String PNGImage)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String PNGImage -> IO (Either String PNGImage))
-> Either String PNGImage -> IO (Either String PNGImage)
forall a b. (a -> b) -> a -> b
$ String -> Either String PNGImage
forall a b. a -> Either a b
Left String
x
loadPNGFile :: FilePath -> IO (Either String PNGImage)
loadPNGFile :: String -> IO (Either String PNGImage)
loadPNGFile String
fn = do
Either String [RawPNGChunk]
rawChunks <- Parser [RawPNGChunk] -> String -> IO (Either String [RawPNGChunk])
forall a. Parser a -> String -> IO (Either String a)
parseFromFile Parser [RawPNGChunk]
pngFile String
fn
case Either String [RawPNGChunk]
rawChunks of
Right [RawPNGChunk]
chunks -> [RawPNGChunk] -> IO (Either String PNGImage)
toPngImage [RawPNGChunk]
chunks IO (Either String PNGImage)
-> (IOException -> IO (Either String PNGImage))
-> IO (Either String PNGImage)
forall a. IO a -> (IOException -> IO a) -> IO a
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
`catchError` (\IOException
e -> Either String PNGImage -> IO (Either String PNGImage)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Either String PNGImage
forall a b. a -> Either a b
Left (IOException -> String
forall a. Show a => a -> String
show IOException
e)))
Left String
s -> Either String PNGImage -> IO (Either String PNGImage)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Either String PNGImage
forall a b. a -> Either a b
Left String
s)
sampleWidth :: BitDepth -> Int
sampleWidth :: BitDepth -> Int
sampleWidth BitDepth
Bd1 = Int
1
sampleWidth BitDepth
Bd2 = Int
2
sampleWidth BitDepth
Bd4 = Int
4
sampleWidth BitDepth
Bd8 = Int
8
sampleWidth BitDepth
Bd16 = Int
16
bytesPerPixel :: ColorType -> BitDepth -> Int
bytesPerPixel :: ColorType -> BitDepth -> Int
bytesPerPixel ColorType
Ct0 BitDepth
Bd16 = Int
2
bytesPerPixel ColorType
Ct0 BitDepth
_ = Int
1
bytesPerPixel ColorType
Ct2 BitDepth
Bd1 = Int
1
bytesPerPixel ColorType
Ct2 BitDepth
Bd2 = Int
1
bytesPerPixel ColorType
Ct2 BitDepth
Bd4 = Int
2
bytesPerPixel ColorType
Ct2 BitDepth
Bd8 = Int
3
bytesPerPixel ColorType
Ct2 BitDepth
Bd16 = Int
6
bytesPerPixel ColorType
Ct3 BitDepth
_ = Int
3
bytesPerPixel ColorType
Ct4 BitDepth
Bd8 = Int
2
bytesPerPixel ColorType
Ct4 BitDepth
Bd16 = Int
4
bytesPerPixel ColorType
Ct4 BitDepth
_ = Int
1
bytesPerPixel ColorType
Ct6 BitDepth
Bd8 = Int
4
bytesPerPixel ColorType
Ct6 BitDepth
Bd16 = Int
8
bytesPerPixel ColorType
Ct6 BitDepth
Bd4 = Int
2
bytesPerPixel ColorType
Ct6 BitDepth
_ = Int
1
hasAlphaChannel :: PNGImage -> Bool
hasAlphaChannel :: PNGImage -> Bool
hasAlphaChannel PNGImage
img = case PNGChunk -> ColorType
ihdr_colorType PNGChunk
hdr of
ColorType
Ct6 -> Bool
True
ColorType
_ -> Bool
False
where hdr :: PNGChunk
hdr = PNGImage -> PNGChunk
pngImg_header PNGImage
img
dimensions :: PNGImage -> (Width,Height)
dimensions :: PNGImage -> (Word32, Word32)
dimensions PNGImage
img = (PNGChunk -> Word32
ihdr_width PNGChunk
hdr, PNGChunk -> Word32
ihdr_height PNGChunk
hdr)
where hdr :: PNGChunk
hdr = PNGImage -> PNGChunk
pngImg_header PNGImage
img
pixelWidth :: PNGImage -> Int
pixelWidth :: PNGImage -> Int
pixelWidth PNGImage
img = ColorType -> BitDepth -> Int
bytesPerPixel (PNGChunk -> ColorType
ihdr_colorType PNGChunk
hdr) (PNGChunk -> BitDepth
ihdr_bitDepth PNGChunk
hdr)
where hdr :: PNGChunk
hdr = PNGImage -> PNGChunk
pngImg_header PNGImage
img
imageData :: PNGImage -> StorableArray (Int,Int) Word8
imageData :: PNGImage -> StorableArray (Int, Int) Word8
imageData PNGImage
img = PNGImage -> StorableArray (Int, Int) Word8
pngImg_imageData PNGImage
img