-----------------------------------------------------------------------------
-- |
-- Module      :  Graphics.Formats.PNG
-- Copyright   :  (c) Marko Lauronen 2008
-- License     :  BSD
--
-- Maintainer  :  marko.lauronen@pp1.inet.fi
-- Stability   :  experimental
-- Portability :  non-portable (GHC only)
--
-- A simple, pure Haskell PNG loader. Currently supports 24bit RGB(A) images
-- with no interlacing. Also lacks support for color indexed (paletted) images.
--
-- The image is stored in a StorableArray for compatibility with OpenGL (the
-- array supports getting Ptr Word8 to the image data using withStorableArray
-- function).
--
-----------------------------------------------------------------------------
module Gamgine.Image.PNG
    (
     -- * Types
      PNGImage, Width, Height
     -- * Functions
    , loadPNGFile
    , dimensions
    --, pixelWidth
    , 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 ()

-- | Type for raw PNG chunks
-- The parsing happens in two phases: first the file is read into
-- raw chunks, then the raw chunks are parsed into actual PNGChunks
-- This is due to the CRC checksum that requires is easiest to compute
-- with raw chunk data.
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)

-- | The actual fully parsed chunk type
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    -- chunk types not supported yet
  | 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 {
      PNGImage -> PNGChunk
pngImg_header  :: !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"

-- | Raw chunk parsing

pngHeaderBytes :: LBS
pngHeaderBytes :: LBS
pngHeaderBytes = [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

-- | Final chunk parsing

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
  -- [(1,Bd1), (2,Bd2), (4,Bd4), (8,Bd8), (16,Bd16)]
  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)"
  --[(0,Ct0), (2,Ct2), (3,Ct3), (4,Ct4), (6,Ct6)]
  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"
  -- [(0, NoInterlace), (1, Adam7)]
  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
             }

-- | conversion from raw chunks to final chunks
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

-- |Load a PNG file, Left value contains a description of a problem as a String,
-- if any
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

-- |Check if the image has alpha channel
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

-- |Get dimensions of the image (in pixels)
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

-- |Bytes per pixel
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

-- |Get image data as C-compatible StorableArray
imageData :: PNGImage -> StorableArray (Int,Int) Word8
imageData :: PNGImage -> StorableArray (Int, Int) Word8
imageData PNGImage
img = PNGImage -> StorableArray (Int, Int) Word8
pngImg_imageData PNGImage
img