diff --git a/LICENSE b/LICENSE
new file mode 100644
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,165 @@
+ GNU LESSER GENERAL PUBLIC LICENSE
+ Version 3, 29 June 2007
+
+ Copyright (C) 2007 Free Software Foundation, Inc.
+ Everyone is permitted to copy and distribute verbatim copies
+ of this license document, but changing it is not allowed.
+
+
+ This version of the GNU Lesser General Public License incorporates
+the terms and conditions of version 3 of the GNU General Public
+License, supplemented by the additional permissions listed below.
+
+ 0. Additional Definitions.
+
+ As used herein, "this License" refers to version 3 of the GNU Lesser
+General Public License, and the "GNU GPL" refers to version 3 of the GNU
+General Public License.
+
+ "The Library" refers to a covered work governed by this License,
+other than an Application or a Combined Work as defined below.
+
+ An "Application" is any work that makes use of an interface provided
+by the Library, but which is not otherwise based on the Library.
+Defining a subclass of a class defined by the Library is deemed a mode
+of using an interface provided by the Library.
+
+ A "Combined Work" is a work produced by combining or linking an
+Application with the Library. The particular version of the Library
+with which the Combined Work was made is also called the "Linked
+Version".
+
+ The "Minimal Corresponding Source" for a Combined Work means the
+Corresponding Source for the Combined Work, excluding any source code
+for portions of the Combined Work that, considered in isolation, are
+based on the Application, and not on the Linked Version.
+
+ The "Corresponding Application Code" for a Combined Work means the
+object code and/or source code for the Application, including any data
+and utility programs needed for reproducing the Combined Work from the
+Application, but excluding the System Libraries of the Combined Work.
+
+ 1. Exception to Section 3 of the GNU GPL.
+
+ You may convey a covered work under sections 3 and 4 of this License
+without being bound by section 3 of the GNU GPL.
+
+ 2. Conveying Modified Versions.
+
+ If you modify a copy of the Library, and, in your modifications, a
+facility refers to a function or data to be supplied by an Application
+that uses the facility (other than as an argument passed when the
+facility is invoked), then you may convey a copy of the modified
+version:
+
+ a) under this License, provided that you make a good faith effort to
+ ensure that, in the event an Application does not supply the
+ function or data, the facility still operates, and performs
+ whatever part of its purpose remains meaningful, or
+
+ b) under the GNU GPL, with none of the additional permissions of
+ this License applicable to that copy.
+
+ 3. Object Code Incorporating Material from Library Header Files.
+
+ The object code form of an Application may incorporate material from
+a header file that is part of the Library. You may convey such object
+code under terms of your choice, provided that, if the incorporated
+material is not limited to numerical parameters, data structure
+layouts and accessors, or small macros, inline functions and templates
+(ten or fewer lines in length), you do both of the following:
+
+ a) Give prominent notice with each copy of the object code that the
+ Library is used in it and that the Library and its use are
+ covered by this License.
+
+ b) Accompany the object code with a copy of the GNU GPL and this license
+ document.
+
+ 4. Combined Works.
+
+ You may convey a Combined Work under terms of your choice that,
+taken together, effectively do not restrict modification of the
+portions of the Library contained in the Combined Work and reverse
+engineering for debugging such modifications, if you also do each of
+the following:
+
+ a) Give prominent notice with each copy of the Combined Work that
+ the Library is used in it and that the Library and its use are
+ covered by this License.
+
+ b) Accompany the Combined Work with a copy of the GNU GPL and this license
+ document.
+
+ c) For a Combined Work that displays copyright notices during
+ execution, include the copyright notice for the Library among
+ these notices, as well as a reference directing the user to the
+ copies of the GNU GPL and this license document.
+
+ d) Do one of the following:
+
+ 0) Convey the Minimal Corresponding Source under the terms of this
+ License, and the Corresponding Application Code in a form
+ suitable for, and under terms that permit, the user to
+ recombine or relink the Application with a modified version of
+ the Linked Version to produce a modified Combined Work, in the
+ manner specified by section 6 of the GNU GPL for conveying
+ Corresponding Source.
+
+ 1) Use a suitable shared library mechanism for linking with the
+ Library. A suitable mechanism is one that (a) uses at run time
+ a copy of the Library already present on the user's computer
+ system, and (b) will operate properly with a modified version
+ of the Library that is interface-compatible with the Linked
+ Version.
+
+ e) Provide Installation Information, but only if you would otherwise
+ be required to provide such information under section 6 of the
+ GNU GPL, and only to the extent that such information is
+ necessary to install and execute a modified version of the
+ Combined Work produced by recombining or relinking the
+ Application with a modified version of the Linked Version. (If
+ you use option 4d0, the Installation Information must accompany
+ the Minimal Corresponding Source and Corresponding Application
+ Code. If you use option 4d1, you must provide the Installation
+ Information in the manner specified by section 6 of the GNU GPL
+ for conveying Corresponding Source.)
+
+ 5. Combined Libraries.
+
+ You may place library facilities that are a work based on the
+Library side by side in a single library together with other library
+facilities that are not Applications and are not covered by this
+License, and convey such a combined library under terms of your
+choice, if you do both of the following:
+
+ a) Accompany the combined library with a copy of the same work based
+ on the Library, uncombined with any other library facilities,
+ conveyed under the terms of this License.
+
+ b) Give prominent notice with the combined library that part of it
+ is a work based on the Library, and explaining where to find the
+ accompanying uncombined form of the same work.
+
+ 6. Revised Versions of the GNU Lesser General Public License.
+
+ The Free Software Foundation may publish revised and/or new versions
+of the GNU Lesser General Public License from time to time. Such new
+versions will be similar in spirit to the present version, but may
+differ in detail to address new problems or concerns.
+
+ Each version is given a distinguishing version number. If the
+Library as you received it specifies that a certain numbered version
+of the GNU Lesser General Public License "or any later version"
+applies to it, you have the option of following the terms and
+conditions either of that published version or of any later version
+published by the Free Software Foundation. If the Library as you
+received it does not specify a version number of the GNU Lesser
+General Public License, you may choose any version of the GNU Lesser
+General Public License ever published by the Free Software Foundation.
+
+ If the Library as you received it specifies that a proxy can decide
+whether future versions of the GNU Lesser General Public License shall
+apply, that proxy's public statement of acceptance of any version is
+permanent authorization for you to choose that version for the
+Library.
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/demo/Main.hs b/demo/Main.hs
new file mode 100644
--- /dev/null
+++ b/demo/Main.hs
@@ -0,0 +1,62 @@
+{-# LANGUAGE FlexibleContexts #-}
+module Main where
+
+import Codec.Picture (DynamicImage)
+import qualified Codec.Picture.Png as Juicy
+import Codec.Picture.Png.Streaming
+import Codec.Picture.Png.Streaming.Juicy
+
+import Control.Monad (void)
+import Control.Monad.IO.Class (MonadIO (..))
+import Control.Monad.Trans.Resource (MonadResource, runResourceT)
+
+import qualified Data.ByteString as B
+
+import Criterion.Main
+
+import qualified Data.ByteString.Streaming as Q
+import Streaming.Prelude (Of (..))
+
+readPNG :: (MonadResource m) => FilePath -> m DynamicImage
+readPNG readPath =
+ do decoded <- decodePNGFile readPath
+ res :> _ <- imageFromStream decoded
+ return res
+
+decodeBS :: B.ByteString -> IO DynamicImage
+decodeBS bs =
+ do decoded <- decodePNG $ Q.fromStrict bs
+ res :> _ <- imageFromStream decoded
+ return res
+
+copyPNG :: (MonadResource m) => FilePath -> FilePath -> m ()
+copyPNG readPath writePath =
+ do image <- readPNG readPath
+ liftIO . void $ Juicy.writeDynamicPng writePath image
+
+fstOf :: Of a b -> a
+fstOf (x :> _) = x
+
+benchImage :: (String, B.ByteString) -> [Benchmark]
+benchImage (path, image) =
+ -- [ bench ("read " ++ path ++ " with JuicyPixels") . nf Juicy.decodePng $ image
+ [ bench ("read " ++ path ++ " with streaming") . nfIO $ decodeBS image
+ ]
+
+benchmarkMain :: IO ()
+benchmarkMain =
+ do hugeFile <- B.readFile "huge.png"
+ largeFile <- B.readFile "large.png"
+ mediumFile <- B.readFile "medium.png"
+ smallFile <- B.readFile "small.png"
+
+ defaultMain $ benchImage =<< [("huge.png", hugeFile)]
+ -- [ ("small.png", smallFile)
+ -- , ("medium.png", mediumFile)
+ -- , ("large.png", largeFile)
+ -- , ("huge.png", hugeFile)
+ -- ]
+
+main :: IO ()
+-- main = runResourceT $ copyPNG "huge.png" "result.png"
+main = benchmarkMain
diff --git a/src/Codec/Picture/Png/Streaming.hs b/src/Codec/Picture/Png/Streaming.hs
new file mode 100644
--- /dev/null
+++ b/src/Codec/Picture/Png/Streaming.hs
@@ -0,0 +1,140 @@
+{-|
+Module : Codec.Picture.Png.Streaming
+Copyright : (c) Bradley Hardy 2016
+License: LGPL3
+Maintainer: bradleyhardy@live.com
+Stability: experimental
+Portability: non-portable
+
+A perfectly streaming PNG decoding library.
+-}
+
+{-# LANGUAGE RecordWildCards #-}
+module Codec.Picture.Png.Streaming
+ (
+ -- * Decoding
+ decodePNG
+ , decodePNGComplete
+ , decodePNGFile
+ , decodeHeader
+
+ -- * Types
+ , PNGDecodeError(..)
+ , DecodedPNG
+ , HeaderData(..)
+
+ -- * Misc
+ , ChunkType
+ , BitDepth
+ , ColourType
+ , CompressionMethod
+ , FilterMethod
+ , FilterType
+ , InterlaceMethod
+
+ , isColourTypeSupported
+ , isCompressionMethodSupported
+ , isFilterMethodSupported
+ , isInterlaceMethodSupported
+ )
+ where
+
+import Codec.Picture.Png.Streaming.Core
+import Codec.Picture.Png.Streaming.Header
+import Codec.Picture.Png.Streaming.Info
+import Codec.Picture.Png.Streaming.MainData
+import Codec.Picture.Png.Streaming.Util
+
+import Control.Monad (unless)
+import Control.Monad.Catch (MonadThrow (..))
+import Control.Monad.IO.Class (MonadIO (..))
+import Control.Monad.Trans (MonadTrans (..))
+import Control.Monad.Trans.Resource (MonadResource)
+
+import Data.ByteString.Streaming (ByteString)
+import qualified Data.ByteString.Streaming as Q
+import Streaming.Prelude (Of (..))
+
+-- | A decoded PNG: header information followed by decoded pixel data whose
+-- format depends on the image's colour type and bit depth.
+type DecodedPNG m r = Of HeaderData (ByteString m r)
+
+{-|
+Decode a PNG from the given raw streaming 'ByteString'. The result is header
+information followed by a stream of bytes that can be interpreted directly as
+pixels whose format depends on the image's colour type and bit depth.
+
+Any remaining data after the end of the PNG image is returned untouched.
+-}
+decodePNG :: (MonadThrow m, MonadIO m) => ByteString m r -> m (DecodedPNG m (ByteString m r))
+decodePNG input =
+ do (hd :> rest) <- takeHeaderData (decodePNGChunks input)
+ unless (isImageTypeSupported hd) (throwM UnsupportedImageType)
+ return (hd :> decodeImageData hd rest)
+
+{-|
+Decode just the PNG header data from the given raw streaming 'ByteString',
+inspecting the minimum number of bytes from the input necessary to do so. The
+remaining bytes are returned also.
+-}
+decodeHeader :: (MonadThrow m) => ByteString m r -> m (Of HeaderData (ByteString m r))
+decodeHeader input =
+ do PNGChunk{..} <-
+ either (const $ throwM UnexpectedEOF) return
+ =<< decodeChunk input
+
+ unless (chunkType == ctIHDR) (throwM (UnexpectedChunk chunkType))
+ tryDecodeHeader chunkData
+
+{-|
+Decode a PNG from the given raw streaming 'ByteString'. The result is header
+information followed by a stream of bytes that can be interpreted directly as
+pixels whose format depends on the image's colour type and bit depth.
+
+If there is any more data after the end of the PNG image, an 'ExpectedEOF'
+exception is thrown.
+-}
+decodePNGComplete :: (MonadThrow m, MonadIO m) => ByteString m r -> m (DecodedPNG m r)
+decodePNGComplete input =
+ do (hd :> rest) <- decodePNG input
+ let rest' = lift . expectNull ExpectedEOF =<< rest
+ return (hd :> rest')
+
+{-|
+Decode a PNG from the given file. The result is header information followed by a
+stream of bytes that can be interpreted directly as pixels whose format depends
+on the image's colour type and bit depth.
+
+If there is any more data after the end of the PNG image, an 'ExpectedEOF'
+exception is thrown.
+-}
+decodePNGFile :: (MonadResource m) => FilePath -> m (DecodedPNG m ())
+decodePNGFile = decodePNGComplete . Q.readFile
+
+-- | Is the PNG image type described by the given header supported?
+isImageTypeSupported :: HeaderData -> Bool
+isImageTypeSupported HeaderData{..} =
+ isColourTypeSupported hdColourType &&
+ isCompressionMethodSupported hdCompressionMethod &&
+ isFilterMethodSupported hdFilterMethod &&
+ isInterlaceMethodSupported hdInterlaceMethod
+
+-- | Is the given PNG image colour type supported? Currently we only support
+-- non-indexed colour types.
+isColourTypeSupported :: ColourType -> Bool
+isColourTypeSupported = (`elem` [0, 2, 4, 6])
+
+-- | Is the given PNG compression method supported? Currently we only support
+-- method 0.
+isCompressionMethodSupported :: CompressionMethod -> Bool
+isCompressionMethodSupported = (== 0)
+
+-- | Is the given PNG filter method supported? Currently we only support method
+-- 0.
+isFilterMethodSupported :: FilterMethod -> Bool
+isFilterMethodSupported = (== 0)
+
+-- | Is the given PNG interlace method supported? Currently only the null
+-- interlace method (no interlacing) is supported.
+isInterlaceMethodSupported :: InterlaceMethod -> Bool
+isInterlaceMethodSupported = (== 0)
diff --git a/src/Codec/Picture/Png/Streaming/Core.hs b/src/Codec/Picture/Png/Streaming/Core.hs
new file mode 100644
--- /dev/null
+++ b/src/Codec/Picture/Png/Streaming/Core.hs
@@ -0,0 +1,227 @@
+{-|
+Module : Codec.Picture.Png.Streaming.Core
+Copyright : (c) Bradley Hardy 2016
+License: LGPL3
+Maintainer: bradleyhardy@live.com
+Stability: experimental
+Portability: non-portable
+
+-}
+
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE RecordWildCards #-}
+module Codec.Picture.Png.Streaming.Core
+ ( ChunkType
+ , ChunkLength
+ , PNGDecodeError(..)
+ , PNGEncodeError(..)
+ , PNGChunk(..)
+ , decodePNGChunks
+ , encodePNGChunks
+ , decodeChunk
+ )
+ where
+
+import Streaming.CRC
+import Codec.Picture.Png.Streaming.Info
+import Codec.Picture.Png.Streaming.Util
+
+import Control.Monad (join, when)
+import Control.Monad.Catch (Exception, MonadThrow (..))
+import Control.Monad.Trans (lift)
+import qualified Data.ByteString as B
+import Data.Int (Int64)
+import qualified Data.Serialize as C
+import Data.Word (Word32)
+
+import Data.ByteString.Streaming (ByteString)
+import qualified Data.ByteString.Streaming as Q
+import Streaming (Stream)
+import qualified Streaming as S
+import Streaming.Prelude (Of (..))
+
+--------------------------------------------------------------------------------
+-- Types
+
+-- | A raw chunk of PNG data, containing the length, type and a streaming
+-- 'ByteString' of data.
+data PNGChunk m r =
+ PNGChunk
+ { chunkLength :: ChunkLength
+ , chunkType :: ChunkType
+ , chunkData :: ByteString m r
+ }
+ deriving (Functor)
+
+-- | The type of errors that might arise when decoding a PNG.
+data PNGDecodeError
+ = IncorrectSignature
+ | CRCMismatch
+ | UnexpectedEOF
+ | BadChunkSize ChunkType
+ | UnexpectedChunk ChunkType
+ | UnsupportedImageType
+ | UnsupportedColourType
+ | UnsupportedFilterType FilterType
+ | ExpectedEOF
+ | UnknownError String
+ deriving (Show)
+
+instance Exception PNGDecodeError where
+
+-- | The type of errors that might arise when encoding a PNG.
+data PNGEncodeError
+ = IncorrectLength
+ deriving (Show)
+
+instance Exception PNGEncodeError where
+
+--------------------------------------------------------------------------------
+-- Raw decode and encode functions
+
+-- | Fully decode a PNG to its raw streaming representation, returning the PNG
+-- data chunks until "IEND" is reached. The return value is the (potentially
+-- empty) rest of the 'ByteString' after the PNG.
+
+{-|
+
+Decode a stream of individual PNG chunks from a raw streaming 'ByteString'
+input. The return value of the resulting stream is any remaining data after
+encountering the final "IEND" chunk.
+
+-}
+decodePNGChunks :: (MonadThrow m) => ByteString m r -> Stream (PNGChunk m) m (ByteString m r)
+decodePNGChunks = S.unfold decodeChunk . checkSig
+
+-- | Encode a stream of individual PNG chunks into a raw streaming 'ByteString'.
+encodePNGChunks :: (MonadThrow m) => Stream (PNGChunk m) m r -> ByteString m r
+encodePNGChunks png =
+ do Q.fromStrict pngSignature
+ res <- S.iterTM (join . encodeChunk) png
+ encodeChunk chunkIEND
+ return res
+
+--------------------------------------------------------------------------------
+-- Decoding and encoding individual chunks
+
+-- | Decode a chunk of a PNG file, returning the raw binary data in the chunk
+-- followed by the rest of the input; or the remaining data in the 'ByteString'
+-- if we have reached the "IEND" chunk.
+decodeChunk
+ :: (MonadThrow m)
+ => ByteString m r
+ -> m (Either (ByteString m r) (PNGChunk m (ByteString m r)))
+decodeChunk input =
+ do -- The first 4 bytes tell us the length of the chunk
+ lenBS :> input' <- Q.toStrict $ Q.splitAt 4 input
+
+ -- Read the length (which is in big endian) using 'cereal',
+ -- throwing an error if it can't be read.
+ chunkLength <- readWord32 lenBS
+
+ -- Split at the end of the chunk, and calculate the CRC of the data, while
+ -- copying the chunk data so that we can hand it to 'reader'.
+ let input'' = calcCRC32 $ Q.copy $ Q.splitAt (fromIntegral chunkLength + 4) input'
+
+ -- The next 4 bytes tell us the chunk type.
+ chunkType :> input''' <- Q.toStrict $ Q.splitAt 4 input''
+
+ -- The length of the chunk type can't be more than 4 because we split at 4,
+ -- but if it's less then we have encountered an error.
+ when (B.length chunkType < 4) (throwM UnexpectedEOF)
+
+ -- Use the provided 'reader' function to read the input, while
+ -- simultaneously calculating the CRC of the data.
+ let readData = Q.splitAt (fromIntegral chunkLength) input'''
+
+ -- Discard the rest of the first ByteString in the result, as it's always
+ -- empty, then make sure we fail with an error if the CRC is wrong.
+ chunkData = checkCRC <$> Q.drained readData
+
+ if chunkType /= ctIEND
+ then return $ Right PNGChunk{..}
+ else Left <$> Q.effects chunkData
+
+-- | Encode a chunk of a PNG file with a specified length and chunk type. The
+-- input 'PNGChunk' must not lie about its length. If it does, an
+-- 'IncorrectLength' error will be thrown. It is important to know the length
+-- at the head of the chunk to maintain streaming.
+encodeChunk
+ :: (MonadThrow m)
+ => PNGChunk m r -- ^ The data segment to write.
+ -> ByteString m r -- ^ The resulting data encoded as a PNG chunk.
+encodeChunk PNGChunk{..} =
+ do let lenBS = C.runPut . C.putWord32be $ chunkLength
+
+ -- write the
+ Q.fromStrict lenBS
+
+ let -- restrict the length of the input to the given data length as above
+ restrictedLen = checkLength (fromIntegral chunkLength) chunkData
+
+ -- tack the chunk type bytes to the front
+ -- it is important to do this BEFORE calculating the CRC, because the
+ -- CRC applies to the chunk type too (but not to the length)
+ withChunkType = Q.fromStrict chunkType >> restrictedLen
+
+ -- calculate the CRC and write that to the end
+ appendCRC32 withChunkType
+
+--------------------------------------------------------------------------------
+-- Extra helper functions
+
+-- | Check the length of a ByteString against an expected length. Running the
+-- resulting 'ByteString' to the end will throw an error if it is not exactly the
+-- right length.
+checkLength
+ :: MonadThrow m
+ => Int64
+ -> ByteString m r
+ -> ByteString m r
+checkLength expectedLength input =
+ do (len :> rest) <- Q.length $ Q.copy $ Q.splitAt expectedLength input
+ when (fromIntegral len /= expectedLength) $
+ lift $ throwM IncorrectLength
+
+ lift $ expectNull IncorrectLength rest
+
+-- | Read 32 bits from a 'B.ByteString' into a 'Word32'. Throws an
+-- 'UnexpectedEOF' exception if the bits can't be read.
+readWord32 :: MonadThrow m => B.ByteString -> m Word32
+readWord32 bs =
+ case C.runGet C.getWord32be bs of
+ Left _ -> throwM UnexpectedEOF
+ Right x -> return (fromIntegral x)
+
+-- | Given an expected CRC and a 'ByteString' whose first 4 bytes should match
+-- that CRC, check if there is a match. If not, throw a 'CRCMismatch' error. If
+-- it matches, return the remainder of the 'ByteString'.
+checkCRC :: MonadThrow m => Of Word32 (ByteString m r) -> ByteString m r
+checkCRC (dataCRC :> bytes) = Q.mwrap $
+ do (crcBS :> bytes') <- Q.toStrict $ Q.splitAt 4 bytes
+ crc <- readWord32 crcBS
+ if crc == dataCRC
+ then return bytes'
+ else throwM CRCMismatch
+
+-- | Check the fixed PNG signature, return the rest of the input after the
+-- signature.
+checkSig :: MonadThrow m => ByteString m r -> ByteString m r
+checkSig input = Q.mwrap $ do
+ (header :> remainder) <- Q.toStrict $ Q.splitAt 8 input
+ if header == pngSignature
+ then return remainder
+ else throwM IncorrectSignature
+
+chunkIEND :: (Monad m) => PNGChunk m ()
+chunkIEND =
+ let chunkLength = 0
+ chunkType = ctIEND
+ chunkData = mempty
+ in PNGChunk{..}
diff --git a/src/Codec/Picture/Png/Streaming/Header.hs b/src/Codec/Picture/Png/Streaming/Header.hs
new file mode 100644
--- /dev/null
+++ b/src/Codec/Picture/Png/Streaming/Header.hs
@@ -0,0 +1,90 @@
+{-|
+Module : Codec.Picture.Png.Streaming.Header
+Copyright : (c) Bradley Hardy 2016
+License: LGPL3
+Maintainer: bradleyhardy@live.com
+Stability: experimental
+Portability: non-portable
+
+-}
+
+{-# LANGUAGE RecordWildCards #-}
+module Codec.Picture.Png.Streaming.Header
+ ( HeaderData(..)
+ , takeHeaderData
+ , tryDecodeHeader
+ )
+ where
+
+import Codec.Picture.Png.Streaming.Core
+import Codec.Picture.Png.Streaming.Info
+import Codec.Picture.Png.Streaming.Util
+
+import Control.Monad (unless)
+import Control.Monad.Catch (MonadThrow (..))
+
+import qualified Data.ByteString as B
+import qualified Data.Serialize as C
+import Data.Word (Word32)
+
+import Data.ByteString.Streaming (ByteString)
+import qualified Data.ByteString.Streaming as Q
+import Streaming (Stream)
+import qualified Streaming as S
+import Streaming.Prelude (Of (..))
+
+-- | Represents the header data of a PNG file in raw binary format.
+data HeaderData =
+ HeaderData
+ { hdWidth :: Word32
+ , hdHeight :: Word32
+ , hdBitDepth :: BitDepth
+ , hdColourType :: ColourType
+ , hdCompressionMethod :: CompressionMethod
+ , hdFilterMethod :: FilterMethod
+ , hdInterlaceMethod :: InterlaceMethod
+ }
+ deriving (Show)
+
+-- | Take the header data from the front of a stream and return the remainder.
+-- Throws an 'UnexpectedChunk' exception if the first chunk isn't of type
+-- "IHDR", or 'UnexpectedEOF' if the stream is empty.
+takeHeaderData :: (MonadThrow m) => Stream (PNGChunk m) m r -> m (Of HeaderData (Stream (PNGChunk m) m r))
+takeHeaderData input =
+ do maybeChunk <- S.inspect input
+ case maybeChunk of
+ Left _ -> throwM UnexpectedEOF
+ Right PNGChunk{..} ->
+ do unless (chunkType == ctIHDR) (throwM (UnexpectedChunk chunkType))
+ tryDecodeHeader chunkData
+
+deserializeHeaderData :: B.ByteString -> Either String HeaderData
+deserializeHeaderData = C.runGet $
+ do hdWidth <- C.getWord32be
+ hdHeight <- C.getWord32be
+ hdBitDepth <- C.getWord8
+ hdColourType <- C.getWord8
+ hdCompressionMethod <- C.getWord8
+ hdFilterMethod <- C.getWord8
+ hdInterlaceMethod <- C.getWord8
+ return HeaderData{..}
+
+-- serializeHeaderData :: HeaderData -> B.ByteString
+-- serializeHeaderData HeaderData{..} = C.runPut $
+-- do C.putWord32be hdWidth
+-- C.putWord32be hdHeight
+-- C.putWord8 hdBitDepth
+-- C.putWord8 hdColourType
+-- C.putWord8 hdCompressionMethod
+-- C.putWord8 hdFilterMethod
+-- C.putWord8 hdInterlaceMethod
+
+-- | Try to decode a PNG header from a ByteString, failing if it is of the wrong
+-- length.
+tryDecodeHeader
+ :: MonadThrow m => ByteString m r -> m (Of HeaderData r)
+tryDecodeHeader input =
+ do (bytes :> rest) <- Q.toStrict $ Q.splitAt (fromIntegral ihdrLength) input
+ res <- expectNull (BadChunkSize ctIHDR) rest
+ parsed <- either (throwM . UnknownError) return (deserializeHeaderData bytes)
+ return (parsed :> res)
diff --git a/src/Codec/Picture/Png/Streaming/Info.hs b/src/Codec/Picture/Png/Streaming/Info.hs
new file mode 100644
--- /dev/null
+++ b/src/Codec/Picture/Png/Streaming/Info.hs
@@ -0,0 +1,137 @@
+{-|
+Module : Codec.Picture.Png.Streaming.Info
+Copyright : (c) Bradley Hardy 2016
+License: LGPL3
+Maintainer: bradleyhardy@live.com
+Stability: experimental
+Portability: non-portable
+
+-}
+
+{-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE OverloadedStrings #-}
+module Codec.Picture.Png.Streaming.Info where
+
+import qualified Data.ByteString as B
+import Data.Int (Int16)
+import Data.Word (Word16, Word32, Word8)
+
+-- | A chunk type, represented as a 'B.ByteString' of length 4.
+type ChunkType = B.ByteString
+
+-- | A chunk length.
+type ChunkLength = Word32
+
+-- | A colour type.
+type ColourType = Word8
+
+-- | A bit depth.
+type BitDepth = Word8
+
+-- | A PNG compression method (distinct from the type in 'Streaming.Zlib' of the
+-- same name).
+type CompressionMethod = Word8
+
+-- | A PNG filtering method.
+type FilterMethod = Word8
+
+-- | A PNG interlacing method.
+type InterlaceMethod = Word8
+
+-- | A PNG filter type, for filter method 0.
+type FilterType = Word8
+
+-- | The 4-byte identifier for a PNG header chunk.
+ctIHDR :: ChunkType
+ctIHDR = "IHDR"
+
+-- | The 4-byte identifier for a PNG data chunk.
+ctIDAT :: ChunkType
+ctIDAT = "IDAT"
+
+-- | The 4-byte identifier for a PNG ending chunk.
+ctIEND :: ChunkType
+ctIEND = "IEND"
+
+-- | The 8-byte signature for a PNG file.
+pngSignature :: B.ByteString
+pngSignature = "\137PNG\r\n\26\n"
+
+-- | The length of the header chunk.
+ihdrLength :: ChunkLength
+ihdrLength = 13
+
+-- | From a bit depth and colour type, return the number of bits in each pixel,
+-- checking also that the bit depth provided is allowed for the given colour
+-- type.
+getBitsPerPixel :: BitDepth -> ColourType -> Maybe Word8
+getBitsPerPixel bitDepth colourType
+ -- greyscale
+ | colourType == 0 && bitDepth `elem` [1, 2, 4, 8, 16] = Just bitDepth
+ -- indexed colour
+ | colourType == 3 && bitDepth `elem` [1, 2, 4, 8] = Just bitDepth
+ -- truecolour
+ | colourType == 2 && bitDepth == 8 || bitDepth == 16 = Just (bitDepth * 3)
+ -- greyscale with alpha
+ | colourType == 4 && bitDepth == 8 || bitDepth == 16 = Just (bitDepth * 2)
+ -- truecolour with alpha
+ | colourType == 6 && bitDepth == 8 || bitDepth == 16 = Just (bitDepth * 4)
+ -- unknown
+ | otherwise = Nothing
+
+-- | The Paeth predictor function due to Alan W. Paeth.
+paethPredictor :: Word8 -> Word8 -> Word8 -> Word8
+paethPredictor a b c =
+ -- It is important to convert the bytes to signed integers before doing the
+ -- calculations, because the Paeth predictor relies on signed arithmetic.
+ let ia = fromIntegral a :: Int16
+ ib = fromIntegral b
+ ic = fromIntegral c
+
+ p = ia + ib - ic
+ pa = abs (p - ia)
+ pb = abs (p - ib)
+ pc = abs (p - ic)
+ in if | pa <= pb && pa <= pc -> a
+ | pb <= pc -> b
+ | otherwise -> c
+
+-- | Average filter a byte.
+filterAverage :: Word8 -> Word8 -> Word8 -> Word8
+filterAverage a b x = x - fromIntegral ((fromIntegral a + fromIntegral b) `div` (2 :: Word16))
+{-# INLINE filterAverage #-}
+
+-- | Paeth filter a byte.
+filterPaeth :: Word8 -> Word8 -> Word8 -> Word8 -> Word8
+filterPaeth a b c x = x - paethPredictor a b c
+{-# INLINE filterPaeth #-}
+
+-- | Reconstruct an average filtered byte.
+reconAverage :: Word8 -> Word8 -> Word8 -> Word8
+reconAverage a b x = x + fromIntegral ((fromIntegral a + fromIntegral b) `div` (2 :: Word16))
+{-# INLINE reconAverage #-}
+
+-- | Reconstruct a Paeth filtered byte.
+reconPaeth :: Word8 -> Word8 -> Word8 -> Word8 -> Word8
+reconPaeth a b c x = x + paethPredictor a b c
+{-# INLINE reconPaeth #-}
+
+-- {- |
+-- Given a filter type, return the reconstruction function for a single byte, if
+-- the filter type is valid. If @f@ is a function returned by 'getReconFunction',
+-- the correct argument order is @f a b c x@, where those variable names match the
+-- ones used in the .
+-- -}
+-- getReconFunction :: FilterType -> Maybe (Word8 -> Word8 -> Word8 -> Word8 -> Word8)
+-- getReconFunction filterType =
+-- let ftInt = fromIntegral filterType
+-- funs = [ reconNone
+-- , reconSub
+-- , reconUp
+-- , reconAverage
+-- , reconPaeth ]
+
+-- in if ftInt < length funs
+-- then Just (funs !! ftInt)
+-- else Nothing
diff --git a/src/Codec/Picture/Png/Streaming/Juicy.hs b/src/Codec/Picture/Png/Streaming/Juicy.hs
new file mode 100644
--- /dev/null
+++ b/src/Codec/Picture/Png/Streaming/Juicy.hs
@@ -0,0 +1,74 @@
+{-|
+Module : Codec.Picture.Png.Streaming.Juicy
+Copyright : (c) Bradley Hardy 2016
+License: LGPL3
+Maintainer: bradleyhardy@live.com
+Stability: experimental
+Portability: non-portable
+
+Provides a way to produce @JuicyPixels@ images from PNG data decoded with
+@streaming-png@.
+
+For example, to load a @JuicyPixels@ image from a PNG file:
+
+> decodePNGFile "my-png.png" >>= imageFromStream :: (MonadIO m, MonadThrow m) => m (Of DynamicImage ())
+
+-}
+{-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE RecordWildCards #-}
+module Codec.Picture.Png.Streaming.Juicy
+ ( imageFromStream )
+ where
+
+import Codec.Picture
+import Codec.Picture.Png.Streaming
+import Codec.Picture.Png.Streaming.Util
+
+import Control.Monad.Catch (MonadThrow (..))
+
+import qualified Data.ByteString.Internal as BI
+import Data.Vector.Storable (Vector)
+import qualified Data.Vector.Storable as Vec
+import Data.Word (Word16, Word8)
+import Foreign (castForeignPtr, sizeOf)
+
+import Data.ByteString.Streaming (ByteString)
+import qualified Data.ByteString.Streaming as Q
+import Streaming.Prelude (Of (..))
+
+type BytePacker m b r = ByteString m r -> m (Of (Vector b) r)
+type MkImage m p r = (Int, Int) -> ByteString m r -> m (Of (Image p) r)
+
+bp8 :: (Monad m) => BytePacker m Word8 r
+bp8 input =
+ do bs :> res <- Q.toStrict input
+ return (bytestringToVector bs :> res)
+
+bp16 :: (Monad m) => BytePacker m Word16 r
+bp16 input =
+ do BI.PS fptr offset idx :> res <- Q.toStrict input
+ let ws = sizeOf (0 :: Word16)
+ return (Vec.unsafeFromForeignPtr (castForeignPtr fptr) (offset `div` ws) (idx `div` ws) :> res)
+
+mkImage :: (Monad m) => BytePacker m (PixelBaseComponent p) r -> MkImage m p r
+mkImage bytePacker (imageWidth, imageHeight) input =
+ do imageData :> res <- bytePacker input
+ return (Image{..} :> res)
+
+lmap :: (a -> b) -> Of a r -> Of b r
+lmap f (x :> r) = f x :> r
+
+-- | Pulls a PNG image stream into memory as a JuicyPixels 'DynamicImage'.
+-- Currently supports every legal non-indexed colour type.
+imageFromStream :: (MonadThrow m) => DecodedPNG m r -> m (Of DynamicImage r)
+imageFromStream (HeaderData{..} :> bytes) =
+ let wh = (fromIntegral hdWidth, fromIntegral hdHeight)
+ in if | hdColourType == 0 && hdBitDepth == 8 -> lmap ImageY8 <$> mkImage bp8 wh bytes
+ | hdColourType == 0 && hdBitDepth == 16 -> lmap ImageY16 <$> mkImage bp16 wh bytes
+ | hdColourType == 2 && hdBitDepth == 8 -> lmap ImageRGB8 <$> mkImage bp8 wh bytes
+ | hdColourType == 2 && hdBitDepth == 16 -> lmap ImageRGB16 <$> mkImage bp16 wh bytes
+ | hdColourType == 4 && hdBitDepth == 8 -> lmap ImageYA8 <$> mkImage bp8 wh bytes
+ | hdColourType == 4 && hdBitDepth == 16 -> lmap ImageYA16 <$> mkImage bp16 wh bytes
+ | hdColourType == 6 && hdBitDepth == 8 -> lmap ImageRGBA8 <$> mkImage bp8 wh bytes
+ | hdColourType == 6 && hdBitDepth == 16 -> lmap ImageRGBA16 <$> mkImage bp16 wh bytes
+ | otherwise -> throwM UnsupportedImageType
diff --git a/src/Codec/Picture/Png/Streaming/MainData.hs b/src/Codec/Picture/Png/Streaming/MainData.hs
new file mode 100644
--- /dev/null
+++ b/src/Codec/Picture/Png/Streaming/MainData.hs
@@ -0,0 +1,336 @@
+{-|
+Module : Codec.Picture.Png.Streaming.MainData
+Copyright : (c) Bradley Hardy 2016
+License: LGPL3
+Maintainer: bradleyhardy@live.com
+Stability: experimental
+Portability: non-portable
+
+-}
+{-# LANGUAGE RecordWildCards #-}
+module Codec.Picture.Png.Streaming.MainData
+ ( decodeImageData )
+ where
+
+import Codec.Picture.Png.Streaming.Core
+import Codec.Picture.Png.Streaming.Header
+import Codec.Picture.Png.Streaming.Info
+import Codec.Picture.Png.Streaming.Util
+import Streaming.Zlib
+
+import Control.Monad.Catch (MonadThrow (..))
+import Control.Monad.IO.Class (MonadIO (..))
+
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Unsafe as B
+import Data.Functor.Identity (Identity (..))
+import Data.Functor.Sum (Sum (..))
+import Data.Int (Int64)
+import qualified Data.Vector.Storable as Vec
+import qualified Data.Vector.Storable.Mutable as Vec
+import Data.Word (Word64)
+import Data.Foldable (minimumBy)
+import Data.Ord (comparing)
+
+import Data.ByteString.Streaming (ByteString)
+import qualified Data.ByteString.Streaming as Q
+import Streaming (Of (..), Stream)
+import qualified Streaming as S
+
+--------------------------------------------------------------------------------
+-- Main function
+
+{-|
+Given a stream of PNG chunks, decode the image data from it. The resulting bytes
+can be directly interpreted as pixels, whose format depends on the image's
+colour type.
+-}
+decodeImageData
+ :: (MonadThrow m, MonadIO m)
+ => HeaderData
+ -> Stream (PNGChunk m) m r
+ -> ByteString m r
+decodeImageData hd@HeaderData{..} =
+ let prevByteDistance =
+ case getBitsPerPixel hdBitDepth hdColourType of
+ Just bpp -> (fromIntegral bpp + 4) `div` 8
+ Nothing -> 1
+ in Q.fromChunks
+ . reconstructScanlines prevByteDistance
+ . splitImageDataByScanlines hd
+ . getDecompressedImageData
+
+--------------------------------------------------------------------------------
+-- Internals
+
+{- |
+
+Given a chunk type and a mapping function from a streaming ByteString to some
+other functor, returns a filtering function suitable for passing to
+'filterMapped' which accepts only the specified chunk type and applies the given
+function to the bytes of the chunks of that type.
+
+-}
+mapChunkOfType
+ :: (Monad m, Functor f)
+ => ChunkType
+ -> (ByteString m r -> m (f r))
+ -> PNGChunk m r
+ -> m (Sum Identity f r)
+mapChunkOfType desiredType f PNGChunk{..}
+ | chunkType == desiredType = InR <$> f chunkData
+ | otherwise = InL . Identity <$> Q.effects chunkData
+
+-- | From a raw stream of PNG chunks, filter out the IDAT chunks and decompress
+-- them.
+getDecompressedImageData
+ :: (MonadIO m, MonadThrow m)
+ => Stream (PNGChunk m) m r
+ -> ByteString m r
+getDecompressedImageData
+ = decompressStream
+ . Q.concat
+ . filterMapped (mapChunkOfType ctIDAT return)
+
+-- | Returns the number of bytes per scanline in a PNG with the given header, so
+-- long as the colour type and bit depth fields are compatible with each other.
+getScanlineLengthBytes :: HeaderData -> Maybe Int64
+getScanlineLengthBytes HeaderData{..}
+ = (1 +) -- Each scanline is preceded by a filter type byte
+ . ceiling
+ . (/ (8.0 :: Float))
+ . fromIntegral
+ . (* (fromIntegral hdWidth :: Word64))
+ . fromIntegral
+ <$> getBitsPerPixel hdBitDepth hdColourType
+
+-- | Split a stream of raw, decompressed, PNG image data into scanlines.
+splitImageDataByScanlines
+ :: (MonadThrow m)
+ => HeaderData
+ -> ByteString m r
+ -> Stream (ByteString m) m r
+splitImageDataByScanlines hd@HeaderData{..} input = S.effect $
+ do scanlineLength <-
+ maybe (throwM UnsupportedColourType) return (getScanlineLengthBytes hd)
+
+ return (chunksOfBS scanlineLength input)
+
+type UnfilteredScanline = B.ByteString
+type FilteredScanline = B.ByteString
+
+-- | Given a stream of filtered scanlines, reconstruct each of them.
+reconstructScanlines
+ :: (MonadThrow m)
+ => Int
+ -> Stream (ByteString m) m r
+ -> Stream (Of UnfilteredScanline) m r
+reconstructScanlines prevByteDistance
+ = mapWithMemory (reconstructScanline prevByteDistance)
+ . S.mapped Q.toStrict
+
+{- |
+
+Given a filtered scanline (whose first byte encodes the filter method), along
+with the previous unfiltered scanline (which is 'Nothing' if we're at the first
+scanline), reconstruct the pixel data. Fails at runtime, possible even with a
+segfault, if either input scanline is the wrong size.
+
+This is a giant ugly mess, but it's fast. Can it be refactored into something
+nicer while retaining its speed?
+
+Also, it still takes up roughly 50% of the running time of decoding a PNG. Maybe
+it can be made even faster?
+-}
+reconstructScanline
+ :: (MonadThrow m)
+ => Int
+ -> Maybe UnfilteredScanline
+ -> FilteredScanline
+ -> m UnfilteredScanline
+reconstructScanline prevByteDistance mprev filteredLine
+ | Just (filterType, this) <- B.uncons filteredLine =
+ let lenThis = B.length this
+
+ -- This function is equivalent to @forM_ [0 .. lenThis - 1]@, but
+ -- slightly faster in my benchmarks
+ loop :: Monad m => (Int -> m ()) -> m ()
+ loop action = go 0
+ where
+ go n | n < lenThis = do action n; go (n + 1)
+ | otherwise = return ()
+ {-# INLINE loop #-}
+
+ noFilter = this
+
+ subFilter = vectorToBytestring $ Vec.create $
+ do v <- Vec.new lenThis
+ loop $ \i ->
+ do a <- if i >= prevByteDistance
+ then Vec.read v (i - prevByteDistance)
+ else return 0
+ Vec.write v i (B.unsafeIndex this i + a)
+ return v
+
+ upFilter =
+ case mprev of
+ Just prev ->
+ vectorToBytestring $ Vec.generate lenThis $ \i ->
+ B.unsafeIndex prev i + B.unsafeIndex this i
+ Nothing -> this
+
+ averageFilter = vectorToBytestring $ Vec.create $
+ case mprev of
+ Just prev ->
+ do v <- Vec.new lenThis
+ loop $ \i ->
+ do a <- if i >= prevByteDistance
+ then Vec.read v (i - prevByteDistance)
+ else return 0
+ Vec.write v i (reconAverage a (B.unsafeIndex prev i) (B.unsafeIndex this i))
+ return v
+ Nothing ->
+ do v <- Vec.new lenThis
+ loop $ \i ->
+ do a <- if i >= prevByteDistance
+ then Vec.read v (i - prevByteDistance)
+ else return 0
+ Vec.write v i (reconAverage a 0 (B.unsafeIndex this i))
+ return v
+
+ paethFilter = vectorToBytestring $ Vec.create $
+ case mprev of
+ Just prev ->
+ do v <- Vec.new lenThis
+ loop $ \i ->
+ do (a, c) <- if i >= prevByteDistance
+ then do a <- Vec.read v (i - prevByteDistance)
+ return (a, B.unsafeIndex prev (i - prevByteDistance))
+ else return (0, 0)
+ Vec.write v i (reconPaeth a (B.unsafeIndex prev i) c (B.unsafeIndex this i))
+ return v
+ Nothing ->
+ do v <- Vec.new lenThis
+ loop $ \i ->
+ do a <- if i >= prevByteDistance
+ then Vec.read v (i - prevByteDistance)
+ else return 0
+ Vec.write v i (reconPaeth a 0 0 (B.unsafeIndex this i))
+ return v
+
+ res | filterType == 0 = noFilter
+ | filterType == 1 = subFilter
+ | filterType == 2 = upFilter
+ | filterType == 3 = averageFilter
+ | filterType == 4 = paethFilter
+ | otherwise = mempty
+
+ in if B.length res == lenThis
+ then return res
+ else throwM (UnsupportedFilterType filterType)
+
+ | otherwise = error "reconstructScanline: empty input"
+
+filterScanlineFixed
+ :: Int
+ -> Maybe FilteredScanline
+ -> UnfilteredScanline
+ -> FilterType
+ -> FilteredScanline
+filterScanlineFixed prevByteDistance mprev this filterType =
+ let lenThis = B.length this
+
+ -- This function is equivalent to @forM_ [0 .. lenThis - 1]@, but
+ -- slightly faster in my benchmarks
+ loop :: Monad m => (Int -> m ()) -> m ()
+ loop action = go 0
+ where
+ go n | n < lenThis = do action n; go (n + 1)
+ | otherwise = return ()
+ {-# INLINE loop #-}
+
+ noFilter = this
+
+ subFilter = vectorToBytestring $ Vec.create $
+ do v <- Vec.new lenThis
+ loop $ \i ->
+ do a <- if i >= prevByteDistance
+ then Vec.read v (i - prevByteDistance)
+ else return 0
+ Vec.write v i (B.unsafeIndex this i - a)
+ return v
+
+ upFilter =
+ case mprev of
+ Just prev ->
+ vectorToBytestring $ Vec.generate lenThis $ \i ->
+ B.unsafeIndex this i - B.unsafeIndex prev i
+ Nothing -> this
+
+ averageFilter = vectorToBytestring $ Vec.create $
+ case mprev of
+ Just prev ->
+ do v <- Vec.new lenThis
+ loop $ \i ->
+ do a <- if i >= prevByteDistance
+ then Vec.read v (i - prevByteDistance)
+ else return 0
+ Vec.write v i (filterAverage a (B.unsafeIndex prev i) (B.unsafeIndex this i))
+ return v
+ Nothing ->
+ do v <- Vec.new lenThis
+ loop $ \i ->
+ do a <- if i >= prevByteDistance
+ then Vec.read v (i - prevByteDistance)
+ else return 0
+ Vec.write v i (filterAverage a 0 (B.unsafeIndex this i))
+ return v
+
+ paethFilter = vectorToBytestring $ Vec.create $
+ case mprev of
+ Just prev ->
+ do v <- Vec.new lenThis
+ loop $ \i ->
+ do (a, c) <- if i >= prevByteDistance
+ then do a <- Vec.read v (i - prevByteDistance)
+ return (a, B.unsafeIndex prev (i - prevByteDistance))
+ else return (0, 0)
+ Vec.write v i (filterPaeth a (B.unsafeIndex prev i) c (B.unsafeIndex this i))
+ return v
+ Nothing ->
+ do v <- Vec.new lenThis
+ loop $ \i ->
+ do a <- if i >= prevByteDistance
+ then Vec.read v (i - prevByteDistance)
+ else return 0
+ Vec.write v i (filterPaeth a 0 0 (B.unsafeIndex this i))
+ return v
+
+ res | filterType == 0 = noFilter
+ | filterType == 1 = subFilter
+ | filterType == 2 = upFilter
+ | filterType == 3 = averageFilter
+ | filterType == 4 = paethFilter
+ | otherwise = error "filterScanlineFixed: bad filter type"
+
+ in res
+
+-- | Calculate the absolute value of the signed sum of the input bytes.
+absSumBytes :: B.ByteString -> Int64
+absSumBytes = abs . B.foldl' addSigned 0
+ where addSigned a b = a + fromIntegral b - 128
+
+data FilterHeuristic
+ = FixedFilter FilterType
+ | MinAbsSum
+
+filterScanline
+ :: FilterHeuristic
+ -> Int
+ -> Maybe FilteredScanline
+ -> UnfilteredScanline
+ -> FilteredScanline
+filterScanline (FixedFilter filterType) pbd mprev this = filterScanlineFixed pbd mprev this filterType
+filterScanline MinAbsSum pbd mprev this =
+ let differentMethods = map (filterScanlineFixed pbd mprev this) [0..4]
+ in minimumBy (comparing absSumBytes) differentMethods
diff --git a/src/Codec/Picture/Png/Streaming/Util.hs b/src/Codec/Picture/Png/Streaming/Util.hs
new file mode 100644
--- /dev/null
+++ b/src/Codec/Picture/Png/Streaming/Util.hs
@@ -0,0 +1,141 @@
+{-|
+Module : Codec.Picture.Png.Streaming.Util
+Copyright : (c) Bradley Hardy 2016
+License: LGPL3
+Maintainer: bradleyhardy@live.com
+Stability: experimental
+Portability: non-portable
+
+This is a set of assorted utility functions for @streaming@ and
+@streaming-bytestring@ which are used in various places in this library, but may
+also be of use to others so they are exposed here.
+
+-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+module Codec.Picture.Png.Streaming.Util where
+
+import Control.Monad.Catch (Exception, MonadThrow (..))
+import Control.Monad.Morph (generalize)
+import Control.Monad.Trans (MonadTrans (..))
+import qualified Data.ByteString.Internal as BI
+import Data.Functor.Identity (Identity (..))
+import Data.Functor.Sum (Sum (..))
+import Data.Int (Int64)
+import Data.Vector.Storable (Vector)
+import qualified Data.Vector.Storable as Vec
+import Data.Word (Word8)
+
+import Data.ByteString.Streaming (ByteString)
+import qualified Data.ByteString.Streaming as Q
+import Streaming (Stream)
+import qualified Streaming as S
+import Streaming.Prelude (Of (..))
+import qualified Streaming.Prelude as S
+
+-- | If the input 'ByteString' is empty, return its result. Otherwise throw the
+-- provided error value.
+expectNull :: (MonadThrow m, Exception e) => e -> ByteString m r -> m r
+expectNull err input =
+ do headChunk <- Q.nextChunk input
+ case headChunk of
+ Left res -> return res
+ Right _ -> throwM err
+
+-- | Split a streaming ByteString up into a stream of chunks of the given size.
+chunksOfBS :: (Monad m) => Int64 -> ByteString m r -> Stream (ByteString m) m r
+chunksOfBS n input =
+ do isEmpty <- lift (Q.null_ input)
+ if isEmpty
+ then lift (Q.effects input)
+ else do rest <- S.yields (Q.splitAt n input)
+ chunksOfBS n rest
+
+-- | Remember the previous value at each point in a stream of values.
+rememberPrevious :: (Monad m) => Stream (Of a) m r -> Stream (Of (Maybe a, a)) m r
+rememberPrevious = go Nothing
+ where
+ go prevItem input =
+ let continue (thisItem, rest) =
+ do S.yields ((prevItem, thisItem) :> ())
+ go (Just thisItem) rest
+ in lift (S.next input) >>= either return continue
+
+-- | Map a function across a stream, but also include in its arguments the
+-- result of applying it to the previous item in the stream (which is 'Nothing'
+-- if the current item is the first in the stream).
+mapWithMemory :: forall m a b r. (Monad m) => (Maybe b -> a -> m b) -> Stream (Of a) m r -> Stream (Of b) m r
+mapWithMemory f input = S.unfoldr step (Nothing, input)
+ where
+ step :: (Maybe b, Stream (Of a) m r) -> m (Either r (b, (Maybe b, Stream (Of a) m r)))
+ step (prevResult, stream) =
+ let handleItem (thisItem, remainder) =
+ do thisResult <- f prevResult thisItem
+ return (Right (thisResult, (Just thisResult, remainder)))
+ in S.next stream >>= either (return . Left) handleItem
+
+{-|
+
+For each functor wrapper @f@ in the stream, either strip it off or convert it to
+some new functor @g@. Return the stream of @g@'s. This can be seen to be
+analogous to a list function of type @'Monad' m => (a -> m ('Maybe' b)) -> [a]
+-> m [b]@ if we consider what it looks like when @f@ and @g@ are @'Of' a@ and
+@'Of' b@ respectively:
+
+> filterMapped
+> :: (forall x. Of a x -> m (Sum Identity (Of b) x))
+> -> Stream (Of a) m r -> Stream (Of b) m r
+
+Here, @'Sum' 'Identity' ('Of' b) x@ is isomorphic to @'Of' ('Maybe' b) x@.
+
+-}
+
+filterMapped
+ :: (Monad m, Functor f, Functor g)
+ => (forall x. f x -> m (Sum Identity g x))
+ -> Stream f m r
+ -> Stream g m r
+filterMapped f = S.run . S.maps generalize . S.separate . S.mapped f
+
+{-|
+
+For each functor wrapper in the stream, optionally strip it off. Those stripped
+off will be removed from the resulting stream.
+
+-}
+
+filtered
+ :: (Monad m, Functor f)
+ => (forall x. f x -> m (Maybe x))
+ -> Stream f m r
+ -> Stream f m r
+filtered f =
+ let f' x = maybe (InR x) (InL . Identity) <$> f x
+ in filterMapped f'
+
+
+-- | Build a 'ByteString' monadically from a seed.
+buildByteString
+ :: Monad m
+ => (a -> m (Either r (ByteString m (), a)))
+ -> a
+ -> ByteString m r
+buildByteString build seed =
+ do mx <- lift $ build seed
+ case mx of
+ Left r -> return r
+ Right (bs, seed') ->
+ do bs
+ buildByteString build seed'
+
+-- | Directly convert a 'BI.ByteString' into a storable 'Vector', in constant
+-- time.
+bytestringToVector :: BI.ByteString -> Vector Word8
+bytestringToVector (BI.PS fptr offset idx) = Vec.unsafeFromForeignPtr fptr offset idx
+
+-- | Directly convert a storable 'Vector' of 'Word8's into a 'BI.ByteString', in
+-- constant time.
+vectorToBytestring :: Vector Word8 -> BI.ByteString
+vectorToBytestring v
+ | (fptr, offset, idx) <- Vec.unsafeToForeignPtr v =
+ BI.PS fptr offset idx
diff --git a/src/Streaming/CRC.hs b/src/Streaming/CRC.hs
new file mode 100644
--- /dev/null
+++ b/src/Streaming/CRC.hs
@@ -0,0 +1,56 @@
+{-|
+Module : Streaming.CRC
+Copyright : (c) Bradley Hardy 2016
+License: LGPL3
+Maintainer: bradleyhardy@live.com
+Stability: experimental
+Portability: non-portable
+
+-}
+module Streaming.CRC (calcCRC32, appendCRC32) where
+
+import Data.Bits
+import Data.Vector.Unboxed (Vector)
+import qualified Data.Vector.Unboxed as U
+import Data.Word (Word32, Word8)
+import qualified Data.Serialize as C
+
+import qualified Data.ByteString as B
+import Data.ByteString.Streaming (ByteString)
+import qualified Data.ByteString.Streaming as Q
+import Streaming.Prelude (Of (..))
+
+crc32Table :: Vector Word32
+crc32Table = U.generate 256 (calc . fromIntegral)
+ where
+ calc :: Word8 -> Word32
+ calc = go 8 . fromIntegral
+ where
+ go :: Int -> Word32 -> Word32
+ go 0 c = c
+ go k c =
+ if c .&. 1 > 0
+ then go (k - 1) (0xedb88320 `xor` shiftR c 1)
+ else go (k - 1) (shift c (-1))
+
+updateCRC32 :: Word32 -> B.ByteString -> Word32
+updateCRC32 crc bytes
+ | Just (h, tl) <- B.uncons bytes =
+ let index = fromIntegral ((crc `xor` fromIntegral h) .&. 0xff)
+ in updateCRC32 ((crc32Table U.! index) `xor` shiftR crc 8) tl
+ | otherwise = crc
+
+-- | Calculate the CRC of a streaming 'ByteString', consuming the input and
+-- returning the CRC paired with the 'ByteString''s return value.
+calcCRC32 :: Monad m => ByteString m r -> m (Of Word32 r)
+calcCRC32 input =
+ do (res :> x) <- Q.foldlChunks updateCRC32 0xffffffff input
+ return (res `xor` 0xffffffff :> x)
+
+-- | If the input stream is finite, calculate its CRC and append it to the end
+-- (maintaining streaming). The is the identity function for infinite inputs.
+appendCRC32 :: Monad m => ByteString m r -> ByteString m r
+appendCRC32 input =
+ do (crc :> res) <- calcCRC32 $ Q.copy input
+ Q.fromStrict (C.runPut . C.putWord32be $ crc)
+ return res
diff --git a/src/Streaming/Zlib.hs b/src/Streaming/Zlib.hs
new file mode 100644
--- /dev/null
+++ b/src/Streaming/Zlib.hs
@@ -0,0 +1,119 @@
+{-|
+Module : Streaming.Zlib
+Copyright : (c) Bradley Hardy 2016
+License: LGPL3
+Maintainer: bradleyhardy@live.com
+Stability: experimental
+Portability: non-portable
+
+-}
+{-# LANGUAGE OverloadedStrings #-}
+module Streaming.Zlib
+ (
+ -- * Decompressing and compressing streams
+ decompressStream
+ , decompressStream'
+ , compressStream
+ , compressStream'
+
+ -- * Re-exported from 'Data.Streaming.Zlib'
+ , CompressionLevel
+ , WindowBits
+ , defaultWindowBits
+ , defaultCompressionLevel)
+ where
+
+import Codec.Picture.Png.Streaming.Util
+
+import Data.Streaming.Zlib (Popper, PopperRes (PRDone, PRNext, PRError),
+ WindowBits,
+ defaultWindowBits)
+import qualified Data.Streaming.Zlib as Z
+
+import Control.Monad.Catch (MonadThrow (..))
+import Control.Monad.IO.Class (MonadIO (..))
+
+import Data.ByteString.Streaming (ByteString)
+import qualified Data.ByteString.Streaming as Q
+
+exhaustPopper
+ :: (MonadIO m, MonadThrow m)
+ => Popper
+ -> ByteString m ()
+exhaustPopper popper = go
+ where
+ go = do pres <- liftIO popper
+ case pres of
+ PRDone -> return ()
+ PRNext bs -> do Q.chunk bs; go
+ PRError e -> throwM e
+
+-- | Use Zlib to decompress a 'ByteString' with the specified 'WindowBits'.
+decompressStream'
+ :: (MonadIO m, MonadThrow m)
+ => WindowBits
+ -> ByteString m r
+ -> ByteString m r
+decompressStream' windowBits input =
+ do inflate <- liftIO $ Z.initInflate windowBits
+
+ let build bs =
+ do mchnk <- Q.nextChunk bs
+ case mchnk of
+ Left r -> return (Left r)
+ Right (chnk, bs') ->
+ do popper <- liftIO $ Z.feedInflate inflate chnk
+ return (Right (exhaustPopper popper, bs'))
+
+ res <- buildByteString build input
+
+ remaining <- liftIO $ Z.finishInflate inflate
+ Q.chunk remaining
+
+ return res
+
+-- | Use Zlib to decompress a 'ByteString' with the default parameters.
+decompressStream
+ :: (MonadIO m, MonadThrow m)
+ => ByteString m r
+ -> ByteString m r
+decompressStream = decompressStream' defaultWindowBits
+
+-- | An integer between 0 and 9.
+type CompressionLevel = Int
+
+-- | The default compression level is 6.
+defaultCompressionLevel :: CompressionLevel
+defaultCompressionLevel = 6
+
+-- | Use Zlib to compress a 'ByteString' with the specified 'CompressionLevel'
+-- and 'WindowBits'.
+compressStream'
+ :: (MonadIO m, MonadThrow m)
+ => CompressionLevel
+ -> WindowBits
+ -> ByteString m r
+ -> ByteString m r
+compressStream' compressLevel windowBits input =
+ do deflate <- liftIO $ Z.initDeflate compressLevel windowBits
+
+ let build bs =
+ do mchnk <- Q.nextChunk bs
+ case mchnk of
+ Left r -> return (Left r)
+ Right (chnk, bs') ->
+ do popper <- liftIO $ Z.feedDeflate deflate chnk
+ return (Right (exhaustPopper popper, bs'))
+
+ res <- buildByteString build input
+
+ exhaustPopper $ Z.finishDeflate deflate
+
+ return res
+
+-- | Use Zlib to compress a 'ByteString' with the default parameters.
+compressStream
+ :: (MonadIO m, MonadThrow m)
+ => ByteString m r
+ -> ByteString m r
+compressStream = compressStream' defaultCompressionLevel defaultWindowBits
diff --git a/streaming-png.cabal b/streaming-png.cabal
new file mode 100644
--- /dev/null
+++ b/streaming-png.cabal
@@ -0,0 +1,72 @@
+name: streaming-png
+version: 0.1.0.0
+synopsis: Perfectly streaming PNG image decoding
+description: Please see README.md
+homepage: http://github.com/bch29/streaming-png#readme
+license: BSD3
+license-file: LICENSE
+author: Bradley Hardy
+maintainer: bradleyhardy@live.com
+copyright: (C) Bradley Hardy 2015
+category: Codec, Graphics, Image, Streaming
+build-type: Simple
+cabal-version: >=1.10
+
+flag build-demo
+ description: Build the executable demo.
+ default: False
+
+executable streaming-png-demo
+ hs-source-dirs: demo
+ main-is: Main.hs
+ default-language: Haskell2010
+ if flag(build-demo)
+ build-depends: JuicyPixels
+ , base >= 4.7 && < 5
+ , criterion >= 1.1.0.0
+ , resourcet
+ , streaming
+ , streaming-bytestring
+ , streaming-png
+ , transformers
+ , bytestring
+ else
+ buildable: False
+
+library
+ hs-source-dirs: src
+
+ exposed-modules: Codec.Picture.Png.Streaming
+ , Codec.Picture.Png.Streaming.Util
+ , Codec.Picture.Png.Streaming.Juicy
+ , Streaming.CRC
+ , Streaming.Zlib
+
+ other-modules: Codec.Picture.Png.Streaming.Core
+ , Codec.Picture.Png.Streaming.Header
+ , Codec.Picture.Png.Streaming.MainData
+ , Codec.Picture.Png.Streaming.Info
+
+ default-language: Haskell2010
+
+ build-depends: JuicyPixels >= 3.2
+ , base >= 4.7 && < 5
+ , bytestring >= 0.10
+ , cereal >= 0.5
+ , exceptions >= 0.8.2
+ , mmorph >= 1.0
+ , mtl >= 2.2
+ , resourcet >= 1.1
+ , streaming >= 0.1.4
+ , streaming-bytestring >= 0.1.4
+ , streaming-commons >= 0.1.14
+ , transformers >= 0.4.2
+ , vector >= 0.11
+
+ ghc-options:
+ -- -Wall
+ -O2
+
+source-repository head
+ type: git
+ location: http://github.com/bch29/streaming-png