packages feed

massiv-io 0.1.9.0 → 1.0.0.1

raw patch · 39 files changed

Files

CHANGELOG.md view
@@ -1,3 +1,48 @@+# 1.0.0++* Update to support `massiv-1.0`++# 0.4.1++* Reexport `Default` class.+* Add support for massiv-0.6+* Expose `Encode` and `Decode` cosntructors+* Add `encodeAdhocM` and `decodeAdhocM`+* Add `writableAdhoc` and `readableAdhoc`+* Add `displayImageUsingAdhoc`+* Add `coerceBinaryImage`+* Add instance for writing binary images: `Image S X Bit` without conversions.+* Add `selectFileFormat`++# 0.4.0++* Adjust insatnces to account for changes in `Color-0.3.0`, namely improvements to Luma+  (`Y'`) and `Y'CBCr` color spaces.++# 0.3.0++* Support for `Color-0.2.0`, in particular addition of `Linearity` kind to `RGB` color+  spaces. Pixels are re-exported from `massiv-io`, hence it is a breaking change.++# 0.2.1++* Move the package into it's own repository: [lehins/massiv-io](https://github.com/lehins/massiv-io)+* Addition of instances for `GIF` sequences in `RGB` with `Alpha` and instanced with+  `GifDisposalMethod`+* Addition of conversion functions: `demoteLumaImage`, `promoteLumaImage`,+  `demoteLumaAlphaImage`, `promoteLumaAlphaImage`+* Instances for reading and writing images in Luma: `Y'` and `Y'A`++# 0.2.0++* Switch to `MonadIO`+* Write files with durability and atomicity guarantees+* Switch to `encodeM` and `decodeM`, as well as corresponding `encodeImageM` and `decodeImageM`+* Addition of `decodeWithMetadataM`+* Addition of `ConvertError`, `DecodeError` and `EncodeError`.+* Got rid of `ReadOptions`+* Switch to `Color` package for pixels and color space coversion+ # 0.1.9  * Fix `HDR` decoding, i.e. `.hdr` and `.pic` file reading.
LICENSE view
@@ -1,30 +1,29 @@-Copyright Alexey Kuleshevich (c) 2017+BSD 3-Clause License +Copyright (c) 2013-2021, Alexey Kuleshevich All rights reserved.  Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: -    * Redistributions of source code must retain the above copyright-      notice, this list of conditions and the following disclaimer.+* Redistributions of source code must retain the above copyright notice, this+  list of conditions and the following disclaimer. -    * Redistributions in binary form must reproduce the above-      copyright notice, this list of conditions and the following-      disclaimer in the documentation and/or other materials provided-      with the distribution.+* Redistributions in binary form must reproduce the above copyright notice,+  this list of conditions and the following disclaimer in the documentation+  and/or other materials provided with the distribution. -    * Neither the name of Author name here nor the names of other-      contributors may be used to endorse or promote products derived-      from this software without specific prior written permission.+* Neither the name of the copyright holder nor the names of its+  contributors may be used to endorse or promote products derived from+  this software without specific prior written permission. -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"+AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,+OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
README.md view
@@ -1,2 +1,16 @@ # massiv-io-Import/export Arrays in various formats.++`massiv-io` is a package that brings together `JuicyPixels`, `Netpbm`, `Color` and `massiv`+in order to easily read, write and convert images in various formats and color spaces.++## Status++| Language | Github Actions | Coveralls |Gitter.im |+|:--------:|:--------------:|:---------:|:--------:|+| ![GitHub top language](https://img.shields.io/github/languages/top/lehins/massiv-io.svg) | [![Build Status](https://github.com/lehins/massiv/workflows/massiv-io-CI/badge.svg)](https://github.com/lehins/massiv-io/actions) | [![Coverage Status](https://coveralls.io/repos/github/lehins/massiv-io/badge.svg?branch=master)](https://coveralls.io/github/lehins/massiv-io?branch=master) | [![Join the chat at https://gitter.im/haskell-massiv/Lobby](https://badges.gitter.im/haskell-massiv/Lobby.svg)](https://gitter.im/haskell-massiv/Lobby?utm_source=badge&utm_medium=badge&utm_campaign=pr-badge&utm_content=badge)++|      Package       | Hackage | Nightly | LTS |+|:-------------------|:-------:|:-------:|:---:|+|  [`massiv-io`](https://github.com/lehins/massiv-io)|                                [![Hackage](https://img.shields.io/hackage/v/massiv-io.svg)](https://hackage.haskell.org/package/massiv-io)|                                                                                                  [![Nightly](https://www.stackage.org/package/massiv-io/badge/nightly)](https://www.stackage.org/nightly/package/massiv-io)|                                                                                   [![Nightly](https://www.stackage.org/package/massiv-io/badge/lts)](https://www.stackage.org/lts/package/massiv-io)|+|  [`massiv`](https://github.com/lehins/massiv/tree/master/massiv)|                                       [![Hackage](https://img.shields.io/hackage/v/massiv.svg)](https://hackage.haskell.org/package/massiv)|                                                                                                        [![Nightly](https://www.stackage.org/package/massiv/badge/nightly)](https://www.stackage.org/nightly/package/massiv)|                                                                                         [![Nightly](https://www.stackage.org/package/massiv/badge/lts)](https://www.stackage.org/lts/package/massiv)|+|  [`Color`](https://github.com/lehins/Color/tree/master/Color)|                                       [![Hackage](https://img.shields.io/hackage/v/Color.svg)](https://hackage.haskell.org/package/Color)|                                                                                                        [![Nightly](https://www.stackage.org/package/Color/badge/nightly)](https://www.stackage.org/nightly/package/Color)|                                                                                         [![Nightly](https://www.stackage.org/package/Color/badge/lts)](https://www.stackage.org/lts/package/Color)|
Setup.hs view
@@ -1,2 +1,4 @@ import Distribution.Simple++main :: IO () main = defaultMain
+ bench/Convert.hs view
@@ -0,0 +1,95 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE PartialTypeSignatures #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+module Main where++import Criterion.Main+import Data.Massiv.Array as A+import Data.Massiv.Array.IO as A+import Data.ByteString as B+import Data.ByteString.Lazy as BL++encodeIO :: Writable f arr => f -> arr -> IO B.ByteString+encodeIO f img =+  BL.toStrict <$> encodeM f def img+{-# INLINE encodeIO #-}++benchDecode ::+     forall fr fw r cs e.+     ( Readable fr (Image S cs e)+     , Writable fw (Image S cs e)+     , Load r Ix2 (Pixel cs e)+     , ColorModel cs e+     )+  => String+  -> fr -- ^ Decode as+  -> fw -- ^ Encode as+  -> Image r cs e+  -> Benchmark+benchDecode name fr fw img =+  env (encodeIO fw (computeAs S img)) $ \bs ->+    bench name $ nfIO (decodeM fr bs :: IO (Image S cs e))+++convertIO ::+     forall cs' e' i' r cs e i. (Source r (Pixel cs e), ColorSpace cs i e, ColorSpace cs' i' e')+  => Image r cs e+  -> IO (Image S cs' e')+convertIO = computeIO . convertImage+{-# INLINE convertIO #-}++main :: IO ()+main = do+  !frog <- readImageAuto "files/frog.jpg" :: IO (Image S (SRGB 'NonLinear) Double)+  defaultMain+    [ bgroup "Convert" [bench "Y'CbCr" $ nfIO (convertIO frog :: IO (Image S (Y'CbCr SRGB) Double))]+    , bgroup+        "Encode"+        [ bgroup+            "PNG"+            [ bgroup+                "Exact"+                [ env (convertIO frog) $ \(f :: Image S (SRGB 'NonLinear) Word8) ->+                    bench "SRGB Word8" $ nfIO (encodeIO PNG f)+                , env (convertIO frog) $ \(f :: Image S (SRGB 'NonLinear) Word16) ->+                    bench "SRGB Word16" $ nfIO (encodeIO PNG f)+                ]+            , bgroup+                "Auto"+                [ env (convertIO frog) $ \(f :: Image S (SRGB 'NonLinear) Word8) ->+                    bench "SRGB Word8" $ nfIO (encodeIO (Auto PNG) f)+                , env (convertIO frog) $ \(f :: Image S (SRGB 'NonLinear) Word16) ->+                    bench "SRGB Word16" $ nfIO (encodeIO (Auto PNG) f)+                , env (convertIO frog) $ \(f :: Image S (SRGB 'NonLinear) Word32) ->+                    bench "SRGB Word32" $ nfIO (encodeIO (Auto PNG) f)+                ]+            ]+        ]+    , bgroup+        "Decode"+        [ bgroup+            "PNG"+            [ bgroup+                "Exact"+                [ benchDecode "SRGB Word8" PNG PNG $+                  (convertImage frog :: Image D (SRGB 'NonLinear) Word8)+                , benchDecode "SRGB Word16" PNG PNG $+                  (convertImage frog :: Image D (SRGB 'NonLinear) Word16)+                ]+            , bgroup+                "Auto"+                [ benchDecode "SRGB Word8" (Auto PNG) PNG $+                  (convertImage frog :: Image D (SRGB 'NonLinear) Word8)+                , benchDecode "SRGB Word16" (Auto PNG) PNG $+                  (convertImage frog :: Image D (SRGB 'NonLinear) Word16)+                , env (encodeIO PNG =<< (convertIO frog :: IO (Image S (SRGB 'NonLinear) Word8))) $ \bs ->+                    bench "SRGB Word8 -> Word16" $+                    nfIO (decodeM (Auto PNG) bs :: IO (Image S (SRGB 'NonLinear) Word16))+                ]+            ]+        ]+    ]+
+ files/_frog.jpg view

binary file changed (absent → 124229 bytes)

+ files/frog.jpg view

binary file changed (absent → 82430 bytes)

massiv-io.cabal view
@@ -1,49 +1,49 @@ name:                massiv-io-version:             0.1.9.0+version:             1.0.0.1 synopsis:            Import/export of Image files into massiv Arrays description:         This package contains functionality for import/export of arrays                      into the real world. For now it only has the ability to read/write                      image files in various formats.-homepage:            https://github.com/lehins/massiv+homepage:            https://github.com/lehins/massiv-io license:             BSD3 license-file:        LICENSE author:              Alexey Kuleshevich maintainer:          alexey@kuleshevi.ch-copyright:           2018-2019 Alexey Kuleshevich+copyright:           2018-2021 Alexey Kuleshevich category:            Data, Data Structures build-type:          Simple+extra-doc-files:     files/*.jpg extra-source-files:  README.md                    , CHANGELOG.md-cabal-version:       >=1.10+cabal-version:       1.18  library   hs-source-dirs:      src-  exposed-modules:     Graphics.ColorSpace-                     , Graphics.ColorSpace.Binary-                     , Graphics.ColorSpace.CMYK-                     , Graphics.ColorSpace.Complex-                     , Graphics.ColorSpace.HSI-                     , Graphics.ColorSpace.RGB-                     , Graphics.ColorSpace.X-                     , Graphics.ColorSpace.Y-                     , Graphics.ColorSpace.YCbCr-                     , Data.Massiv.Array.IO-  other-modules:       Graphics.ColorSpace.Elevator-                     , Graphics.ColorSpace.Internal-                     , Data.Massiv.Array.IO.Base+  exposed-modules:     Data.Massiv.Array.IO+                     , Graphics.ColorModel+  other-modules:       Data.Massiv.Array.IO.Base                      , Data.Massiv.Array.IO.Image                      , Data.Massiv.Array.IO.Image.JuicyPixels+                     , Data.Massiv.Array.IO.Image.JuicyPixels.Base+                     , Data.Massiv.Array.IO.Image.JuicyPixels.BMP+                     , Data.Massiv.Array.IO.Image.JuicyPixels.GIF+                     , Data.Massiv.Array.IO.Image.JuicyPixels.HDR+                     , Data.Massiv.Array.IO.Image.JuicyPixels.JPG+                     , Data.Massiv.Array.IO.Image.JuicyPixels.PNG+                     , Data.Massiv.Array.IO.Image.JuicyPixels.TGA+                     , Data.Massiv.Array.IO.Image.JuicyPixels.TIF                      , Data.Massiv.Array.IO.Image.Netpbm   build-depends:       base            >= 4.8 && < 5                      , bytestring+                     , Color           >= 0.2                      , data-default-class                      , deepseq-                     , directory-                     , filepath        >= 1.0-                     , massiv          >= 0.1.1-                     , process-                     , JuicyPixels     >= 3.2.7+                     , exceptions+                     , filepath+                     , massiv          >= 1.0.0+                     , JuicyPixels     >= 3.3.5                      , netpbm+                     , unliftio        >= 0.2.12                      , vector          >= 0.10   default-language:    Haskell2010   ghc-options:         -Wall@@ -56,6 +56,58 @@       if os(darwin)         CPP-options:  -DOS_Mac +test-suite tests+  type:               exitcode-stdio-1.0+  hs-source-dirs:     tests+  main-is:            Main.hs+  other-modules:      Test.Massiv.Array.IO.Image.Common+                    , Test.Massiv.Array.IO.Image.JuicyPixelsSpec+                    , Test.Massiv.Array.IO.Image.AutoSpec+                    , Spec+  build-tool-depends: hspec-discover:hspec-discover+  build-depends:      JuicyPixels+                    , QuickCheck+                    , base+                    , bytestring+                    , hspec+                    , massiv+                    , massiv-io+                    , massiv-test+                    , random++  default-language:   Haskell2010+  ghc-options:        -Wall+                      -Wincomplete-record-updates+                      -Wincomplete-uni-patterns+                      -Wredundant-constraints+                      -fno-warn-orphans+                      -threaded+                      -freduction-depth=0+++test-suite doctests+  type:             exitcode-stdio-1.0+  hs-source-dirs:   tests+  main-is:          doctests.hs+  build-depends: base+               , doctest >=0.15+               , QuickCheck+  default-language:    Haskell2010++benchmark convert+  type:                exitcode-stdio-1.0+  hs-source-dirs:      bench+  main-is:             Convert.hs+  ghc-options:         -Wall -threaded -O2 -rtsopts -with-rtsopts=-N+  build-depends:       base+                     , bytestring+                     , Color+                     , criterion+                     , massiv+                     , massiv-io+  default-language:    Haskell2010+ source-repository head   type:     git-  location: https://github.com/lehins/massiv+  location: https://github.com/lehins/massiv-io+  subdir:   massiv-io
src/Data/Massiv/Array/IO.hs view
@@ -4,20 +4,23 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE TypeSynonymInstances #-} -- | -- Module      : Data.Massiv.Array.IO--- Copyright   : (c) Alexey Kuleshevich 2018-2019+-- Copyright   : (c) Alexey Kuleshevich 2018-2021 -- License     : BSD3 -- Maintainer  : Alexey Kuleshevich <lehins@yandex.ru> -- Stability   : experimental -- Portability : non-portable -- module Data.Massiv.Array.IO-  ( -- $supported+  ( -- * Supported Image Formats+    module Graphics.Pixel.ColorSpace+  , Image+    -- $supported+     -- * Reading-    readArray+  , readArray+  , readArrayWithMetadata   , readImage   , readImageAuto   -- * Writing@@ -28,6 +31,7 @@   , ExternalViewer(..)   , displayImage   , displayImageUsing+  , displayImageUsingAdhoc   , displayImageFile   -- ** Common viewers   , defaultViewer@@ -36,27 +40,41 @@   , fehViewer   , gimpViewer   -- * Supported Image Formats-  , module Data.Massiv.Array.IO.Base   , module Data.Massiv.Array.IO.Image+  -- * All other common reading/writing components+  , module Base   ) where -import Control.Concurrent (forkIO)-import Control.Exception (bracket) import Control.Monad (void) import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL import Data.Massiv.Array as A-import Data.Massiv.Array.IO.Base hiding (convertEither, fromEitherDecode,-                                  fromMaybeEncode, toProxy)+import Data.Massiv.Array.IO.Base (Image)+import Data.Massiv.Array.IO.Base as Base (Auto(..), ConvertError(..),+                                          DecodeError(..), EncodeError(..),+                                          FileFormat(..), MonadThrow(..),+                                          Readable(..), Sequence(..),+                                          Writable(..), Default(..),+                                          convertEither,+                                          convertImage, coerceBinaryImage,+                                          decode', decodeError,+                                          defaultWriteOptions,+                                          encode', encodeError,+                                          fromImageBaseModel, fromMaybeDecode,+                                          fromMaybeEncode,+                                          toImageBaseModel,+                                          toProxy) import Data.Massiv.Array.IO.Image-import Graphics.ColorSpace+import Graphics.Pixel.ColorSpace+import Prelude import Prelude as P hiding (readFile, writeFile)-import System.Directory (createDirectoryIfMissing, getTemporaryDirectory)-import System.FilePath-import System.IO (hClose, openBinaryTempFile)-import System.Process (readProcess)--+import System.FilePath ((</>), (<.>))+import System.IO (IOMode(..), hClose, openBinaryTempFile)+import UnliftIO.Concurrent (forkIO)+import UnliftIO.Directory (createDirectoryIfMissing, getTemporaryDirectory)+import UnliftIO.Exception (catchAny, bracket)+import UnliftIO.IO.File+import UnliftIO.Process (readProcess)   -- | External viewing application to use for displaying images.@@ -72,136 +90,241 @@   --- | Read an array from one of the supported file formats.-readArray :: Readable f arr =>+-- | Read an array from one of the supported `Readable` file formats.+--+-- For example `readImage` assumes all images to be in sRGB color space, but if you know+-- that the image is actually encoded in some other color space, for example `AdobeRGB`,+-- then you can read it in manually into a matching color model and then cast into a color+-- space you know it is encoded in:+--+-- >>> :set -XDataKinds+-- >>> import qualified Graphics.ColorModel as CM+-- >>> frogRGB <- readArray JPG "files/_frog.jpg" :: IO (Image S CM.RGB Word8)+-- >>> let frogAdobeRGB = (fromImageBaseModel frogRGB :: Image S (AdobeRGB 'NonLinear) Word8)+--+-- @since 0.1.0+readArray :: (Readable f arr, MonadIO m) =>              f -- ^ File format that should be used while decoding the file-          -> ReadOptions f -- ^ Any file format related decoding options. Use `def` for default.           -> FilePath -- ^ Path to the file-          -> IO arr-readArray format opts path = decode format opts <$> B.readFile path+          -> m arr+readArray format path = liftIO (B.readFile path >>= decodeM format) {-# INLINE readArray #-} +-- | Read an array from one of the supported file formats. Some formats are capable of+-- preducing format specific metadata.+--+-- @since 0.2.0+readArrayWithMetadata ::+     (Readable f arr, MonadIO m)+  => f -- ^ File format that should be used while decoding the file+  -> FilePath -- ^ Path to the file+  -> m (arr, Metadata f)+readArrayWithMetadata format path = liftIO (B.readFile path >>= decodeWithMetadataM format)+{-# INLINE readArrayWithMetadata #-} -writeArray :: Writable f arr =>+writeLazyAtomically :: FilePath -> BL.ByteString -> IO ()+writeLazyAtomically filepath bss =+  withBinaryFileDurableAtomic filepath WriteMode $ \h -> Prelude.mapM_ (B.hPut h) (BL.toChunks bss)+{-# INLINE writeLazyAtomically #-}++-- | Write an array to disk.+--+-- >>> :set -XDataKinds+-- >>> frogYCbCr <- readImage "files/frog.jpg" :: IO (Image S (Y'CbCr SRGB) Word8)+-- >>> frogAdobeRGB = convertImage frogYCbCr :: Image D (AdobeRGB 'NonLinear) Word8+-- >>> writeArray JPG def "files/_frog.jpg" $ toImageBaseModel $ computeAs S frogAdobeRGB+--+-- /Note/ - On UNIX operating systems writing will happen with guarantees of atomicity and+-- durability, see `withBinaryFileDurableAtomic`.+--+-- @since 0.2.0+writeArray :: (Writable f arr, MonadIO m) =>               f -- ^ Format to use while encoding the array            -> WriteOptions f -- ^ Any file format related encoding options. Use `def` for default.            -> FilePath-           -> arr -> IO ()-writeArray format opts path arr = BL.writeFile path (encode format opts arr)+           -> arr+           -> m ()+writeArray format opts filepath arr =+  liftIO (encodeM format opts arr >>= writeLazyAtomically filepath) {-# INLINE writeArray #-}  --- | Try to guess an image format from file's extension, then attempt to decode it as such. In order--- to supply the format manually and thus avoid this guessing technique, use `readArray`--- instead. Color space and precision of the result array must match exactly that of the actual--- image, in order to apply auto conversion use `readImageAuto` instead.+-- | Tries to guess an image format from file's extension, then attempts to decode it as+-- such. It also assumes an image is encoded in sRGB color space or its alternate+-- representation. In order to supply the format manually or choose a different color+-- space, eg. `AdobeRGB`, use `readArray` instead. Color space and precision of the result+-- image must match exactly that of the actual image. ----- Might throw `ConvertError`, `DecodeError` and other standard errors related to file IO.+-- May throw `ConvertError`, `DecodeError` and other standard errors related to file IO. ----- Result image will be read as specified by the type signature:+-- Resulting image will be read as specified by the type signature: ----- >>> frog <- readImage "files/frog.jpg" :: IO (Image S YCbCr Word8)--- >>> displayImage frog+-- >>> :set -XDataKinds+-- >>> frog <- readImage "files/frog.jpg" :: IO (Image S (Y'CbCr SRGB) Word8)+-- >>> size frog+-- Sz (200 :. 320) ----- In case when the result image type does not match the color space or precision of the actual--- image file, `ConvertError` will be thrown.+-- @__>>> displayImage frog__ @ ----- >>> frog <- readImage "files/frog.jpg" :: IO (Image S CMYK Word8)--- >>> displayImage frog--- *** Exception: ConvertError "Cannot decode JPG image <Image S YCbCr Word8> as <Image S CMYK Word8>"+-- ![frog](files/frog.jpg) ----- Whenever image is not in the color space or precision that we need, either use `readImageAuto` or--- manually convert to the desired one by using the appropriate conversion functions:+-- In case when the result image type does not match the color space or precision of the+-- actual image file, `ConvertError` will be thrown. ----- >>> frogCMYK <- readImageAuto "files/frog.jpg" :: IO (Image S CMYK Double)--- >>> displayImage frogCMYK+-- >>> frog <- readImage "files/frog.jpg" :: IO (Image S (SRGB 'NonLinear) Word8)+-- *** Exception: ConvertError "Cannot decode JPG image <Image S YCbCr Word8> as <Image S SRGB 'NonLinear Word8>" ---readImage :: (Source S Ix2 (Pixel cs e), ColorSpace cs e) =>-              FilePath -- ^ File path for an image-           -> IO (Image S cs e)-readImage path = decodeImage imageReadFormats path <$> B.readFile path+-- Whenever image is not in the color space or precision that we need, either use+-- `readImageAuto` or manually convert to the desired one by using the appropriate+-- conversion functions:+--+-- >>> frogYCbCr <- readImage "files/frog.jpg" :: IO (Image S (Y'CbCr SRGB) Word8)+-- >>> let frogSRGB = convertImage frogYCbCr :: Image D (SRGB 'NonLinear) Word8+--+-- A simpler approach to achieve the same effect would be to use `readImageAuto`:+--+-- >>> frogSRGB' <- readImageAuto "files/frog.jpg" :: IO (Image S (SRGB 'NonLinear) Word8)+-- >>> compute frogSRGB == frogSRGB'+-- True+--+-- @since 0.1.0+readImage ::+     (ColorModel cs e, MonadIO m)+  => FilePath -- ^ File path for an image+  -> m (Image S cs e)+readImage path = liftIO (B.readFile path >>= decodeImageM imageReadFormats path) {-# INLINE readImage #-}  --- | Same as `readImage`, but will perform any possible color space and--- precision conversions in order to match the result image type. Very useful--- whenever image format isn't known at compile time.-readImageAuto :: (Mutable r Ix2 (Pixel cs e), ColorSpace cs e) =>-                  FilePath -- ^ File path for an image-               -> IO (Image r cs e)-readImageAuto path = decodeImage imageReadAutoFormats path <$> B.readFile path+-- | Similar to `readImage`, but will perform all necessary color space conversion+-- and precision adjustment in order to match the result image type. Very useful whenever+-- image format isn't known ahead of time.+--+-- >>> frogCMYK <- readImageAuto "files/frog.jpg" :: IO (Image S (CMYK (SRGB 'NonLinear)) Double)+-- >>> size frogCMYK+-- Sz (200 :. 320)+--+-- @since 0.1.0+readImageAuto ::+     (Manifest r (Pixel cs e), ColorSpace cs i e, MonadIO m)+  => FilePath -- ^ File path for an image+  -> m (Image r cs e)+readImageAuto path = liftIO (B.readFile path >>= decodeImageM imageReadAutoFormats path) {-# INLINE readImageAuto #-}   --- | This function will guess an output file format from the file extension and will write to file--- any image with the colorspace that is supported by that format. Precision of the image might be--- adjusted using `Elevator` if precision of the source array is not supported by the image file--- format. For instance an @(`Image` r `RGBA` `Double`)@ being saved as `PNG` file would be written as--- @(`Image` r `RGBA` `Word16`)@, thus using highest supported precision `Word16` for that--- format. If automatic colors space is also desired, `writeImageAuto` can be used instead.+-- | This function will guess an output file format from the file extension and will write+-- to file any image with the color model that is supported by that format. In case that+-- automatic precision adjustment or colors space conversion is also desired,+-- `writeImageAuto` can be used instead. -- -- Can throw `ConvertError`, `EncodeError` and other usual IO errors. ---writeImage :: (Source r Ix2 (Pixel cs e), ColorSpace cs e) =>-               FilePath -> Image r cs e -> IO ()-writeImage path = BL.writeFile path . encodeImage imageWriteFormats path+-- /Note/ - On UNIX operating systems writing will happen with guarantees of atomicity and+-- durability, see `withBinaryFileDurableAtomic`.+--+-- @since 0.1.0+writeImage ::+     (Source r (Pixel cs e), ColorModel cs e, MonadIO m) => FilePath -> Image r cs e -> m ()+writeImage path img = liftIO (encodeImageM imageWriteFormats path img >>= writeLazyAtomically path)+{-# INLINE writeImage #-}  --- | Write an image to file while performing all necessary precisiona and color space conversions.-writeImageAuto-  :: ( Source r Ix2 (Pixel cs e)-     , ColorSpace cs e-     , ToYA cs e-     , ToRGBA cs e-     , ToYCbCr cs e-     , ToCMYK cs e-     )-  => FilePath -> Image r cs e -> IO ()-writeImageAuto path = BL.writeFile path . encodeImage imageWriteAutoFormats path-+-- | Write an image encoded in sRGB color space into a file while performing all necessary+-- precision and color space conversions. If a file supports color model that the image is+-- on then it will be encoded as such. For example writing a TIF file in CMYK color model,+-- 8bit precision and an sRGB color space:+--+-- >>> frogYCbCr <- readImage "files/frog.jpg" :: IO (Image S (Y'CbCr SRGB) Word8)+-- >>> writeImageAuto "files/frog.tiff" (convertImage frogYCbCr :: Image D (CMYK (AdobeRGB 'NonLinear)) Word8)+--+-- Regardless that the color space supplied was `AdobeRGB` auto conversion will ensure it+-- is stored as `SRGB`, except in `CM.CMYK` color model, since `TIF` file format supports it.+--+-- @since 0.1.0+writeImageAuto ::+     (Source r (Pixel cs e), ColorSpace cs i e, ColorSpace (BaseSpace cs) i e, MonadIO m)+  => FilePath+  -> Image r cs e+  -> m ()+writeImageAuto path img =+  liftIO (encodeImageM imageWriteAutoFormats path img >>= writeLazyAtomically path)+{-# INLINE writeImageAuto #-}   -- | An image is written as a @.tiff@ file into an operating system's temporary -- directory and passed as an argument to the external viewer program.+--+-- @since 0.1.0 displayImageUsing ::-     Writable (Auto TIF) (Image r cs e)+     (Writable (Auto TIF) (Image r cs e), MonadIO m)   => ExternalViewer -- ^ Image viewer program-  -> Bool -- ^ Should the function block the current thread until viewer is closed.-  -> Image r cs e-  -> IO ()-displayImageUsing viewer block img =-  if block-    then display-    else img `seq` void (forkIO display)+  -> Bool -- ^ Should this function block the current thread until viewer is+          -- closed. Supplying `False` is only safe in the ghci session.+  -> Image r cs e -- ^ Image to display+  -> m ()+displayImageUsing viewer block = displayImageUsingAdhoc viewer block (writableAdhoc (Auto TIF))+++-- | Encode an image using an adhoc into an operating system's temporary+-- directory and passed as an argument to the external viewer program.+--+-- @since 4.1.0+displayImageUsingAdhoc ::+     MonadIO m+  => ExternalViewer -- ^ Image viewer program+  -> Bool -- ^ Should this function block the current thread until viewer is+          -- closed. Supplying `False` is only safe in the ghci session.+  -> Encode img+  -> img -- ^ Image to display+  -> m ()+displayImageUsingAdhoc viewer block adhoc img =+  liftIO $ do+    bs <- encodeAdhocM adhoc img+    -- this function is meant to be used in ghci, therefore it is ok to not cleanup+    -- dangling threads after display is called.+    (if block then id else void . forkIO . reportErrors) $ display bs   where-    display = do+    reportErrors action =+      catchAny action $ \ exc ->+        putStrLn $ "<displayImageUsingAdhoc>: Failed with: " <> displayException exc+    display bs = do       tmpDir <- fmap (</> "massiv-io") getTemporaryDirectory       createDirectoryIfMissing True tmpDir       bracket-        (openBinaryTempFile tmpDir "tmp-img.tiff")+        (openBinaryTempFile tmpDir ("tmp-img" <.> ext adhoc))         (hClose . snd)         (\(imgPath, imgHandle) -> do-           BL.hPut imgHandle (encode (Auto TIF) () img)+           BL.hPut imgHandle bs            hClose imgHandle            displayImageFile viewer imgPath)  ---- | Displays an image file by calling an external image viewer.-displayImageFile :: ExternalViewer -> FilePath -> IO ()+-- | Displays an image file by calling an external image viewer. It will block until the+-- external viewer is closed.+--+-- @since 0.1.0+displayImageFile :: MonadIO m => ExternalViewer -> FilePath -> m () displayImageFile (ExternalViewer exe args ix) imgPath =-  void $ readProcess exe (argsBefore ++ [imgPath] ++ argsAfter) ""+  void $ liftIO $ readProcess exe (argsBefore ++ [imgPath] ++ argsAfter) ""   where (argsBefore, argsAfter) = P.splitAt ix args  --- | Makes a call to an external viewer that is set as a default image viewer by--- the OS. This is a non-blocking function call, so it might take some time--- before an image will appear.-displayImage :: Writable (Auto TIF) (Image r cs e) => Image r cs e -> IO ()+-- | Writes an image to a temporary file and makes a call to an external viewer that is+-- set as a default image viewer by the OS. This is a non-blocking function call, so it+-- might take some time before an image will appear.+--+-- /Note/ - This function should only be used in ghci, otherwise use @`displayImageUsing`+-- `defaultViewer` `True`@+--+-- @since 0.1.0+displayImage :: (Writable (Auto TIF) (Image r cs e), MonadIO m) => Image r cs e -> m () displayImage = displayImageUsing defaultViewer False  -- | Default viewer is inferred from the operating system.+--+-- @since 0.1.0 defaultViewer :: ExternalViewer defaultViewer = #if defined(OS_Win32)@@ -215,28 +338,28 @@ #endif  --- | @eog \/tmp\/hip\/img.tiff@+-- | @eog \/tmp\/massiv\/img.tiff@ -- -- <https://help.gnome.org/users/eog/stable/ Eye of GNOME> eogViewer :: ExternalViewer eogViewer = ExternalViewer "eog" [] 0  --- | @feh --fullscreen --auto-zoom \/tmp\/hip\/img.tiff@+-- | @feh --fullscreen --auto-zoom \/tmp\/massiv\/img.tiff@ -- -- <https://feh.finalrewind.org/ FEH> fehViewer :: ExternalViewer fehViewer = ExternalViewer "feh" ["--fullscreen", "--auto-zoom"] 2  --- | @gpicview \/tmp\/hip\/img.tiff@+-- | @gpicview \/tmp\/massiv\/img.tiff@ -- -- <http://lxde.sourceforge.net/gpicview/ GPicView> gpicviewViewer :: ExternalViewer gpicviewViewer = ExternalViewer "gpicview" [] 0  --- | @gimp \/tmp\/hip\/img.tiff@+-- | @gimp \/tmp\/massiv\/img.tiff@ -- -- <https://www.gimp.org/ GIMP> gimpViewer :: ExternalViewer@@ -249,67 +372,70 @@ <http://hackage.haskell.org/package/JuicyPixels JuicyPixels> and <http://hackage.haskell.org/package/netpbm netpbm> packages. -List of image formats that are currently supported, and their exact-'ColorSpace's and precision for reading and writing without an implicit-conversion:+List of image formats that are currently supported, and their exact 'ColorModel's with+precision for reading and writing without any conversion:  * 'BMP': -    * __read__: ('Y' 'Word8'), ('RGB' 'Word8'), ('RGBA' 'Word8')-    * __write__: ('Y' 'Word8'), ('RGB' 'Word8'), ('RGBA' 'Word8')+    * __read__: ('PixelX' 'Bit'), ('PixelY' 'Word8'), ('PixelRGB' 'Word8'), ('PixelRGBA' 'Word8')+    * __write__: ('PixelY' 'Word8'), ('PixelRGB' 'Word8'), ('PixelRGBA' 'Word8')  * 'GIF': -    * __read__: ('RGB' 'Word8'), ('RGBA' 'Word8')-    * __write__: ('RGB' 'Word8')+    * __read__: ('PixelRGB' 'Word8'), ('PixelRGBA' 'Word8')+    * __write__: ('PixelY' 'Word8'), ('PixelRGB' 'Word8')     * Also supports reading and writing animated images  * 'HDR': -    * __read__: ('RGB' 'Float')-    * __write__: ('RGB' 'Float')+    * __read__: ('PixelRGB' 'Float')+    * __write__: ('PixelRGB' 'Float')  * 'JPG': -    * __read__: ('Y' 'Word8'), ('YA' 'Word8'), ('RGB' 'Word8'), ('CMYK' 'Word8'),-    ('YCbCr', 'Word8')-    * __write__: ('Y' 'Word8'), ('YA', 'Word8'), ('RGB' 'Word8'), ('CMYK' 'Word8'),-    ('YCbCr', 'Word8')+    * __read__: ('PixelY' 'Word8'), ('PixelYA' 'Word8'), ('PixelRGB' 'Word8'), ('PixelCMYK' 'Word8'),+    (`PixelY'CbCr`, 'Word8')+    * __write__: ('PixelY' 'Word8'), ('PixelRGB' 'Word8'), ('PixelCMYK' 'Word8'),+    (`PixelY'CbCr`, 'Word8')  * 'PNG': -    * __read__: ('Y' 'Word8'), ('Y' 'Word16'), ('YA' 'Word8'), ('YA' 'Word16'),-    ('RGB' 'Word8'), ('RGB' 'Word16'), ('RGBA' 'Word8'), ('RGBA' 'Word16')-    * __write__: ('Y' 'Word8'), ('Y' 'Word16'), ('YA' 'Word8'), ('YA' 'Word16'),-    ('RGB' 'Word8'), ('RGB' 'Word16'), ('RGBA' 'Word8'), ('RGBA' 'Word16')+    * __read__: ('PixelX' 'Bit'), ('PixelY' 'Word8'), ('PixelY' 'Word16'), ('PixelYA' 'Word8'), ('PixelYA' 'Word16'),+    ('PixelRGB' 'Word8'), ('PixelRGB' 'Word16'), ('PixelRGBA' 'Word8'), ('PixelRGBA' 'Word16')+    * __write__: ('PixelY' 'Word8'), ('PixelY' 'Word16'), ('PixelYA' 'Word8'), ('PixelYA' 'Word16'),+    ('PixelRGB' 'Word8'), ('PixelRGB' 'Word16'), ('PixelRGBA' 'Word8'), ('PixelRGBA' 'Word16')  * 'TGA': -    * __read__: ('Y' 'Word8'), ('RGB' 'Word8'), ('RGBA' 'Word8')-    * __write__: ('Y' 'Word8'), ('RGB' 'Word8'), ('RGBA' 'Word8')+    * __read__: ('PixelX' 'Bit'), ('PixelY' 'Word8'), ('PixelRGB' 'Word8'), ('PixelRGBA' 'Word8')+    * __write__: ('PixelY' 'Word8'), ('PixelRGB' 'Word8'), ('PixelRGBA' 'Word8')  * 'TIF': -    * __read__: ('Y' 'Word8'), ('Y' 'Word16'), ('YA' 'Word8'), ('YA' 'Word16'),-    ('RGB' 'Word8'), ('RGB' 'Word16'), ('RGBA' 'Word8'), ('RGBA' 'Word16'),-    ('CMYK' 'Word8'), ('CMYK' 'Word16')-    * __write__: ('Y' 'Word8'), ('Y' 'Word16'), ('YA' 'Word8'), ('YA' 'Word16'),-    ('RGB' 'Word8'), ('RGB' 'Word16'), ('RGBA' 'Word8'), ('RGBA' 'Word16')-    ('CMYK' 'Word8'), ('CMYK' 'Word16'), ('YCbCr' 'Word8')+    * __read__:+    ('PixelY' 'Word8'), ('PixelY' 'Word16'), ('PixelY' 'Word32'), ('PixelY' 'Float'),+    ('PixelYA' 'Word8'), ('PixelYA' 'Word16'),+    ('PixelRGB' 'Word8'), ('PixelRGB' 'Word16'), ('PixelRGBA' 'Word8'), ('PixelRGBA' 'Word16'),+    ('PixelCMYK' 'Word8'), ('PixelCMYK' 'Word16')+    * __write__:+    ('PixelY' 'Word8'), ('PixelY' 'Word16'), ('PixelY' 'Word32'), ('PixelY' 'Float'),+    ('PixelYA' 'Word8'), ('PixelYA' 'Word16'),+    ('PixelRGB' 'Word8'), ('PixelRGB' 'Word16'), ('PixelRGBA' 'Word8'), ('PixelRGBA' 'Word16')+    ('PixelCMYK' 'Word8'), ('PixelCMYK' 'Word16'), (`PixelY'CbCr` 'Word8')  * 'PBM': -    * __read__: ('Binary' 'Bit')-    * Also supports sequence of images in one file, when read as @['PBM']@+    * __read__: ('PixelY' 'Bit')+    * Also supports `Sequence` of images in one file, when read as @['PBM']@  * 'PGM': -    * __read__: ('Y' 'Word8'), ('Y' 'Word16')-    * Also supports sequence of images in one file, when read as @['PGM']@+    * __read__: ('PixelY' 'Word8'), ('PixelY' 'Word16')+    * Also supports `Sequence` of images in one file, when read as @['PGM']@  * 'PPM': -    * __read__: ('RGB' 'Word8'), ('RGB' 'Word16')-    * Also supports sequence of images in one file, when read as @['PPM']@+    * __read__: ('PixelRGB' 'Word8'), ('PixelRGB' 'Word16')+    * Also supports `Sequence` of images in one file, when read as @['PPM']@  -}
src/Data/Massiv/Array/IO/Base.hs view
@@ -1,13 +1,16 @@+{-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} -- | -- Module      : Data.Massiv.Array.IO.Base--- Copyright   : (c) Alexey Kuleshevich 2018-2019+-- Copyright   : (c) Alexey Kuleshevich 2018-2021 -- License     : BSD3 -- Maintainer  : Alexey Kuleshevich <lehins@yandex.ru> -- Stability   : experimental@@ -15,46 +18,67 @@ -- module Data.Massiv.Array.IO.Base   ( FileFormat(..)+  , selectFileFormat   , Readable(..)+  , decode'   , Writable(..)+  , encode'   , ConvertError(..)   , EncodeError(..)   , DecodeError(..)   , Sequence(..)+  , Default(..)   , Auto(..)   , Image-  , defaultReadOptions+  , convertImage+  , convertImageM+  , toImageBaseModel+  , fromImageBaseModel+  , coerceBinaryImage   , defaultWriteOptions+  , encodeError+  , decodeError   , toProxy   , fromMaybeEncode-  , fromEitherDecode+  , fromMaybeDecodeM+  , fromMaybeDecode   , convertEither+  , unsafeFromStorableVectorM+  , MonadThrow(..)   ) where -import Control.Exception (Exception, throw)+import Control.Exception (Exception)+import Control.Monad.Catch (MonadThrow(..)) import qualified Data.ByteString as B (ByteString) import qualified Data.ByteString.Lazy as BL (ByteString)+import Data.Char (toLower) import Data.Default.Class (Default(..))-import Data.Massiv.Array-import Data.Maybe (fromMaybe)+import qualified Data.Massiv.Array as A import Data.Typeable-import Graphics.ColorSpace (ColorSpace, Pixel)+import qualified Data.Vector.Storable as V+import GHC.Stack+import Graphics.Pixel as CM+import Graphics.Pixel.ColorSpace+import Prelude as P+import System.FilePath (takeExtension)+import Unsafe.Coerce -type Image r cs e = Array r Ix2 (Pixel cs e)+type Image r cs e = A.Matrix r (Pixel cs e) --- | Conversion error, which is thrown when there is a mismatch between the--- expected array type and the one supported by the file format. It is also--- thrown upon a failure of automatic conversion between those types, in case--- such conversion is utilized.+-- | Conversion error, which is thrown when there is a mismatch between the expected array+-- type and the one supported by the file format. It is also thrown upon a failure of+-- automatic conversion between those types, in case when such conversion is utilized. newtype ConvertError = ConvertError String deriving Show -instance Exception ConvertError+instance Exception ConvertError where+  displayException (ConvertError str) = "ConvertError: " ++ str  -- | This exception can be thrown while reading/decoding a file and indicates an -- error in the file itself. newtype DecodeError = DecodeError String deriving Show -instance Exception DecodeError+instance Exception DecodeError where+  displayException (DecodeError str) = "DecodeError: " ++ str  -- | This exception can be thrown while writing/encoding into a file and -- indicates an error in an array that is being encoded.@@ -63,11 +87,6 @@ instance Exception EncodeError  --- | Generate default read options for a file format-defaultReadOptions :: FileFormat f => f -> ReadOptions f-defaultReadOptions _ = def-- -- | Generate default write options for a file format defaultWriteOptions :: FileFormat f => f -> WriteOptions f defaultWriteOptions _ = def@@ -80,15 +99,14 @@  -- | File format. Helps in guessing file format from a file extension, -- as well as supplying format specific options during saving the file.-class (Default (ReadOptions f), Default (WriteOptions f), Show f) => FileFormat f where-  -- | Options that can be used during reading a file in this format.-  type ReadOptions f-  type ReadOptions f = ()-+class (Default (WriteOptions f), Show f) => FileFormat f where   -- | Options that can be used during writing a file in this format.   type WriteOptions f   type WriteOptions f = () +  type Metadata f+  type Metadata f = ()+   -- | Default file extension for this file format.   ext :: f -> String @@ -103,87 +121,202 @@   instance FileFormat f => FileFormat (Auto f) where-  type ReadOptions (Auto f) = ReadOptions f   type WriteOptions (Auto f) = WriteOptions f+  type Metadata (Auto f) = Metadata f    ext (Auto f) = ext f   exts (Auto f) = exts f +-- | Try to select a file format by looking at the file extension and matching it to one+-- of the formats in the list+--+-- @since 0.4.1+selectFileFormat :: (FileFormat f, MonadThrow m) => [f] -> FilePath -> m f+selectFileFormat formats path = do+  let ext' = P.map toLower . takeExtension $ path+  case P.dropWhile (not . isFormat ext') formats of+    []    -> throwM $ EncodeError $ "File format is not supported: " ++ ext'+    (f:_) -> pure f --- | File formats that can be read into an Array.-class Readable f arr where -  -- | Decode a `B.ByteString` into an Array.-  decode :: f -> ReadOptions f -> B.ByteString -> arr+-- | File formats that can be read into arrays.+class FileFormat f => Readable f arr where+  {-# MINIMAL (decodeM | decodeWithMetadataM) #-}+  -- | Decode a `B.ByteString` into an array. Can also return whatever left over data that+  -- was not consumed during decoding.+  --+  -- @since 0.2.0+  decodeM :: MonadThrow m => f -> B.ByteString -> m arr+  decodeM f bs = fst <$> decodeWithMetadataM f bs+  -- | Just as `decodeM`, but also return any format type specific metadata+  --+  -- @since 0.2.0+  decodeWithMetadataM :: MonadThrow m => f -> B.ByteString -> m (arr, Metadata f)+  default decodeWithMetadataM :: (Metadata f ~ (), MonadThrow m) =>+    f -> B.ByteString -> m (arr, Metadata f)+  decodeWithMetadataM f bs = do+    arr <- decodeM f bs+    pure (arr, ()) +-- | Encode an array into a lazy `BL.ByteString`.+encode' :: (Writable f arr, HasCallStack) => f -> WriteOptions f -> arr -> BL.ByteString+encode' f opts = A.throwEither . encodeM f opts +-- | Decode a strict `B.ByteString` into an Array.+decode' :: (Readable f arr, HasCallStack) => f -> B.ByteString -> arr+decode' f = A.throwEither . decodeM f++ -- | Arrays that can be written into a file.-class Writable f arr where+class FileFormat f => Writable f arr where    -- | Encode an array into a `BL.ByteString`.-  encode :: f -> WriteOptions f -> arr -> BL.ByteString+  --+  -- @since 0.2.0+  encodeM :: MonadThrow m => f -> WriteOptions f -> arr -> m BL.ByteString   -- | Helper function to create a `Proxy` from the value. toProxy :: a -> Proxy a toProxy _ = Proxy +showImageType ::+     forall r cs e. (Typeable r, ColorModel cs e)+  => Proxy (Image r cs e)+  -> String+showImageType _ =+  ("<Image " ++) .+  showsTypeRep (typeRep (Proxy :: Proxy r)) .+  (' ' :) .+  showsColorModelName (Proxy :: Proxy (Color cs e)) .+  (' ' :) . showsTypeRep (typeRep (Proxy :: Proxy e)) $+  ">"++ -- | Encode an image using the supplied function or throw an error in case of failure. fromMaybeEncode-  :: forall f r cs e b. (ColorSpace cs e, FileFormat f, Typeable r)-  => f -> Proxy (Image r cs e) -> Maybe b -> b-fromMaybeEncode _ _         (Just b) = b-fromMaybeEncode f _imgProxy Nothing =-  throw $-  ConvertError-    ("Format " ++-     show f ++-     " cannot be encoded as <Image " ++-     showsTypeRep (typeRep (Proxy :: Proxy r)) " " ++-     showsTypeRep (typeRep (Proxy :: Proxy cs)) " " ++-     showsTypeRep (typeRep (Proxy :: Proxy e)) ">")+  :: forall f r cs e b m. (ColorModel cs e, FileFormat f, Typeable r, MonadThrow m)+  => f -> Proxy (Image r cs e) -> Maybe b -> m b+fromMaybeEncode f imgProxy =+  \case+    Just b -> pure b+    Nothing ->+      throwM $+      ConvertError ("Format " ++ show f ++ " cannot be encoded as " ++ showImageType imgProxy)   -- | Decode an image using the supplied function or throw an error in case of failure.-fromEitherDecode :: forall r cs e a f. (ColorSpace cs e, FileFormat f, Typeable r) =>-                    f-                 -> (a -> String)-                 -> (a -> Maybe (Image r cs e))-                 -> Either String a-                 -> Image r cs e-fromEitherDecode _ _      _    (Left err)   = throw $ DecodeError err-fromEitherDecode f showCS conv (Right eImg) =-  fromMaybe-    (throw $-     ConvertError-       ("Cannot decode " ++ show f ++ " image <" ++-        showCS eImg ++-        "> as " ++-        "<Image " ++-        showsTypeRep (typeRep (Proxy :: Proxy r)) " " ++-        showsTypeRep (typeRep (Proxy :: Proxy cs)) " " ++-        showsTypeRep (typeRep (Proxy :: Proxy e)) ">"))-    (conv eImg)+fromMaybeDecode ::+     forall r cs e a f m. (ColorModel cs e, FileFormat f, Typeable r, MonadThrow m)+  => f+  -> (a -> String)+  -> (a -> Maybe (Image r cs e))+  -> a+  -> m (Image r cs e)+fromMaybeDecode f showCS conv eImg =+  case conv eImg of+    Nothing ->+      throwM $+      ConvertError $+      "Cannot decode " +++      show f +++      " image <" ++ showCS eImg ++ "> as " ++ showImageType (Proxy :: Proxy (Image r cs e))+    Just img -> pure img +-- | Decode an image using the supplied function or throw an error in case of failure.+fromMaybeDecodeM ::+     forall r cs e a f m. (ColorModel cs e, FileFormat f, Typeable r, MonadThrow m)+  => f+  -> (a -> String)+  -> (a -> m (Maybe (Image r cs e)))+  -> a+  -> m (Image r cs e)+fromMaybeDecodeM f showCS conv eImg =+  conv eImg >>= \case+    Nothing ->+      throwM $+      ConvertError $+      "Cannot decode " +++      show f +++      " image <" ++ showCS eImg ++ "> as " ++ showImageType (Proxy :: Proxy (Image r cs e))+    Just img -> pure img + -- | Convert an image using the supplied function and return ConvertError error in case of failure.-convertEither :: forall r cs e a f. (ColorSpace cs e, FileFormat f, Typeable r) =>-                    f-                 -> (a -> String)-                 -> (a -> Maybe (Image r cs e))-                 -> a-                 -> Either ConvertError (Image r cs e)+convertEither ::+     forall r cs i e a f m. (ColorSpace cs i e, FileFormat f, Typeable r, MonadThrow m)+  => f+  -> (a -> String)+  -> (a -> Maybe (Image r cs e))+  -> a+  -> m (Image r cs e) convertEither f showCS conv eImg =   maybe-    (Left $+    (throwM $      ConvertError-       ("Cannot convert " ++ show f ++ " image <" ++-        showCS eImg ++-        "> as " ++-        "<Image " ++-        showsTypeRep (typeRep (Proxy :: Proxy r)) " " ++-        showsTypeRep (typeRep (Proxy :: Proxy cs)) " " ++-        showsTypeRep (typeRep (Proxy :: Proxy e)) ">"))-    Right+       ("Cannot convert " +++        show f +++        " image <" ++ showCS eImg ++ "> as " ++ showImageType (Proxy :: Proxy (Image r cs e))))+    pure     (conv eImg) ++encodeError :: MonadThrow m => Either String a -> m a+encodeError = either (throwM . EncodeError) pure++decodeError :: MonadThrow m => Either String a -> m a+decodeError = either (throwM . DecodeError) pure+++-- | Convert image to any supported color space+--+-- @since 0.2.0+convertImage ::+     (A.Source r' (Pixel cs' e'), ColorSpace cs' i' e', ColorSpace cs i e)+  => Image r' cs' e'+  -> Image A.D cs e+convertImage = A.map convertPixel+{-# INLINE convertImage #-}+++-- | Convert image to any supported color space and compute the resulting image+--+-- @since 1.0.1+convertImageM ::+     (ColorSpace cs' i' e', ColorSpace cs i e, A.Manifest r (Pixel cs e))+  => Image A.S cs' e'+  -> Image r cs e+convertImageM = A.compute . A.map convertPixel+{-# INLINE [1] convertImageM #-}+{-# RULES+ "convertImageM = id" convertImageM = id+#-}++-- | Cast an array. This is theoretically unsafe operation, but for all currently+-- available `ColorSpace` instances this function is perfectly safe.+--+-- @since 0.2.0+toImageBaseModel :: A.Matrix A.S (Pixel cs e) -> A.Matrix A.S (Pixel (BaseModel cs) e)+toImageBaseModel = unsafeCoerce+++-- | Cast an array. This is theoretically unsafe operation, but for all currently+-- available `ColorSpace` instances this function is perfectly safe.+--+-- @since 0.2.0+fromImageBaseModel :: A.Matrix A.S (Pixel (BaseModel cs) e) -> A.Matrix A.S (Pixel cs e)+fromImageBaseModel = unsafeCoerce++-- | Convert Binary image to its Word8 backed pixel without copy+--+-- @since 0.4.1+coerceBinaryImage :: A.Matrix A.S (Pixel CM.X Bit) -> A.Matrix A.S (Pixel CM.X Word8)+coerceBinaryImage = unsafeCoerce++unsafeFromStorableVectorM ::+     (MonadThrow m, A.Index ix, A.Storable a, A.Storable b)+  => A.Sz ix+  -> V.Vector a+  -> m (A.Array A.S ix b)+unsafeFromStorableVectorM sz v =+  A.resizeM sz $ A.fromStorableVector A.Par $ V.unsafeCast v
src/Data/Massiv/Array/IO/Image.hs view
@@ -2,163 +2,207 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeApplications #-} -- | -- Module      : Data.Massiv.Array.IO.Image--- Copyright   : (c) Alexey Kuleshevich 2018-2019+-- Copyright   : (c) Alexey Kuleshevich 2018-2021 -- License     : BSD3 -- Maintainer  : Alexey Kuleshevich <lehins@yandex.ru> -- Stability   : experimental -- Portability : non-portable -- module Data.Massiv.Array.IO.Image-  ( Encode-  , encodeImage+  ( module Data.Massiv.Array.IO.Image.JuicyPixels+  , module Data.Massiv.Array.IO.Image.Netpbm+  -- ** Helper image functions+  , selectFileFormat+  , Encode(..)+  , encodeImageM+  , encodeAdhocM+  , writableAdhoc   , imageWriteFormats   , imageWriteAutoFormats-  , Decode-  , decodeImage+  , Decode(..)+  , decodeImageM+  , decodeAdhocM+  , readableAdhoc   , imageReadFormats   , imageReadAutoFormats-  , module Data.Massiv.Array.IO.Image.JuicyPixels-  , module Data.Massiv.Array.IO.Image.Netpbm   ) where -import Control.Exception (throw) import qualified Data.ByteString as B (ByteString) import qualified Data.ByteString.Lazy as BL (ByteString)-import Data.Char (toLower) import Data.Massiv.Array import Data.Massiv.Array.IO.Base import Data.Massiv.Array.IO.Image.JuicyPixels import Data.Massiv.Array.IO.Image.Netpbm-import Graphics.ColorSpace+import Graphics.Pixel.ColorSpace import Prelude as P-import System.FilePath (takeExtension)  -+-- | Adhoc encoder data Encode out where-  EncodeAs :: (FileFormat f, Writable f out) => f -> Encode out+  -- | Provide a custom way to encode a particular file format. This is an alternative+  -- approach to `Writable` class+  --+  -- @since 0.4.1+  Encode+    :: FileFormat f+    => f+    -> (forall m. MonadThrow m => f -> out -> m BL.ByteString)+    -> Encode out  instance Show (Encode out) where-  show (EncodeAs f) = show f+  show (Encode f _) = show f -instance FileFormat (Encode (Image r cs e)) where-  ext (EncodeAs f) = ext f+instance FileFormat (Encode out) where+  ext (Encode f _) = ext f -  exts (EncodeAs f) = exts f+  exts (Encode f _) = exts f -instance Writable (Encode (Image r cs e)) (Image r cs e) where-  encode (EncodeAs f) _ = encode f (defaultWriteOptions f)+-- | Decode binary data without requiring `Readable` instances+--+-- @since 0.4.1+encodeAdhocM :: MonadThrow m => Encode out -> out -> m BL.ByteString+encodeAdhocM (Encode f enc) = enc f+{-# INLINE encodeAdhocM #-} +-- | Utilize a Writable instance in order to construct an adhoc Encode type+--+-- @since 0.4.1+writableAdhoc :: Writable f out => f -> Encode out+writableAdhoc f = Encode f (`encodeM` def)+{-# INLINE writableAdhoc #-}++ -- | Encode an image into a lazy `BL.ByteString`, while selecting the appropriate format from the -- file extension.-encodeImage-  :: (Source r Ix2 (Pixel cs e), ColorSpace cs e)+--+-- @since 0.2.0+encodeImageM+  :: MonadThrow m   => [Encode (Image r cs e)] -- ^ List of image formats to choose from (useful lists are-                             -- `imageWriteFormats` and `imageWriteAutoFormats`+                             -- `imageWriteFormats` and `imageWriteAutoFormats`)   -> FilePath -- ^ File name with extension, so the format can be inferred   -> Image r cs e -- ^ Image to encode-  -> BL.ByteString-encodeImage formats path img = do-  let ext' = P.map toLower . takeExtension $ path-  case dropWhile (not . isFormat ext') formats of-    []    -> throw $ EncodeError $ "File format is not supported: " ++ ext'-    (f:_) -> encode f () img+  -> m BL.ByteString+encodeImageM formats path img = do+  f <- selectFileFormat formats path+  encodeAdhocM f img+{-# INLINE encodeImageM #-} + -- | List of image formats that can be encoded without any color space conversion.-imageWriteFormats :: (Source r Ix2 (Pixel cs e), ColorSpace cs e) => [Encode (Image r cs e)]+imageWriteFormats :: (Source r (Pixel cs e), ColorModel cs e) => [Encode (Image r cs e)] imageWriteFormats =-  [ EncodeAs BMP-  , EncodeAs GIF-  , EncodeAs HDR-  , EncodeAs JPG-  , EncodeAs PNG-  , EncodeAs TGA-  , EncodeAs TIF+  [ Encode PNG (\ f -> encodePNG f . computeSource @S)+  , Encode TIF (\ f -> encodeTIF f . computeSource @S)+  , Encode JPG (\ f -> encodeJPG f def . computeSource @S)+  , Encode BMP (\ f -> encodeBMP f def . computeSource @S)+  , Encode GIF (\ f -> encodeGIF f def . computeSource @S)+  , Encode TGA (\ f -> encodeTGA f . computeSource @S)+  , Encode HDR (\ f -> encodeHDR f def . computeSource @S)   ]+{-# INLINEABLE imageWriteFormats #-}  -- | List of image formats that can be encoded with any necessary color space conversions.-imageWriteAutoFormats-  :: ( Source r Ix2 (Pixel cs e)-     , ColorSpace cs e-     , ToYA cs e-     , ToRGBA cs e-     , ToYCbCr cs e-     , ToCMYK cs e-     )+imageWriteAutoFormats ::+     (Source r (Pixel cs e), ColorSpace cs i e, ColorSpace (BaseSpace cs) i e)   => [Encode (Image r cs e)] imageWriteAutoFormats =-  [ EncodeAs (Auto BMP)-  , EncodeAs (Auto GIF)-  , EncodeAs (Auto HDR)-  , EncodeAs (Auto JPG)-  , EncodeAs (Auto PNG)-  , EncodeAs (Auto TGA)-  , EncodeAs (Auto TIF)+  [ Encode (Auto PNG) (\f -> pure . encodeAutoPNG f)+  , Encode (Auto TIF) (\f -> pure . encodeAutoTIF f)+  , Encode (Auto JPG) (\f -> pure . encodeAutoJPG f def)+  , Encode (Auto BMP) (\f -> pure . encodeAutoBMP f def)+  , Encode (Auto GIF) (`encodeAutoGIF` def)+  , Encode (Auto HDR) (\f -> pure . encodeAutoHDR f def)+  , Encode (Auto TGA) (\f -> pure . encodeAutoTGA f)   ]-+{-# INLINEABLE imageWriteAutoFormats #-}  +-- | Adhoc decoder data Decode out where-  DecodeAs :: (FileFormat f, Readable f out) => f -> Decode out+  -- | Provide a custom way to encode a particular file format. This is an alternative+  -- approach to `Writable` class+  --+  -- @since 0.4.1+  Decode+    :: FileFormat f+    => f+    -> (forall m. MonadThrow m => f -> B.ByteString -> m out)+    -> Decode out  instance Show (Decode out) where-  show (DecodeAs f) = show f+  show (Decode f _) = show f  instance FileFormat (Decode (Image r cs e)) where-  ext (DecodeAs f) = ext f+  ext (Decode f _) = ext f -  exts (DecodeAs f) = exts f+  exts (Decode f _) = exts f -instance Readable (Decode (Image r cs e)) (Image r cs e) where-  decode (DecodeAs f) _ = decode f (defaultReadOptions f)+-- | Decode binary data without requiring `Readable` instances+--+-- @since 0.4.1+decodeAdhocM :: MonadThrow m => Decode out -> B.ByteString -> m out+decodeAdhocM (Decode f dec) = dec f+{-# INLINE decodeAdhocM #-} ++-- | Utilize a Readable instance in order to construct an adhoc Decode type+--+-- @since 0.4.1+readableAdhoc :: Readable f out => f -> Decode out+readableAdhoc f = Decode f decodeM+{-# INLINE readableAdhoc #-}++ -- | Decode an image from the strict `ByteString` while inferring format the image is encoded in -- from the file extension-decodeImage-  :: (Source r Ix2 (Pixel cs e), ColorSpace cs e)+--+-- @since 0.2.0+decodeImageM+  :: MonadThrow m   => [Decode (Image r cs e)] -- ^ List of available formats to choose from   -> FilePath -- ^ File name with extension, so format can be inferred   -> B.ByteString -- ^ Encoded image-  -> Image r cs e-decodeImage formats path bs = do-  let ext' = P.map toLower . takeExtension $ path-  case dropWhile (not . isFormat ext') formats of-    []    -> throw $ DecodeError $ "File format is not supported: " ++ ext'-    (f:_) -> decode f () bs+  -> m (Image r cs e)+decodeImageM formats path bs = do+  f <- selectFileFormat formats path+  decodeAdhocM f bs+{-# INLINE decodeImageM #-} --- | List of image formats decodable with no colorspace conversion-imageReadFormats-  :: (Source S Ix2 (Pixel cs e), ColorSpace cs e)-  => [Decode (Image S cs e)]+-- | List of image formats decodable with no color space conversion+imageReadFormats :: ColorModel cs e => [Decode (Image S cs e)] imageReadFormats =-  [ DecodeAs BMP-  , DecodeAs GIF-  , DecodeAs HDR-  , DecodeAs JPG-  , DecodeAs PNG-  , DecodeAs TGA-  , DecodeAs TIF-  , DecodeAs PBM-  , DecodeAs PGM-  , DecodeAs PPM+  [ Decode PNG decodePNG+  , Decode TIF decodeTIF+  , Decode JPG decodeJPG+  , Decode BMP decodeBMP+  , Decode GIF decodeGIF+  , Decode HDR decodeHDR+  , Decode TGA decodeTGA+  , Decode PBM (\f -> fmap fst . decodeNetpbmImage f)+  , Decode PGM (\f -> fmap fst . decodeNetpbmImage f)+  , Decode PPM (\f -> fmap fst . decodeNetpbmImage f)   ]+{-# INLINEABLE imageReadFormats #-} --- | List of image formats decodable with no colorspace conversion+-- | List of image formats decodable with automatic colorspace conversion imageReadAutoFormats-  :: (Mutable r Ix2 (Pixel cs e), ColorSpace cs e)+  :: (Manifest r (Pixel cs e), ColorSpace cs i e)   => [Decode (Image r cs e)] imageReadAutoFormats =-  [ DecodeAs (Auto BMP)-  , DecodeAs (Auto GIF)-  , DecodeAs (Auto HDR)-  , DecodeAs (Auto JPG)-  , DecodeAs (Auto PNG)-  , DecodeAs (Auto TGA)-  , DecodeAs (Auto TIF)-  , DecodeAs (Auto PBM)-  , DecodeAs (Auto PGM)-  , DecodeAs (Auto PPM)+  [ Decode (Auto PNG) decodeAutoPNG+  , Decode (Auto TIF) decodeAutoTIF+  , Decode (Auto JPG) decodeAutoJPG+  , Decode (Auto BMP) decodeAutoBMP+  , Decode (Auto GIF) decodeAutoGIF+  , Decode (Auto HDR) decodeAutoHDR+  , Decode (Auto TGA) decodeAutoTGA+  , Decode (Auto PBM) (\f -> fmap fst . decodeAutoNetpbmImage f)+  , Decode (Auto PGM) (\f -> fmap fst . decodeAutoNetpbmImage f)+  , Decode (Auto PPM) (\f -> fmap fst . decodeAutoNetpbmImage f)   ]+{-# INLINEABLE imageReadAutoFormats #-}
src/Data/Massiv/Array/IO/Image/JuicyPixels.hs view
@@ -1,1023 +1,52 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE PatternSynonyms #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}--- |--- Module      : Data.Massiv.Array.IO.Image.JuicyPixels--- Copyright   : (c) Alexey Kuleshevich 2018-2019--- License     : BSD3--- Maintainer  : Alexey Kuleshevich <lehins@yandex.ru>--- Stability   : experimental--- Portability : non-portable----module Data.Massiv.Array.IO.Image.JuicyPixels-  ( -- * JuicyPixels formats-    -- ** BMP-    BMP(..)-    -- ** GIF-  , GIF(..)-  , WriteOptionsGIF-  , woGetPaletteOptionsGIF-  , woSetPaletteOptionsGIF-  , JP.PaletteOptions(..)-  , JP.PaletteCreationMethod(..)-    -- *** Animated-  , WriteOptionsSequenceGIF-  , woGetGifLoopingGIFs-  , woGetPaletteOptionsGIFs-  , woSetGifLoopingGIFs-  , woSetPaletteOptionsGIFs-  , JP.GifDelay-  , JP.GifLooping(..)-  -- ** HDR-  , HDR(..)-  -- ** JPG-  , JPG(..)-  , WriteOptionsJPG-  , woGetQualityJPG-  , woSetQualityJPG-  -- ** PNG-  , PNG(..)-  -- ** TGA-  , TGA(..)-  -- ** TIF-  , TIF(..)-  -- * JuciyPixels conversion-  -- ** To JuicyPixels-  -- O(1) Conversion to JuicyPixels images-  , toAnyCS-  , toJPImageY8-  , toJPImageYA8-  , toJPImageY16-  , toJPImageYA16-  , toJPImageYF-  , toJPImageRGB8-  , toJPImageRGBA8-  , toJPImageRGB16-  , toJPImageRGBA16-  , toJPImageRGBF-  , toJPImageYCbCr8-  , toJPImageCMYK8-  , toJPImageCMYK16-  -- ** From JuicyPixels-  , fromDynamicImage-  , fromAnyDynamicImage-  ) where--import Prelude as P--import qualified Codec.Picture as JP-import qualified Codec.Picture.ColorQuant as JP-import qualified Codec.Picture.Gif as JP-import qualified Codec.Picture.Jpg as JP-import qualified Codec.Picture.Types as TypesJP-import Control.Exception-import Control.Monad (guard, msum, unless)-import Data.Bifunctor-import qualified Data.ByteString as B-import qualified Data.ByteString.Lazy as BL (ByteString)-import Data.Default.Class (Default(..))-import Data.Massiv.Array as M-import Data.Massiv.Array.IO.Base-import Data.Massiv.Array.Manifest.Vector-import Data.Typeable-import qualified Data.Vector.Storable as V-import Foreign.Storable (Storable(sizeOf))-import Graphics.ColorSpace--#if !MIN_VERSION_massiv(0, 2, 7)-pattern Sz :: ix -> ix-pattern Sz ix = ix-type Sz ix = ix-#endif-#if !MIN_VERSION_massiv(0, 3, 0)-fromVectorM ::-     (Construct S ix a, Mutable S ix a, Storable a)-  => Comp-  -> Sz ix-  -> V.Vector a-  -> Maybe (Array S ix a)-fromVectorM comp sz = pure . fromVector comp sz-#endif------------------------------------------------------------------------------------- BMP Format ------------------------------------------------------------------------------------------------------------------------------------------------------- | Bitmap image with @.bmp@ extension.-data BMP = BMP deriving Show--instance FileFormat BMP where--  ext _ = ".bmp"---instance (ColorSpace cs e, Source r Ix2 (Pixel cs e)) =>-         Writable BMP (Image r cs e) where-  encode f _ img = fromMaybeEncode f (toProxy img) $ encodeBMP img--instance (ColorSpace cs e, ToRGBA cs e, Source r Ix2 (Pixel cs e)) =>-         Writable (Auto BMP) (Image r cs e) where-  encode f _ = encodeAuto f encodeBMP id toPixelRGBA toPixelRGB toPixelRGBA---instance ColorSpace cs e => Readable BMP (Image S cs e) where-  decode f _ = fromEitherDecode f showJP fromDynamicImage . JP.decodeBitmap---instance (Mutable r Ix2 (Pixel cs e), ColorSpace cs e) =>-         Readable (Auto BMP) (Image r cs e) where-  decode f _ = fromEitherDecode f showJP fromAnyDynamicImage . JP.decodeBitmap---encodeBMP :: forall r cs e . (ColorSpace cs e, Source r Ix2 (Pixel cs e))-          => Image r cs e -> Maybe BL.ByteString-encodeBMP img =-  msum-    [ do Refl <- eqT :: Maybe (cs :~: Y)-         msum-           [ do Refl <- eqT :: Maybe (e :~: Word8)-                return $ JP.encodeBitmap $ toJPImageY8 img-           , return $ JP.encodeBitmap $ toJPImageY8 $ M.map toWord8 img-           ]-    , do Refl <- eqT :: Maybe (cs :~: RGB)-         msum-           [ do Refl <- eqT :: Maybe (e :~: Word8)-                return $ JP.encodeBitmap $ toJPImageRGB8 img-           , return $ JP.encodeBitmap $ toJPImageRGB8 $ M.map toWord8 img-           ]-    , do Refl <- eqT :: Maybe (cs :~: RGBA)-         msum-           [ do Refl <- eqT :: Maybe (e :~: Word8)-                return $ JP.encodeBitmap $ toJPImageRGBA8 img-           , return $ JP.encodeBitmap $ toJPImageRGBA8 $ M.map toWord8 img-           ]-    ]-------------------------------------------------------------------------------------- PNG Format ------------------------------------------------------------------------------------------------------------------------------------------------------- | Portable Network Graphics image with @.png@ extension.-data PNG = PNG deriving Show--instance FileFormat PNG where--  ext _ = ".png"--instance (ColorSpace cs e, Source r Ix2 (Pixel cs e)) =>-         Writable PNG (Image r cs e) where-  encode f _ img = fromMaybeEncode f (toProxy img) (encodePNG img)---instance (ColorSpace cs e, ToYA cs e, ToRGBA cs e, Source r Ix2 (Pixel cs e)) =>-         Writable (Auto PNG) (Image r cs e) where-  encode f _ = encodeAuto f encodePNG id toPixelYA toPixelRGB toPixelRGBA---instance ColorSpace cs e => Readable PNG (Image S cs e) where-  decode f _ = fromEitherDecode f showJP fromDynamicImage . JP.decodePng--instance (Mutable r Ix2 (Pixel cs e), ColorSpace cs e) =>-         Readable (Auto PNG) (Image r cs e) where-  decode f _ = fromEitherDecode f showJP fromAnyDynamicImage . JP.decodePng----encodePNG :: forall r cs e. (ColorSpace cs e, Source r Ix2 (Pixel cs e))-          => Image r cs e -> Maybe BL.ByteString-encodePNG img =-  msum-    [ do Refl <- eqT :: Maybe (cs :~: Y)-         msum-           [ do Refl <- eqT :: Maybe (e :~: Word8)-                return $ JP.encodePng $ toJPImageY8 img-           , do Refl <- eqT :: Maybe (e :~: Word16)-                return $ JP.encodePng $ toJPImageY16 img-           , return $ JP.encodePng $ toJPImageY16 $ M.map toWord16 img-           ]-    , do Refl <- eqT :: Maybe (cs :~: YA)-         msum-           [ do Refl <- eqT :: Maybe (e :~: Word8)-                return $ JP.encodePng $ toJPImageYA8 img-           , do Refl <- eqT :: Maybe (e :~: Word16)-                return $ JP.encodePng $ toJPImageYA16 img-           , return $ JP.encodePng $ toJPImageYA16 $ M.map toWord16 img-           ]-    , do Refl <- eqT :: Maybe (cs :~: RGB)-         msum-           [ do Refl <- eqT :: Maybe (e :~: Word8)-                return $ JP.encodePng $ toJPImageRGB8 img-           , do Refl <- eqT :: Maybe (e :~: Word16)-                return $ JP.encodePng $ toJPImageRGB16 img-           , return $ JP.encodePng $ toJPImageRGB16 $ M.map toWord16 img-           ]-    , do Refl <- eqT :: Maybe (cs :~: RGBA)-         msum-           [ do Refl <- eqT :: Maybe (e :~: Word8)-                return $ JP.encodePng $ toJPImageRGBA8 img-           , do Refl <- eqT :: Maybe (e :~: Word16)-                return $ JP.encodePng $ toJPImageRGBA16 img-           , return $ JP.encodePng $ toJPImageRGBA16 $ M.map toWord16 img-           ]-    ]--------------------------------------------------------------------------------------- GIF Format ------------------------------------------------------------------------------------------------------------------------------------------------------- | Graphics Interchange Format image with @.gif@ extension.-data GIF = GIF deriving Show--newtype WriteOptionsGIF = WriteOptionsGIF-  { woGetPaletteOptionsGIF :: JP.PaletteOptions-  }--woSetPaletteOptionsGIF :: JP.PaletteOptions -> WriteOptionsGIF -> WriteOptionsGIF-woSetPaletteOptionsGIF palOpts opts = opts { woGetPaletteOptionsGIF = palOpts }--instance Default WriteOptionsGIF where-  def = WriteOptionsGIF JP.defaultPaletteOptions--instance FileFormat GIF where-  type WriteOptions GIF = WriteOptionsGIF--  ext _ = ".gif"---data WriteOptionsSequenceGIF = WriteOptionsSequenceGIF-  { woGetPaletteOptionsGIFs :: JP.PaletteOptions-  , woGetGifLoopingGIFs     :: JP.GifLooping-  }--woSetPaletteOptionsGIFs :: JP.PaletteOptions -> WriteOptionsSequenceGIF -> WriteOptionsSequenceGIF-woSetPaletteOptionsGIFs palOpts opts = opts { woGetPaletteOptionsGIFs = palOpts }---woSetGifLoopingGIFs :: JP.GifLooping -> WriteOptionsSequenceGIF -> WriteOptionsSequenceGIF-woSetGifLoopingGIFs looping opts = opts { woGetGifLoopingGIFs = looping }---instance Default WriteOptionsSequenceGIF where-  def = WriteOptionsSequenceGIF JP.defaultPaletteOptions JP.LoopingNever--instance FileFormat (Sequence GIF) where--  type WriteOptions (Sequence GIF) = WriteOptionsSequenceGIF-  ext _ = ext GIF---instance FileFormat (Sequence (Auto GIF)) where--  type WriteOptions (Sequence (Auto GIF)) = WriteOptions (Sequence GIF)-  ext _ = ext GIF---instance (ColorSpace cs e, Source r Ix2 (Pixel cs e)) =>-         Writable GIF (Image r cs e) where-  encode f opt img = fromMaybeEncode f (toProxy img) $ encodeGIF opt img--instance (ColorSpace cs e, ToY cs e, ToRGB cs e, Source r Ix2 (Pixel cs e)) =>-         Writable (Auto GIF) (Image r cs e) where-  encode f opt = encodeAuto f (encodeGIF opt) id toPixelY toPixelRGB toPixelRGB---instance ColorSpace cs e => Readable GIF (Image S cs e) where-  decode f _ = fromEitherDecode f showJP fromDynamicImage . JP.decodeGif--instance (Mutable r Ix2 (Pixel cs e), ColorSpace cs e) =>-         Readable (Auto GIF) (Image r cs e) where-  decode f _ = fromEitherDecode f showJP fromAnyDynamicImage . JP.decodeGif-----instance ColorSpace cs e =>-         Readable (Sequence GIF) (Array B Ix1 (Image S cs e)) where-  decode f _ = decodeGIFs f fromDynamicImage--instance (Mutable r Ix2 (Pixel cs e), ColorSpace cs e) =>-         Readable (Sequence (Auto GIF)) (Array B Ix1 (Image r cs e)) where-  decode f _ = decodeGIFs f fromAnyDynamicImage---instance (ColorSpace cs e, Source r Ix2 (Pixel cs e)) =>-         Writable (Sequence GIF) (Array B Ix1 (JP.GifDelay, Image r cs e)) where-  encode _ opts =-    fromMaybeEncode (Sequence GIF) (Proxy :: Proxy (Image r cs e)) . encodeGIFs opts---instance ColorSpace cs e =>-         Readable (Sequence GIF) (Array B Ix1 (JP.GifDelay, Image S cs e)) where-  decode f _ = decodeGIFsWithDelays f fromDynamicImage------ Animated GIF Format frames reading into an Array of Images--decodeGIFs-  :: (FileFormat f, Mutable r Ix2 (Pixel cs e), ColorSpace cs e)-  => f-  -> (JP.DynamicImage -> Maybe (Image r cs e))-  -> B.ByteString-  -> Array B Ix1 (Image r cs e)-decodeGIFs f converter bs =-  either throw (fromList Seq) $ do-    jpImgs <- first (toException . DecodeError) $ JP.decodeGifImages bs-    first toException $ P.mapM (convertEither f showJP converter) jpImgs-  -- either-  --   (throw . DecodeError)-  --   (fromList' Seq)-  --   (P.map (fromEitherDecode f showJP decoder . Right) <$> JP.decodeGifImages bs)-{-# INLINE decodeGIFs #-}----decodeGIFsWithDelays-  :: ColorSpace cs e-  => Sequence GIF-  -> (JP.DynamicImage -> Maybe (Image S cs e))-  -> B.ByteString-  -> Array B Ix1 (JP.GifDelay, Image S cs e)-decodeGIFsWithDelays f converter bs =-  either throw (fromList Seq) $ do-    jpImgsLs <- first (toException . DecodeError) $ JP.decodeGifImages bs-    delays <- first (toException . DecodeError) $ JP.getDelaysGifImages bs-    imgs <- first toException $ P.mapM (convertEither f showJP converter) jpImgsLs-    return $ P.zip delays imgs-{-# INLINE decodeGIFsWithDelays #-}----encodeGIF :: forall r cs e . (ColorSpace cs e, Source r Ix2 (Pixel cs e))-          => WriteOptionsGIF-          -> Image r cs e-          -> Maybe BL.ByteString-encodeGIF (WriteOptionsGIF pal) img =-  (either (throw . EncodeError) id . uncurry JP.encodeGifImageWithPalette) <$>-  msum-    [ do Refl <- eqT :: Maybe (cs :~: Y)-         jImg <--           msum-             [ do Refl <- eqT :: Maybe (e :~: Word8)-                  return $ toJPImageY8 img-             , return $ toJPImageY8 $ M.map toWord8 img-             ]-         return (jImg, JP.greyPalette)-    , do Refl <- eqT :: Maybe (cs :~: RGB)-         msum-           [ do Refl <- eqT :: Maybe (e :~: Word8)-                palettizeRGB pal img-           , palettizeRGB pal $ M.map toWord8 img-           ]-    ]---encodeGIFs :: forall r cs e . (ColorSpace cs e, Source r Ix2 (Pixel cs e))-           => WriteOptionsSequenceGIF-           -> Array B Ix1 (JP.GifDelay, Image r cs e)-           -> Maybe BL.ByteString-encodeGIFs (WriteOptionsSequenceGIF pal looping) arr = do-  palImgsLs <--    msum-      [ do Refl <- eqT :: Maybe (cs :~: Y)-           msum-             [ do Refl <- eqT :: Maybe (e :~: Word8)-                  return $ P.map ((, JP.greyPalette) . toJPImageY8) imgsLs-             , return $-               P.map ((, JP.greyPalette) . toJPImageY8 . M.map toWord8) imgsLs-             ]-      , do Refl <- eqT :: Maybe (cs :~: RGB)-           msum-             [ do Refl <- eqT :: Maybe (e :~: Word8)-                  P.mapM (palettizeRGB pal) imgsLs-             , P.mapM (palettizeRGB pal . M.map toWord8) imgsLs-             ]-      ]-  let palDelImgsLs = P.zipWith (\(i, p) d -> (p, d, i)) palImgsLs delaysLs-  return $-    either (throw . EncodeError) id $ JP.encodeGifImages looping palDelImgsLs-  where-    delaysLs = toList delays-    imgsLs = toList imgs-    (delays, imgs) = M.unzip arr-{-# INLINE encodeGIFs #-}---palettizeRGB :: forall r e . (ColorSpace RGB e, Source r Ix2 (Pixel RGB e))-          => JP.PaletteOptions-          -> Image r RGB e-          -> Maybe (JP.Image JP.Pixel8, JP.Palette)-palettizeRGB pal img =-  msum-    [ do Refl <- eqT :: Maybe (e :~: Word8)-         return $ palettize' img-    , return $ palettize' $ M.map toWord8 img-    ]-  where-    palettize' :: forall r' . Source r' Ix2 (Pixel RGB Word8) =>-                  Image r' RGB Word8 -> (JP.Image JP.Pixel8, JP.Palette)-    palettize' = JP.palettize pal . toJPImageRGB8-    {-# INLINE palettize' #-}-{-# INLINE palettizeRGB #-}-------------------------------------------------------------------------------------- HDR Format -------------------------------------------------------------------------------------------------------------------------------------------------------- | High-dynamic-range image with @.hdr@ or @.pic@ extension.-data HDR = HDR deriving Show--instance FileFormat HDR where--  ext _ = ".hdr"--  exts _ = [".hdr", ".pic"]--instance (ColorSpace cs e, Source r Ix2 (Pixel cs e)) =>-         Writable HDR (Image r cs e) where-  encode f _ img = fromMaybeEncode f (toProxy img) $ encodeHDR img---instance (ColorSpace cs e, ToRGB cs e, Source r Ix2 (Pixel cs e)) =>-         Writable (Auto HDR) (Image r cs e) where-  encode f _ =-    encodeAuto f encodeHDR toPixelRGB toPixelRGB toPixelRGB toPixelRGB---instance ColorSpace cs e => Readable HDR (Image S cs e) where-  decode f _ = fromEitherDecode f showJP fromDynamicImage . JP.decodeHDR--instance (Mutable r Ix2 (Pixel cs e), ColorSpace cs e) =>-         Readable (Auto HDR) (Image r cs e) where-  decode f _ = fromEitherDecode f showJP fromAnyDynamicImage . JP.decodeHDR-----encodeHDR :: forall r cs e. (ColorSpace cs e, Source r Ix2 (Pixel cs e))-          => Image r cs e -> Maybe BL.ByteString-encodeHDR img = do-  Refl <- eqT :: Maybe (cs :~: RGB)-  msum-    [ do Refl <- eqT :: Maybe (e :~: Float)-         return $ JP.encodeHDR $ toJPImageRGBF img-    , return $ JP.encodeHDR $ toJPImageRGBF $ M.map toFloat img-    ]---------------------------------------------------------------------------------------- JPG Format -----------------------------------------------------------------------------------------------------------------------------------------------------newtype WriteOptionsJPG = WriteOptionsJPG { woGetQualityJPG :: Word8 } deriving Show---- | Set the image quality, supplied value will be clamped to @[0, 100]@--- range. This setting directly affects the Jpeg compression level.-woSetQualityJPG :: Word8 -> WriteOptionsJPG -> WriteOptionsJPG-woSetQualityJPG q opts = opts { woGetQualityJPG = min 100 (max 0 q) }--instance Default WriteOptionsJPG where-  def = WriteOptionsJPG 100---- | Joint Photographic Experts Group image with @.jpg@ or @.jpeg@ extension.-data JPG = JPG deriving Show--instance FileFormat JPG where-  type WriteOptions JPG = WriteOptionsJPG--  ext _ = ".jpg"--  exts _ = [".jpg", ".jpeg"]--instance (ColorSpace cs e, Source r Ix2 (Pixel cs e)) =>-         Writable JPG (Image r cs e) where-  encode f opts img = fromMaybeEncode f (toProxy img) $ encodeJPG opts img---instance (ColorSpace cs e, ToYCbCr cs e, Source r Ix2 (Pixel cs e)) =>-         Writable (Auto JPG) (Image r cs e) where-  encode f opt =-    encodeAuto f (encodeJPG opt) toPixelYCbCr toPixelYCbCr toPixelYCbCr toPixelYCbCr---instance ColorSpace cs e => Readable JPG (Image S cs e) where-  decode f _ = fromEitherDecode f showJP fromDynamicImage . JP.decodeJpeg--instance (Mutable r Ix2 (Pixel cs e), ColorSpace cs e) =>-         Readable (Auto JPG) (Image r cs e) where-  decode f _ = fromEitherDecode f showJP fromAnyDynamicImage . JP.decodeJpeg-----encodeJPG :: forall r cs e. (ColorSpace cs e, Source r Ix2 (Pixel cs e))-          => WriteOptionsJPG -> Image r cs e -> Maybe BL.ByteString-encodeJPG (WriteOptionsJPG q) img =-  msum-    [ do Refl <- eqT :: Maybe (cs :~: Y)-         msum-           [ do Refl <- eqT :: Maybe (e :~: Word8)-                return $ encJPG $ toJPImageY8 img-           , return $ encJPG $ toJPImageY8 $ M.map toWord8 img-           ]-    , do Refl <- eqT :: Maybe (cs :~: RGB)-         msum-           [ do Refl <- eqT :: Maybe (e :~: Word8)-                return $ encJPG $ toJPImageRGB8 img-           , return $ encJPG $ toJPImageRGB8 $ M.map toWord8 img-           ]-    , do Refl <- eqT :: Maybe (cs :~: CMYK)-         msum-           [ do Refl <- eqT :: Maybe (e :~: Word8)-                return $ encJPG $ toJPImageCMYK8 img-           , return $ encJPG $ toJPImageCMYK8 $ M.map toWord8 img-           ]-    , do Refl <- eqT :: Maybe (cs :~: YCbCr)-         msum-           [ do Refl <- eqT :: Maybe (e :~: Word8)-                return $ encJPG $ toJPImageYCbCr8 img-           , return $ encJPG $ toJPImageYCbCr8 $ M.map toWord8 img-           ]-    ]-  where-    encJPG :: forall px . JP.JpgEncodable px => JP.Image px -> BL.ByteString-    encJPG = JP.encodeDirectJpegAtQualityWithMetadata q mempty-    {-# INLINE encJPG #-}--------------------------------------------------------------------------------------- TGA Format -------------------------------------------------------------------------------------------------------------------------------------------------------- | Truevision Graphics Adapter image with .tga extension.-data TGA = TGA deriving Show--instance FileFormat TGA where--  ext _ = ".tga"-  {-# INLINE ext #-}----instance (ColorSpace cs e, Source r Ix2 (Pixel cs e)) =>-         Writable TGA (Image r cs e) where-  encode f _ img = fromMaybeEncode f (toProxy img) $ encodeTGA img--instance (ColorSpace cs e, ToRGBA cs e, Source r Ix2 (Pixel cs e)) =>-         Writable (Auto TGA) (Image r cs e) where-  encode f _ = encodeAuto f encodeTGA id toPixelRGBA toPixelRGB toPixelRGBA---instance ColorSpace cs e => Readable TGA (Image S cs e) where-  decode f _ = fromEitherDecode f showJP fromDynamicImage . JP.decodeTga---instance (Mutable r Ix2 (Pixel cs e), ColorSpace cs e) =>-         Readable (Auto TGA) (Image r cs e) where-  decode f _ = fromEitherDecode f showJP fromAnyDynamicImage . JP.decodeTga---encodeTGA :: forall r cs e . (ColorSpace cs e, Source r Ix2 (Pixel cs e))-          => Image r cs e -> Maybe BL.ByteString-encodeTGA img =-  msum-    [ do Refl <- eqT :: Maybe (cs :~: Y)-         msum-           [ do Refl <- eqT :: Maybe (e :~: Word8)-                return $ JP.encodeTga $ toJPImageY8 img-           , return $ JP.encodeTga $ toJPImageY8 $ M.map toWord8 img-           ]-    , do Refl <- eqT :: Maybe (cs :~: RGB)-         msum-           [ do Refl <- eqT :: Maybe (e :~: Word8)-                return $ JP.encodeTga $ toJPImageRGB8 img-           , return $ JP.encodeTga $ toJPImageRGB8 $ M.map toWord8 img-           ]-    , do Refl <- eqT :: Maybe (cs :~: RGBA)-         msum-           [ do Refl <- eqT :: Maybe (e :~: Word8)-                return $ JP.encodeTga $ toJPImageRGBA8 img-           , return $ JP.encodeTga $ toJPImageRGBA8 $ M.map toWord8 img-           ]-    ]-------------------------------------------------------------------------------------- TIF Format -------------------------------------------------------------------------------------------------------------------------------------------------------- | Tagged Image File Format image with @.tif@ or @.tiff@ extension.-data TIF = TIF deriving Show--instance FileFormat TIF where--  ext _ = ".tif"-  {-# INLINE ext #-}--  exts _ = [".tif", ".tiff"]-  {-# INLINE exts #-}---instance (ColorSpace cs e, Source r Ix2 (Pixel cs e)) =>-         Writable TIF (Image r cs e) where-  encode f _ img = fromMaybeEncode f (toProxy img) $ encodeTIF img---instance (ColorSpace cs e, ToRGBA cs e, Source r Ix2 (Pixel cs e)) =>-         Writable (Auto TIF) (Image r cs e) where-  encode f _ = encodeAuto f encodeTIF id id id toPixelRGBA---instance ColorSpace cs e => Readable TIF (Image S cs e) where-  decode f _ = fromEitherDecode f showJP fromDynamicImage . JP.decodeTiff--instance (Mutable r Ix2 (Pixel cs e), ColorSpace cs e) =>-         Readable (Auto TIF) (Image r cs e) where-  decode f _ = fromEitherDecode f showJP fromAnyDynamicImage . JP.decodeTiff-----encodeTIF :: forall r cs e. (ColorSpace cs e, Source r Ix2 (Pixel cs e))-          => Image r cs e -> Maybe BL.ByteString-encodeTIF img =-  msum-    [ do Refl <- eqT :: Maybe (cs :~: Y)-         msum-           [ do Refl <- eqT :: Maybe (e :~: Word8)-                return $ JP.encodeTiff $ toJPImageY8 img-           , do Refl <- eqT :: Maybe (e :~: Word16)-                return $ JP.encodeTiff $ toJPImageY16 img-#if MIN_VERSION_JuicyPixels(3,3,0)-           , do Refl <- eqT :: Maybe (e :~: Word32)-                return $ JP.encodeTiff $ toJPImageY32 img-           , do Refl <- eqT :: Maybe (e :~: Float)-                return $ JP.encodeTiff $ toJPImageYF img-#endif-           , return $ JP.encodeTiff $ toJPImageY16 $ M.map toWord16 img-           ]-    , do Refl <- eqT :: Maybe (cs :~: YA)-         msum-           [ do Refl <- eqT :: Maybe (e :~: Word8)-                return $ JP.encodeTiff $ toJPImageYA8 img-           , do Refl <- eqT :: Maybe (e :~: Word16)-                return $ JP.encodeTiff $ toJPImageYA16 img-           , return $ JP.encodeTiff $ toJPImageYA16 $ M.map toWord16 img-           ]-    , do Refl <- eqT :: Maybe (cs :~: RGB)-         msum-           [ do Refl <- eqT :: Maybe (e :~: Word8)-                return $ JP.encodeTiff $ toJPImageRGB8 img-           , do Refl <- eqT :: Maybe (e :~: Word16)-                return $ JP.encodeTiff $ toJPImageRGB16 img-           , return $ JP.encodeTiff $ toJPImageRGB16 $ M.map toWord16 img-           ]-    , do Refl <- eqT :: Maybe (cs :~: RGBA)-         msum-           [ do Refl <- eqT :: Maybe (e :~: Word8)-                return $ JP.encodeTiff $ toJPImageRGBA8 img-           , do Refl <- eqT :: Maybe (e :~: Word16)-                return $ JP.encodeTiff $ toJPImageRGBA16 img-           , return $ JP.encodeTiff $ toJPImageRGBA16 $ M.map toWord16 img-           ]-    , do Refl <- eqT :: Maybe (cs :~: YCbCr)-         msum-           [ do Refl <- eqT :: Maybe (e :~: Word8)-                return $ JP.encodeTiff $ toJPImageYCbCr8 img-           , return $ JP.encodeTiff $ toJPImageYCbCr8 $ M.map toWord8 img-           ]-    , do Refl <- eqT :: Maybe (cs :~: CMYK)-         msum-           [ do Refl <- eqT :: Maybe (e :~: Word8)-                return $ JP.encodeTiff $ toJPImageCMYK8 img-           , do Refl <- eqT :: Maybe (e :~: Word16)-                return $ JP.encodeTiff $ toJPImageCMYK16 img-             -- for CMYK default is 8bit, instead of 16bit, since many viewers and editors-             -- don't support it.-           , return $ JP.encodeTiff $ toJPImageCMYK8 $ M.map toWord8 img-           ]-    ]---------------------------------------------------------------------------------------- Common encoding/decoding functions ------------------------------------------------------------------------------------------------------------------------------encodeAuto-  :: forall f r cs e a csY eY csYA eYA csC eC csCA eCA.-     ( ColorSpace cs e-     , ColorSpace csC eC-     , ColorSpace csCA eCA-     , ColorSpace csY eY-     , ColorSpace csYA eYA-     , Source r Ix2 (Pixel cs e)-     , FileFormat f-     )-  => f-  -> (forall r' cs' e'. (Source r' Ix2 (Pixel cs' e'), ColorSpace cs' e') =>-                          Image r' cs' e' -> Maybe a)-  -> (Pixel cs e -> Pixel csY eY) -- ^ To preferred from Luma-  -> (Pixel cs e -> Pixel csYA eYA) -- ^ To preferred from Luma with Alpha-  -> (Pixel cs e -> Pixel csC eC) -- ^ To preferred from any color-  -> (Pixel cs e -> Pixel csCA eCA) -- ^ To preferred from any color with Alpha-  -> Image r cs e-  -> a-encodeAuto f enc toLuma toLumaA toColor toColorA img =-  fromMaybeEncode f (toProxy img) $ msum-    [ enc img-    , do Refl <- eqT :: Maybe (cs :~: Y)-         enc $ M.map toLuma img-    , do Refl <- eqT :: Maybe (cs :~: YA)-         enc $ M.map toLumaA img-    , do Refl <- eqT :: Maybe (cs :~: RGB)-         enc $ M.map toColor img-    , do Refl <- eqT :: Maybe (cs :~: RGBA)-         enc $ M.map toColorA img-    , do Refl <- eqT :: Maybe (cs :~: HSI)-         enc $ M.map toColor img-    , do Refl <- eqT :: Maybe (cs :~: HSIA)-         enc $ M.map toColorA img-    , do Refl <- eqT :: Maybe (cs :~: YCbCr)-         enc $ M.map toColor img-    , do Refl <- eqT :: Maybe (cs :~: YCbCrA)-         enc $ M.map toColorA img-    , do Refl <- eqT :: Maybe (cs :~: CMYK)-         enc $ M.map toColor img-    , do Refl <- eqT :: Maybe (cs :~: CMYKA)-         enc $ M.map toColorA img-    , do Refl <- eqT :: Maybe (Pixel cs e :~: Pixel X Bit)-         enc $ M.map fromPixelBinary img-    ]-----elevate-  :: forall cs e' e.-     ( ColorSpace cs e'-     , ColorSpace cs e-     , Source D Ix2 (Pixel cs e')-     )-  => Image D cs e' -> Maybe (Image D cs e)-elevate img =-  msum-    [ fmap (\Refl -> img) (eqT :: Maybe (e :~: e'))-    , do Refl <- eqT :: Maybe (e :~: Word8)-         return $ M.map toWord8 img-    , do Refl <- eqT :: Maybe (e :~: Word16)-         return $ M.map toWord16 img-    , do Refl <- eqT :: Maybe (e :~: Word32)-         return $ M.map toWord32 img-    , do Refl <- eqT :: Maybe (e :~: Word64)-         return $ M.map toWord64 img-    , do Refl <- eqT :: Maybe (e :~: Double)-         return $ M.map toDouble img-    ]--fromDynamicImage :: forall cs e . ColorSpace cs e-                 => JP.DynamicImage -> Maybe (Image S cs e)-fromDynamicImage jpDynImg =-  case jpDynImg of-    JP.ImageY8 jimg -> do-      Refl <- eqT :: Maybe (Pixel cs e :~: Pixel Y Word8)-      fromJPImageUnsafe jimg-    JP.ImageY16 jimg -> do-      Refl <- eqT :: Maybe (Pixel cs e :~: Pixel Y Word16)-      fromJPImageUnsafe jimg-#if MIN_VERSION_JuicyPixels(3,3,0)-    JP.ImageY32 jimg -> do-      Refl <- eqT :: Maybe (Pixel cs e :~: Pixel Y Word32)-      fromJPImageUnsafe jimg-#endif-    JP.ImageYF jimg -> do-      Refl <- eqT :: Maybe (Pixel cs e :~: Pixel Y Float)-      fromJPImageUnsafe jimg-    JP.ImageYA8 jimg -> do-      Refl <- eqT :: Maybe (Pixel cs e :~: Pixel YA Word8)-      fromJPImageUnsafe jimg-    JP.ImageYA16 jimg -> do-      Refl <- eqT :: Maybe (Pixel cs e :~: Pixel YA Word16)-      fromJPImageUnsafe jimg-    JP.ImageRGB8 jimg -> do-      Refl <- eqT :: Maybe (Pixel cs e :~: Pixel RGB Word8)-      fromJPImageUnsafe jimg-    JP.ImageRGB16 jimg -> do-      Refl <- eqT :: Maybe (Pixel cs e :~: Pixel RGB Word16)-      fromJPImageUnsafe jimg-    JP.ImageRGBF jimg -> do-      Refl <- eqT :: Maybe (Pixel cs e :~: Pixel RGB Float)-      fromJPImageUnsafe jimg-    JP.ImageRGBA8 jimg -> do-      Refl <- eqT :: Maybe (Pixel cs e :~: Pixel RGBA Word8)-      fromJPImageUnsafe jimg-    JP.ImageRGBA16 jimg -> do-      Refl <- eqT :: Maybe (Pixel cs e :~: Pixel RGBA Word16)-      fromJPImageUnsafe jimg-    JP.ImageYCbCr8 jimg -> do-      Refl <- eqT :: Maybe (Pixel cs e :~: Pixel YCbCr Word8)-      fromJPImageUnsafe jimg-    JP.ImageCMYK8 jimg -> do-      Refl <- eqT :: Maybe (Pixel cs e :~: Pixel CMYK Word8)-      fromJPImageUnsafe jimg-    JP.ImageCMYK16 jimg -> do-      Refl <- eqT :: Maybe (Pixel cs e :~: Pixel CMYK Word16)-      fromJPImageUnsafe jimg----fromAnyDynamicImage :: (Mutable r Ix2 (Pixel cs e), ColorSpace cs e) =>-                       JP.DynamicImage -> Maybe (Image r cs e)-fromAnyDynamicImage jpDynImg =-  case jpDynImg of-    JP.ImageY8 jimg     -> (fromJPImageUnsafe jimg :: Maybe (Image S Y Word8))     >>= toAnyCS-    JP.ImageY16 jimg    -> (fromJPImageUnsafe jimg :: Maybe (Image S Y Word16))    >>= toAnyCS-#if MIN_VERSION_JuicyPixels(3,3,0)-    JP.ImageY32 jimg    -> (fromJPImageUnsafe jimg :: Maybe (Image S Y Word32))    >>= toAnyCS-#endif-    JP.ImageYF jimg     -> (fromJPImageUnsafe jimg :: Maybe (Image S Y Float))     >>= toAnyCS-    JP.ImageYA8 jimg    -> (fromJPImageUnsafe jimg :: Maybe (Image S YA Word8))    >>= toAnyCS-    JP.ImageYA16 jimg   -> (fromJPImageUnsafe jimg :: Maybe (Image S YA Word16))   >>= toAnyCS-    JP.ImageRGB8 jimg   -> (fromJPImageUnsafe jimg :: Maybe (Image S RGB Word8))   >>= toAnyCS-    JP.ImageRGB16 jimg  -> (fromJPImageUnsafe jimg :: Maybe (Image S RGB Word16))  >>= toAnyCS-    JP.ImageRGBF jimg   -> (fromJPImageUnsafe jimg :: Maybe (Image S RGB Float))   >>= toAnyCS-    JP.ImageRGBA8 jimg  -> (fromJPImageUnsafe jimg :: Maybe (Image S RGBA Word8))  >>= toAnyCS-    JP.ImageRGBA16 jimg -> (fromJPImageUnsafe jimg :: Maybe (Image S RGBA Word16)) >>= toAnyCS-    JP.ImageYCbCr8 jimg -> (fromJPImageUnsafe jimg :: Maybe (Image S YCbCr Word8)) >>= toAnyCS-    JP.ImageCMYK8 jimg  -> (fromJPImageUnsafe jimg :: Maybe (Image S CMYK Word8))  >>= toAnyCS-    JP.ImageCMYK16 jimg -> (fromJPImageUnsafe jimg :: Maybe (Image S CMYK Word16)) >>= toAnyCS---toAnyCS-  :: forall r' cs' e' r cs e.-     ( Source r' Ix2 (Pixel cs' e')-     , Mutable r Ix2 (Pixel cs e)-     , ColorSpace cs e-     , ToYA cs' e'-     , ToRGBA cs' e'-     , ToHSIA cs' e'-     , ToCMYKA cs' e'-     , ToYCbCrA cs' e'-     )-  => Image r' cs' e' -> Maybe (Image r cs e)-toAnyCS img =-  msum-    [ (\Refl -> computeSource img) <$>-      (eqT :: Maybe (Pixel cs' e' :~: Pixel cs e))-    , do Refl <- eqT :: Maybe (cs :~: Y)-         compute <$> elevate (M.map toPixelY img)-    , do Refl <- eqT :: Maybe (cs :~: YA)-         compute <$> elevate (M.map toPixelYA img)-    , do Refl <- eqT :: Maybe (cs :~: RGB)-         compute <$> elevate (M.map toPixelRGB img)-    , do Refl <- eqT :: Maybe (cs :~: RGBA)-         compute <$> elevate (M.map toPixelRGBA img)-    , do Refl <- eqT :: Maybe (cs :~: HSI)-         compute <$> elevate (M.map toPixelHSI img)-    , do Refl <- eqT :: Maybe (cs :~: HSIA)-         compute <$> elevate (M.map toPixelHSIA img)-    , do Refl <- eqT :: Maybe (cs :~: CMYK)-         compute <$> elevate (M.map toPixelCMYK img)-    , do Refl <- eqT :: Maybe (cs :~: CMYKA)-         compute <$> elevate (M.map toPixelCMYKA img)-    , do Refl <- eqT :: Maybe (cs :~: YCbCr)-         compute <$> elevate (M.map toPixelYCbCr img)-    , do Refl <- eqT :: Maybe (cs :~: YCbCrA)-         compute <$> elevate (M.map toPixelYCbCrA img)-    , do Refl <- eqT :: Maybe (Pixel cs e :~: Pixel X Bit)-         return $ compute $ M.map toPixelBinary img-    ]----showJP :: JP.DynamicImage -> String-showJP (JP.ImageY8     _) = "Image S Y Word8"-showJP (JP.ImageY16    _) = "Image S Y Word16"-#if MIN_VERSION_JuicyPixels(3,3,0)-showJP (JP.ImageY32    _) = "Image S Y Word32"-#endif-showJP (JP.ImageYF     _) = "Image S Y Float"-showJP (JP.ImageYA8    _) = "Image S YA Word8"-showJP (JP.ImageYA16   _) = "Image S YA Word16"-showJP (JP.ImageRGB8   _) = "Image S RGB Word8"-showJP (JP.ImageRGB16  _) = "Image S RGB Word16"-showJP (JP.ImageRGBF   _) = "Image S RGB Float"-showJP (JP.ImageRGBA8  _) = "Image S RGBA Word8"-showJP (JP.ImageRGBA16 _) = "Image S RGBA Word16"-showJP (JP.ImageYCbCr8 _) = "Image S YCbCr Word8"-showJP (JP.ImageCMYK8  _) = "Image S CMYK Word8"-showJP (JP.ImageCMYK16 _) = "Image S CMYK Word16"----- Encoding--toJPImageUnsafe-  :: forall r cs a . (JP.Pixel a, Source r Ix2 (Pixel cs (JP.PixelBaseComponent a)),-                      ColorSpace cs (JP.PixelBaseComponent a))-  => Image r cs (JP.PixelBaseComponent a)-  -> JP.Image a-toJPImageUnsafe img = JP.Image n m $ V.unsafeCast $ toVector arrS where-  !arrS = computeSource img :: Image S cs (JP.PixelBaseComponent a)-  Sz (m :. n) = size img-{-# INLINE toJPImageUnsafe #-}--toJPImageY8 :: Source r Ix2 (Pixel Y Word8) => Image r Y Word8 -> JP.Image TypesJP.Pixel8-toJPImageY8 = toJPImageUnsafe-{-# INLINE toJPImageY8 #-}--toJPImageY16 :: Source r Ix2 (Pixel Y Word16) => Image r Y Word16 -> JP.Image TypesJP.Pixel16-toJPImageY16 = toJPImageUnsafe-{-# INLINE toJPImageY16 #-}--#if MIN_VERSION_JuicyPixels(3,3,0)-toJPImageY32 :: Source r Ix2 (Pixel Y Word32) => Image r Y Word32 -> JP.Image TypesJP.Pixel32-toJPImageY32 = toJPImageUnsafe-{-# INLINE toJPImageY32 #-}-#endif--toJPImageYA8 :: Source r Ix2 (Pixel YA Word8) => Image r YA Word8 -> JP.Image JP.PixelYA8-toJPImageYA8 = toJPImageUnsafe-{-# INLINE toJPImageYA8 #-}--toJPImageYA16 :: Source r Ix2 (Pixel YA Word16) => Image r YA Word16 -> JP.Image JP.PixelYA16-toJPImageYA16 = toJPImageUnsafe-{-# INLINE toJPImageYA16 #-}--toJPImageYF :: Source r Ix2 (Pixel Y Float) => Image r Y Float -> JP.Image JP.PixelF-toJPImageYF = toJPImageUnsafe-{-# INLINE toJPImageYF #-}--toJPImageRGB8 :: Source r Ix2 (Pixel RGB Word8) => Image r RGB Word8 -> JP.Image JP.PixelRGB8-toJPImageRGB8 = toJPImageUnsafe-{-# INLINE toJPImageRGB8 #-}--toJPImageRGBA8 :: Source r Ix2 (Pixel RGBA Word8) => Image r RGBA Word8 -> JP.Image JP.PixelRGBA8-toJPImageRGBA8 = toJPImageUnsafe-{-# INLINE toJPImageRGBA8 #-}--toJPImageRGB16 :: Source r Ix2 (Pixel RGB Word16) => Image r RGB Word16 -> JP.Image JP.PixelRGB16-toJPImageRGB16 = toJPImageUnsafe-{-# INLINE toJPImageRGB16 #-}--toJPImageRGBA16 :: Source r Ix2 (Pixel RGBA Word16) => Image r RGBA Word16 -> JP.Image JP.PixelRGBA16-toJPImageRGBA16 = toJPImageUnsafe-{-# INLINE toJPImageRGBA16 #-}--toJPImageRGBF :: Source r Ix2 (Pixel RGB Float) => Image r RGB Float -> JP.Image JP.PixelRGBF-toJPImageRGBF = toJPImageUnsafe-{-# INLINE toJPImageRGBF #-}--toJPImageYCbCr8 :: Source r Ix2 (Pixel YCbCr Word8) => Image r YCbCr Word8 -> JP.Image JP.PixelYCbCr8-toJPImageYCbCr8 = toJPImageUnsafe-{-# INLINE toJPImageYCbCr8 #-}--toJPImageCMYK8 :: Source r Ix2 (Pixel CMYK Word8) => Image r CMYK Word8 -> JP.Image JP.PixelCMYK8-toJPImageCMYK8 = toJPImageUnsafe-{-# INLINE toJPImageCMYK8 #-}--toJPImageCMYK16 :: Source r Ix2 (Pixel CMYK Word16) => Image r CMYK Word16 -> JP.Image JP.PixelCMYK16-toJPImageCMYK16 = toJPImageUnsafe-{-# INLINE toJPImageCMYK16 #-}------- General decoding and helper functions--fromJPImageUnsafe :: forall jpx cs e . (Storable (Pixel cs e), Storable e, JP.Pixel jpx) =>-                     JP.Image jpx -> Maybe (Image S cs e)-fromJPImageUnsafe (JP.Image n m !v) = do-  let numberOfComponentsFromSize = sizeOf (undefined :: Pixel cs e) `div` sizeOf (undefined :: e)-      numComponentsPerPixel = JP.componentCount (undefined :: jpx)-  unless (numComponentsPerPixel == numberOfComponentsFromSize) $-    error $-    concat-      [ "Mismatched sizes beteen JuicyPixels: "-      , show numComponentsPerPixel-      , " and massiv: "-      , show numberOfComponentsFromSize-      ]-  guard (n * m * numComponentsPerPixel == V.length v)-  fromVectorM Par (Sz (m :. n)) $ V.unsafeCast v-{-# INLINE fromJPImageUnsafe #-}-+-- |+-- Module      : Data.Massiv.Array.IO.Image.JuicyPixels+-- Copyright   : (c) Alexey Kuleshevich 2018-2021+-- License     : BSD3+-- Maintainer  : Alexey Kuleshevich <lehins@yandex.ru>+-- Stability   : experimental+-- Portability : non-portable+--+module Data.Massiv.Array.IO.Image.JuicyPixels+  ( -- * JuicyPixels formats+    -- ** BMP+    module BMP+    -- ** GIF+  , module GIF+    -- ** HDR+  , module HDR+    -- ** JPG+  , module JPG+    -- ** PNG+  , module PNG+    -- ** TGA+  , module TGA+    -- ** TIF+  , module TIF+    -- ** JuicyPixels conversion+  , toJPImageY8+  , toJPImageY16+  , toJPImageY32+  , toJPImageYA8+  , toJPImageYA16+  , toJPImageYF+  , toJPImageRGB8+  , toJPImageRGB16+  , toJPImageRGBA8+  , toJPImageRGBA16+  , toJPImageRGBF+  , toJPImageYCbCr8+  , toJPImageCMYK8+  , toJPImageCMYK16+  , fromDynamicImage+  , fromDynamicImageM+  , fromDynamicImageAuto+  ) where++import Data.Massiv.Array.IO.Image.JuicyPixels.Base+import Data.Massiv.Array.IO.Image.JuicyPixels.BMP as BMP+import Data.Massiv.Array.IO.Image.JuicyPixels.GIF as GIF+import Data.Massiv.Array.IO.Image.JuicyPixels.HDR as HDR+import Data.Massiv.Array.IO.Image.JuicyPixels.JPG as JPG+import Data.Massiv.Array.IO.Image.JuicyPixels.PNG as PNG+import Data.Massiv.Array.IO.Image.JuicyPixels.TGA as TGA+import Data.Massiv.Array.IO.Image.JuicyPixels.TIF as TIF
+ src/Data/Massiv/Array/IO/Image/JuicyPixels/BMP.hs view
@@ -0,0 +1,214 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+-- |+-- Module      : Data.Massiv.Array.IO.Image.JuicyPixels.BMP+-- Copyright   : (c) Alexey Kuleshevich 2019-2021+-- License     : BSD3+-- Maintainer  : Alexey Kuleshevich <lehins@yandex.ru>+-- Stability   : experimental+-- Portability : non-portable+--+module Data.Massiv.Array.IO.Image.JuicyPixels.BMP+  ( BMP(..)+  , BitmapOptions(..)+  , decodeBMP+  , decodeWithMetadataBMP+  , decodeAutoBMP+  , decodeAutoWithMetadataBMP+  , encodeBMP+  , encodeAutoBMP+  ) where++import qualified Codec.Picture as JP+import qualified Codec.Picture.Bitmap as JP+import qualified Codec.Picture.Metadata as JP+import Control.Monad (msum)+import Data.Bifunctor (first)+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL (ByteString)+import Data.Massiv.Array as A+import Data.Massiv.Array.IO.Base+import Data.Massiv.Array.IO.Image.JuicyPixels.Base+import Data.Maybe (fromMaybe)+import Data.Typeable+import qualified Graphics.Pixel as CM+import Graphics.Pixel.ColorSpace+import Prelude as P++--------------------------------------------------------------------------------+-- BMP Format ------------------------------------------------------------------+--------------------------------------------------------------------------------++newtype BitmapOptions = BitmapOptions+  { bitmapMetadata :: JP.Metadatas+  } deriving (Show)++instance Default BitmapOptions where+  def = BitmapOptions mempty++-- | Bitmap image with @.bmp@ extension.+data BMP = BMP deriving Show++instance FileFormat BMP where+  type WriteOptions BMP = BitmapOptions+  type Metadata BMP = JP.Metadatas++  ext _ = ".bmp"++instance Writable BMP (Image A.S CM.X Bit) where+  encodeM f opts img = encodeM f opts (coerceBinaryImage img)++instance Writable BMP (Image S CM.X Word8) where+  encodeM BMP BitmapOptions {bitmapMetadata} =+    pure . JP.encodeBitmapWithMetadata bitmapMetadata . toJPImageY8++instance Writable BMP (Image S CM.RGB Word8) where+  encodeM BMP BitmapOptions {bitmapMetadata} =+    pure . JP.encodeBitmapWithMetadata bitmapMetadata . toJPImageRGB8++instance Writable BMP (Image S (Alpha CM.RGB) Word8) where+  encodeM BMP BitmapOptions {bitmapMetadata} =+    pure . JP.encodeBitmapWithMetadata bitmapMetadata . toJPImageRGBA8+++instance Writable BMP (Image S (Y' SRGB) Word8) where+  encodeM f opts = encodeM f opts . toImageBaseModel++instance Writable BMP (Image S (Y D65) Word8) where+  encodeM f opts = encodeM f opts . toImageBaseModel++instance Writable BMP (Image S (SRGB 'NonLinear) Word8) where+  encodeM f opts = encodeM f opts . toImageBaseModel++instance Writable BMP (Image S (Alpha (SRGB 'NonLinear)) Word8) where+  encodeM f opts = encodeM f opts . toImageBaseModel++instance (ColorSpace cs i e, ColorSpace (BaseSpace cs) i e, Source r (Pixel cs e)) =>+         Writable (Auto BMP) (Image r cs e) where+  encodeM f opts = pure . encodeAutoBMP f opts++instance Readable BMP (Image S CM.X Word8) where+  decodeWithMetadataM = decodeWithMetadataBMP++instance Readable BMP (Image S CM.RGB Word8) where+  decodeWithMetadataM = decodeWithMetadataBMP++instance Readable BMP (Image S (Alpha CM.RGB) Word8) where+  decodeWithMetadataM = decodeWithMetadataBMP++instance Readable BMP (Image S (Y' SRGB) Word8) where+  decodeWithMetadataM f = fmap (first fromImageBaseModel) . decodeWithMetadataM f++instance Readable BMP (Image S (Y D65) Word8) where+  decodeWithMetadataM f = fmap (first fromImageBaseModel) . decodeWithMetadataM f++instance Readable BMP (Image S (SRGB 'NonLinear) Word8) where+  decodeWithMetadataM f = fmap (first fromImageBaseModel) . decodeWithMetadataM f++instance Readable BMP (Image S (Alpha (SRGB 'NonLinear)) Word8) where+  decodeWithMetadataM f = fmap (first fromImageBaseModel) . decodeWithMetadataM f++-- | Decode a Bitmap Image+decodeBMP :: (ColorModel cs e, MonadThrow m) => BMP -> B.ByteString -> m (Image S cs e)+decodeBMP f bs = convertWith f (JP.decodeBitmap bs)+{-# INLINE decodeBMP #-}++-- | Decode a Bitmap Image+decodeWithMetadataBMP ::+     (ColorModel cs e, MonadThrow m) => BMP -> B.ByteString -> m (Image S cs e, JP.Metadatas)+decodeWithMetadataBMP f bs = convertWithMetadata f (JP.decodeBitmapWithMetadata bs)+{-# INLINE decodeWithMetadataBMP #-}++-- | Decode a Bitmap Image+decodeAutoBMP ::+     (Manifest r (Pixel cs e), ColorSpace cs i e, MonadThrow m)+  => Auto BMP+  -> B.ByteString+  -> m (Image r cs e)+decodeAutoBMP f bs = convertAutoWith f (JP.decodeBitmap bs)+{-# INLINE decodeAutoBMP #-}++-- | Decode a Bitmap Image+decodeAutoWithMetadataBMP ::+     (Manifest r (Pixel cs e), ColorSpace cs i e, MonadThrow m)+  => Auto BMP+  -> B.ByteString+  -> m (Image r cs e, JP.Metadatas)+decodeAutoWithMetadataBMP f bs = convertAutoWithMetadata f (JP.decodeBitmapWithMetadata bs)+{-# INLINE decodeAutoWithMetadataBMP #-}++instance (Manifest r (Pixel cs e), ColorSpace cs i e) =>+         Readable (Auto BMP) (Image r cs e) where+  decodeM = decodeAutoBMP+  decodeWithMetadataM = decodeAutoWithMetadataBMP++encodeBMP ::+     forall cs e m. (ColorModel cs e, MonadThrow m)+  => BMP+  -> BitmapOptions+  -> Image S cs e+  -> m BL.ByteString+encodeBMP f opts@BitmapOptions {bitmapMetadata} img =+  fromMaybeEncode f (Proxy :: Proxy (Image S cs e)) encoded+  where+    encoded+      | Just Refl <- eqT :: Maybe (Pixel cs e :~: Pixel CM.X Bit) = encodeM BMP opts img+      | Just Refl <- eqT :: Maybe (e :~: Word8) = do+        msum+          [ JP.encodeBitmapWithMetadata bitmapMetadata <$> maybeJPImageY8 img+          , JP.encodeBitmapWithMetadata bitmapMetadata <$> maybeJPImageRGB8 img+          , do Refl <- eqT :: Maybe (cs :~: Alpha (Opaque cs))+               JP.encodeBitmapWithMetadata bitmapMetadata <$> maybeJPImageRGBA8 img+          ]+      | otherwise = Nothing++++encodeAutoBMP ::+     forall r cs i e.+     (ColorSpace (BaseSpace cs) i e, ColorSpace cs i e, Source r (Pixel cs e))+  => Auto BMP+  -> BitmapOptions+  -> Image r cs e+  -> BL.ByteString+encodeAutoBMP _ BitmapOptions {bitmapMetadata} img =+  fromMaybe (toBitmap toJPImageRGB8 toSRGB8 img) $+  msum+    [ do Refl <- eqT :: Maybe (r :~: S)+         case eqT :: Maybe (e :~: Word8) of+           Just Refl+             | Just Refl <- (eqT :: Maybe (BaseModel cs :~: CM.X)) ->+               pure $+               JP.encodeBitmapWithMetadata bitmapMetadata $ toJPImageY8 (toImageBaseModel img)+             | Just Refl <- (eqT :: Maybe (BaseModel cs :~: CM.RGB)) ->+               pure $+               JP.encodeBitmapWithMetadata bitmapMetadata $ toJPImageRGB8 (toImageBaseModel img)+             | Just Refl <- (eqT :: Maybe (BaseModel cs :~: Alpha CM.RGB)) ->+               pure $+               JP.encodeBitmapWithMetadata bitmapMetadata $ toJPImageRGBA8 (toImageBaseModel img)+           _ -> Nothing+    , do Refl <- eqT :: Maybe (BaseModel cs :~: CM.X)+         msum+           [ do Refl <- eqT :: Maybe (e :~: Bit)+                pure $ toBitmap toJPImageY8 (toPixel8 . toPixelBaseModel) img+           , pure $ toBitmap toJPImageY8 (toPixel8 . toPixelBaseModel) img+           ]+    , do Refl <- eqT :: Maybe (cs :~: Alpha (Opaque cs))+         pure $ toBitmap toJPImageRGBA8 toSRGBA8 img+    ]+  where+    toBitmap ::+         (JP.BmpEncodable px, Source r a, Index ix)+      => (Array D ix b -> JP.Image px)+      -> (a -> b)+      -> Array r ix a+      -> BL.ByteString+    toBitmap toJP adjustPixel =+      JP.encodeBitmapWithMetadata bitmapMetadata . toJP . A.map adjustPixel
+ src/Data/Massiv/Array/IO/Image/JuicyPixels/Base.hs view
@@ -0,0 +1,668 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+-- |+-- Module      : Data.Massiv.Array.IO.Image.JuicyPixels.Base+-- Copyright   : (c) Alexey Kuleshevich 2019-2021+-- License     : BSD3+-- Maintainer  : Alexey Kuleshevich <lehins@yandex.ru>+-- Stability   : experimental+-- Portability : non-portable+--+module Data.Massiv.Array.IO.Image.JuicyPixels.Base+  ( showJP+  , convertWith+  , convertWithMetadata+  , convertAutoWith+  , convertAutoWithMetadata+  , convertSequenceWith+  , convertAutoSequenceWith+  , toJPImageY8+  , toJPImageY16+  , toJPImageY32+  , toJPImageYA8+  , toJPImageYA16+  , toJPImageYF+  , toJPImageRGB8+  , toJPImageRGB16+  , toJPImageRGBA8+  , toJPImageRGBA16+  , toJPImageRGBF+  , toJPImageYCbCr8+  , toJPImageCMYK8+  , toJPImageCMYK16+  , maybeJPImageY8+  , maybeJPImageY16+  , maybeJPImageY32+  , maybeJPImageYA8+  , maybeJPImageYA16+  , maybeJPImageYF+  , maybeJPImageRGB8+  , maybeJPImageRGB16+  , maybeJPImageRGBA8+  , maybeJPImageRGBA16+  , maybeJPImageRGBF+  , maybeJPImageYCbCr8+  , maybeJPImageCMYK8+  , maybeJPImageCMYK16+  , fromDynamicImage+  , fromDynamicImageM+  , fromDynamicImageAuto+  -- * Conversion to sRGB+  , toYCbCr8+  , toCMYK8+  , toCMYK16+  , toSRGB8+  , toSRGB16+  , toSRGBA8+  , toSRGBA16+  ) where++import qualified Codec.Picture as JP+import Control.Exception (assert)+import Control.Monad (msum, unless)+import Data.Massiv.Array as A+import Data.Massiv.Array.IO.Base+import Data.Typeable+import qualified Data.Vector.Storable as V+import Foreign.Storable (Storable(sizeOf))+import qualified Graphics.Pixel as CM+import Graphics.Pixel.ColorSpace+import Prelude as P++--------------------------------------------------------------------------------+-- Common JuciyPixels encoding/decoding functions ------------------------------+--------------------------------------------------------------------------------++convertWith ::+     (MonadThrow m, ColorModel cs e, FileFormat f)+  => f+  -> Either String JP.DynamicImage+  -> m (Image S cs e)+convertWith f = either (throwM . DecodeError) (fromMaybeDecodeM f showJP fromDynamicImageM)+++convertWithMetadata ::+     (MonadThrow m, ColorModel cs e, FileFormat f)+  => f+  -> Either String (JP.DynamicImage, Metadata f)+  -> m (Image S cs e, Metadata f)+convertWithMetadata f decoded =+  case decoded of+    Left err -> throwM $ DecodeError err+    Right (jp, meta) -> do+      i <- fromMaybeDecodeM f showJP fromDynamicImageM jp+      pure (i, meta)++convertAutoWithMetadata ::+     (MonadThrow m, Manifest r (Pixel cs e), ColorSpace cs i e)+  => Auto f+  -> Either String (JP.DynamicImage, Metadata f)+  -> m (Image r cs e, Metadata f)+convertAutoWithMetadata _ decoded =+  case decoded of+    Left err -> throwM $ DecodeError err+    Right (jp, meta) -> do+      i <- fromDynamicImageAuto jp+      pure (i, meta)++convertAutoWith ::+     (MonadThrow m, Manifest r (Pixel cs e), ColorSpace cs i e)+  => Auto f+  -> Either String JP.DynamicImage+  -> m (Image r cs e)+convertAutoWith _ = either (throwM . DecodeError) fromDynamicImageAuto+{-# INLINE convertAutoWith #-}++convertSequenceWith ::+     (MonadThrow m, ColorModel cs e, FileFormat (Sequence f))+  => Sequence f+  -> Either String [JP.DynamicImage]+  -> m [Image S cs e]+convertSequenceWith f ejpImgs = do+  jpImgs <- decodeError ejpImgs+  P.traverse (fromMaybeDecodeM f showJP fromDynamicImageM) jpImgs+++convertAutoSequenceWith ::+     (MonadThrow m, Manifest r (Pixel cs e), ColorSpace cs i e)+  => Auto (Sequence f)+  -> Either String [JP.DynamicImage]+  -> m [Image r cs e]+convertAutoSequenceWith _ ejpImgs = do+  jpImgs <- decodeError ejpImgs+  P.traverse fromDynamicImageAuto jpImgs+++fromDynamicImageM ::+     forall cs e m. (ColorModel cs e, MonadThrow m)+  => JP.DynamicImage+  -> m (Maybe (Image S cs e))+fromDynamicImageM jpDynImg =+  case jpDynImg of+    JP.ImageY8 jimg+      | Just Refl <- (eqT :: Maybe (Pixel cs e :~: Pixel (Y' SRGB) Word8)) -> justFromJP jimg+      | Just Refl <- (eqT :: Maybe (Pixel cs e :~: Pixel (Y D65) Word8)) -> justFromJP jimg+      | Just Refl <- (eqT :: Maybe (Pixel cs e :~: Pixel CM.X Word8)) -> justFromJP jimg+      | otherwise -> pure Nothing+    JP.ImageY16 jimg+      | Just Refl <- (eqT :: Maybe (Pixel cs e :~: Pixel (Y' SRGB) Word16)) -> justFromJP jimg+      | Just Refl <- (eqT :: Maybe (Pixel cs e :~: Pixel (Y D65) Word16)) -> justFromJP jimg+      | Just Refl <- (eqT :: Maybe (Pixel cs e :~: Pixel CM.X Word16)) -> justFromJP jimg+      | otherwise -> pure Nothing+    JP.ImageY32 jimg+      | Just Refl <- (eqT :: Maybe (Pixel cs e :~: Pixel (Y' SRGB) Word32)) -> justFromJP jimg+      | Just Refl <- (eqT :: Maybe (Pixel cs e :~: Pixel (Y D65) Word32)) -> justFromJP jimg+      | Just Refl <- (eqT :: Maybe (Pixel cs e :~: Pixel CM.X Word32)) -> justFromJP jimg+      | otherwise -> pure Nothing+    JP.ImageYF jimg+      | Just Refl <- (eqT :: Maybe (Pixel cs e :~: Pixel (Y' SRGB) Float)) -> justFromJP jimg+      | Just Refl <- (eqT :: Maybe (Pixel cs e :~: Pixel (Y D65) Float)) -> justFromJP jimg+      | Just Refl <- (eqT :: Maybe (Pixel cs e :~: Pixel CM.X Float)) -> justFromJP jimg+      | otherwise -> pure Nothing+    JP.ImageYA8 jimg+      | Just Refl <- (eqT :: Maybe (Pixel cs e :~: Pixel (Alpha (Y' SRGB)) Word8)) -> justFromJP jimg+      | Just Refl <- (eqT :: Maybe (Pixel cs e :~: Pixel (Alpha (Y D65)) Word8)) -> justFromJP jimg+      | Just Refl <- (eqT :: Maybe (Pixel cs e :~: Pixel (Alpha CM.X) Word8)) -> justFromJP jimg+      | otherwise -> pure Nothing+    JP.ImageYA16 jimg+      | Just Refl <- (eqT :: Maybe (Pixel cs e :~: Pixel (Alpha (Y' SRGB)) Word16)) -> justFromJP jimg+      | Just Refl <- (eqT :: Maybe (Pixel cs e :~: Pixel (Alpha (Y D65)) Word16)) -> justFromJP jimg+      | Just Refl <- (eqT :: Maybe (Pixel cs e :~: Pixel (Alpha CM.X) Word16)) -> justFromJP jimg+      | otherwise -> pure Nothing+    JP.ImageRGB8 jimg+      | Just Refl <- (eqT :: Maybe (Pixel cs e :~: Pixel (SRGB 'NonLinear) Word8)) -> justFromJP jimg+      | Just Refl <- (eqT :: Maybe (Pixel cs e :~: Pixel (AdobeRGB 'NonLinear) Word8)) ->+        justFromJP jimg+      | Just Refl <- (eqT :: Maybe (Pixel cs e :~: Pixel CM.RGB Word8)) -> justFromJP jimg+      | otherwise -> pure Nothing+    JP.ImageRGB16 jimg+      | Just Refl <- (eqT :: Maybe (Pixel cs e :~: Pixel (SRGB 'NonLinear) Word16)) -> justFromJP jimg+      | Just Refl <- (eqT :: Maybe (Pixel cs e :~: Pixel (AdobeRGB 'NonLinear) Word16)) ->+        justFromJP jimg+      | Just Refl <- (eqT :: Maybe (Pixel cs e :~: Pixel CM.RGB Word16)) -> justFromJP jimg+      | otherwise -> pure Nothing+    JP.ImageRGBF jimg+      | Just Refl <- (eqT :: Maybe (Pixel cs e :~: Pixel (SRGB 'NonLinear) Float)) -> justFromJP jimg+      | Just Refl <- (eqT :: Maybe (Pixel cs e :~: Pixel (AdobeRGB 'NonLinear) Float)) ->+        justFromJP jimg+      | Just Refl <- (eqT :: Maybe (Pixel cs e :~: Pixel CM.RGB Float)) -> justFromJP jimg+      | otherwise -> pure Nothing+    JP.ImageRGBA8 jimg+      | Just Refl <- (eqT :: Maybe (Pixel cs e :~: Pixel (Alpha (SRGB 'NonLinear)) Word8)) ->+        justFromJP jimg+      | Just Refl <- (eqT :: Maybe (Pixel cs e :~: Pixel (Alpha (AdobeRGB 'NonLinear)) Word8)) ->+        justFromJP jimg+      | Just Refl <- (eqT :: Maybe (Pixel cs e :~: Pixel (Alpha CM.RGB) Word8)) -> justFromJP jimg+      | otherwise -> pure Nothing+    JP.ImageRGBA16 jimg+      | Just Refl <- (eqT :: Maybe (Pixel cs e :~: Pixel (Alpha (SRGB 'NonLinear)) Word16)) ->+        justFromJP jimg+      | Just Refl <- (eqT :: Maybe (Pixel cs e :~: Pixel (Alpha (AdobeRGB 'NonLinear)) Word16)) ->+        justFromJP jimg+      | Just Refl <- (eqT :: Maybe (Pixel cs e :~: Pixel (Alpha CM.RGB) Word16)) -> justFromJP jimg+      | otherwise -> pure Nothing+    JP.ImageYCbCr8 jimg+      | Just Refl <- (eqT :: Maybe (Pixel cs e :~: Pixel (Y'CbCr SRGB) Word8)) -> justFromJP jimg+      | Just Refl <- (eqT :: Maybe (Pixel cs e :~: Pixel (Y'CbCr AdobeRGB) Word8)) -> justFromJP jimg+      | Just Refl <- (eqT :: Maybe (Pixel cs e :~: Pixel CM.YCbCr Word8)) -> justFromJP jimg+      | otherwise -> pure Nothing+    JP.ImageCMYK8 jimg+      | Just Refl <- (eqT :: Maybe (Pixel cs e :~: Pixel (CMYK (SRGB 'NonLinear)) Word8)) ->+        justFromJP jimg+      | Just Refl <- (eqT :: Maybe (Pixel cs e :~: Pixel (CMYK (AdobeRGB 'NonLinear)) Word8)) ->+        justFromJP jimg+      | Just Refl <- (eqT :: Maybe (Pixel cs e :~: Pixel CM.CMYK Word8)) -> justFromJP jimg+      | otherwise -> pure Nothing+    JP.ImageCMYK16 jimg+      | Just Refl <- (eqT :: Maybe (Pixel cs e :~: Pixel (CMYK (SRGB 'NonLinear)) Word16)) ->+        justFromJP jimg+      | Just Refl <- (eqT :: Maybe (Pixel cs e :~: Pixel (CMYK (AdobeRGB 'NonLinear)) Word16)) ->+        justFromJP jimg+      | Just Refl <- (eqT :: Maybe (Pixel cs e :~: Pixel CM.CMYK Word16)) -> justFromJP jimg+      | otherwise -> pure Nothing+  where+    justFromJP :: JP.Pixel px => JP.Image px -> m (Maybe (Image S cs e))+    justFromJP = fmap Just . fromJPImageUnsafeM++fromDynamicImage ::+     forall cs e. ColorModel cs e+  => JP.DynamicImage+  -> Maybe (Image S cs e)+fromDynamicImage jpDynImg =+  case jpDynImg of+    JP.ImageY8 jimg -> do+      Refl <- eqT :: Maybe (Pixel cs e :~: Pixel CM.X Word8)+      fromJPImageUnsafeM jimg+    JP.ImageY16 jimg -> do+      Refl <- eqT :: Maybe (Pixel cs e :~: Pixel CM.X Word16)+      fromJPImageUnsafeM jimg+    JP.ImageY32 jimg -> do+      Refl <- eqT :: Maybe (Pixel cs e :~: Pixel CM.X Word32)+      fromJPImageUnsafeM jimg+    JP.ImageYF jimg -> do+      Refl <- eqT :: Maybe (Pixel cs e :~: Pixel CM.X Float)+      fromJPImageUnsafeM jimg+    JP.ImageYA8 jimg -> do+      Refl <- eqT :: Maybe (Pixel cs e :~: Pixel (Alpha CM.X) Word8)+      fromJPImageUnsafeM jimg+    JP.ImageYA16 jimg -> do+      Refl <- eqT :: Maybe (Pixel cs e :~: Pixel (Alpha CM.X) Word16)+      fromJPImageUnsafeM jimg+    JP.ImageRGB8 jimg -> do+      Refl <- eqT :: Maybe (Pixel cs e :~: Pixel CM.RGB Word8)+      fromJPImageUnsafeM jimg+    JP.ImageRGB16 jimg -> do+      Refl <- eqT :: Maybe (Pixel cs e :~: Pixel CM.RGB Word16)+      fromJPImageUnsafeM jimg+    JP.ImageRGBF jimg -> do+      Refl <- eqT :: Maybe (Pixel cs e :~: Pixel CM.RGB Float)+      fromJPImageUnsafeM jimg+    JP.ImageRGBA8 jimg -> do+      Refl <- eqT :: Maybe (Pixel cs e :~: Pixel (Alpha CM.RGB) Word8)+      fromJPImageUnsafeM jimg+    JP.ImageRGBA16 jimg -> do+      Refl <- eqT :: Maybe (Pixel cs e :~: Pixel (Alpha CM.RGB) Word16)+      fromJPImageUnsafeM jimg+    JP.ImageYCbCr8 jimg -> do+      Refl <- eqT :: Maybe (Pixel cs e :~: Pixel CM.YCbCr Word8)+      fromJPImageUnsafeM jimg+    JP.ImageCMYK8 jimg -> do+      Refl <- eqT :: Maybe (Pixel cs e :~: Pixel CM.CMYK Word8)+      fromJPImageUnsafeM jimg+    JP.ImageCMYK16 jimg -> do+      Refl <- eqT :: Maybe (Pixel cs e :~: Pixel CM.CMYK Word16)+      fromJPImageUnsafeM jimg+{-# DEPRECATED fromDynamicImage "In favor of `fromDynamicImageM`" #-}++fromDynamicImageAuto ::+     forall r cs i e m. (Manifest r (Pixel cs e), ColorSpace cs i e, MonadThrow m)+  => JP.DynamicImage+  -> m (Image r cs e)+fromDynamicImageAuto jpDynImg =+  case jpDynImg of+    JP.ImageY8 jimg ->+      convertImageM <$> (fromJPImageUnsafeM jimg :: m (Image S (Y D65) Word8))+    JP.ImageY16 jimg ->+      convertImageM <$> (fromJPImageUnsafeM jimg :: m (Image S (Y D65) Word16))+    JP.ImageY32 jimg ->+      convertImageM <$> (fromJPImageUnsafeM jimg :: m (Image S (Y D65) Word32))+    JP.ImageYF jimg ->+      convertImageM <$> (fromJPImageUnsafeM jimg :: m (Image S (Y D65) Float))+    JP.ImageYA8 jimg ->+      convertImageM <$> (fromJPImageUnsafeM jimg :: m (Image S (Alpha (Y D65)) Word8))+    JP.ImageYA16 jimg ->+      convertImageM <$> (fromJPImageUnsafeM jimg :: m (Image S (Alpha (Y D65)) Word16))+    JP.ImageRGB8 jimg ->+      convertImageM <$> (fromJPImageUnsafeM jimg :: m (Image S (SRGB 'NonLinear) Word8))+    JP.ImageRGB16 jimg ->+      convertImageM <$> (fromJPImageUnsafeM jimg :: m (Image S (SRGB 'NonLinear) Word16))+    JP.ImageRGBF jimg ->+      convertImageM <$> (fromJPImageUnsafeM jimg :: m (Image S (SRGB 'NonLinear) Float))+    JP.ImageRGBA8 jimg ->+      convertImageM <$>+      (fromJPImageUnsafeM jimg :: m (Image S (Alpha (SRGB 'NonLinear)) Word8))+    JP.ImageRGBA16 jimg ->+      convertImageM <$>+      (fromJPImageUnsafeM jimg :: m (Image S (Alpha (SRGB 'NonLinear)) Word16))+    JP.ImageYCbCr8 jimg ->+      convertImageM <$>+      (fromJPImageUnsafeM jimg :: m (Image S (Y'CbCr SRGB) Word8))+    JP.ImageCMYK8 jimg ->+      convertImageM <$>+      (fromJPImageUnsafeM jimg :: m (Image S (CMYK (SRGB 'NonLinear)) Word8))+    JP.ImageCMYK16 jimg ->+      convertImageM <$>+      (fromJPImageUnsafeM jimg :: m (Image S (CMYK (SRGB 'NonLinear)) Word16))+{-# INLINE fromDynamicImageAuto #-}+++showJP :: JP.DynamicImage -> String+showJP (JP.ImageY8     _) = "Image S Y Word8"+showJP (JP.ImageY16    _) = "Image S Y Word16"+showJP (JP.ImageY32    _) = "Image S Y Word32"+showJP (JP.ImageYF     _) = "Image S Y Float"+showJP (JP.ImageYA8    _) = "Image S YA Word8"+showJP (JP.ImageYA16   _) = "Image S YA Word16"+showJP (JP.ImageRGB8   _) = "Image S RGB Word8"+showJP (JP.ImageRGB16  _) = "Image S RGB Word16"+showJP (JP.ImageRGBF   _) = "Image S RGB Float"+showJP (JP.ImageRGBA8  _) = "Image S RGBA Word8"+showJP (JP.ImageRGBA16 _) = "Image S RGBA Word16"+showJP (JP.ImageYCbCr8 _) = "Image S YCbCr Word8"+showJP (JP.ImageCMYK8  _) = "Image S CMYK Word8"+showJP (JP.ImageCMYK16 _) = "Image S CMYK Word16"+++-- Encoding++toJPImageUnsafe ::+     forall r cs a.+     ( JP.Pixel a+     , Source r (Pixel cs (JP.PixelBaseComponent a))+     , ColorModel cs (JP.PixelBaseComponent a)+     )+  => Image r cs (JP.PixelBaseComponent a)+  -> JP.Image a+toJPImageUnsafe img = JP.Image n m $ V.unsafeCast $ toStorableVector arrS+  where+    !arrS = computeSource img :: Image S cs (JP.PixelBaseComponent a)+    Sz (m :. n) = size img+{-# INLINE toJPImageUnsafe #-}++toJPImageY8 :: Source r (Pixel CM.X Word8) => Image r CM.X Word8 -> JP.Image JP.Pixel8+toJPImageY8 = toJPImageUnsafe+{-# INLINE toJPImageY8 #-}++maybeJPImageY8 ::+     forall cs. (Typeable cs, Storable (Pixel cs Word8))+  => Image S cs Word8+  -> Maybe (JP.Image JP.Pixel8)+maybeJPImageY8 img =+  msum+    [ (\Refl -> toJPImageY8 img) <$> (eqT :: Maybe (cs :~: CM.X))+    , (\Refl -> toJPImageY8 $ toImageBaseModel img) <$> (eqT :: Maybe (cs :~: Y' SRGB))+    , (\Refl -> toJPImageY8 $ toImageBaseModel img) <$> (eqT :: Maybe (cs :~: Y D65))+    ]+{-# INLINE maybeJPImageY8 #-}++toJPImageY16 :: Source r (Pixel CM.X Word16) => Image r CM.X Word16 -> JP.Image JP.Pixel16+toJPImageY16 = toJPImageUnsafe+{-# INLINE toJPImageY16 #-}++++maybeJPImageY16 ::+     forall cs. (Typeable cs, Storable (Pixel cs Word16))+  => Image S cs Word16+  -> Maybe (JP.Image JP.Pixel16)+maybeJPImageY16 img =+  msum+    [ (\Refl -> toJPImageY16 img) <$> (eqT :: Maybe (cs :~: CM.X))+    , (\Refl -> toJPImageY16 $ toImageBaseModel img) <$> (eqT :: Maybe (cs :~: Y' SRGB))+    , (\Refl -> toJPImageY16 $ toImageBaseModel img) <$> (eqT :: Maybe (cs :~: Y D65))+    ]+{-# INLINE maybeJPImageY16 #-}++toJPImageY32 :: Source r (Pixel CM.X Word32) => Image r CM.X Word32 -> JP.Image JP.Pixel32+toJPImageY32 = toJPImageUnsafe+{-# INLINE toJPImageY32 #-}+++maybeJPImageY32 ::+     forall cs. (Typeable cs, Storable (Pixel cs Word32))+  => Image S cs Word32+  -> Maybe (JP.Image JP.Pixel32)+maybeJPImageY32 img =+  msum+    [ (\Refl -> toJPImageY32 img) <$> (eqT :: Maybe (cs :~: CM.X))+    , (\Refl -> toJPImageY32 $ toImageBaseModel img) <$> (eqT :: Maybe (cs :~: Y' SRGB))+    , (\Refl -> toJPImageY32 $ toImageBaseModel img) <$> (eqT :: Maybe (cs :~: Y D65))+    ]+{-# INLINE maybeJPImageY32 #-}+++toJPImageYF :: Source r (Pixel CM.X Float) => Image r CM.X Float -> JP.Image JP.PixelF+toJPImageYF = toJPImageUnsafe+{-# INLINE toJPImageYF #-}+++maybeJPImageYF ::+     forall cs. (Typeable cs, Storable (Pixel cs Float))+  => Image S cs Float+  -> Maybe (JP.Image JP.PixelF)+maybeJPImageYF img =+  msum+    [ (\Refl -> toJPImageYF img) <$> (eqT :: Maybe (cs :~: CM.X))+    , (\Refl -> toJPImageYF $ toImageBaseModel img) <$> (eqT :: Maybe (cs :~: Y' SRGB))+    , (\Refl -> toJPImageYF $ toImageBaseModel img) <$> (eqT :: Maybe (cs :~: Y D65))+    ]+{-# INLINE maybeJPImageYF #-}+++toJPImageYA8 ::+     Source r (Pixel (Alpha CM.X) Word8) => Image r (Alpha CM.X) Word8 -> JP.Image JP.PixelYA8+toJPImageYA8 = toJPImageUnsafe+{-# INLINE toJPImageYA8 #-}++maybeJPImageYA8 ::+     forall cs. (Typeable cs, Storable (Pixel (Alpha cs) Word8))+  => Image S (Alpha cs) Word8+  -> Maybe (JP.Image JP.PixelYA8)+maybeJPImageYA8 img =+  msum+    [ (\Refl -> toJPImageYA8 img) <$> (eqT :: Maybe (cs :~: CM.X))+    , (\Refl -> toJPImageYA8 $ toImageBaseModel img) <$> (eqT :: Maybe (cs :~: Y' SRGB))+    , (\Refl -> toJPImageYA8 $ toImageBaseModel img) <$> (eqT :: Maybe (cs :~: Y D65))+    ]+{-# INLINE maybeJPImageYA8 #-}+++toJPImageYA16 ::+     Source r (Pixel (Alpha CM.X) Word16)+  => Image r (Alpha CM.X) Word16+  -> JP.Image JP.PixelYA16+toJPImageYA16 = toJPImageUnsafe+{-# INLINE toJPImageYA16 #-}+++maybeJPImageYA16 ::+     forall cs. (Typeable cs, Storable (Pixel (Alpha cs) Word16))+  => Image S (Alpha cs) Word16+  -> Maybe (JP.Image JP.PixelYA16)+maybeJPImageYA16 img =+  msum+    [ (\Refl -> toJPImageYA16 img) <$> (eqT :: Maybe (cs :~: CM.X))+    , (\Refl -> toJPImageYA16 $ toImageBaseModel img) <$> (eqT :: Maybe (cs :~: Y' SRGB))+    , (\Refl -> toJPImageYA16 $ toImageBaseModel img) <$> (eqT :: Maybe (cs :~: Y D65))+    ]+{-# INLINE maybeJPImageYA16 #-}++++toJPImageRGB8 :: Source r (Pixel CM.RGB Word8) => Image r CM.RGB Word8 -> JP.Image JP.PixelRGB8+toJPImageRGB8 = toJPImageUnsafe+{-# INLINE toJPImageRGB8 #-}+++maybeJPImageRGB8 ::+     forall cs. (Typeable cs, Storable (Pixel cs Word8))+  => Image S cs Word8+  -> Maybe (JP.Image JP.PixelRGB8)+maybeJPImageRGB8 img =+  msum+    [ (\Refl -> toJPImageRGB8 img) <$> (eqT :: Maybe (cs :~: CM.RGB))+    , (\Refl -> toJPImageRGB8 $ toImageBaseModel img) <$> (eqT :: Maybe (cs :~: SRGB 'NonLinear))+    , (\Refl -> toJPImageRGB8 $ toImageBaseModel img) <$> (eqT :: Maybe (cs :~: AdobeRGB 'NonLinear))+    ]+{-# INLINE maybeJPImageRGB8 #-}+++toJPImageRGB16 ::+     Source r (Pixel CM.RGB Word16) => Image r CM.RGB Word16 -> JP.Image JP.PixelRGB16+toJPImageRGB16 = toJPImageUnsafe+{-# INLINE toJPImageRGB16 #-}++maybeJPImageRGB16 ::+     forall cs. (Typeable cs, Storable (Pixel cs Word16))+  => Image S cs Word16+  -> Maybe (JP.Image JP.PixelRGB16)+maybeJPImageRGB16 img =+  msum+    [ (\Refl -> toJPImageRGB16 img) <$> (eqT :: Maybe (cs :~: CM.RGB))+    , (\Refl -> toJPImageRGB16 $ toImageBaseModel img) <$> (eqT :: Maybe (cs :~: SRGB 'NonLinear))+    , (\Refl -> toJPImageRGB16 $ toImageBaseModel img) <$> (eqT :: Maybe (cs :~: AdobeRGB 'NonLinear))+    ]+{-# INLINE maybeJPImageRGB16 #-}+++toJPImageRGBF :: Source r (Pixel CM.RGB Float) => Image r CM.RGB Float -> JP.Image JP.PixelRGBF+toJPImageRGBF = toJPImageUnsafe+{-# INLINE toJPImageRGBF #-}++maybeJPImageRGBF ::+     forall cs. (Typeable cs, Storable (Pixel cs Float))+  => Image S cs Float+  -> Maybe (JP.Image JP.PixelRGBF)+maybeJPImageRGBF img =+  msum+    [ (\Refl -> toJPImageRGBF img) <$> (eqT :: Maybe (cs :~: CM.RGB))+    , (\Refl -> toJPImageRGBF $ toImageBaseModel img) <$> (eqT :: Maybe (cs :~: SRGB 'NonLinear))+    , (\Refl -> toJPImageRGBF $ toImageBaseModel img) <$> (eqT :: Maybe (cs :~: AdobeRGB 'NonLinear))+    ]+{-# INLINE maybeJPImageRGBF #-}+++toJPImageRGBA8 ::+     Source r (Pixel (Alpha CM.RGB) Word8)+  => Image r (Alpha CM.RGB) Word8+  -> JP.Image JP.PixelRGBA8+toJPImageRGBA8 = toJPImageUnsafe+{-# INLINE toJPImageRGBA8 #-}++maybeJPImageRGBA8 ::+     forall cs. (Typeable cs, Storable (Pixel (Alpha cs) Word8))+  => Image S (Alpha cs) Word8+  -> Maybe (JP.Image JP.PixelRGBA8)+maybeJPImageRGBA8 img =+  msum+    [ (\Refl -> toJPImageRGBA8 img) <$> (eqT :: Maybe (cs :~: CM.RGB))+    , (\Refl -> toJPImageRGBA8 $ toImageBaseModel img) <$> (eqT :: Maybe (cs :~: SRGB 'NonLinear))+    , (\Refl -> toJPImageRGBA8 $ toImageBaseModel img) <$>+      (eqT :: Maybe (cs :~: AdobeRGB 'NonLinear))+    ]+{-# INLINE maybeJPImageRGBA8 #-}+++toJPImageRGBA16 ::+     Source r (Pixel (Alpha CM.RGB) Word16)+  => Image r (Alpha CM.RGB) Word16+  -> JP.Image JP.PixelRGBA16+toJPImageRGBA16 = toJPImageUnsafe+{-# INLINE toJPImageRGBA16 #-}++maybeJPImageRGBA16 ::+     forall cs. (Typeable cs, Storable (Pixel (Alpha cs) Word16))+  => Image S (Alpha cs) Word16+  -> Maybe (JP.Image JP.PixelRGBA16)+maybeJPImageRGBA16 img =+  msum+    [ (\Refl -> toJPImageRGBA16 img) <$> (eqT :: Maybe (cs :~: CM.RGB))+    , (\Refl -> toJPImageRGBA16 $ toImageBaseModel img) <$>+      (eqT :: Maybe (cs :~: SRGB 'NonLinear))+    , (\Refl -> toJPImageRGBA16 $ toImageBaseModel img) <$>+      (eqT :: Maybe (cs :~: AdobeRGB 'NonLinear))+    ]+{-# INLINE maybeJPImageRGBA16 #-}++toJPImageYCbCr8 ::+     Source r (Pixel CM.YCbCr Word8) => Image r CM.YCbCr Word8 -> JP.Image JP.PixelYCbCr8+toJPImageYCbCr8 = toJPImageUnsafe+{-# INLINE toJPImageYCbCr8 #-}+++maybeJPImageYCbCr8 ::+     forall cs. (Typeable cs, Storable (Pixel cs Word8))+  => Image S cs Word8+  -> Maybe (JP.Image JP.PixelYCbCr8)+maybeJPImageYCbCr8 img =+  msum+    [ (\Refl -> toJPImageYCbCr8 img) <$> (eqT :: Maybe (cs :~: CM.YCbCr))+    , (\Refl -> toJPImageYCbCr8 $ toImageBaseModel img) <$> (eqT :: Maybe (cs :~: Y'CbCr SRGB))+    --, (\Refl -> toJPImageYCbCr8 $ toImageBaseModel img) <$> (eqT :: Maybe (cs :~: Y'CbCr AdobeRGB)))+    ]+{-# INLINE maybeJPImageYCbCr8 #-}+++toJPImageCMYK8 ::+     Source r (Pixel CM.CMYK Word8) => Image r CM.CMYK Word8 -> JP.Image JP.PixelCMYK8+toJPImageCMYK8 = toJPImageUnsafe+{-# INLINE toJPImageCMYK8 #-}+++maybeJPImageCMYK8 ::+     forall cs. (Typeable cs, Storable (Pixel cs Word8))+  => Image S cs Word8+  -> Maybe (JP.Image JP.PixelCMYK8)+maybeJPImageCMYK8 img =+  msum+    [ (\Refl -> toJPImageCMYK8 img) <$> (eqT :: Maybe (cs :~: CM.CMYK))+    , (\Refl -> toJPImageCMYK8 $ toImageBaseModel img) <$>+      (eqT :: Maybe (cs :~: CMYK (SRGB 'NonLinear)))+    , (\Refl -> toJPImageCMYK8 $ toImageBaseModel img) <$>+      (eqT :: Maybe (cs :~: CMYK (AdobeRGB 'NonLinear)))+    ]+{-# INLINE maybeJPImageCMYK8 #-}+++toJPImageCMYK16 ::+     Source r (Pixel CM.CMYK Word16) => Image r CM.CMYK Word16 -> JP.Image JP.PixelCMYK16+toJPImageCMYK16 = toJPImageUnsafe+{-# INLINE toJPImageCMYK16 #-}+++maybeJPImageCMYK16 ::+     forall cs. (Typeable cs, Storable (Pixel cs Word16))+  => Image S cs Word16+  -> Maybe (JP.Image JP.PixelCMYK16)+maybeJPImageCMYK16 img =+  msum+    [ (\Refl -> toJPImageCMYK16 img) <$> (eqT :: Maybe (cs :~: CM.CMYK))+    , (\Refl -> toJPImageCMYK16 $ toImageBaseModel img) <$>+      (eqT :: Maybe (cs :~: CMYK (SRGB 'NonLinear)))+    , (\Refl -> toJPImageCMYK16 $ toImageBaseModel img) <$>+      (eqT :: Maybe (cs :~: CMYK (AdobeRGB 'NonLinear)))+    ]+{-# INLINE maybeJPImageCMYK16 #-}+++-- General decoding and helper functions++fromJPImageUnsafeM ::+     forall jpx cs e m. (Storable (Pixel cs e), Storable e, JP.Pixel jpx, MonadThrow m)+  => JP.Image jpx+  -> m (Image S cs e)+fromJPImageUnsafeM (JP.Image n m !v) = do+  let numberOfComponentsFromSize = sizeOf (undefined :: Pixel cs e) `div` sizeOf (undefined :: e)+      numComponentsPerPixel = JP.componentCount (undefined :: jpx)+  unless (numComponentsPerPixel == numberOfComponentsFromSize) $+    throwM $ ConvertError $+    concat+      [ "Mismatched sizes between JuicyPixels: "+      , show numComponentsPerPixel+      , " and massiv: "+      , show numberOfComponentsFromSize+      ]+  assert (n * m * numComponentsPerPixel == V.length v) $+    unsafeFromStorableVectorM (Sz (m :. n)) v+++-- Conversion to sRGB color space based color models++toYCbCr8 :: forall cs i e . ColorSpace cs i e => Pixel cs e -> Pixel CM.YCbCr Word8+toYCbCr8 = toPixelBaseModel . (convertPixel :: Pixel cs e -> Pixel (Y'CbCr SRGB) Word8)++toCMYK8 :: forall cs i e . ColorSpace cs i e => Pixel cs e -> Pixel CM.CMYK Word8+toCMYK8 = toPixelBaseModel . (convertPixel :: Pixel cs e -> Pixel (CMYK (SRGB 'NonLinear)) Word8)++toCMYK16 :: forall cs i e . ColorSpace cs i e => Pixel cs e -> Pixel CM.CMYK Word16+toCMYK16 = toPixelBaseModel . (convertPixel :: Pixel cs e -> Pixel (CMYK (SRGB 'NonLinear)) Word16)++toSRGB8 :: forall cs i e . ColorSpace cs i e => Pixel cs e -> Pixel CM.RGB Word8+toSRGB8 = toPixelBaseModel . (convertPixel :: Pixel cs e -> Pixel (SRGB 'NonLinear) Word8)++toSRGB16 :: forall cs i e . ColorSpace cs i e => Pixel cs e -> Pixel CM.RGB Word16+toSRGB16 = toPixelBaseModel . (convertPixel :: Pixel cs e -> Pixel (SRGB 'NonLinear) Word16)++toSRGBA8 :: forall cs i e . ColorSpace cs i e => Pixel cs e -> Pixel (Alpha CM.RGB) Word8+toSRGBA8 = toPixelBaseModel . (convertPixel :: Pixel cs e -> Pixel (Alpha (SRGB 'NonLinear)) Word8)++toSRGBA16 :: forall cs i e . ColorSpace cs i e => Pixel cs e -> Pixel (Alpha CM.RGB) Word16+toSRGBA16 = toPixelBaseModel . (convertPixel :: Pixel cs e -> Pixel (Alpha (SRGB 'NonLinear)) Word16)
+ src/Data/Massiv/Array/IO/Image/JuicyPixels/GIF.hs view
@@ -0,0 +1,400 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+-- |+-- Module      : Data.Massiv.Array.IO.Image.JuicyPixels.GIF+-- Copyright   : (c) Alexey Kuleshevich 2019-2021+-- License     : BSD3+-- Maintainer  : Alexey Kuleshevich <lehins@yandex.ru>+-- Stability   : experimental+-- Portability : non-portable+--+module Data.Massiv.Array.IO.Image.JuicyPixels.GIF+  ( GIF(..)+  , GifOptions(..)+  , SequenceGifOptions(..)+  , JP.GifDelay+  , JP.GifLooping(..)+  , JP.PaletteOptions(..)+  , JP.PaletteCreationMethod(..)+  , JP.GifDisposalMethod(..)++  , decodeGIF+  , decodeWithMetadataGIF+  , decodeAutoGIF+  , decodeAutoWithMetadataGIF+  , encodeGIF+  , encodeAutoGIF+  -- Sequence+  , decodeSequenceGIF+  , decodeSequenceWithMetadataGIF+  , decodeAutoSequenceGIF+  , decodeAutoSequenceWithMetadataGIF+  ) where++import qualified Codec.Picture as JP+import qualified Codec.Picture.ColorQuant as JP+import qualified Codec.Picture.Gif as JP+import qualified Codec.Picture.Metadata as JP+import Control.Monad (msum)+import Data.Bifunctor (first)+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL (ByteString)+import Data.List.NonEmpty as NE+import Data.Massiv.Array as A+import Data.Massiv.Array.IO.Base+import Data.Massiv.Array.IO.Image.JuicyPixels.Base+import Data.Typeable+import qualified Graphics.Pixel as CM+import Graphics.Pixel.ColorSpace+import Prelude as P++--------------------------------------------------------------------------------+-- GIF Format ------------------------------------------------------------------+--------------------------------------------------------------------------------+++newtype GifOptions = GifOptions+  { gifPaletteOptions :: JP.PaletteOptions+  }++instance Default GifOptions where+  def = GifOptions JP.defaultPaletteOptions+++-- | Graphics Interchange Format image with @.gif@ extension.+data GIF = GIF deriving Show++instance FileFormat GIF where+  type WriteOptions GIF = GifOptions+  type Metadata GIF = JP.Metadatas+  ext _ = ".gif"++instance Writable GIF (Image A.S CM.X Bit) where+  encodeM f opts img = encodeM f opts (coerceBinaryImage img)++instance Writable GIF (Image S CM.X Word8) where+  encodeM GIF _ =  pure . JP.encodeGifImage . toJPImageY8++instance Writable GIF (Image S CM.RGB Word8) where+  encodeM GIF = encodePalettizedRGB++instance Writable GIF (Image S (Y' SRGB) Word8) where+  encodeM GIF opts = encodeM GIF opts . toImageBaseModel++instance Writable GIF (Image S (Y D65) Word8) where+  encodeM GIF opts = encodeM GIF opts . toImageBaseModel++instance Writable GIF (Image S (SRGB 'NonLinear) Word8) where+  encodeM GIF opts = encodeM GIF opts . toImageBaseModel++encodePalettizedRGB ::+     (MonadThrow m, Source r (Pixel CM.RGB Word8))+  => GifOptions+  -> Image r CM.RGB Word8+  -> m BL.ByteString+encodePalettizedRGB GifOptions {gifPaletteOptions} =+  encodeError .+  uncurry JP.encodeGifImageWithPalette . JP.palettize gifPaletteOptions . toJPImageRGB8++instance (ColorSpace cs i e, ColorSpace (BaseSpace cs) i e, Source r (Pixel cs e)) =>+         Writable (Auto GIF) (Image r cs e) where+  encodeM = encodeAutoGIF+++instance Readable GIF (Image S CM.RGB Word8) where+  decodeM = decodeGIF+  decodeWithMetadataM = decodeWithMetadataGIF++instance Readable GIF (Image S (Alpha CM.RGB) Word8) where+  decodeM = decodeGIF+  decodeWithMetadataM = decodeWithMetadataGIF++instance Readable GIF (Image S (SRGB 'NonLinear) Word8) where+  decodeM f = fmap fromImageBaseModel . decodeM f+  decodeWithMetadataM f = fmap (first fromImageBaseModel) . decodeWithMetadataM f++instance Readable GIF (Image S (Alpha (SRGB 'NonLinear)) Word8) where+  decodeM f = fmap fromImageBaseModel . decodeM f+  decodeWithMetadataM f = fmap (first fromImageBaseModel) . decodeWithMetadataM f++-- | Decode a Gif Image+decodeGIF :: (ColorModel cs e, MonadThrow m) => GIF -> B.ByteString -> m (Image S cs e)+decodeGIF f bs = convertWith f (JP.decodeGif bs)+{-# INLINE decodeGIF #-}++-- | Decode a Gif Image+decodeWithMetadataGIF ::+     (ColorModel cs e, MonadThrow m) => GIF -> B.ByteString -> m (Image S cs e, JP.Metadatas)+decodeWithMetadataGIF f bs = convertWithMetadata f (JP.decodeGifWithMetadata bs)+{-# INLINE decodeWithMetadataGIF #-}+++-- | Decode a Gif Image+decodeAutoGIF ::+     (Manifest r (Pixel cs e), ColorSpace cs i e, MonadThrow m)+  => Auto GIF+  -> B.ByteString+  -> m (Image r cs e)+decodeAutoGIF f bs = convertAutoWith f (JP.decodeGif bs)+{-# INLINE decodeAutoGIF #-}++-- | Decode a Gif Image+decodeAutoWithMetadataGIF ::+     (Manifest r (Pixel cs e), ColorSpace cs i e, MonadThrow m)+  => Auto GIF+  -> B.ByteString+  -> m (Image r cs e, JP.Metadatas)+decodeAutoWithMetadataGIF f bs = convertAutoWithMetadata f (JP.decodeGifWithMetadata bs)+{-# INLINE decodeAutoWithMetadataGIF #-}+++instance (Manifest r (Pixel cs e), ColorSpace cs i e) =>+         Readable (Auto GIF) (Image r cs e) where+  decodeM = decodeAutoGIF+  decodeWithMetadataM = decodeAutoWithMetadataGIF++encodeGIF ::+     forall cs e m. (ColorModel cs e, MonadThrow m)+  => GIF+  -> GifOptions+  -> Image S cs e+  -> m BL.ByteString+encodeGIF f opts img =+  fallbackEncodePalettizedRGB $ do+    Refl <- eqT :: Maybe (e :~: Word8)+    JP.encodeGifImage <$> maybeJPImageY8 img+  where+    fallbackEncodePalettizedRGB =+      \case+        Just bs -> pure bs+        Nothing+          | Just Refl <- (eqT :: Maybe (Pixel cs e :~: Pixel CM.X Bit)) ->+            encodeM f opts img+          | Just Refl <- (eqT :: Maybe (Pixel cs e :~: Pixel CM.RGB Word8)) ->+            encodePalettizedRGB opts img+          | Just Refl <- (eqT :: Maybe (Pixel cs e :~: Pixel (SRGB 'NonLinear) Word8)) ->+            encodePalettizedRGB opts $ toImageBaseModel img+          | Just Refl <- (eqT :: Maybe (Pixel cs e :~: Pixel (AdobeRGB 'NonLinear) Word8)) ->+            encodePalettizedRGB opts $ toImageBaseModel img+        Nothing -> fromMaybeEncode f (Proxy :: Proxy (Image S cs e)) Nothing+++encodeAutoGIF ::+     forall r cs i e m. (ColorSpace cs i e, Source r (Pixel cs e), MonadThrow m)+  => Auto GIF+  -> GifOptions+  -> Image r cs e+  -> m BL.ByteString+encodeAutoGIF _ opts img =+  fallbackEncodePalettizedRGB $ do+    msum+      [ do Refl <- eqT :: Maybe (r :~: S)+           case eqT :: Maybe (e :~: Word8) of+             Just Refl+               | Just Refl <- (eqT :: Maybe (BaseModel cs :~: CM.X)) ->+                 pure $ JP.encodeGifImage $ toJPImageY8 (toImageBaseModel img)+               | Just Refl <- (eqT :: Maybe (BaseModel cs :~: CM.RGB)) ->+                 encodePalettizedRGB opts (toImageBaseModel img)+             _ -> Nothing+      , do Refl <- eqT :: Maybe (BaseModel cs :~: CM.X)+           pure $ JP.encodeGifImage $ toJPImageY8 $ A.map (toPixel8 . toPixelBaseModel) img+      ]+  where+    fallbackEncodePalettizedRGB =+      \case+        Just bs -> pure bs+        Nothing -> encodePalettizedRGB opts $ A.map toSRGB8 img++data SequenceGifOptions = SequenceGifOptions+  { sequenceGifPaletteOptions :: !JP.PaletteOptions+   -- ^ Options used for palletization. Ignored for images with Alpha channel+  , sequenceGifLooping        :: !JP.GifLooping+  }++instance Default SequenceGifOptions where+  def =+    SequenceGifOptions+      {sequenceGifPaletteOptions = JP.defaultPaletteOptions, sequenceGifLooping = JP.LoopingNever}++instance FileFormat (Sequence GIF) where+  type WriteOptions (Sequence GIF) = SequenceGifOptions+  type Metadata (Sequence GIF) = [JP.GifDelay]+  ext _ = ext GIF++instance Readable (Sequence GIF) [Image S CM.RGB Word8] where+  decodeM = decodeSequenceGIF+  decodeWithMetadataM = decodeSequenceWithMetadataGIF++instance Readable (Sequence GIF) [Image S (Alpha CM.RGB) Word8] where+  decodeM = decodeSequenceGIF+  decodeWithMetadataM = decodeSequenceWithMetadataGIF++instance Readable (Sequence GIF) [Image S (SRGB 'NonLinear) Word8] where+  decodeM f = fmap (fmap fromImageBaseModel) . decodeM f+  decodeWithMetadataM f = fmap (first (fmap fromImageBaseModel)) . decodeWithMetadataM f++instance Readable (Sequence GIF) [Image S (Alpha (SRGB 'NonLinear)) Word8] where+  decodeM f = fmap (fmap fromImageBaseModel) . decodeM f+  decodeWithMetadataM f = fmap (first (fmap fromImageBaseModel)) . decodeWithMetadataM f+++instance (Manifest r (Pixel cs e), ColorSpace cs i e) =>+         Readable (Auto (Sequence GIF)) [Image r cs e] where+  decodeM = decodeAutoSequenceGIF+  decodeWithMetadataM = decodeAutoSequenceWithMetadataGIF+++-- | Decode a sequence of Gif images+decodeSequenceGIF ::+     (ColorModel cs e, MonadThrow m) => Sequence GIF -> B.ByteString -> m [Image S cs e]+decodeSequenceGIF f bs = convertSequenceWith f (JP.decodeGifImages bs)++-- | Decode a sequence of Gif images+decodeSequenceWithMetadataGIF ::+     (ColorModel cs e, MonadThrow m)+  => Sequence GIF+  -> B.ByteString+  -> m ([Image S cs e], [JP.GifDelay])+decodeSequenceWithMetadataGIF = decodeSeqMetadata decodeSequenceGIF++-- | Decode a sequence of Gif images+decodeAutoSequenceGIF ::+     (Manifest r (Pixel cs e), ColorSpace cs i e, MonadThrow m)+  => Auto (Sequence GIF)+  -> B.ByteString+  -> m [Image r cs e]+decodeAutoSequenceGIF f bs = convertAutoSequenceWith f (JP.decodeGifImages bs)++-- | Decode a sequence of Gif images+decodeAutoSequenceWithMetadataGIF ::+     (Manifest r (Pixel cs e), ColorSpace cs i e, MonadThrow m)+  => Auto (Sequence GIF)+  -> B.ByteString+  -> m ([Image r cs e], [JP.GifDelay])+decodeAutoSequenceWithMetadataGIF = decodeSeqMetadata decodeAutoSequenceGIF++decodeSeqMetadata ::+     MonadThrow m => (t -> B.ByteString -> m a) -> t -> B.ByteString -> m (a, [JP.GifDelay])+decodeSeqMetadata decode f bs = do+  imgs <- decode f bs+  delays <- decodeError $ JP.getDelaysGifImages bs+  pure (imgs, delays)++instance Writable (Sequence GIF) (NE.NonEmpty (JP.GifDelay, Image S CM.X Bit)) where+  encodeM f opts imgs = encodeM f opts (fmap (fmap coerceBinaryImage) imgs)++instance Writable (Sequence GIF) (NE.NonEmpty (JP.GifDelay, Image S CM.X Word8)) where+  encodeM _ SequenceGifOptions {sequenceGifLooping} gifs =+    encodeError $+    JP.encodeComplexGifImage $+    JP.GifEncode+      { JP.geWidth = cols+      , JP.geHeight = rows+      , JP.gePalette = Just JP.greyPalette+      , JP.geBackground = Nothing+      , JP.geLooping = sequenceGifLooping+      , JP.geFrames =+          flip fmap (NE.toList gifs) $ \(gifDelay, gif) ->+            JP.GifFrame+              { JP.gfXOffset = 0+              , JP.gfYOffset = 0+              , JP.gfPalette = Nothing+              , JP.gfTransparent = Nothing+              , JP.gfDelay = gifDelay+              , JP.gfDisposal = JP.DisposalAny+              , JP.gfPixels = toJPImageY8 gif+              }+      }+    where+      (rows :. cols) = foldl1 (liftIndex2 max) $ fmap (unSz . size . snd) gifs++instance Writable (Sequence GIF) (NE.NonEmpty ( JP.GifDelay+                                              , JP.GifDisposalMethod+                                              , Image S CM.RGB Word8)) where+  encodeM _ SequenceGifOptions {sequenceGifLooping, sequenceGifPaletteOptions} gifs =+    encodeError $+    JP.encodeComplexGifImage $+    JP.GifEncode+      { JP.geWidth = cols+      , JP.geHeight = rows+      , JP.gePalette = Nothing+      , JP.geBackground = Nothing+      , JP.geLooping = sequenceGifLooping+      , JP.geFrames =+          flip fmap (NE.toList gifs) $ \(gifDelay, disposalMethod, gif) ->+            let (img, palette) = JP.palettize sequenceGifPaletteOptions $ toJPImageRGB8 gif+             in JP.GifFrame+                  { JP.gfXOffset = 0+                  , JP.gfYOffset = 0+                  , JP.gfPalette = Just palette+                  , JP.gfTransparent = Nothing+                  , JP.gfDelay = gifDelay+                  , JP.gfDisposal = disposalMethod+                  , JP.gfPixels = img+                  }+      }+    where+      (rows :. cols) = foldl1 (liftIndex2 max) $ fmap (\(_, _, i) -> unSz $ size i) gifs++instance Writable (Sequence GIF) (NE.NonEmpty (JP.GifDelay, Image S CM.RGB Word8)) where+  encodeM f opts = encodeM f opts . fmap (\(d, i) -> (d, JP.DisposalAny, i))++instance Writable (Sequence GIF) (NE.NonEmpty ( JP.GifDelay+                                              , JP.GifDisposalMethod+                                              , Image S (Alpha CM.RGB) Word8)) where+  encodeM _ SequenceGifOptions {sequenceGifLooping} gifsNE =+    encodeError $+    JP.encodeComplexGifImage $+    JP.GifEncode+      { JP.geWidth = cols+      , JP.geHeight = rows+      , JP.gePalette = Nothing+      , JP.geBackground = Nothing+      , JP.geLooping = sequenceGifLooping+      , JP.geFrames =+          P.zipWith (\d f -> f {JP.gfDisposal = d}) disposals $+          JP.palettizeWithAlpha (P.zip delays $ P.map toJPImageRGBA8 images) JP.DisposalAny+      }+    where+      (delays, disposals, images) = P.unzip3 $ NE.toList gifsNE+      (rows :. cols) = foldl1 (liftIndex2 max) $ fmap (unSz . size) images++instance Writable (Sequence GIF) (NE.NonEmpty (JP.GifDelay, Image S (Alpha CM.RGB) Word8)) where+  encodeM f opts = encodeM f opts . fmap (\(d, i) -> (d, JP.DisposalRestoreBackground, i))++instance Writable (Sequence GIF) (NE.NonEmpty (JP.GifDelay, Image S (Y' SRGB) Word8)) where+  encodeM f opts = encodeM f opts . fmap (fmap toImageBaseModel)++instance Writable (Sequence GIF) (NE.NonEmpty (JP.GifDelay, Image S (Y D65) Word8)) where+  encodeM f opts = encodeM f opts . fmap (fmap toImageBaseModel)++instance Writable (Sequence GIF) (NE.NonEmpty (JP.GifDelay, Image S (SRGB 'NonLinear) Word8)) where+  encodeM f opts = encodeM f opts . fmap (fmap toImageBaseModel)++instance Writable (Sequence GIF) (NE.NonEmpty (JP.GifDelay, Image S (Alpha (SRGB 'NonLinear)) Word8)) where+  encodeM f opts = encodeM f opts . fmap (fmap toImageBaseModel)++instance Writable (Sequence GIF) (NE.NonEmpty ( JP.GifDelay+                                              , JP.GifDisposalMethod+                                              , Image S (SRGB 'NonLinear) Word8)) where+  encodeM f opts = encodeM f opts . fmap (\(dl, dp, i) -> (dl, dp, toImageBaseModel i))++instance Writable (Sequence GIF) (NE.NonEmpty ( JP.GifDelay+                                              , JP.GifDisposalMethod+                                              , Image S (Alpha (SRGB 'NonLinear)) Word8)) where+  encodeM f opts = encodeM f opts . fmap (\(dl, dp, i) -> (dl, dp, toImageBaseModel i))+++instance (Manifest r (Pixel cs e), ColorSpace cs i e) =>+         Writable (Auto (Sequence GIF)) (NE.NonEmpty (JP.GifDelay, Image r cs e)) where+  encodeM (Auto f) opts =+    encodeM f opts .+    fmap (fmap (computeAs S . (convertImage :: Image r cs e -> Image D (SRGB 'NonLinear) Word8)))
+ src/Data/Massiv/Array/IO/Image/JuicyPixels/HDR.hs view
@@ -0,0 +1,151 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+-- |+-- Module      : Data.Massiv.Array.IO.Image.JuicyPixels.HDR+-- Copyright   : (c) Alexey Kuleshevich 2019-2021+-- License     : BSD3+-- Maintainer  : Alexey Kuleshevich <lehins@yandex.ru>+-- Stability   : experimental+-- Portability : non-portable+--+module Data.Massiv.Array.IO.Image.JuicyPixels.HDR+  ( HDR(..)+  , HdrOptions(..)+  , decodeHDR+  , decodeWithMetadataHDR+  , decodeAutoHDR+  , decodeAutoWithMetadataHDR+  , encodeHDR+  , encodeAutoHDR+  ) where++import qualified Codec.Picture as JP+import qualified Codec.Picture.HDR as JP+import qualified Codec.Picture.Metadata as JP+import Data.Bifunctor (first)+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL (ByteString)+import Data.Massiv.Array as A+import Data.Massiv.Array.IO.Base+import Data.Massiv.Array.IO.Image.JuicyPixels.Base+import Data.Typeable+import qualified Graphics.Pixel as CM+import Graphics.Pixel.ColorSpace+import Prelude as P++--------------------------------------------------------------------------------+-- HDR Format ------------------------------------------------------------------+--------------------------------------------------------------------------------++newtype HdrOptions = HdrOptions+  { hdrUseLightRLE :: Bool+  -- ^ Use light RLE compression. Causes problems in some viewers. See:+  -- `JP.encodeRLENewStyleHDR`+  } deriving (Show)++instance Default HdrOptions where+  def = HdrOptions False+++-- | High-dynamic-range image with @.hdr@ or @.pic@ extension.+data HDR = HDR deriving Show++instance FileFormat HDR where+  type WriteOptions HDR = HdrOptions+  type Metadata HDR = JP.Metadatas+  ext _ = ".hdr"+  exts _ = [".hdr", ".pic"]++getHdrEncoder+  :: HdrOptions -> JP.Image JP.PixelRGBF -> BL.ByteString+getHdrEncoder HdrOptions {hdrUseLightRLE}+  | hdrUseLightRLE = JP.encodeRLENewStyleHDR+  | otherwise = JP.encodeHDR++instance Writable HDR (Image S CM.RGB Float) where+  encodeM HDR opts = pure . getHdrEncoder opts . toJPImageRGBF++instance Writable HDR (Image S (SRGB 'NonLinear) Float) where+  encodeM f opts = encodeM f opts . toImageBaseModel++instance (ColorSpace cs i e, ColorSpace (BaseSpace cs) i e, Source r (Pixel cs e)) =>+         Writable (Auto HDR) (Image r cs e) where+  encodeM f opts = pure . encodeAutoHDR f opts+++instance Readable HDR (Image S CM.RGB Float) where+  decodeWithMetadataM = decodeWithMetadataHDR++instance Readable HDR (Image S (SRGB 'NonLinear) Float) where+  decodeWithMetadataM f = fmap (first fromImageBaseModel) . decodeWithMetadataM f++-- | Decode a HDR Image+decodeHDR :: (ColorModel cs e, MonadThrow m) => HDR -> B.ByteString -> m (Image S cs e)+decodeHDR f bs = convertWith f (JP.decodeHDR bs)+{-# INLINE decodeHDR #-}++-- | Decode a HDR Image+decodeWithMetadataHDR ::+     (ColorModel cs e, MonadThrow m) => HDR -> B.ByteString -> m (Image S cs e, JP.Metadatas)+decodeWithMetadataHDR f bs = convertWithMetadata f (JP.decodeHDRWithMetadata bs)+{-# INLINE decodeWithMetadataHDR #-}+++-- | Decode a HDR Image+decodeAutoHDR ::+     (Manifest r (Pixel cs e), ColorSpace cs i e, MonadThrow m)+  => Auto HDR+  -> B.ByteString+  -> m (Image r cs e)+decodeAutoHDR f bs = convertAutoWith f (JP.decodeHDR bs)+{-# INLINE decodeAutoHDR #-}++-- | Decode a HDR Image+decodeAutoWithMetadataHDR ::+     (Manifest r (Pixel cs e), ColorSpace cs i e, MonadThrow m)+  => Auto HDR+  -> B.ByteString+  -> m (Image r cs e, JP.Metadatas)+decodeAutoWithMetadataHDR f bs = convertAutoWithMetadata f (JP.decodeHDRWithMetadata bs)+{-# INLINE decodeAutoWithMetadataHDR #-}++instance (Manifest r (Pixel cs e), ColorSpace cs i e) =>+         Readable (Auto HDR) (Image r cs e) where+  decodeM = decodeAutoHDR+  decodeWithMetadataM = decodeAutoWithMetadataHDR++encodeHDR ::+     forall cs e m.+     (ColorModel cs e, MonadThrow m)+  => HDR+  -> HdrOptions+  -> Image S cs e+  -> m BL.ByteString+encodeHDR f opts img =+  fromMaybeEncode f (Proxy :: Proxy (Image S cs e)) $ do+    Refl <- eqT :: Maybe (e :~: Float)+    getHdrEncoder opts <$> maybeJPImageRGBF img++++encodeAutoHDR ::+     forall r cs i e. (ColorSpace cs i e, Source r (Pixel cs e))+  => Auto HDR+  -> HdrOptions+  -> Image r cs e+  -> BL.ByteString+encodeAutoHDR _ opts  img=+  case eqT :: Maybe (Image r cs e :~: Image S (SRGB 'NonLinear) Float) of+    Just Refl -> getHdrEncoder opts $ toJPImageRGBF (toImageBaseModel img)+    Nothing -> toHdr (toPixelBaseModel . toSRGBF) img+  where+    toSRGBF = convertPixel :: Pixel cs e -> Pixel (SRGB 'NonLinear) Float+    toHdr :: Source r a => (a -> Pixel CM.RGB Float) -> Array r Ix2 a -> BL.ByteString+    toHdr adjustPixel = getHdrEncoder opts . toJPImageRGBF . A.map adjustPixel
+ src/Data/Massiv/Array/IO/Image/JuicyPixels/JPG.hs view
@@ -0,0 +1,248 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+-- |+-- Module      : Data.Massiv.Array.IO.Image.JuicyPixels.JPG+-- Copyright   : (c) Alexey Kuleshevich 2019-2021+-- License     : BSD3+-- Maintainer  : Alexey Kuleshevich <lehins@yandex.ru>+-- Stability   : experimental+-- Portability : non-portable+--+module Data.Massiv.Array.IO.Image.JuicyPixels.JPG+  ( JPG(..)+  , JpegOptions(..)+  , decodeJPG+  , decodeWithMetadataJPG+  , decodeAutoJPG+  , decodeAutoWithMetadataJPG+  , encodeJPG+  , encodeAutoJPG+  ) where++import qualified Codec.Picture as JP+import qualified Codec.Picture.Jpg as JP+import qualified Codec.Picture.Metadata as JP+import Control.Monad (msum)+import Data.Bifunctor (first)+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL (ByteString)+import Data.Massiv.Array as A+import Data.Massiv.Array.IO.Base+import Data.Massiv.Array.IO.Image.JuicyPixels.Base+import Data.Maybe (fromMaybe)+import Data.Typeable+import qualified Graphics.Pixel as CM+import Graphics.Pixel.ColorSpace+import Prelude as P++--------------------------------------------------------------------------------+-- JPG Format ------------------------------------------------------------------+--------------------------------------------------------------------------------++-- TODOs: Check if JP is capable of writing Jpegs with PixelYA8 (No instance for+-- JpegEncodable, but it can read 'em)++data JpegOptions = JpegOptions+  { jpegQuality  :: !Word8+  , jpegMetadata :: !JP.Metadatas+  } deriving (Show)++instance Default JpegOptions where+  def = JpegOptions 100 mempty+++-- | Joint Photographic Experts Group image with @.jpg@ or @.jpeg@ extension.+data JPG = JPG deriving Show++instance FileFormat JPG where+  type WriteOptions JPG = JpegOptions+  type Metadata JPG = JP.Metadatas+  ext _ = ".jpg"+  exts _ = [".jpg", ".jpeg"]++instance Writable JPG (Image A.S CM.X Bit) where+  encodeM f opts img = encodeM f opts (coerceBinaryImage img)++instance Writable JPG (Image S CM.X Word8) where+  encodeM JPG JpegOptions {jpegQuality, jpegMetadata} =+    pure . JP.encodeDirectJpegAtQualityWithMetadata jpegQuality jpegMetadata . toJPImageY8++instance Writable JPG (Image S CM.RGB Word8) where+  encodeM JPG JpegOptions {jpegQuality, jpegMetadata} =+    pure . JP.encodeDirectJpegAtQualityWithMetadata jpegQuality jpegMetadata . toJPImageRGB8++instance Writable JPG (Image S CM.YCbCr Word8) where+  encodeM JPG JpegOptions {jpegQuality, jpegMetadata} =+    pure . JP.encodeJpegAtQualityWithMetadata jpegQuality jpegMetadata . toJPImageYCbCr8++instance Writable JPG (Image S CM.CMYK Word8) where+  encodeM JPG JpegOptions {jpegQuality, jpegMetadata} =+    pure . JP.encodeDirectJpegAtQualityWithMetadata jpegQuality jpegMetadata . toJPImageCMYK8++instance Writable JPG (Image S (Y' SRGB) Word8) where+  encodeM f opts = encodeM f opts . toImageBaseModel++instance Writable JPG (Image S (Y D65) Word8) where+  encodeM f opts = encodeM f opts . toImageBaseModel++instance Writable JPG (Image S (SRGB 'NonLinear) Word8) where+  encodeM f opts = encodeM f opts . toImageBaseModel++instance Writable JPG (Image S (Y'CbCr SRGB) Word8) where+  encodeM f opts = encodeM f opts . toImageBaseModel++instance Writable JPG (Image S (CMYK (SRGB 'NonLinear)) Word8) where+  encodeM f opts = encodeM f opts . toImageBaseModel++instance (ColorSpace cs i e, ColorSpace (BaseSpace cs) i e, Source r (Pixel cs e)) =>+         Writable (Auto JPG) (Image r cs e) where+  encodeM f opts = pure . encodeAutoJPG f opts+++instance Readable JPG (Image S CM.X Word8) where+  decodeWithMetadataM = decodeWithMetadataJPG++instance Readable JPG (Image S (Alpha CM.X) Word8) where+  decodeWithMetadataM = decodeWithMetadataJPG++instance Readable JPG (Image S CM.RGB Word8) where+  decodeWithMetadataM = decodeWithMetadataJPG++instance Readable JPG (Image S CM.CMYK Word8) where+  decodeWithMetadataM = decodeWithMetadataJPG++instance Readable JPG (Image S CM.YCbCr Word8) where+  decodeWithMetadataM = decodeWithMetadataJPG++instance Readable JPG (Image S (Y' SRGB) Word8) where+  decodeWithMetadataM f = fmap (first fromImageBaseModel) . decodeWithMetadataM f++instance Readable JPG (Image S (Alpha (Y' SRGB)) Word8) where+  decodeWithMetadataM f = fmap (first fromImageBaseModel) . decodeWithMetadataM f++instance Readable JPG (Image S (Y D65) Word8) where+  decodeWithMetadataM f = fmap (first fromImageBaseModel) . decodeWithMetadataM f++instance Readable JPG (Image S (Alpha (Y D65)) Word8) where+  decodeWithMetadataM f = fmap (first fromImageBaseModel) . decodeWithMetadataM f++instance Readable JPG (Image S (SRGB 'NonLinear) Word8) where+  decodeWithMetadataM f = fmap (first fromImageBaseModel) . decodeWithMetadataM f++instance Readable JPG (Image S (CMYK (SRGB 'NonLinear)) Word8) where+  decodeWithMetadataM f = fmap (first fromImageBaseModel) . decodeWithMetadataM f++instance Readable JPG (Image S (Y'CbCr SRGB) Word8) where+  decodeWithMetadataM f = fmap (first fromImageBaseModel) . decodeWithMetadataM f+++-- | Decode a Jpeg Image+decodeJPG :: (ColorModel cs e, MonadThrow m) => JPG -> B.ByteString -> m (Image S cs e)+decodeJPG f bs = convertWith f (JP.decodeJpeg bs)+{-# INLINE decodeJPG #-}++-- | Decode a Jpeg Image+decodeWithMetadataJPG ::+     (ColorModel cs e, MonadThrow m) => JPG -> B.ByteString -> m (Image S cs e, JP.Metadatas)+decodeWithMetadataJPG f bs = convertWithMetadata f (JP.decodeJpegWithMetadata bs)+{-# INLINE decodeWithMetadataJPG #-}++-- | Decode a Jpeg Image+decodeAutoJPG ::+     (Manifest r (Pixel cs e), ColorSpace cs i e, MonadThrow m)+  => Auto JPG+  -> B.ByteString+  -> m (Image r cs e)+decodeAutoJPG f bs = convertAutoWith f (JP.decodeJpeg bs)+{-# INLINE decodeAutoJPG #-}++-- | Decode a Jpeg Image+decodeAutoWithMetadataJPG ::+     (Manifest r (Pixel cs e), ColorSpace cs i e, MonadThrow m)+  => Auto JPG+  -> B.ByteString+  -> m (Image r cs e, JP.Metadatas)+decodeAutoWithMetadataJPG f bs = convertAutoWithMetadata f (JP.decodeJpegWithMetadata bs)+{-# INLINE decodeAutoWithMetadataJPG #-}++instance (Manifest r (Pixel cs e), ColorSpace cs i e) =>+         Readable (Auto JPG) (Image r cs e) where+  decodeM = decodeAutoJPG+  decodeWithMetadataM = decodeAutoWithMetadataJPG++encodeJPG ::+     forall cs e m. (ColorModel cs e, MonadThrow m)+  => JPG+  -> JpegOptions+  -> Image S cs e+  -> m BL.ByteString+encodeJPG f opts@JpegOptions {jpegQuality, jpegMetadata} img =+  fromMaybeEncode f (Proxy :: Proxy (Image S cs e)) encoded+  where+    encoded+      | Just Refl <- eqT :: Maybe (Pixel cs e :~: Pixel CM.X Bit) = encodeM JPG opts img+      | Just Refl <- eqT :: Maybe (e :~: Word8) =+        msum+          [ JP.encodeDirectJpegAtQualityWithMetadata jpegQuality jpegMetadata <$> maybeJPImageY8 img+          , JP.encodeDirectJpegAtQualityWithMetadata jpegQuality jpegMetadata <$>+            maybeJPImageRGB8 img+          , JP.encodeDirectJpegAtQualityWithMetadata jpegQuality jpegMetadata <$>+            maybeJPImageYCbCr8 img+          , JP.encodeDirectJpegAtQualityWithMetadata jpegQuality jpegMetadata <$>+            maybeJPImageCMYK8 img+          ]+      | otherwise = Nothing+++encodeAutoJPG ::+     forall r cs i e. (ColorSpace (BaseSpace cs) i e, ColorSpace cs i e, Source r (Pixel cs e))+  => Auto JPG+  -> JpegOptions+  -> Image r cs e+  -> BL.ByteString+encodeAutoJPG _ JpegOptions {jpegQuality, jpegMetadata} img =+  fromMaybe (toJpeg toJPImageYCbCr8 toYCbCr8 img) $+  msum+    [ do Refl <- eqT :: Maybe (r :~: S)+         case eqT :: Maybe (e :~: Word8) of+           Just Refl+             | Just Refl <- (eqT :: Maybe (BaseModel cs :~: CM.X)) ->+               pure $+               JP.encodeDirectJpegAtQualityWithMetadata jpegQuality jpegMetadata $+               toJPImageY8 (toImageBaseModel img)+             | Just Refl <- (eqT :: Maybe (BaseModel cs :~: CM.RGB)) ->+               pure $+               JP.encodeDirectJpegAtQualityWithMetadata jpegQuality jpegMetadata $+               toJPImageRGB8 (toImageBaseModel img)+             | Just Refl <- (eqT :: Maybe (BaseModel cs :~: CM.YCbCr)) ->+               pure $+               JP.encodeDirectJpegAtQualityWithMetadata jpegQuality jpegMetadata $+               toJPImageYCbCr8 (toImageBaseModel img)+           _ -> Nothing+    , do Refl <- eqT :: Maybe (BaseModel cs :~: CM.X)+         msum+           [ do Refl <- eqT :: Maybe (e :~: Bit)+                pure $ toJpeg toJPImageY8 (toPixel8 . toPixelBaseModel) img+           , pure $ toJpeg toJPImageY8 (toPixel8 . toPixelBaseModel) img+           ]+    , do Refl <- eqT :: Maybe (BaseModel cs :~: CM.CMYK)+         pure $ toJpeg toJPImageCMYK8 toCMYK8 img+    , do Refl <- eqT :: Maybe (BaseModel cs :~: CM.RGB)+         pure $ toJpeg toJPImageRGB8 toSRGB8 img+    ]+  where+    toJpeg ::+         (JP.JpgEncodable px, Source r a, Index ix)+      => (Array D ix b -> JP.Image px)+      -> (a -> b)+      -> Array r ix a+      -> BL.ByteString+    toJpeg toJP adjustPixel =+      JP.encodeDirectJpegAtQualityWithMetadata jpegQuality jpegMetadata . toJP . A.map adjustPixel
+ src/Data/Massiv/Array/IO/Image/JuicyPixels/PNG.hs view
@@ -0,0 +1,308 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+-- |+-- Module      : Data.Massiv.Array.IO.Image.JuicyPixels.PNG+-- Copyright   : (c) Alexey Kuleshevich 2019-2021+-- License     : BSD3+-- Maintainer  : Alexey Kuleshevich <lehins@yandex.ru>+-- Stability   : experimental+-- Portability : non-portable+--+module Data.Massiv.Array.IO.Image.JuicyPixels.PNG+  ( PNG(..)+  , decodePNG+  , decodeWithMetadataPNG+  , decodeAutoPNG+  , decodeAutoWithMetadataPNG+  , encodePNG+  , encodeAutoPNG+  ) where++import qualified Codec.Picture as JP+import qualified Codec.Picture.Metadata as JP+import qualified Codec.Picture.Png as JP+import Control.Monad (msum)+import Data.Bifunctor (first)+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL (ByteString)+import Data.Massiv.Array as A+import Data.Massiv.Array.IO.Base+import Data.Massiv.Array.IO.Image.JuicyPixels.Base+import Data.Maybe (fromMaybe)+import Data.Typeable+import qualified Graphics.Pixel as CM+import Graphics.Pixel.ColorSpace+import Prelude as P++--------------------------------------------------------------------------------+-- PNG Format ------------------------------------------------------------------+--------------------------------------------------------------------------------+++-- | Portable Network Graphics image with @.png@ extension.+data PNG = PNG deriving Show++instance FileFormat PNG where+  type Metadata PNG = JP.Metadatas+  ext _ = ".png"++instance Writable PNG (Image A.S CM.X Bit) where+  encodeM f opts img = encodeM f opts (coerceBinaryImage img)++instance Writable PNG (Image S CM.X Word8) where+  encodeM PNG _ img = pure $ JP.encodePng (toJPImageY8 img)++instance Writable PNG (Image S CM.X Word16) where+  encodeM PNG _ img = pure $ JP.encodePng (toJPImageY16 img)++instance Writable PNG (Image S (Alpha CM.X) Word8) where+  encodeM PNG _ img = pure $ JP.encodePng (toJPImageYA8 img)++instance Writable PNG (Image S (Alpha CM.X) Word16) where+  encodeM PNG _ img = pure $ JP.encodePng (toJPImageYA16 img)++instance Writable PNG (Image S CM.RGB Word8) where+  encodeM PNG _ img = pure $ JP.encodePng (toJPImageRGB8 img)++instance Writable PNG (Image S CM.RGB Word16) where+  encodeM PNG _ img = pure $ JP.encodePng (toJPImageRGB16 img)++instance Writable PNG (Image S (Alpha CM.RGB) Word8) where+  encodeM PNG _ img = pure $ JP.encodePng (toJPImageRGBA8 img)++instance Writable PNG (Image S (Alpha CM.RGB) Word16) where+  encodeM PNG _ img = pure $ JP.encodePng (toJPImageRGBA16 img)+++instance Writable PNG (Image S (Y' SRGB) Word8) where+  encodeM f opts = encodeM f opts . toImageBaseModel++instance Writable PNG (Image S (Y' SRGB) Word16) where+  encodeM f opts = encodeM f opts . toImageBaseModel++instance Writable PNG (Image S (Alpha (Y' SRGB)) Word8) where+  encodeM f opts = encodeM f opts . toImageBaseModel++instance Writable PNG (Image S (Alpha (Y' SRGB)) Word16) where+  encodeM f opts = encodeM f opts . toImageBaseModel++instance Writable PNG (Image S (Y D65) Word8) where+  encodeM f opts = encodeM f opts . toImageBaseModel++instance Writable PNG (Image S (Y D65) Word16) where+  encodeM f opts = encodeM f opts . toImageBaseModel++instance Writable PNG (Image S (Alpha (Y D65)) Word8) where+  encodeM f opts = encodeM f opts . toImageBaseModel++instance Writable PNG (Image S (Alpha (Y D65)) Word16) where+  encodeM f opts = encodeM f opts . toImageBaseModel++instance Writable PNG (Image S (SRGB 'NonLinear) Word8) where+  encodeM f opts = encodeM f opts . toImageBaseModel++instance Writable PNG (Image S (SRGB 'NonLinear) Word16) where+  encodeM f opts = encodeM f opts . toImageBaseModel++instance Writable PNG (Image S (Alpha (SRGB 'NonLinear)) Word8) where+  encodeM f opts = encodeM f opts . toImageBaseModel++instance Writable PNG (Image S (Alpha (SRGB 'NonLinear)) Word16) where+  encodeM f opts = encodeM f opts . toImageBaseModel++instance (ColorSpace cs i e, ColorSpace (BaseSpace cs) i e, Source r (Pixel cs e)) =>+         Writable (Auto PNG) (Image r cs e) where+  encodeM f _ = pure . encodeAutoPNG f+++instance Readable PNG (Image S CM.X Word8) where+  decodeWithMetadataM = decodeWithMetadataPNG++instance Readable PNG (Image S CM.X Word16) where+  decodeWithMetadataM = decodeWithMetadataPNG++instance Readable PNG (Image S (Alpha CM.X) Word8) where+  decodeWithMetadataM = decodeWithMetadataPNG++instance Readable PNG (Image S (Alpha CM.X) Word16) where+  decodeWithMetadataM = decodeWithMetadataPNG++instance Readable PNG (Image S CM.RGB Word8) where+  decodeWithMetadataM = decodeWithMetadataPNG++instance Readable PNG (Image S CM.RGB Word16) where+  decodeWithMetadataM = decodeWithMetadataPNG++instance Readable PNG (Image S (Alpha CM.RGB) Word8) where+  decodeWithMetadataM = decodeWithMetadataPNG++instance Readable PNG (Image S (Alpha CM.RGB) Word16) where+  decodeWithMetadataM = decodeWithMetadataPNG+++instance Readable PNG (Image S (Y' SRGB) Word8) where+  decodeWithMetadataM f = fmap (first fromImageBaseModel) . decodeWithMetadataPNG f++instance Readable PNG (Image S (Y' SRGB) Word16) where+  decodeWithMetadataM f = fmap (first fromImageBaseModel) . decodeWithMetadataPNG f++instance Readable PNG (Image S (Alpha (Y' SRGB)) Word8) where+  decodeWithMetadataM f = fmap (first fromImageBaseModel) . decodeWithMetadataPNG f++instance Readable PNG (Image S (Alpha (Y' SRGB)) Word16) where+  decodeWithMetadataM f = fmap (first fromImageBaseModel) . decodeWithMetadataPNG f++instance Readable PNG (Image S (Y D65) Word8) where+  decodeWithMetadataM f = fmap (first fromImageBaseModel) . decodeWithMetadataPNG f++instance Readable PNG (Image S (Y D65) Word16) where+  decodeWithMetadataM f = fmap (first fromImageBaseModel) . decodeWithMetadataPNG f++instance Readable PNG (Image S (Alpha (Y D65)) Word8) where+  decodeWithMetadataM f = fmap (first fromImageBaseModel) . decodeWithMetadataPNG f++instance Readable PNG (Image S (Alpha (Y D65)) Word16) where+  decodeWithMetadataM f = fmap (first fromImageBaseModel) . decodeWithMetadataPNG f++instance Readable PNG (Image S (SRGB 'NonLinear) Word8) where+  decodeWithMetadataM f = fmap (first fromImageBaseModel) . decodeWithMetadataPNG f++instance Readable PNG (Image S (SRGB 'NonLinear) Word16) where+  decodeWithMetadataM f = fmap (first fromImageBaseModel) . decodeWithMetadataPNG f++instance Readable PNG (Image S (Alpha (SRGB 'NonLinear)) Word8) where+  decodeWithMetadataM f = fmap (first fromImageBaseModel) . decodeWithMetadataPNG f++instance Readable PNG (Image S (Alpha (SRGB 'NonLinear)) Word16) where+  decodeWithMetadataM f = fmap (first fromImageBaseModel) . decodeWithMetadataPNG f++-- | Decode a Png Image+decodePNG :: (ColorModel cs e, MonadThrow m) => PNG -> B.ByteString -> m (Image S cs e)+decodePNG f bs = convertWith f (JP.decodePng bs)+{-# INLINE decodePNG #-}++-- | Decode a Png Image+decodeWithMetadataPNG ::+     (ColorModel cs e, MonadThrow m) => PNG -> B.ByteString -> m (Image S cs e, JP.Metadatas)+decodeWithMetadataPNG f bs = convertWithMetadata f (JP.decodePngWithMetadata bs)+{-# INLINE decodeWithMetadataPNG #-}++-- | Decode a Png Image+decodeAutoPNG ::+     (Manifest r (Pixel cs e), ColorSpace cs i e, MonadThrow m)+  => Auto PNG+  -> B.ByteString+  -> m (Image r cs e)+decodeAutoPNG f bs = convertAutoWith f (JP.decodePng bs)+{-# INLINE decodeAutoPNG #-}++-- | Decode a Png Image+decodeAutoWithMetadataPNG ::+     (Manifest r (Pixel cs e), ColorSpace cs i e, MonadThrow m)+  => Auto PNG+  -> B.ByteString+  -> m (Image r cs e, JP.Metadatas)+decodeAutoWithMetadataPNG f bs = convertAutoWithMetadata f (JP.decodePngWithMetadata bs)+{-# INLINE decodeAutoWithMetadataPNG #-}++instance (Manifest r (Pixel cs e), ColorSpace cs i e) =>+         Readable (Auto PNG) (Image r cs e) where+  decodeM = decodeAutoPNG+  decodeWithMetadataM = decodeAutoWithMetadataPNG++encodePNG ::+     forall cs e m. (ColorModel cs e, MonadThrow m)+  => PNG+  -> Image S cs e+  -> m BL.ByteString+encodePNG f img = fromMaybeEncode f (Proxy :: Proxy (Image S cs e)) encoded+  where+    encoded+      | Just Refl <- eqT :: Maybe (Pixel cs e :~: Pixel CM.X Bit) = encodeM PNG () img+      | Just Refl <- eqT :: Maybe (e :~: Word8) =+        msum+          [ JP.encodePng <$> maybeJPImageY8 img+          , JP.encodePng <$> maybeJPImageRGB8 img+          , do Refl <- eqT :: Maybe (cs :~: Alpha (Opaque cs))+               msum [JP.encodePng <$> maybeJPImageYA8 img, JP.encodePng <$> maybeJPImageRGBA8 img]+          ]+      | Just Refl <- eqT :: Maybe (e :~: Word16) =+        msum+          [ JP.encodePng <$> maybeJPImageY16 img+          , JP.encodePng <$> maybeJPImageRGB16 img+          , do Refl <- eqT :: Maybe (cs :~: Alpha (Opaque cs))+               msum [JP.encodePng <$> maybeJPImageYA16 img, JP.encodePng <$> maybeJPImageRGBA16 img]+          ]+      | otherwise = Nothing+++encodeAutoPNG ::+     forall r cs i e. (ColorSpace (BaseSpace cs) i e, ColorSpace cs i e, Source r (Pixel cs e))+  => Auto PNG+  -> Image r cs e+  -> BL.ByteString+encodeAutoPNG _ img =+  fromMaybe (toPng toJPImageRGB16 toSRGB16 img) $+  msum+    [ do Refl <- eqT :: Maybe (r :~: S)+         msum+           [ case eqT :: Maybe (e :~: Word8) of+               Just Refl+                 | Just Refl <- (eqT :: Maybe (BaseModel cs :~: CM.X)) ->+                   pure $ JP.encodePng $ toJPImageY8 (toImageBaseModel img)+                 | Just Refl <- (eqT :: Maybe (BaseModel cs :~: CM.RGB)) ->+                   pure $ JP.encodePng $ toJPImageRGB8 (toImageBaseModel img)+                 | Just Refl <- (eqT :: Maybe (BaseModel cs :~: Alpha CM.X)) ->+                   pure $ JP.encodePng $ toJPImageYA8 (toImageBaseModel img)+                 | Just Refl <- (eqT :: Maybe (BaseModel cs :~: Alpha CM.RGB)) ->+                   pure $ JP.encodePng $ toJPImageRGBA8 (toImageBaseModel img)+               _ -> Nothing+           , case eqT :: Maybe (e :~: Word16) of+               Just Refl+                 | Just Refl <- (eqT :: Maybe (BaseModel cs :~: CM.X)) ->+                   pure $ JP.encodePng $ toJPImageY16 (toImageBaseModel img)+                 | Just Refl <- (eqT :: Maybe (BaseModel cs :~: CM.RGB)) ->+                   pure $ JP.encodePng $ toJPImageRGB16 (toImageBaseModel img)+                 | Just Refl <- (eqT :: Maybe (BaseModel cs :~: Alpha CM.X)) ->+                   pure $ JP.encodePng $ toJPImageYA16 (toImageBaseModel img)+                 | Just Refl <- (eqT :: Maybe (BaseModel cs :~: Alpha CM.RGB)) ->+                   pure $ JP.encodePng $ toJPImageRGBA16 (toImageBaseModel img)+               _ -> Nothing+           ]+    , do Refl <- eqT :: Maybe (BaseModel cs :~: CM.X)+         msum+           [ do Refl <- eqT :: Maybe (e :~: Bit)+                pure $ toPng toJPImageY8 (toPixel8 . toPixelBaseModel) img+           , do Refl <- eqT :: Maybe (e :~: Word8)+                pure $ toPng toJPImageY8 toPixelBaseModel img+           , pure $ toPng toJPImageY16 (toPixel16 . toPixelBaseModel) img+           ]+    , do Refl <- eqT :: Maybe (BaseModel cs :~: Alpha CM.X)+         msum+           [ do Refl <- eqT :: Maybe (e :~: Word8)+                pure $ toPng toJPImageYA8 toPixelBaseModel img+           , pure $ toPng toJPImageYA16 (toPixel16 . toPixelBaseModel) img+           ]+    , do Refl <- eqT :: Maybe (cs :~: Alpha (Opaque cs))+         msum+           [ do Refl <- eqT :: Maybe (e :~: Word8)+                pure $ toPng toJPImageRGBA8 toSRGBA8 img+           , pure $ toPng toJPImageRGBA16 toSRGBA16 img+           ]+    , do Refl <- eqT :: Maybe (e :~: Word8)+         pure $ toPng toJPImageRGB8 toSRGB8 img+    ]+  where+    toPng ::+         (JP.PngSavable px, Source r a, Index ix)+      => (Array D ix b -> JP.Image px)+      -> (a -> b)+      -> Array r ix a+      -> BL.ByteString+    toPng toJP adjustPixel = JP.encodePng . toJP . A.map adjustPixel
+ src/Data/Massiv/Array/IO/Image/JuicyPixels/TGA.hs view
@@ -0,0 +1,201 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+-- |+-- Module      : Data.Massiv.Array.IO.Image.JuicyPixels.TGA+-- Copyright   : (c) Alexey Kuleshevich 2019-2021+-- License     : BSD3+-- Maintainer  : Alexey Kuleshevich <lehins@yandex.ru>+-- Stability   : experimental+-- Portability : non-portable+--+module Data.Massiv.Array.IO.Image.JuicyPixels.TGA+  ( TGA(..)+  , decodeTGA+  , decodeWithMetadataTGA+  , decodeAutoTGA+  , decodeAutoWithMetadataTGA+  , encodeTGA+  , encodeAutoTGA+  ) where++import qualified Codec.Picture as JP+import qualified Codec.Picture.Metadata as JP+import qualified Codec.Picture.Tga as JP+import Control.Monad (msum)+import Data.Bifunctor (first)+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL (ByteString)+import Data.Massiv.Array as A+import Data.Massiv.Array.IO.Base+import Data.Massiv.Array.IO.Image.JuicyPixels.Base+import Data.Maybe (fromMaybe)+import Data.Typeable+import qualified Graphics.Pixel as CM+import Graphics.Pixel.ColorSpace+import Prelude as P+++--------------------------------------------------------------------------------+-- TGA Format ------------------------------------------------------------------+--------------------------------------------------------------------------------+++-- | Truevision Graphics Adapter image with .tga extension.+data TGA = TGA deriving Show++instance FileFormat TGA where+  type Metadata TGA = JP.Metadatas+  ext _ = ".tga"++instance Writable TGA (Image A.S CM.X Bit) where+  encodeM f opts img = encodeM f opts (coerceBinaryImage img)++instance Writable TGA (Image S CM.X Word8) where+  encodeM TGA _ img = pure $ JP.encodeTga (toJPImageY8 img)++instance Writable TGA (Image S CM.RGB Word8) where+  encodeM TGA _ img = pure $ JP.encodeTga (toJPImageRGB8 img)++instance Writable TGA (Image S (Alpha CM.RGB) Word8) where+  encodeM TGA _ img = pure $ JP.encodeTga (toJPImageRGBA8 img)+++instance Writable TGA (Image S (Y' SRGB) Word8) where+  encodeM f opts = encodeM f opts . toImageBaseModel++instance Writable TGA (Image S (Y D65) Word8) where+  encodeM f opts = encodeM f opts . toImageBaseModel++instance Writable TGA (Image S (SRGB 'NonLinear) Word8) where+  encodeM f opts = encodeM f opts . toImageBaseModel++instance Writable TGA (Image S (Alpha (SRGB 'NonLinear)) Word8) where+  encodeM f opts = encodeM f opts . toImageBaseModel+++instance (ColorSpace cs i e, ColorSpace (BaseSpace cs) i e, Source r (Pixel cs e)) =>+         Writable (Auto TGA) (Image r cs e) where+  encodeM f _ = pure . encodeAutoTGA f+++instance Readable TGA (Image S CM.X Word8) where+  decodeWithMetadataM = decodeWithMetadataTGA++instance Readable TGA (Image S CM.RGB Word8) where+  decodeWithMetadataM = decodeWithMetadataTGA++instance Readable TGA (Image S (Alpha CM.RGB) Word8) where+  decodeWithMetadataM = decodeWithMetadataTGA+++instance Readable TGA (Image S (Y' SRGB) Word8) where+  decodeWithMetadataM f = fmap (first fromImageBaseModel) . decodeWithMetadataM f++instance Readable TGA (Image S (Y D65) Word8) where+  decodeWithMetadataM f = fmap (first fromImageBaseModel) . decodeWithMetadataM f++instance Readable TGA (Image S (SRGB 'NonLinear) Word8) where+  decodeWithMetadataM f = fmap (first fromImageBaseModel) . decodeWithMetadataM f++instance Readable TGA (Image S (Alpha (SRGB 'NonLinear)) Word8) where+  decodeWithMetadataM f = fmap (first fromImageBaseModel) . decodeWithMetadataM f++-- | Decode a Tga Image+decodeTGA :: (ColorModel cs e, MonadThrow m) => TGA -> B.ByteString -> m (Image S cs e)+decodeTGA f bs = convertWith f (JP.decodeTga bs)+{-# INLINE decodeTGA #-}++-- | Decode a Tga Image+decodeWithMetadataTGA ::+     (ColorModel cs e, MonadThrow m) => TGA -> B.ByteString -> m (Image S cs e, JP.Metadatas)+decodeWithMetadataTGA f bs = convertWithMetadata f (JP.decodeTgaWithMetadata bs)+{-# INLINE decodeWithMetadataTGA #-}++-- | Decode a Tga Image+decodeAutoTGA ::+     (Manifest r (Pixel cs e), ColorSpace cs i e, MonadThrow m)+  => Auto TGA+  -> B.ByteString+  -> m (Image r cs e)+decodeAutoTGA f bs = convertAutoWith f (JP.decodeTga bs)+{-# INLINE decodeAutoTGA #-}++-- | Decode a Tga Image+decodeAutoWithMetadataTGA ::+     (Manifest r (Pixel cs e), ColorSpace cs i e, MonadThrow m)+  => Auto TGA+  -> B.ByteString+  -> m (Image r cs e, JP.Metadatas)+decodeAutoWithMetadataTGA f bs = convertAutoWithMetadata f (JP.decodeTgaWithMetadata bs)+{-# INLINE decodeAutoWithMetadataTGA #-}+++instance (Manifest r (Pixel cs e), ColorSpace cs i e) =>+         Readable (Auto TGA) (Image r cs e) where+  decodeWithMetadataM = decodeAutoWithMetadataTGA++encodeTGA ::+     forall cs e m. (ColorModel cs e, MonadThrow m)+  => TGA+  -> Image S cs e+  -> m BL.ByteString+encodeTGA f img = fromMaybeEncode f (Proxy :: Proxy (Image S cs e)) encoded+  where+    encoded+      | Just Refl <- eqT :: Maybe (Pixel cs e :~: Pixel CM.X Bit) = encodeM TGA def img+      | Just Refl <- eqT :: Maybe (e :~: Word8) = do+        msum+          [ JP.encodeTga <$> maybeJPImageY8 img+          , JP.encodeTga <$> maybeJPImageRGB8 img+          , do Refl <- eqT :: Maybe (cs :~: Alpha (Opaque cs))+               JP.encodeTga <$> maybeJPImageRGBA8 img+          ]+      | otherwise = Nothing++encodeAutoTGA ::+     forall r cs i e.+     ( ColorSpace (BaseSpace cs) i e+     , ColorSpace cs i e+     , Source r (Pixel cs e)+     )+  => Auto TGA+  -> Image r cs e+  -> BL.ByteString+encodeAutoTGA _ img =+  fromMaybe (toTga toJPImageRGB8 toSRGB8 img) $+  msum+    [ do Refl <- eqT :: Maybe (r :~: S)+         case eqT :: Maybe (e :~: Word8) of+           Just Refl+             | Just Refl <- (eqT :: Maybe (BaseModel cs :~: CM.X)) ->+               pure $ JP.encodeTga $ toJPImageY8 (toImageBaseModel img)+             | Just Refl <- (eqT :: Maybe (BaseModel cs :~: CM.RGB)) ->+               pure $ JP.encodeTga $ toJPImageRGB8 (toImageBaseModel img)+             | Just Refl <- (eqT :: Maybe (BaseModel cs :~: Alpha CM.RGB)) ->+               pure $ JP.encodeTga $ toJPImageRGBA8 (toImageBaseModel img)+           _ -> Nothing+    , do Refl <- eqT :: Maybe (BaseModel cs :~: CM.X)+         msum+           [ do Refl <- eqT :: Maybe (e :~: Bit)+                pure $ toTga toJPImageY8 (toPixel8 . toPixelBaseModel) img+           , do Refl <- eqT :: Maybe (e :~: Word8)+                pure $ toTga toJPImageY8 toPixelBaseModel img+           , pure $ toTga toJPImageY8 (toPixel8 . toPixelBaseModel) img+           ]+    , do Refl <- eqT :: Maybe (cs :~: Alpha (Opaque cs))+         pure $ toTga toJPImageRGBA8 toSRGBA8 img+    ]+  where+    toTga ::+         (JP.TgaSaveable px, Source r a, Index ix)+      => (Array D ix b -> JP.Image px)+      -> (a -> b)+      -> Array r ix a+      -> BL.ByteString+    toTga toJP adjustPixel = JP.encodeTga . toJP . A.map adjustPixel
+ src/Data/Massiv/Array/IO/Image/JuicyPixels/TIF.hs view
@@ -0,0 +1,423 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+-- |+-- Module      : Data.Massiv.Array.IO.Image.JuicyPixels.TIF+-- Copyright   : (c) Alexey Kuleshevich 2019-2021+-- License     : BSD3+-- Maintainer  : Alexey Kuleshevich <lehins@yandex.ru>+-- Stability   : experimental+-- Portability : non-portable+--+module Data.Massiv.Array.IO.Image.JuicyPixels.TIF+  ( TIF(..)+  , decodeTIF+  , decodeWithMetadataTIF+  , decodeAutoTIF+  , decodeAutoWithMetadataTIF+  , encodeTIF+  , encodeAutoTIF+  ) where++import qualified Codec.Picture as JP+import qualified Codec.Picture.Metadata as JP+import qualified Codec.Picture.Tiff as JP+import Control.Monad (msum)+import Data.Bifunctor (first)+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL (ByteString)+import Data.Massiv.Array as A+import Data.Massiv.Array.IO.Base+import Data.Massiv.Array.IO.Image.JuicyPixels.Base+import Data.Maybe (fromMaybe)+import Data.Typeable+import qualified Graphics.Pixel as CM+import Graphics.Pixel.ColorSpace+import Prelude as P++++--------------------------------------------------------------------------------+-- TIF Format ------------------------------------------------------------------+--------------------------------------------------------------------------------++-- TODOs:+--  * Check on reading in YCbCr+--  * Check on "except for Y32 which is truncated to 16 bits" in `JP.decodeTiff` doc.+++-- | Tagged Image File Format image with @.tif@ or @.tiff@ extension.+data TIF = TIF deriving Show++instance FileFormat TIF where+  type Metadata TIF = JP.Metadatas+  ext _ = ".tif"+  exts _ = [".tif", ".tiff"]++instance Writable TIF (Image A.S CM.X Bit) where+  encodeM f opts img = encodeM f opts (coerceBinaryImage img)++instance Writable TIF (Image S CM.X Word8) where+  encodeM TIF _ img = pure $ JP.encodeTiff (toJPImageY8 img)++instance Writable TIF (Image S CM.X Word16) where+  encodeM TIF _ img = pure $ JP.encodeTiff (toJPImageY16 img)++instance Writable TIF (Image S CM.X Word32) where+  encodeM TIF _ img = pure $ JP.encodeTiff (toJPImageY32 img)++instance Writable TIF (Image S CM.X Float) where+  encodeM TIF _ img = pure $ JP.encodeTiff (toJPImageYF img)++instance Writable TIF (Image S (Alpha CM.X) Word8) where+  encodeM TIF _ img = pure $ JP.encodeTiff (toJPImageYA8 img)++instance Writable TIF (Image S (Alpha CM.X) Word16) where+  encodeM TIF _ img = pure $ JP.encodeTiff (toJPImageYA16 img)++instance Writable TIF (Image S CM.RGB Word8) where+  encodeM TIF _ img = pure $ JP.encodeTiff (toJPImageRGB8 img)++instance Writable TIF (Image S CM.RGB Word16) where+  encodeM TIF _ img = pure $ JP.encodeTiff (toJPImageRGB16 img)++instance Writable TIF (Image S (Alpha CM.RGB) Word8) where+  encodeM TIF _ img = pure $ JP.encodeTiff (toJPImageRGBA8 img)++instance Writable TIF (Image S (Alpha CM.RGB) Word16) where+  encodeM TIF _ img = pure $ JP.encodeTiff (toJPImageRGBA16 img)++instance Writable TIF (Image S CM.YCbCr Word8) where+  encodeM TIF _ img = pure $ JP.encodeTiff (toJPImageYCbCr8 img)++instance Writable TIF (Image S CM.CMYK Word8) where+  encodeM TIF _ img = pure $ JP.encodeTiff (toJPImageCMYK8 img)++instance Writable TIF (Image S CM.CMYK Word16) where+  encodeM TIF _ img = pure $ JP.encodeTiff (toJPImageCMYK16 img)++instance Writable TIF (Image S (Y' SRGB) Word8) where+  encodeM f opts = encodeM f opts . toImageBaseModel++instance Writable TIF (Image S (Y' SRGB) Word16) where+  encodeM f opts = encodeM f opts . toImageBaseModel++instance Writable TIF (Image S (Y' SRGB) Word32) where+  encodeM f opts = encodeM f opts . toImageBaseModel++instance Writable TIF (Image S (Y' SRGB) Float) where+  encodeM f opts = encodeM f opts . toImageBaseModel++instance Writable TIF (Image S (Alpha (Y' SRGB)) Word8) where+  encodeM f opts = encodeM f opts . toImageBaseModel++instance Writable TIF (Image S (Alpha (Y' SRGB)) Word16) where+  encodeM f opts = encodeM f opts . toImageBaseModel++instance Writable TIF (Image S (Y D65) Word8) where+  encodeM f opts = encodeM f opts . toImageBaseModel++instance Writable TIF (Image S (Y D65) Word16) where+  encodeM f opts = encodeM f opts . toImageBaseModel++instance Writable TIF (Image S (Y D65) Word32) where+  encodeM f opts = encodeM f opts . toImageBaseModel++instance Writable TIF (Image S (Y D65) Float) where+  encodeM f opts = encodeM f opts . toImageBaseModel++instance Writable TIF (Image S (Alpha (Y D65)) Word8) where+  encodeM f opts = encodeM f opts . toImageBaseModel++instance Writable TIF (Image S (Alpha (Y D65)) Word16) where+  encodeM f opts = encodeM f opts . toImageBaseModel++instance Writable TIF (Image S (SRGB 'NonLinear) Word8) where+  encodeM f opts = encodeM f opts . toImageBaseModel++instance Writable TIF (Image S (SRGB 'NonLinear) Word16) where+  encodeM f opts = encodeM f opts . toImageBaseModel++instance Writable TIF (Image S (Alpha (SRGB 'NonLinear)) Word8) where+  encodeM f opts = encodeM f opts . toImageBaseModel++instance Writable TIF (Image S (Alpha (SRGB 'NonLinear)) Word16) where+  encodeM f opts = encodeM f opts . toImageBaseModel++instance Writable TIF (Image S (Y'CbCr SRGB) Word8) where+  encodeM f opts = encodeM f opts . toImageBaseModel++instance Writable TIF (Image S (CMYK (SRGB 'NonLinear)) Word8) where+  encodeM f opts = encodeM f opts . toImageBaseModel++instance Writable TIF (Image S (CMYK (SRGB 'NonLinear)) Word16) where+  encodeM f opts = encodeM f opts . toImageBaseModel++instance (ColorSpace cs i e, ColorSpace (BaseSpace cs) i e, Source r (Pixel cs e)) =>+         Writable (Auto TIF) (Image r cs e) where+  encodeM f _ = pure . encodeAutoTIF f+++instance Readable TIF (Image S CM.X Word8) where+  decodeWithMetadataM = decodeWithMetadataTIF++instance Readable TIF (Image S CM.X Word16) where+  decodeWithMetadataM = decodeWithMetadataTIF++instance Readable TIF (Image S CM.X Word32) where+  decodeWithMetadataM = decodeWithMetadataTIF++instance Readable TIF (Image S CM.X Float) where+  decodeWithMetadataM = decodeWithMetadataTIF++instance Readable TIF (Image S (Alpha CM.X) Word8) where+  decodeWithMetadataM = decodeWithMetadataTIF++instance Readable TIF (Image S (Alpha CM.X) Word16) where+  decodeWithMetadataM = decodeWithMetadataTIF++instance Readable TIF (Image S CM.RGB Word8) where+  decodeWithMetadataM = decodeWithMetadataTIF++instance Readable TIF (Image S CM.RGB Word16) where+  decodeWithMetadataM = decodeWithMetadataTIF++instance Readable TIF (Image S (Alpha CM.RGB) Word8) where+  decodeWithMetadataM = decodeWithMetadataTIF++instance Readable TIF (Image S (Alpha CM.RGB) Word16) where+  decodeWithMetadataM = decodeWithMetadataTIF++instance Readable TIF (Image S CM.CMYK Word8) where+  decodeWithMetadataM = decodeWithMetadataTIF++instance Readable TIF (Image S CM.CMYK Word16) where+  decodeWithMetadataM = decodeWithMetadataTIF+++instance Readable TIF (Image S (Y' SRGB) Word8) where+  decodeWithMetadataM f = fmap (first fromImageBaseModel) . decodeWithMetadataM f++instance Readable TIF (Image S (Y' SRGB) Word16) where+  decodeWithMetadataM f = fmap (first fromImageBaseModel) . decodeWithMetadataM f++instance Readable TIF (Image S (Y' SRGB) Word32) where+  decodeWithMetadataM f = fmap (first fromImageBaseModel) . decodeWithMetadataM f++instance Readable TIF (Image S (Y' SRGB) Float) where+  decodeWithMetadataM f = fmap (first fromImageBaseModel) . decodeWithMetadataM f++instance Readable TIF (Image S (Alpha (Y' SRGB)) Word8) where+  decodeWithMetadataM f = fmap (first fromImageBaseModel) . decodeWithMetadataM f++instance Readable TIF (Image S (Alpha (Y' SRGB)) Word16) where+  decodeWithMetadataM f = fmap (first fromImageBaseModel) . decodeWithMetadataM f++instance Readable TIF (Image S (Y D65) Word8) where+  decodeWithMetadataM f = fmap (first fromImageBaseModel) . decodeWithMetadataM f++instance Readable TIF (Image S (Y D65) Word16) where+  decodeWithMetadataM f = fmap (first fromImageBaseModel) . decodeWithMetadataM f++instance Readable TIF (Image S (Y D65) Word32) where+  decodeWithMetadataM f = fmap (first fromImageBaseModel) . decodeWithMetadataM f++instance Readable TIF (Image S (Y D65) Float) where+  decodeWithMetadataM f = fmap (first fromImageBaseModel) . decodeWithMetadataM f++instance Readable TIF (Image S (Alpha (Y D65)) Word8) where+  decodeWithMetadataM f = fmap (first fromImageBaseModel) . decodeWithMetadataM f++instance Readable TIF (Image S (Alpha (Y D65)) Word16) where+  decodeWithMetadataM f = fmap (first fromImageBaseModel) . decodeWithMetadataM f++instance Readable TIF (Image S (SRGB 'NonLinear) Word8) where+  decodeWithMetadataM f = fmap (first fromImageBaseModel) . decodeWithMetadataM f++instance Readable TIF (Image S (SRGB 'NonLinear) Word16) where+  decodeWithMetadataM f = fmap (first fromImageBaseModel) . decodeWithMetadataM f++instance Readable TIF (Image S (Alpha (SRGB 'NonLinear)) Word8) where+  decodeWithMetadataM f = fmap (first fromImageBaseModel) . decodeWithMetadataM f++instance Readable TIF (Image S (Alpha (SRGB 'NonLinear)) Word16) where+  decodeWithMetadataM f = fmap (first fromImageBaseModel) . decodeWithMetadataM f++instance Readable TIF (Image S (CMYK (SRGB 'NonLinear)) Word8) where+  decodeWithMetadataM f = fmap (first fromImageBaseModel) . decodeWithMetadataM f++instance Readable TIF (Image S (CMYK (SRGB 'NonLinear)) Word16) where+  decodeWithMetadataM f = fmap (first fromImageBaseModel) . decodeWithMetadataM f++-- | Decode a Tiff Image+decodeTIF :: (ColorModel cs e, MonadThrow m) => TIF -> B.ByteString -> m (Image S cs e)+decodeTIF f bs = convertWith f (JP.decodeTiff bs)+{-# INLINE decodeTIF #-}++-- | Decode a Tiff Image+decodeWithMetadataTIF ::+     (ColorModel cs e, MonadThrow m) => TIF -> B.ByteString -> m (Image S cs e, JP.Metadatas)+decodeWithMetadataTIF f bs = convertWithMetadata f (JP.decodeTiffWithMetadata bs)+{-# INLINE decodeWithMetadataTIF #-}++-- | Decode a Tiff Image+decodeAutoTIF ::+     (Manifest r (Pixel cs e), ColorSpace cs i e, MonadThrow m)+  => Auto TIF+  -> B.ByteString+  -> m (Image r cs e)+decodeAutoTIF f bs = convertAutoWith f (JP.decodeTiff bs)+{-# INLINE decodeAutoTIF #-}++-- | Decode a Tiff Image+decodeAutoWithMetadataTIF ::+     (Manifest r (Pixel cs e), ColorSpace cs i e, MonadThrow m)+  => Auto TIF+  -> B.ByteString+  -> m (Image r cs e, JP.Metadatas)+decodeAutoWithMetadataTIF f bs = convertAutoWithMetadata f (JP.decodeTiffWithMetadata bs)+{-# INLINE decodeAutoWithMetadataTIF #-}++instance (Manifest r (Pixel cs e), ColorSpace cs i e) =>+         Readable (Auto TIF) (Image r cs e) where+  decodeM = decodeAutoTIF+  decodeWithMetadataM = decodeAutoWithMetadataTIF++encodeTIF ::+     forall cs e m.+     (ColorModel cs e, MonadThrow m)+  => TIF+  -> Image S cs e+  -> m BL.ByteString+encodeTIF f img = fromMaybeEncode f (Proxy :: Proxy (Image S cs e)) encoded+  where+    encoded+      | Just Refl <- eqT :: Maybe (Pixel cs e :~: Pixel CM.X Bit) = encodeM TIF def img+      | Just Refl <- eqT :: Maybe (e :~: Word8) =+        msum+          [ JP.encodeTiff <$> maybeJPImageY8 img+          , JP.encodeTiff <$> maybeJPImageRGB8 img+          , do Refl <- eqT :: Maybe (cs :~: Alpha (Opaque cs))+               msum [JP.encodeTiff <$> maybeJPImageYA8 img, JP.encodeTiff <$> maybeJPImageRGBA8 img]+          , JP.encodeTiff <$> maybeJPImageYCbCr8 img+          , JP.encodeTiff <$> maybeJPImageCMYK8 img+          ]+      | Just Refl <- eqT :: Maybe (e :~: Word16) =+        msum+          [ JP.encodeTiff <$> maybeJPImageY16 img+          , JP.encodeTiff <$> maybeJPImageRGB16 img+          , do Refl <- eqT :: Maybe (cs :~: Alpha (Opaque cs))+               msum+                 [JP.encodeTiff <$> maybeJPImageYA16 img, JP.encodeTiff <$> maybeJPImageRGBA16 img]+          , JP.encodeTiff <$> maybeJPImageCMYK16 img+          ]+      | Just Refl <- eqT :: Maybe (e :~: Word32) = JP.encodeTiff <$> maybeJPImageY32 img+      | Just Refl <- eqT :: Maybe (e :~: Float) = JP.encodeTiff <$> maybeJPImageYF img+      | otherwise = Nothing++++encodeAutoTIF ::+     forall r cs i e. (ColorSpace (BaseSpace cs) i e, ColorSpace cs i e, Source r (Pixel cs e))+  => Auto TIF+  -> Image r cs e+  -> BL.ByteString+encodeAutoTIF _ img =+  fromMaybe (toTiff toJPImageRGB8 toSRGB8 img) $+  msum+    [ do Refl <- eqT :: Maybe (r :~: S)+         msum+           [ case eqT :: Maybe (e :~: Word8) of+               Just Refl+                 | Just Refl <- (eqT :: Maybe (BaseModel cs :~: CM.X)) ->+                   pure $ JP.encodeTiff $ toJPImageY8 (toImageBaseModel img)+                 | Just Refl <- (eqT :: Maybe (BaseModel cs :~: CM.RGB)) ->+                   pure $ JP.encodeTiff $ toJPImageRGB8 (toImageBaseModel img)+                 | Just Refl <- (eqT :: Maybe (BaseModel cs :~: CM.YCbCr)) ->+                   pure $ JP.encodeTiff $ toJPImageYCbCr8 (toImageBaseModel img)+                 | Just Refl <- (eqT :: Maybe (BaseModel cs :~: CM.CMYK)) ->+                   pure $ JP.encodeTiff $ toJPImageCMYK8 (toImageBaseModel img)+                 | Just Refl <- (eqT :: Maybe (BaseModel cs :~: Alpha CM.X)) ->+                   pure $ JP.encodeTiff $ toJPImageYA8 (toImageBaseModel img)+                 | Just Refl <- (eqT :: Maybe (BaseModel cs :~: Alpha CM.RGB)) ->+                   pure $ JP.encodeTiff $ toJPImageRGBA8 (toImageBaseModel img)+               _ -> Nothing+           , case eqT :: Maybe (e :~: Word16) of+               Just Refl+                 | Just Refl <- (eqT :: Maybe (BaseModel cs :~: CM.X)) ->+                   pure $ JP.encodeTiff $ toJPImageY16 (toImageBaseModel img)+                 | Just Refl <- (eqT :: Maybe (BaseModel cs :~: CM.RGB)) ->+                   pure $ JP.encodeTiff $ toJPImageRGB16 (toImageBaseModel img)+                 | Just Refl <- (eqT :: Maybe (BaseModel cs :~: CM.CMYK)) ->+                   pure $ JP.encodeTiff $ toJPImageCMYK16 (toImageBaseModel img)+                 | Just Refl <- (eqT :: Maybe (BaseModel cs :~: Alpha CM.X)) ->+                   pure $ JP.encodeTiff $ toJPImageYA16 (toImageBaseModel img)+                 | Just Refl <- (eqT :: Maybe (BaseModel cs :~: Alpha CM.RGB)) ->+                   pure $ JP.encodeTiff $ toJPImageRGBA16 (toImageBaseModel img)+               _ -> Nothing+           , do Refl <- eqT :: Maybe (e :~: Word32)+                Refl <- eqT :: Maybe (BaseModel cs :~: CM.X)+                pure $ JP.encodeTiff $ toJPImageY32 (toImageBaseModel img)+           , do Refl <- eqT :: Maybe (e :~: Float)+                Refl <- eqT :: Maybe (BaseModel cs :~: CM.X)+                pure $ JP.encodeTiff $ toJPImageYF (toImageBaseModel img)+           ]+    , do Refl <- eqT :: Maybe (BaseModel cs :~: CM.X)+         msum+           [ do Refl <- eqT :: Maybe (e :~: Bit)+                pure $ toTiff toJPImageY8 (toPixel8 . toPixelBaseModel) img+           , do Refl <- eqT :: Maybe (e :~: Word8)+                pure $ toTiff toJPImageY8 toPixelBaseModel img+           , do Refl <- eqT :: Maybe (e :~: Word16)+                pure $ toTiff toJPImageY16 toPixelBaseModel img+           , do Refl <- eqT :: Maybe (e :~: Word32)+                pure $ toTiff toJPImageY32 toPixelBaseModel img+           , do Refl <- eqT :: Maybe (e :~: Float)+                pure $ toTiff toJPImageYF toPixelBaseModel img+           , pure $ toTiff toJPImageY16 (toPixel16 . toPixelBaseModel) img+           ]+    , do Refl <- eqT :: Maybe (BaseModel cs :~: Alpha CM.X)+         msum+           [ do Refl <- eqT :: Maybe (e :~: Word8)+                pure $ toTiff toJPImageYA8 toPixelBaseModel img+           , do Refl <- eqT :: Maybe (e :~: Word16)+                pure $ toTiff toJPImageYA16 toPixelBaseModel img+           , pure $ toTiff toJPImageYA16 (toPixel16 . toPixelBaseModel) img+           ]+    , do Refl <- eqT :: Maybe (BaseModel cs :~: CM.YCbCr)+         pure $ toTiff toJPImageYCbCr8 toYCbCr8 img+    , do Refl <- eqT :: Maybe (BaseModel cs :~: CM.CMYK)+         msum+           [ do Refl <- eqT :: Maybe (e :~: Word16)+                pure $ toTiff toJPImageCMYK16 toCMYK16 img+             -- for CMYK default is 8bit, instead of 16bit, since many viewers and editors+             -- don't support the latter.+           , pure $ toTiff toJPImageCMYK8 toCMYK8 img+           ]+    , do Refl <- eqT :: Maybe (BaseModel cs :~: CM.RGB)+         msum+           [ do Refl <- eqT :: Maybe (e :~: Word8)+                pure $ toTiff toJPImageRGB8 toSRGB8 img+           , pure $ toTiff toJPImageRGB16 toSRGB16 img+           ]+    , do Refl <- eqT :: Maybe (cs :~: Alpha (Opaque cs))+         msum+           [ do Refl <- eqT :: Maybe (e :~: Word8)+                pure $ toTiff toJPImageRGBA8 toSRGBA8 img+           , pure $ toTiff toJPImageRGBA16 toSRGBA16 img+           ]+    ]+  where+    toTiff ::+         (JP.TiffSaveable px, Source r a, Index ix)+      => (Array D ix b -> JP.Image px)+      -> (a -> b)+      -> Array r ix a+      -> BL.ByteString+    toTiff toJP adjustPixel = JP.encodeTiff . toJP . A.map adjustPixel
src/Data/Massiv/Array/IO/Image/Netpbm.hs view
@@ -1,17 +1,16 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-}-{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE UndecidableInstances #-} -- | -- Module      : Data.Massiv.Array.IO.Image.Netpbm--- Copyright   : (c) Alexey Kuleshevich 2018-2019+-- Copyright   : (c) Alexey Kuleshevich 2018-2021 -- License     : BSD3 -- Maintainer  : Alexey Kuleshevich <lehins@yandex.ru> -- Stability   : experimental@@ -25,156 +24,136 @@   , PGM(..)     -- ** PPM   , PPM(..)+  , decodeNetpbmImage+  , decodeNetpbmImageSequence+  , decodeAutoNetpbmImage+  , decodeAutoNetpbmImageSequence   ) where -import Control.Exception import Control.Monad (guard)+import Data.Bifunctor (first) import qualified Data.ByteString as B (ByteString)-import Data.Massiv.Array as M+import Data.Massiv.Array as A import Data.Massiv.Array.IO.Base-import Data.Massiv.Array.IO.Image.JuicyPixels (toAnyCS)-import Data.Massiv.Array.Manifest.Vector import Data.Typeable import qualified Data.Vector.Storable as V-import Foreign.Storable (Storable)-import Graphics.ColorSpace import Graphics.Netpbm as Netpbm hiding (PPM) import qualified Graphics.Netpbm as Netpbm (PPM(..))+import qualified Graphics.Pixel as CM+import Graphics.Pixel.ColorSpace import Prelude as P -#if !MIN_VERSION_massiv(0, 2, 7)-pattern Sz :: ix -> ix-pattern Sz ix = ix-type Sz ix = ix-#endif-#if !MIN_VERSION_massiv(0, 3, 0)-fromVectorM ::-     (Construct S ix a, Mutable S ix a, Storable a)-  => Comp-  -> Sz ix-  -> V.Vector a-  -> Maybe (Array S ix a)-fromVectorM comp sz = pure . fromVector comp sz-#endif- -- | Netpbm: portable bitmap image with @.pbm@ extension. data PBM = PBM deriving Show  instance FileFormat PBM where+  type Metadata PBM = Maybe B.ByteString   ext _ = ".pbm"  instance FileFormat (Sequence PBM) where   type WriteOptions (Sequence PBM) = WriteOptions PBM-  ext _ = ext PBM--instance FileFormat (Sequence (Auto PBM)) where-  type WriteOptions (Sequence (Auto PBM)) = WriteOptions PBM+  type Metadata (Sequence PBM) = Maybe B.ByteString   ext _ = ext PBM  -instance ColorSpace cs e => Readable PBM (Image S cs e) where-  decode f _ = decodePPM f fromNetpbmImage--instance (Mutable r Ix2 (Pixel cs e), ColorSpace cs e) =>-         Readable (Auto PBM) (Image r cs e) where-  decode f _ = decodePPM f fromNetpbmImageAuto--instance ColorSpace cs e => Readable (Sequence PBM) (Array B Ix1 (Image S cs e)) where-  decode f _ = decodePPMs f fromNetpbmImage--instance (Mutable r Ix2 (Pixel cs e), ColorSpace cs e) =>-         Readable (Sequence (Auto PBM)) (Array B Ix1 (Image r cs e)) where-  decode f _ = decodePPMs f fromNetpbmImageAuto--- -- | Netpbm: portable graymap image with @.pgm@ extension. data PGM = PGM deriving Show  instance FileFormat PGM where+  type Metadata PGM = Maybe B.ByteString   ext _ = ".pgm"  instance FileFormat (Sequence PGM) where   type WriteOptions (Sequence PGM) = WriteOptions PGM-  ext _ = ext PGM--instance FileFormat (Sequence (Auto PGM)) where-  type WriteOptions (Sequence (Auto PGM)) = WriteOptions PGM+  type Metadata (Sequence PGM) = Maybe B.ByteString   ext _ = ext PGM  -instance ColorSpace cs e => Readable PGM (Image S cs e) where-  decode f _ = decodePPM f fromNetpbmImage---instance (Mutable r Ix2 (Pixel cs e), ColorSpace cs e) =>-         Readable (Auto PGM) (Image r cs e) where-  decode f _ = decodePPM f fromNetpbmImageAuto---instance ColorSpace cs e => Readable (Sequence PGM) (Array B Ix1 (Image S cs e)) where-  decode f _ = decodePPMs f fromNetpbmImage---instance (Mutable r Ix2 (Pixel cs e), ColorSpace cs e) =>-         Readable (Sequence (Auto PGM)) (Array B Ix1 (Image r cs e)) where-  decode f _ = decodePPMs f fromNetpbmImageAuto-- -- | Netpbm: portable pixmap image with @.ppm@ extension. data PPM = PPM deriving Show  instance FileFormat PPM where+  type Metadata PPM = Maybe B.ByteString   ext _ = ".ppm"   exts _ = [".ppm", ".pnm"]  instance FileFormat (Sequence PPM) where   type WriteOptions (Sequence PPM) = WriteOptions PPM-  ext _ = ext PPM--instance FileFormat (Sequence (Auto PPM)) where-  type WriteOptions (Sequence (Auto PPM)) = WriteOptions PPM+  type Metadata (Sequence PPM) = Maybe B.ByteString   ext _ = ext PPM --instance ColorSpace cs e => Readable PPM (Image S cs e) where-  decode f _ = decodePPM f fromNetpbmImage--instance (Mutable r Ix2 (Pixel cs e), ColorSpace cs e) =>-         Readable (Auto PPM) (Image r cs e) where-  decode f _ = decodePPM f fromNetpbmImageAuto--instance ColorSpace cs e => Readable (Sequence PPM) (Array B Ix1 (Image S cs e)) where-  decode f _ = decodePPMs f fromNetpbmImage+-- | Try to decode a Netpbm image+--+-- @since 0.2.0+decodeNetpbmImage ::+     (FileFormat f, ColorModel cs e, MonadThrow m)+  => f+  -> B.ByteString+  -> m (Image S cs e, Maybe B.ByteString)+decodeNetpbmImage = decodePPM fromNetpbmImage+{-# INLINE decodeNetpbmImage #-} -instance (Mutable r Ix2 (Pixel cs e), ColorSpace cs e) =>-         Readable (Sequence (Auto PPM)) (Array B Ix1 (Image r cs e)) where-  decode f _ = decodePPMs f fromNetpbmImageAuto+-- | Try to decode a Netpbm image sequence+--+-- @since 0.2.0+decodeNetpbmImageSequence ::+     (FileFormat (Sequence f), ColorModel cs e, MonadThrow m)+  => Sequence f+  -> B.ByteString+  -> m ([Image S cs e], Maybe B.ByteString)+decodeNetpbmImageSequence = decodePPMs fromNetpbmImage+{-# INLINE decodeNetpbmImageSequence #-} +-- | Try to decode a Netpbm image, while auto converting the colorspace.+--+-- @since 0.2.0+decodeAutoNetpbmImage ::+     (FileFormat f, Manifest r (Pixel cs e), MonadThrow m, ColorSpace cs i e)+  => f+  -> B.ByteString+  -> m (Image r cs e, Maybe B.ByteString)+decodeAutoNetpbmImage = decodePPM fromNetpbmImageAuto+{-# INLINE decodeAutoNetpbmImage #-} +-- | Try to decode a Netpbm image sequence, while auto converting the colorspace.+--+-- @since 0.2.0+decodeAutoNetpbmImageSequence ::+     (FileFormat (Sequence f), Manifest r (Pixel cs e), MonadThrow m, ColorSpace cs i e)+  => Auto (Sequence f)+  -> B.ByteString+  -> m ([Image r cs e], Maybe B.ByteString)+decodeAutoNetpbmImageSequence = decodePPMs fromNetpbmImageAuto+{-# INLINE decodeAutoNetpbmImageSequence #-} -decodePPMs :: (FileFormat f, Mutable r Ix2 (Pixel cs e), ColorSpace cs e) =>-              f-           -> (Netpbm.PPM -> Maybe (Image r cs e))+decodePPMs :: (FileFormat f, Manifest r (Pixel cs e), ColorModel cs e, MonadThrow m) =>+              (Netpbm.PPM -> Maybe (Image r cs e))+           -> f            -> B.ByteString-           -> Array B Ix1 (Image r cs e)-decodePPMs f converter bs =-  either (throw . DecodeError) (fromList Seq) $-  P.map (fromEitherDecode f showNetpbmCS converter . Right) . fst <$>-  parsePPM bs+           -> m ([Image r cs e], Maybe B.ByteString)+decodePPMs converter f bs =+  case parsePPM bs of+    Left err -> throwM $ DecodeError err+    Right ([], Just _) -> throwM $ DecodeError "Cannot parse PNM image"+    Right (ppms, leftOver) -> do+      imgs <- P.traverse (fromMaybeDecode f showNetpbmCS converter) ppms+      pure (imgs, leftOver) {-# INLINE decodePPMs #-}  -decodePPM :: (FileFormat f, Mutable r Ix2 (Pixel cs e), ColorSpace cs e) =>-             f-          -> (Netpbm.PPM -> Maybe (Image r cs e))+decodePPM :: (FileFormat f, Manifest r (Pixel cs e), ColorModel cs e, MonadThrow m) =>+             (Netpbm.PPM -> Maybe (Image r cs e))+          -> f           -> B.ByteString-          -> Image r cs e-decodePPM f decoder bs = fromEitherDecode f showNetpbmCS decoder $ do-  (ppms, _) <- parsePPM bs-  case ppms of-    []      -> Left "Cannot parse PNM image"-    (ppm:_) -> Right ppm+          -> m (Image r cs e, Maybe B.ByteString)+decodePPM decoder f bs =+  case parsePPM bs of+    Left err -> throwM $ DecodeError err+    Right ([], Nothing) -> throwM $ DecodeError "PNM image is empty"+    Right ([], _) -> throwM $ DecodeError "Cannot parse PNM image"+    Right (ppm:_, leftover) -> do+      img <- fromMaybeDecode f showNetpbmCS decoder ppm+      pure (img, leftover) {-# INLINE decodePPM #-}  @@ -183,54 +162,144 @@   => Int -> Int -> V.Vector a -> Maybe (Image S cs e) fromNetpbmImageUnsafe m n v = do   guard (n * m == V.length v)-  fromVectorM Par (Sz (m :. n)) $ V.unsafeCast v-+  unsafeFromStorableVectorM (Sz (m :. n)) v   showNetpbmCS :: Netpbm.PPM -> String showNetpbmCS Netpbm.PPM {ppmData} =   case ppmData of-    PbmPixelData _      -> "Image S X Bit"+    PbmPixelData _      -> "Image S Y Bit"     PgmPixelData8 _     -> "Image S Y Word8"     PgmPixelData16 _    -> "Image S Y Word16"     PpmPixelDataRGB8 _  -> "Image S RGB Word8"     PpmPixelDataRGB16 _ -> "Image S RGB Word16"  ++instance Readable PBM (Image S CM.X Bit) where+  decodeWithMetadataM = decodeNetpbmImage+instance Readable PBM (Image S (Y D65) Bit) where+  decodeWithMetadataM f = fmap (first fromImageBaseModel) . decodeWithMetadataM f+++instance Readable (Sequence PBM) [Image S CM.X Bit] where+  decodeWithMetadataM = decodePPMs fromNetpbmImage+instance Readable (Sequence PBM) [Image S (Y D65) Bit] where+  decodeWithMetadataM f = fmap (first (fmap fromImageBaseModel)) . decodeWithMetadataM f+++instance Readable PGM (Image S CM.X Word8) where+  decodeWithMetadataM = decodeNetpbmImage+instance Readable PGM (Image S CM.X Word16) where+  decodeWithMetadataM = decodeNetpbmImage+++instance Readable PGM (Image S (Y' SRGB) Word8) where+  decodeWithMetadataM f = fmap (first fromImageBaseModel) . decodeWithMetadataM f+instance Readable PGM (Image S (Y' SRGB) Word16) where+  decodeWithMetadataM f = fmap (first fromImageBaseModel) . decodeWithMetadataM f+instance Readable PGM (Image S (Y D65) Word8) where+  decodeWithMetadataM f = fmap (first fromImageBaseModel) . decodeWithMetadataM f+instance Readable PGM (Image S (Y D65) Word16) where+  decodeWithMetadataM f = fmap (first fromImageBaseModel) . decodeWithMetadataM f+++instance Readable (Sequence PGM) [Image S CM.X Word8] where+  decodeWithMetadataM = decodePPMs fromNetpbmImage+instance Readable (Sequence PGM) [Image S CM.X Word16] where+  decodeWithMetadataM = decodePPMs fromNetpbmImage+++instance Readable (Sequence PGM) [Image S (Y' SRGB) Word8] where+  decodeWithMetadataM f = fmap (first (fmap fromImageBaseModel)) . decodeWithMetadataM f+instance Readable (Sequence PGM) [Image S (Y' SRGB) Word16] where+  decodeWithMetadataM f = fmap (first (fmap fromImageBaseModel)) . decodeWithMetadataM f+instance Readable (Sequence PGM) [Image S (Y D65) Word8] where+  decodeWithMetadataM f = fmap (first (fmap fromImageBaseModel)) . decodeWithMetadataM f+instance Readable (Sequence PGM) [Image S (Y D65) Word16] where+  decodeWithMetadataM f = fmap (first (fmap fromImageBaseModel)) . decodeWithMetadataM f+++instance Readable PPM (Image S CM.RGB Word8) where+  decodeWithMetadataM = decodeNetpbmImage+instance Readable PPM (Image S CM.RGB Word16) where+  decodeWithMetadataM = decodeNetpbmImage+++instance Readable PPM (Image S (SRGB 'NonLinear) Word8) where+  decodeWithMetadataM f = fmap (first fromImageBaseModel) . decodeWithMetadataM f+instance Readable PPM (Image S (SRGB 'NonLinear) Word16) where+  decodeWithMetadataM f = fmap (first fromImageBaseModel) . decodeWithMetadataM f+++instance Readable (Sequence PPM) [Image S CM.RGB Word8] where+  decodeWithMetadataM = decodePPMs fromNetpbmImage+instance Readable (Sequence PPM) [Image S CM.RGB Word16] where+  decodeWithMetadataM = decodePPMs fromNetpbmImage+++instance Readable (Sequence PPM) [Image S (SRGB 'NonLinear) Word8] where+  decodeWithMetadataM f = fmap (first (fmap fromImageBaseModel)) . decodeWithMetadataM f+instance Readable (Sequence PPM) [Image S (SRGB 'NonLinear) Word16] where+  decodeWithMetadataM f = fmap (first (fmap fromImageBaseModel)) . decodeWithMetadataM f++ fromNetpbmImage-  :: forall cs e . ColorSpace cs e =>+  :: forall cs e . ColorModel cs e =>      Netpbm.PPM -> Maybe (Image S cs e) fromNetpbmImage Netpbm.PPM {..} = do   let m = ppmHeight ppmHeader       n = ppmWidth ppmHeader   case ppmData of-    PbmPixelData v      -> do Refl <- eqT :: Maybe (Pixel cs e :~: Pixel X Bit)+    PbmPixelData v      -> do Refl <- eqT :: Maybe (Pixel cs e :~: Pixel CM.X Bit)                               fromNetpbmImageUnsafe m n v-    PgmPixelData8 v     -> do Refl <- eqT :: Maybe (Pixel cs e :~: Pixel Y Word8)+    PgmPixelData8 v     -> do Refl <- eqT :: Maybe (Pixel cs e :~: Pixel CM.X Word8)                               fromNetpbmImageUnsafe m n v-    PgmPixelData16 v    -> do Refl <- eqT :: Maybe (Pixel cs e :~: Pixel Y Word16)+    PgmPixelData16 v    -> do Refl <- eqT :: Maybe (Pixel cs e :~: Pixel CM.X Word16)                               fromNetpbmImageUnsafe m n v-    PpmPixelDataRGB8 v  -> do Refl <- eqT :: Maybe (Pixel cs e :~: Pixel RGB Word8)+    PpmPixelDataRGB8 v  -> do Refl <- eqT :: Maybe (Pixel cs e :~: Pixel CM.RGB Word8)                               fromNetpbmImageUnsafe m n v-    PpmPixelDataRGB16 v -> do Refl <- eqT :: Maybe (Pixel cs e :~: Pixel RGB Word16)+    PpmPixelDataRGB16 v -> do Refl <- eqT :: Maybe (Pixel cs e :~: Pixel CM.RGB Word16)                               fromNetpbmImageUnsafe m n v  +instance (Manifest r (Pixel cs e), ColorSpace cs i e) =>+         Readable (Auto PBM) (Image r cs e) where+  decodeWithMetadataM = decodeAutoNetpbmImage+instance (Manifest r (Pixel cs e), ColorSpace cs i e) =>+         Readable (Auto (Sequence PBM)) [Image r cs e] where+  decodeWithMetadataM = decodeAutoNetpbmImageSequence++instance (Manifest r (Pixel cs e), ColorSpace cs i e) =>+         Readable (Auto PGM) (Image r cs e) where+  decodeWithMetadataM = decodeAutoNetpbmImage+instance (Manifest r (Pixel cs e), ColorSpace cs i e) =>+         Readable (Auto (Sequence PGM)) [Image r cs e] where+  decodeWithMetadataM = decodeAutoNetpbmImageSequence++instance (Manifest r (Pixel cs e), ColorSpace cs i e) =>+         Readable (Auto PPM) (Image r cs e) where+  decodeWithMetadataM = decodeAutoNetpbmImage+instance (Manifest r (Pixel cs e), ColorSpace cs i e) =>+         Readable (Auto (Sequence PPM)) [Image r cs e] where+  decodeWithMetadataM = decodeAutoNetpbmImageSequence+ fromNetpbmImageAuto-  :: forall cs e r . (Mutable r Ix2 (Pixel cs e), ColorSpace cs e) =>+  :: forall cs i e r . (Manifest r (Pixel cs e), ColorSpace cs i e) =>      Netpbm.PPM -> Maybe (Image r cs e) fromNetpbmImageAuto Netpbm.PPM {..} = do   let m = ppmHeight ppmHeader       n = ppmWidth ppmHeader   case ppmData of     PbmPixelData v ->-      (fromNetpbmImageUnsafe m n v :: Maybe (Image S X Bit)) >>= (toAnyCS . M.map fromPixelBinary)+      compute . convertImage <$> (fromNetpbmImageUnsafe m n v :: Maybe (Image S (Y D65) Bit))     PgmPixelData8 v ->-      (fromNetpbmImageUnsafe m n v :: Maybe (Image S Y Word8)) >>= toAnyCS+      compute . convertImage <$> (fromNetpbmImageUnsafe m n v :: Maybe (Image S (Y D65) Word8))     PgmPixelData16 v ->-      (fromNetpbmImageUnsafe m n v :: Maybe (Image S Y Word16)) >>= toAnyCS+      compute . convertImage <$> (fromNetpbmImageUnsafe m n v :: Maybe (Image S (Y D65) Word16))     PpmPixelDataRGB8 v ->-      (fromNetpbmImageUnsafe m n v :: Maybe (Image S RGB Word8)) >>= toAnyCS+      compute . convertImage <$>+      (fromNetpbmImageUnsafe m n v :: Maybe (Image S (SRGB 'NonLinear) Word8))     PpmPixelDataRGB16 v ->-      (fromNetpbmImageUnsafe m n v :: Maybe (Image S RGB Word16)) >>= toAnyCS-+      compute . convertImage <$>+      (fromNetpbmImageUnsafe m n v :: Maybe (Image S (SRGB 'NonLinear) Word16))
+ src/Graphics/ColorModel.hs view
@@ -0,0 +1,14 @@+-- |+-- Module      : Graphics.ColorModel+-- Copyright   : (c) Alexey Kuleshevich 2020-2021+-- License     : BSD3+-- Maintainer  : Alexey Kuleshevich <lehins@yandex.ru>+-- Stability   : experimental+-- Portability : non-portable+--+module Graphics.ColorModel+  ( -- * Re-export of pixles operating on ColorModel+    module Graphics.Pixel+  ) where++import Graphics.Pixel
− src/Graphics/ColorSpace.hs 
@@ -1,727 +0,0 @@-{-# OPTIONS_GHC -fno-warn-orphans #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE ViewPatterns #-}-#if __GLASGOW_HASKELL__ >= 800-  {-# OPTIONS_GHC -Wno-redundant-constraints #-}-{-# LANGUAGE MonoLocalBinds #-}-#endif--- |--- Module      : Graphics.ColorSpace--- Copyright   : (c) Alexey Kuleshevich 2018-2019--- License     : BSD3--- Maintainer  : Alexey Kuleshevich <lehins@yandex.ru>--- Stability   : experimental--- Portability : non-portable----module Graphics.ColorSpace (-  -- * Pixels-  -- ** Family of Pixels-  -- | Pixel is a type family for all available color spaces. Below is the-  -- listed of all class instances, that pixels are installed in, as well as all-  -- pixel constructors.-  ---  -- >>> :t (PixelY 0) -- Black pixel in Luma-  -- (PixelY 0) :: Num e => Pixel Y e-  -- >>> PixelRGB 255 0 0 :: Pixel RGB Word8 -- Red pixel in RGB-  -- <RGB:(255|0|0)>-  -- >>> PixelRGB 1 0 0 :: Pixel RGB Double -- Same red pixel in RGB with Double precision.-  -- <RGB:(1.0|0.0|0.0)>-  -- >>> (PixelRGB 255 0 0 :: Pixel RGB Word8) == (toWord8 <$> (PixelRGB 1 0 0 :: Pixel RGB Double))-  -- True-  ---  Pixel(..)-  , ColorSpace(..)-  , AlphaSpace(..)-  -- ** Luma (gray scale)-  -- | Conversion to Luma from other color spaces.-  , toPixelY-  , toPixelYA-  -- ** RGB-  -- | Conversion to RGB from other color spaces.-  , toPixelRGB-  , toPixelRGBA-  -- ** HSI-  -- | Conversion to HSI from other color spaces.-  , toPixelHSI-  , toPixelHSIA-  -- ** CMYK-  -- | Conversion to CMYK from other color spaces.-  , toPixelCMYK-  , toPixelCMYKA-  -- ** YCbCr-  -- | Conversion to YCbCr from other color spaces.-  , toPixelYCbCr-  , toPixelYCbCrA-  -- ** Binary-  -- | This is a Binary colorspace, pixel's of which can be created using-  -- these __/constructors/__:-  ---  --   [@'on'@] Represents value @1@ or 'True'. It's a foreground pixel and is-  --   displayed in black.-  ---  --   [@'off'@] Represents value @0@ or 'False'. It's a background pixel and is-  --   displayed in white.-  ---  -- Note, that values are inverted before writing to or reading from file, since-  -- grayscale images represent black as a @0@ value and white as @1@ on a-  -- @[0,1]@ scale.-  ---  -- Binary pixels also behave as binary numbers with a size of 1-bit, for instance:-  ---  -- >>> on + on -- equivalent to: 1 .|. 1-  -- <Binary:(1)>-  -- >>> (on + on) * off -- equivalent to: (1 .|. 1) .&. 0-  -- <Binary:(0)>-  -- >>> (on + on) - on-  -- <Binary:(0)>-  ---  , toPixelBinary-  , fromPixelBinary-  , module Graphics.ColorSpace.Binary-  -- ** Complex-  , module Graphics.ColorSpace.Complex-  -- ** X-  , toPixelsX-  , fromPixelsX-  -- * ColorSpace-  -- ** Operations on Pixels-  , eqTolPx-  -- ** Luma-  ,Y(..), YA(..),-  ToY, ToYA,-  -- ** RGB-  RGB(..), RGBA(..),-  ToRGB, ToRGBA,-  -- ** HSI-  HSI(..), HSIA(..),-  ToHSI, ToHSIA,-  -- ** CMYK-  CMYK(..), CMYKA(..),-  ToCMYK, ToCMYKA,-  -- ** YCbCr-  YCbCr(..), YCbCrA(..),-  ToYCbCr, ToYCbCrA,-  -- ** X-  X(..),-  -- * Precision-  -- ** Pixel-  Elevator(..),-  toWord8,-  toWord16,-  toWord32,-  toWord64,-  toFloat,-  toDouble,-  fromDouble,-  -- ** Componenet-  Word8, Word16, Word32, Word64-  ) where--import Data.Word-import Graphics.ColorSpace.Binary-import Graphics.ColorSpace.CMYK-import Graphics.ColorSpace.Complex-import Graphics.ColorSpace.HSI-import Graphics.ColorSpace.Internal-import Graphics.ColorSpace.RGB-import Graphics.ColorSpace.X-import Graphics.ColorSpace.Y-import Graphics.ColorSpace.YCbCr----- -- Binary:---- | Convert to a `Binary` pixel.-toPixelBinary :: ColorSpace cs e => Pixel cs e -> Pixel X Bit-toPixelBinary px = if px == 0 then on else off----- | Convert a Binary pixel to Luma pixel-fromPixelBinary :: Pixel X Bit -> Pixel Y Word8-fromPixelBinary b = PixelY $ if isOn b then minBound else maxBound-{-# INLINE fromPixelBinary #-}----- | Check weather two Pixels are equal within a tolerance. Useful for comparing--- pixels with `Float` or `Double` precision.-eqTolPx :: (ColorSpace cs e, Ord e) =>-           e -> Pixel cs e -> Pixel cs e -> Bool-eqTolPx !tol = foldlPx2 comp True-  where comp !acc !e1 !e2 = acc && max e1 e2 - min e1 e2 <= tol-        {-# INLINE comp #-}-{-# INLINE eqTolPx #-}---- ToY---- | Conversion to Luma color space.-class ColorSpace cs e => ToY cs e where--  -- | Convert a pixel to Luma pixel.-  toPixelY :: Pixel cs e -> Pixel Y Double---instance Elevator e => ToY X e where-  toPixelY (PixelX y) = PixelY $ eToDouble y-  {-# INLINE toPixelY #-}--instance Elevator e => ToY Y e where-  toPixelY (PixelY y) = PixelY $ eToDouble y-  {-# INLINE toPixelY #-}--instance Elevator e => ToY YA e where-  toPixelY (PixelYA y _) = PixelY $ eToDouble y-  {-# INLINE toPixelY #-}---- | Computes Luma: @ Y' = 0.299 * R' + 0.587 * G' + 0.114 * B' @-instance Elevator e => ToY RGB e where-  toPixelY (toDouble -> PixelRGB r g b) = PixelY (0.299*r + 0.587*g + 0.114*b)-  {-# INLINE toPixelY #-}--instance Elevator e => ToY RGBA e where-  toPixelY = toPixelY . dropAlpha-  {-# INLINE toPixelY #-}--instance Elevator e => ToY HSI e where-  toPixelY = toPixelY . toPixelRGB . toDouble-  {-# INLINE toPixelY #-}--instance Elevator e => ToY HSIA e where-  toPixelY = toPixelY . dropAlpha-  {-# INLINE toPixelY #-}--instance Elevator e => ToY CMYK e where-  toPixelY = toPixelY . toPixelRGB . toDouble-  {-# INLINE toPixelY #-}--instance Elevator e => ToY CMYKA e where-  toPixelY = toPixelY . toPixelRGB . toDouble . dropAlpha-  {-# INLINE toPixelY #-}--instance Elevator e => ToY YCbCr e where-  toPixelY (PixelYCbCr y _ _) = PixelY $ eToDouble y-  {-# INLINE toPixelY #-}--instance Elevator e => ToY YCbCrA e where-  toPixelY (PixelYCbCrA y _ _ _) = PixelY $ eToDouble y-  {-# INLINE toPixelY #-}----- ToYA---- | Conversion to Luma from another color space.-class ToY cs e => ToYA cs e where--  -- | Convert a pixel to Luma pixel with Alpha.-  toPixelYA :: Pixel cs e -> Pixel YA Double-  toPixelYA = addAlpha 1 . toPixelY-  {-# INLINE toPixelYA #-}---instance ToYA X Bit where-  toPixelYA (PixelX y) = PixelYA (eToDouble y) 1-  {-# INLINE toPixelYA #-}---instance ToY Y e => ToYA Y e--instance Elevator e => ToYA YA e where-  toPixelYA = toDouble-  {-# INLINE toPixelYA #-}--instance ToY RGB e => ToYA RGB e--instance Elevator e => ToYA RGBA e where-  toPixelYA !px = addAlpha (eToDouble $ getAlpha px) (toPixelY (dropAlpha px))-  {-# INLINE toPixelYA #-}--instance ToY HSI e => ToYA HSI e--instance Elevator e => ToYA HSIA e where-  toPixelYA !px = addAlpha (eToDouble $ getAlpha px) (toPixelY (dropAlpha px))-  {-# INLINE toPixelYA #-}--instance ToY CMYK e => ToYA CMYK e--instance Elevator e => ToYA CMYKA e where-  toPixelYA !px = addAlpha (eToDouble $ getAlpha px) (toPixelY (dropAlpha px))-  {-# INLINE toPixelYA #-}--instance ToY YCbCr e => ToYA YCbCr e--instance Elevator e => ToYA YCbCrA e where-  toPixelYA !px = addAlpha (eToDouble $ getAlpha px) (toPixelY (dropAlpha px))-  {-# INLINE toPixelYA #-}---- ToRGB------ | Conversion to `RGB` color space.-class ColorSpace cs e => ToRGB cs e where--  -- | Convert to an `RGB` pixel.-  toPixelRGB :: Pixel cs e -> Pixel RGB Double---instance ToRGB X Bit where-  toPixelRGB (PixelX b) = pure $ eToDouble b-  {-# INLINE toPixelRGB #-}--instance Elevator e => ToRGB Y e where-  toPixelRGB (PixelY g) = pure $ eToDouble g-  {-# INLINE toPixelRGB #-}--instance Elevator e => ToRGB YA e where-  toPixelRGB = toPixelRGB . dropAlpha-  {-# INLINE toPixelRGB #-}--instance Elevator e => ToRGB RGB e where-  toPixelRGB = toDouble-  {-# INLINE toPixelRGB #-}--instance Elevator e => ToRGB RGBA e where-  toPixelRGB = toDouble . dropAlpha-  {-# INLINE toPixelRGB #-}--instance Elevator e => ToRGB HSI e where-  toPixelRGB (toDouble -> PixelHSI h' s i) = getRGB (h'*2*pi) where-    !is = i*s-    !second = i - is-    errorHue = error $ "HSI pixel is not properly scaled, Hue: " ++ show h'-    getFirst !a !b = i + is*cos a/cos b-    {-# INLINE getFirst #-}-    getThird !v1 !v2 = i + 2*is + v1 - v2-    {-# INLINE getThird #-}-    getRGB h-      | h < 0      = errorHue-      | h < 2*pi/3 = let !r = getFirst h (pi/3 - h)-                         !b = second-                         !g = getThird b r-                     in PixelRGB r g b-      | h < 4*pi/3 = let !g = getFirst (h - 2*pi/3) (h + pi)-                         !r = second-                         !b = getThird r g-                     in PixelRGB r g b-      | h < 2*pi   = let !b = getFirst (h - 4*pi/3) (2*pi - pi/3 - h)-                         !g = second-                         !r = getThird g b-                     in PixelRGB r g b-      | otherwise  = errorHue-    {-# INLINE getRGB #-}-  {-# INLINE toPixelRGB #-}--instance Elevator e => ToRGB HSIA e where-  toPixelRGB = toPixelRGB . dropAlpha-  {-# INLINE toPixelRGB #-}---instance Elevator e => ToRGB YCbCr e where-  toPixelRGB (toDouble -> PixelYCbCr y cb cr) = PixelRGB r g b where-    !r = clamp01 (y                      +   1.402*(cr - 0.5))-    !g = clamp01 (y - 0.34414*(cb - 0.5) - 0.71414*(cr - 0.5))-    !b = clamp01 (y +   1.772*(cb - 0.5))-  {-# INLINE toPixelRGB #-}--instance Elevator e => ToRGB YCbCrA e where-  toPixelRGB = toPixelRGB . dropAlpha-  {-# INLINE toPixelRGB #-}--instance Elevator e => ToRGB CMYK e where-  toPixelRGB (toDouble -> PixelCMYK c m y k) = PixelRGB r g b where-    !r = (1-c)*(1-k)-    !g = (1-m)*(1-k)-    !b = (1-y)*(1-k)-  {-# INLINE toPixelRGB #-}--instance Elevator e => ToRGB CMYKA e where-  toPixelRGB = toPixelRGB . dropAlpha-  {-# INLINE toPixelRGB #-}----- ToRGBA---- | Conversion to `RGBA` from another color space with Alpha channel.-class ToRGB cs e => ToRGBA cs e where--  -- | Convert to an `RGBA` pixel.-  toPixelRGBA :: Pixel cs e -> Pixel RGBA Double-  toPixelRGBA = addAlpha 1 . toPixelRGB-  {-# INLINE toPixelRGBA #-}---instance ToRGBA X Bit--instance ToRGB Y e => ToRGBA Y e--instance Elevator e => ToRGBA YA e where-  toPixelRGBA !px = addAlpha (eToDouble $ getAlpha px) (toPixelRGB (dropAlpha px))-  {-# INLINE toPixelRGBA #-}--instance ToRGB RGB e => ToRGBA RGB e--instance Elevator e => ToRGBA RGBA e where-  toPixelRGBA = toDouble-  {-# INLINE toPixelRGBA #-}--instance ToRGB HSI e => ToRGBA HSI e--instance Elevator e => ToRGBA HSIA e where-  toPixelRGBA !px = addAlpha (eToDouble $ getAlpha px) (toPixelRGB (dropAlpha px))-  {-# INLINE toPixelRGBA #-}--instance ToRGB CMYK e => ToRGBA CMYK e--instance Elevator e => ToRGBA CMYKA e where-  toPixelRGBA !px = addAlpha (eToDouble $ getAlpha px) (toPixelRGB (dropAlpha px))-  {-# INLINE toPixelRGBA #-}--instance ToRGB YCbCr e => ToRGBA YCbCr e--instance Elevator e => ToRGBA YCbCrA e where-  toPixelRGBA !px = addAlpha (eToDouble $ getAlpha px) (toPixelRGB (dropAlpha px))-  {-# INLINE toPixelRGBA #-}----- ToHSI---- | Conversion to `HSI` color space.-class ColorSpace cs e => ToHSI cs e where--  -- | Convert to an `HSI` pixel.-  toPixelHSI :: Pixel cs e -> Pixel HSI Double---instance Elevator e => ToHSI Y e where-  toPixelHSI (PixelY y) = PixelHSI 0 0 $ eToDouble y-  {-# INLINE toPixelHSI #-}--instance Elevator e => ToHSI YA e where-  toPixelHSI = toPixelHSI . dropAlpha-  {-# INLINE toPixelHSI #-}--instance Elevator e => ToHSI RGB e where-  toPixelHSI (toDouble -> PixelRGB r g b) = PixelHSI h s i where-    !h' = atan2 y x-    !h = (if h' < 0 then h' + 2*pi else h') / (2*pi)-    !s = if i == 0 then 0 else 1 - minimum [r, g, b] / i-    !i = (r + g + b) / 3-    !x = (2*r - g - b) / 2.449489742783178-    !y = (g - b) / 1.4142135623730951-  {-# INLINE toPixelHSI #-}--instance Elevator e => ToHSI RGBA e where-  toPixelHSI = toPixelHSI . dropAlpha-  {-# INLINE toPixelHSI #-}--instance Elevator e => ToHSI HSI e where-  toPixelHSI = toDouble-  {-# INLINE toPixelHSI #-}--instance Elevator e => ToHSI HSIA e where-  toPixelHSI = toPixelHSI . dropAlpha-  {-# INLINE toPixelHSI #-}--instance Elevator e => ToHSI YCbCr e where-  toPixelHSI = toPixelHSI . toPixelRGB-  {-# INLINE toPixelHSI #-}--instance Elevator e => ToHSI YCbCrA e where-  toPixelHSI = toPixelHSI . dropAlpha-  {-# INLINE toPixelHSI #-}--instance Elevator e => ToHSI CMYK e where-  toPixelHSI = toPixelHSI . toPixelRGB-  {-# INLINE toPixelHSI #-}--instance Elevator e => ToHSI CMYKA e where-  toPixelHSI = toPixelHSI . dropAlpha-  {-# INLINE toPixelHSI #-}----- ToHSIA---- | Conversion to `HSIA` from another color space with Alpha channel.-class ToHSI cs e => ToHSIA cs e where--  -- | Convert to an `HSIA` pixel.-  toPixelHSIA :: Pixel cs e -> Pixel HSIA Double-  toPixelHSIA = addAlpha 1 . toPixelHSI-  {-# INLINE toPixelHSIA #-}---instance ToHSI Y e => ToHSIA Y e--instance Elevator e => ToHSIA YA e where-  toPixelHSIA !px = addAlpha (eToDouble $ getAlpha px) (toPixelHSI (dropAlpha px))-  {-# INLINE toPixelHSIA #-}--instance ToHSI RGB e => ToHSIA RGB e--instance Elevator e => ToHSIA RGBA e where-  toPixelHSIA !px = addAlpha (eToDouble $ getAlpha px) (toPixelHSI (dropAlpha px))-  {-# INLINE toPixelHSIA #-}--instance ToHSI HSI e => ToHSIA HSI e--instance Elevator e => ToHSIA HSIA e where-  toPixelHSIA = toDouble-  {-# INLINE toPixelHSIA #-}--instance ToHSI CMYK e => ToHSIA CMYK e--instance Elevator e => ToHSIA CMYKA e where-  toPixelHSIA !px = addAlpha (eToDouble $ getAlpha px) (toPixelHSI (dropAlpha px))-  {-# INLINE toPixelHSIA #-}--instance ToHSI YCbCr e => ToHSIA YCbCr e--instance Elevator e => ToHSIA YCbCrA e where-  toPixelHSIA !px = addAlpha (eToDouble $ getAlpha px) (toPixelHSI (dropAlpha px))-  {-# INLINE toPixelHSIA #-}------ ToCMYK---- | Conversion to `CMYK` color space.-class ColorSpace cs e => ToCMYK cs e where--  -- | Convert to a `CMYK` pixel.-  toPixelCMYK :: Pixel cs e -> Pixel CMYK Double---instance Elevator e => ToCMYK Y e where-  toPixelCMYK = toPixelCMYK . toPixelRGB-  {-# INLINE toPixelCMYK #-}--instance Elevator e => ToCMYK YA e where-  toPixelCMYK = toPixelCMYK . dropAlpha-  {-# INLINE toPixelCMYK #-}--instance Elevator e => ToCMYK RGB e where-  toPixelCMYK (toDouble -> PixelRGB r g b) = PixelCMYK c m y k where-    !c = (k' - r) / k'-    !m = (k' - g) / k'-    !y = (k' - b) / k'-    !k = 1 - k'-    !k' = max r (max g b)-  {-# INLINE toPixelCMYK #-}--instance Elevator e => ToCMYK RGBA e where-  toPixelCMYK = toPixelCMYK . dropAlpha-  {-# INLINE toPixelCMYK #-}--instance Elevator e => ToCMYK HSI e where-  toPixelCMYK = toPixelCMYK . toPixelRGB-  {-# INLINE toPixelCMYK #-}--instance Elevator e => ToCMYK HSIA e where-  toPixelCMYK = toPixelCMYK . dropAlpha-  {-# INLINE toPixelCMYK #-}--instance Elevator e => ToCMYK CMYK e where-  toPixelCMYK = toDouble-  {-# INLINE toPixelCMYK #-}--instance Elevator e => ToCMYK CMYKA e where-  toPixelCMYK = toPixelCMYK . dropAlpha-  {-# INLINE toPixelCMYK #-}--instance Elevator e => ToCMYK YCbCr e where-  toPixelCMYK = toPixelCMYK . toPixelRGB-  {-# INLINE toPixelCMYK #-}--instance Elevator e => ToCMYK YCbCrA e where-  toPixelCMYK = toPixelCMYK . dropAlpha-  {-# INLINE toPixelCMYK #-}----- ToCMYKA---- | Conversion to `CMYKA`.-class ToCMYK cs e => ToCMYKA cs e where--  -- | Convert to a `CMYKA` pixel.-  toPixelCMYKA :: Pixel cs e -> Pixel CMYKA Double-  toPixelCMYKA = addAlpha 1 . toPixelCMYK-  {-# INLINE toPixelCMYKA #-}---instance ToCMYK Y e => ToCMYKA Y e--instance Elevator e => ToCMYKA YA e where-  toPixelCMYKA !px = addAlpha (eToDouble $ getAlpha px) (toPixelCMYK (dropAlpha px))-  {-# INLINE toPixelCMYKA #-}--instance ToCMYK RGB e => ToCMYKA RGB e--instance Elevator e => ToCMYKA RGBA e where-  toPixelCMYKA !px = addAlpha (eToDouble $ getAlpha px) (toPixelCMYK (dropAlpha px))-  {-# INLINE toPixelCMYKA #-}--instance ToCMYK HSI e => ToCMYKA HSI e--instance Elevator e => ToCMYKA HSIA e where-  toPixelCMYKA !px = addAlpha (eToDouble $ getAlpha px) (toPixelCMYK (dropAlpha px))-  {-# INLINE toPixelCMYKA #-}--instance ToCMYK CMYK e => ToCMYKA CMYK e--instance Elevator e => ToCMYKA CMYKA e where-  toPixelCMYKA = toDouble-  {-# INLINE toPixelCMYKA #-}--instance ToCMYK YCbCr e => ToCMYKA YCbCr e--instance Elevator e => ToCMYKA YCbCrA e where-  toPixelCMYKA !px = addAlpha (eToDouble $ getAlpha px) (toPixelCMYK (dropAlpha px))-  {-# INLINE toPixelCMYKA #-}------- ToYCbCr---- | Conversion to `YCbCr` color space.-class ColorSpace cs e => ToYCbCr cs e where--  -- | Convert to an `YCbCr` pixel.-  toPixelYCbCr :: Pixel cs e -> Pixel YCbCr Double----instance Elevator e => ToYCbCr Y e where-  toPixelYCbCr = toPixelYCbCr . toPixelRGB-  {-# INLINE toPixelYCbCr #-}--instance Elevator e => ToYCbCr YA e where-  toPixelYCbCr = toPixelYCbCr . dropAlpha-  {-# INLINE toPixelYCbCr #-}--instance Elevator e => ToYCbCr RGB e where-  toPixelYCbCr (toDouble -> PixelRGB r g b) = PixelYCbCr y cb cr where-    !y  = clamp01 (         0.299*r +    0.587*g +    0.114*b)-    !cb = clamp01 (0.5 - 0.168736*r - 0.331264*g +      0.5*b)-    !cr = clamp01 (0.5 +      0.5*r - 0.418688*g - 0.081312*b)-  {-# INLINE toPixelYCbCr #-}--instance Elevator e => ToYCbCr RGBA e where-  toPixelYCbCr = toPixelYCbCr . dropAlpha-  {-# INLINE toPixelYCbCr #-}--instance Elevator e => ToYCbCr HSI e where-  toPixelYCbCr = toPixelYCbCr . toPixelRGB-  {-# INLINE toPixelYCbCr #-}--instance Elevator e => ToYCbCr HSIA e where-  toPixelYCbCr = toPixelYCbCr . dropAlpha-  {-# INLINE toPixelYCbCr #-}--instance Elevator e => ToYCbCr YCbCr e where-  toPixelYCbCr = toDouble-  {-# INLINE toPixelYCbCr #-}--instance Elevator e => ToYCbCr YCbCrA e where-  toPixelYCbCr = toPixelYCbCr . dropAlpha-  {-# INLINE toPixelYCbCr #-}--instance Elevator e => ToYCbCr CMYK e where-  toPixelYCbCr = toPixelYCbCr . toPixelRGB-  {-# INLINE toPixelYCbCr #-}--instance Elevator e => ToYCbCr CMYKA e where-  toPixelYCbCr = toPixelYCbCr . dropAlpha-  {-# INLINE toPixelYCbCr #-}----- ToYCbCrA----- | Conversion to `YCbCrA` from another color space with Alpha channel.-class ToYCbCr cs e => ToYCbCrA cs e where--  -- | Convert to an `YCbCrA` pixel.-  toPixelYCbCrA :: Pixel cs e -> Pixel YCbCrA Double-  toPixelYCbCrA = addAlpha 1 . toPixelYCbCr-  {-# INLINE toPixelYCbCrA #-}---instance ToYCbCr Y e => ToYCbCrA Y e--instance Elevator e => ToYCbCrA YA e where-  toPixelYCbCrA !px = addAlpha (eToDouble $ getAlpha px) (toPixelYCbCr (dropAlpha px))-  {-# INLINE toPixelYCbCrA #-}--instance ToYCbCr RGB e => ToYCbCrA RGB e---instance ToYCbCr HSI e => ToYCbCrA HSI e--instance Elevator e => ToYCbCrA HSIA e where-  toPixelYCbCrA !px = addAlpha (eToDouble $ getAlpha px) (toPixelYCbCr (dropAlpha px))-  {-# INLINE toPixelYCbCrA #-}--instance Elevator e => ToYCbCrA RGBA e where-  toPixelYCbCrA !px = addAlpha (eToDouble $ getAlpha px) (toPixelYCbCr (dropAlpha px))-  {-# INLINE toPixelYCbCrA #-}--instance ToYCbCr CMYK e => ToYCbCrA CMYK e--instance Elevator e => ToYCbCrA CMYKA e where-  toPixelYCbCrA !px = addAlpha (eToDouble $ getAlpha px) (toPixelYCbCr (dropAlpha px))-  {-# INLINE toPixelYCbCrA #-}--instance ToYCbCr YCbCr e => ToYCbCrA YCbCr e--instance Elevator e => ToYCbCrA YCbCrA e where-  toPixelYCbCrA = toDouble-  {-# INLINE toPixelYCbCrA #-}----- | Change pixel precision to `Word8`.-toWord8 :: (Functor (Pixel cs), Elevator e) => Pixel cs e -> Pixel cs Word8-toWord8 = fmap eToWord8-{-# INLINABLE toWord8 #-}----- | Change pixel precision to `Word16`.-toWord16 :: (Functor (Pixel cs), Elevator e) => Pixel cs e -> Pixel cs Word16-toWord16 = fmap eToWord16-{-# INLINABLE toWord16 #-}----- | Change pixel precision to `Word32`.-toWord32 :: (Functor (Pixel cs), Elevator e) => Pixel cs e -> Pixel cs Word32-toWord32 = fmap eToWord32-{-# INLINABLE toWord32 #-}----- | Change pixel precision to `Word64`.-toWord64 :: (Functor (Pixel cs), Elevator e) => Pixel cs e -> Pixel cs Word64-toWord64 = fmap eToWord64-{-# INLINABLE toWord64 #-}----- | Change pixel precision to `Float`.-toFloat :: (Functor (Pixel cs), Elevator e) => Pixel cs e -> Pixel cs Float-toFloat = fmap eToFloat-{-# INLINABLE toFloat #-}----- | Change pixel precision to `Double`.-toDouble :: (Functor (Pixel cs), Elevator e) => Pixel cs e -> Pixel cs Double-toDouble = fmap eToDouble-{-# INLINABLE toDouble #-}------ | Change pixel precision from `Double`.-fromDouble :: (Functor (Pixel cs), Elevator e) => Pixel cs Double -> Pixel cs e-fromDouble = fmap eFromDouble-{-# INLINABLE fromDouble #-}
− src/Graphics/ColorSpace/Binary.hs 
@@ -1,270 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}--- |--- Module      : Graphics.ColorSpace.Binary--- Copyright   : (c) Alexey Kuleshevich 2018-2019--- License     : BSD3--- Maintainer  : Alexey Kuleshevich <lehins@yandex.ru>--- Stability   : experimental--- Portability : non-portable----module Graphics.ColorSpace.Binary (-  Bit, on, off, isOn, isOff, fromBool, zero, one, bit2bool, bool2bit, toNum, fromNum-  ) where--import Control.Monad-import Data.Bits-import Data.Typeable (Typeable)-import qualified Data.Vector.Generic as V-import qualified Data.Vector.Generic.Mutable as M-import qualified Data.Vector.Unboxed as U-import Data.Word (Word8)-import Foreign.Ptr-import Foreign.Storable-import Graphics.ColorSpace.Internal-import Graphics.ColorSpace.X-import Prelude hiding (map)----- | Under the hood, binary pixels are represented as `Word8`, but can only take--- values of @0@ or @1@. Use `zero`\/`one` to construct a bit and `on`\/`off` to--- construct a binary pixel.-newtype Bit = Bit Word8 deriving (Ord, Eq, Typeable)---instance Show Bit where-  show (Bit 0) = "0"-  show _       = "1"---instance Bits Bit where-  (Bit 0) .&. _       = Bit 0-  (Bit 1) .&. (Bit 1) = Bit 1-  _       .&. (Bit 0) = Bit 0-  _       .&. _       = Bit 1-  {-# INLINE (.&.) #-}-  (Bit 1) .|. _       = Bit 1-  (Bit 0) .|. (Bit 0) = Bit 0-  _       .|. _       = Bit 1-  {-# INLINE (.|.) #-}-  (Bit 0) `xor` (Bit 0) = Bit 0-  (Bit 1) `xor` (Bit 1) = Bit 0-  _       `xor` _       = Bit 1-  {-# INLINE xor #-}-  complement (Bit 0) = Bit 1-  complement       _ = Bit 0-  {-# INLINE complement #-}-  shift !b 0 = b-  shift  _ _ = Bit 0-  {-# INLINE shift #-}-  rotate !b _ = b-  {-# INLINE rotate #-}-  zeroBits = Bit 0-  {-# INLINE zeroBits #-}-  bit 0 = Bit 1-  bit _ = Bit 0-  {-# INLINE bit #-}-  testBit (Bit 1) 0 = True-  testBit _       _ = False-  {-# INLINE testBit #-}-  bitSizeMaybe _ = Just 1-  {-# INLINE bitSizeMaybe #-}-  bitSize _ = 1-  {-# INLINE bitSize #-}-  isSigned _ = False-  {-# INLINE isSigned #-}-  popCount (Bit 0) = 0-  popCount _       = 1-  {-# INLINE popCount #-}---toNum :: Num a => Bit -> a-toNum (Bit 0) = 0-toNum _       = 1-{-# INLINE toNum #-}--fromNum :: (Eq a, Num a) => a -> Bit-fromNum 0 = zero-fromNum _ = one-{-# INLINE fromNum #-}---zero :: Bit-zero = Bit 0-{-# INLINE zero #-}--one :: Bit-one = Bit 1-{-# INLINE one #-}--bool2bit :: Bool -> Bit-bool2bit False = zero-bool2bit True  = one-{-# INLINE bool2bit #-}--bit2bool :: Bit -> Bool-bit2bool (Bit 0) = False-bit2bool _       = True-{-# INLINE bit2bool #-}---- | Represents value 'True' or @1@ in binary. Often also called a foreground--- pixel of an object.-on :: Pixel X Bit-on = PixelX one-{-# INLINE on #-}----- | Represents value 'False' or @0@ in binary. Often also called a background--- pixel.-off :: Pixel X Bit-off = PixelX zero-{-# INLINE off #-}----- | Convert a 'Bool' to a binary pixel.------ >>> isOn (fromBool True)--- True----fromBool :: Bool -> Pixel X Bit-fromBool False = off-fromBool True  = on-{-# INLINE fromBool #-}----- | Test if Pixel's value is 'on'.-isOn :: Pixel X Bit -> Bool-isOn (PixelX (Bit 0)) = False-isOn _                = True-{-# INLINE isOn #-}----- | Test if Pixel's value is 'off'.-isOff :: Pixel X Bit -> Bool-isOff = not . isOn-{-# INLINE isOff #-}----- | Values: @0@ and @1@-instance Elevator Bit where-  eToWord8 (Bit 0) = 0-  eToWord8 _       = maxBound-  {-# INLINE eToWord8 #-}-  eToWord16 (Bit 0) = 0-  eToWord16 _       = maxBound-  {-# INLINE eToWord16 #-}-  eToWord32 (Bit 0) = 0-  eToWord32 _       = maxBound-  {-# INLINE eToWord32 #-}-  eToWord64 (Bit 0) = 0-  eToWord64 _       = maxBound-  {-# INLINE eToWord64 #-}-  eToFloat (Bit 0) = 0-  eToFloat _       = 1-  {-# INLINE eToFloat #-}-  eToDouble (Bit 0) = 0-  eToDouble _       = 1-  {-# INLINE eToDouble #-}-  eFromDouble 0 = Bit 0-  eFromDouble _ = Bit 1-  {-# INLINE eFromDouble #-}---instance Num Bit where-  (+) = (.|.)-  {-# INLINE (+) #-}-  -- 0 - 0 = 0-  -- 0 - 1 = 0-  -- 1 - 0 = 1-  -- 1 - 1 = 0-  (Bit 0) - (Bit 0) = Bit 0-  _       - (Bit 0) = Bit 1-  _       - _       = Bit 0-  {-# INLINE (-) #-}-  (*) = (.&.)-  {-# INLINE (*) #-}-  abs         = id-  {-# INLINE abs #-}-  signum      = id-  {-# INLINE signum #-}-  fromInteger 0 = Bit 0-  fromInteger _ = Bit 1-  {-# INLINE fromInteger #-}---instance Storable Bit where--  sizeOf _ = sizeOf (undefined :: Word8)-  {-# INLINE sizeOf #-}-  alignment _ = alignment (undefined :: Word8)-  {-# INLINE alignment #-}-  peek !p = do-    let !q = castPtr p-    b <- peek q-    return (Bit b)-  {-# INLINE peek #-}-  poke !p (Bit b) = do-    let !q = castPtr p-    poke q b-  {-# INLINE poke #-}----- | Unboxing of a `Bit`.-instance U.Unbox Bit--newtype instance U.MVector s Bit = MV_Bit (U.MVector s Word8)--instance M.MVector U.MVector Bit where-  basicLength (MV_Bit mvec) = M.basicLength mvec-  {-# INLINE basicLength #-}-  basicUnsafeSlice idx len (MV_Bit mvec) = MV_Bit (M.basicUnsafeSlice idx len mvec)-  {-# INLINE basicUnsafeSlice #-}-  basicOverlaps (MV_Bit mvec) (MV_Bit mvec') = M.basicOverlaps mvec mvec'-  {-# INLINE basicOverlaps #-}-  basicUnsafeNew len = MV_Bit `liftM` M.basicUnsafeNew len-  {-# INLINE basicUnsafeNew #-}-  basicUnsafeReplicate len (Bit w) = MV_Bit `liftM` M.basicUnsafeReplicate len w-  {-# INLINE basicUnsafeReplicate #-}-  basicUnsafeRead (MV_Bit mvec) idx = Bit `liftM` M.basicUnsafeRead mvec idx-  {-# INLINE basicUnsafeRead #-}-  basicUnsafeWrite (MV_Bit mvec) idx (Bit w) = M.basicUnsafeWrite mvec idx w-  {-# INLINE basicUnsafeWrite #-}-  basicClear (MV_Bit mvec) = M.basicClear mvec-  {-# INLINE basicClear #-}-  basicSet (MV_Bit mvec) (Bit w) =  M.basicSet mvec w-  {-# INLINE basicSet #-}-  basicUnsafeCopy (MV_Bit mvec) (MV_Bit mvec') = M.basicUnsafeCopy mvec mvec'-  {-# INLINE basicUnsafeCopy #-}-  basicUnsafeMove (MV_Bit mvec) (MV_Bit mvec') = M.basicUnsafeMove mvec mvec'-  {-# INLINE basicUnsafeMove #-}-  basicUnsafeGrow (MV_Bit mvec) len = MV_Bit `liftM` M.basicUnsafeGrow mvec len-  {-# INLINE basicUnsafeGrow #-}-#if MIN_VERSION_vector(0,11,0)-  basicInitialize (MV_Bit mvec) = M.basicInitialize mvec-  {-# INLINE basicInitialize #-}-#endif---newtype instance U.Vector Bit = V_Bit (U.Vector Word8)--instance V.Vector U.Vector Bit where-  basicUnsafeFreeze (MV_Bit mvec) = V_Bit `liftM` V.basicUnsafeFreeze mvec-  {-# INLINE basicUnsafeFreeze #-}-  basicUnsafeThaw (V_Bit vec) = MV_Bit `liftM` V.basicUnsafeThaw vec-  {-# INLINE basicUnsafeThaw #-}-  basicLength (V_Bit vec) = V.basicLength vec-  {-# INLINE basicLength #-}-  basicUnsafeSlice idx len (V_Bit vec) = V_Bit (V.basicUnsafeSlice idx len vec)-  {-# INLINE basicUnsafeSlice #-}-  basicUnsafeIndexM (V_Bit vec) idx = Bit `liftM` V.basicUnsafeIndexM vec idx-  {-# INLINE basicUnsafeIndexM #-}-  basicUnsafeCopy (MV_Bit mvec) (V_Bit vec) = V.basicUnsafeCopy mvec vec-  {-# INLINE basicUnsafeCopy #-}-  elemseq (V_Bit vec) (Bit w) = V.elemseq vec w-  {-# INLINE elemseq #-}
− src/Graphics/ColorSpace/CMYK.hs 
@@ -1,221 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}--- |--- Module      : Graphics.ColorSpace.CMYK--- Copyright   : (c) Alexey Kuleshevich 2018-2019--- License     : BSD3--- Maintainer  : Alexey Kuleshevich <lehins@yandex.ru>--- Stability   : experimental--- Portability : non-portable----module Graphics.ColorSpace.CMYK (-  CMYK(..), CMYKA(..), Pixel(..)-  ) where--import Data.Foldable-import Data.Typeable (Typeable)-import Foreign.Ptr-import Foreign.Storable-import Graphics.ColorSpace.Internal-import Prelude hiding (map)------------------ CMYK -------------------- | Cyan, Magenta, Yellow and Black color space.-data CMYK = CyanCMYK -- ^ Cyan-          | MagCMYK  -- ^ Magenta-          | YelCMYK  -- ^ Yellow-          | KeyCMYK  -- ^ Key (Black)-          deriving (Eq, Enum, Show, Bounded, Typeable)---instance Show e => Show (Pixel CMYK e) where-  show (PixelCMYK c m y k) = "<CMYK:("++show c++"|"++show m++"|"++show y++"|"++show k++")>"---data instance Pixel CMYK e = PixelCMYK !e !e !e !e deriving (Eq, Ord)--instance Elevator e => ColorSpace CMYK e where-  type Components CMYK e = (e, e, e, e)--  fromComponents (c, m, y, k) = PixelCMYK c m y k-  {-# INLINE fromComponents #-}-  toComponents (PixelCMYK c m y k) = (c, m, y, k)-  {-# INLINE toComponents #-}-  getPxC (PixelCMYK c _ _ _) CyanCMYK = c-  getPxC (PixelCMYK _ m _ _) MagCMYK  = m-  getPxC (PixelCMYK _ _ y _) YelCMYK  = y-  getPxC (PixelCMYK _ _ _ k) KeyCMYK  = k-  {-# INLINE setPxC #-}-  setPxC (PixelCMYK _ m y k) CyanCMYK c = PixelCMYK c m y k-  setPxC (PixelCMYK c _ y k) MagCMYK  m = PixelCMYK c m y k-  setPxC (PixelCMYK c m _ k) YelCMYK  y = PixelCMYK c m y k-  setPxC (PixelCMYK c m y _) KeyCMYK  k = PixelCMYK c m y k-  {-# INLINE getPxC #-}-  mapPxC f (PixelCMYK c m y k) =-    PixelCMYK (f CyanCMYK c) (f MagCMYK m) (f YelCMYK y) (f KeyCMYK k)-  {-# INLINE mapPxC #-}-  foldlPx = foldl'-  {-# INLINE foldlPx #-}-  foldlPx2 f !z (PixelCMYK c1 m1 y1 k1) (PixelCMYK c2 m2 y2 k2) =-    f (f (f (f z c1 c2) m1 m2) y1 y2) k1 k2-  {-# INLINE foldlPx2 #-}---instance Functor (Pixel CMYK) where-  fmap f (PixelCMYK c m y k) = PixelCMYK (f c) (f m) (f y) (f k)-  {-# INLINE fmap #-}---instance Applicative (Pixel CMYK) where-  pure !e = PixelCMYK e e e e-  {-# INLINE pure #-}-  (PixelCMYK fc fm fy fk) <*> (PixelCMYK c m y k) = PixelCMYK (fc c) (fm m) (fy y) (fk k)-  {-# INLINE (<*>) #-}---instance Foldable (Pixel CMYK) where-  foldr f !z (PixelCMYK c m y k) = f c (f m (f y (f k z)))-  {-# INLINE foldr #-}---instance Traversable (Pixel CMYK) where-  traverse f (PixelCMYK c m y k) = PixelCMYK <$> f c <*> f m <*> f y <*> f k-  {-# INLINE traverse #-}---instance Storable e => Storable (Pixel CMYK e) where--  sizeOf _ = 4 * sizeOf (undefined :: e)-  {-# INLINE sizeOf #-}-  alignment _ = alignment (undefined :: e)-  {-# INLINE alignment #-}-  peek !p = do-    let !q = castPtr p-    c <- peek q-    m <- peekElemOff q 1-    y <- peekElemOff q 2-    k <- peekElemOff q 3-    return $! PixelCMYK c m y k-  {-# INLINE peek #-}-  poke !p (PixelCMYK c m y k) = do-    let !q = castPtr p-    poke q c-    pokeElemOff q 1 m-    pokeElemOff q 2 y-    pokeElemOff q 3 k-  {-# INLINE poke #-}------------------- CMYKA --------------------- | Cyan, Magenta, Yellow and Black color space with Alpha channel.-data CMYKA = CyanCMYKA  -- ^ Cyan-           | MagCMYKA   -- ^ Magenta-           | YelCMYKA   -- ^ Yellow-           | KeyCMYKA   -- ^ Key (Black)-           | AlphaCMYKA -- ^ Alpha-           deriving (Eq, Enum, Show, Bounded, Typeable)---data instance Pixel CMYKA e = PixelCMYKA !e !e !e !e !e deriving (Eq, Ord)---instance Show e => Show (Pixel CMYKA e) where-  show (PixelCMYKA c m y k a) =-    "<CMYKA:("++show c++"|"++show m++"|"++show y++"|"++show k++"|"++show a++")>"---instance Elevator e => ColorSpace CMYKA e where-  type Components CMYKA e = (e, e, e, e, e)--  fromComponents (c, m, y, k, a) = PixelCMYKA c m y k a-  {-# INLINE fromComponents #-}-  toComponents (PixelCMYKA c m y k a) = (c, m, y, k, a)-  {-# INLINE toComponents #-}-  getPxC (PixelCMYKA c _ _ _ _) CyanCMYKA  = c-  getPxC (PixelCMYKA _ m _ _ _) MagCMYKA   = m-  getPxC (PixelCMYKA _ _ y _ _) YelCMYKA   = y-  getPxC (PixelCMYKA _ _ _ k _) KeyCMYKA   = k-  getPxC (PixelCMYKA _ _ _ _ a) AlphaCMYKA = a-  {-# INLINE getPxC #-}-  setPxC (PixelCMYKA _ m y k a) CyanCMYKA  c = PixelCMYKA c m y k a-  setPxC (PixelCMYKA c _ y k a) MagCMYKA   m = PixelCMYKA c m y k a-  setPxC (PixelCMYKA c m _ k a) YelCMYKA   y = PixelCMYKA c m y k a-  setPxC (PixelCMYKA c m y _ a) KeyCMYKA   k = PixelCMYKA c m y k a-  setPxC (PixelCMYKA c m y k _) AlphaCMYKA a = PixelCMYKA c m y k a-  {-# INLINE setPxC #-}-  mapPxC f (PixelCMYKA c m y k a) =-    PixelCMYKA (f CyanCMYKA c) (f MagCMYKA m) (f YelCMYKA y) (f KeyCMYKA k) (f AlphaCMYKA a)-  {-# INLINE mapPxC #-}-  foldlPx2 f !z (PixelCMYKA c1 m1 y1 k1 a1) (PixelCMYKA c2 m2 y2 k2 a2) =-    f (f (f (f (f z c1 c2) m1 m2) y1 y2) k1 k2) a1 a2-  {-# INLINE foldlPx2 #-}---instance Elevator e => AlphaSpace CMYKA e where-  type Opaque CMYKA = CMYK--  getAlpha (PixelCMYKA _ _ _ _ a) = a-  {-# INLINE getAlpha #-}--  addAlpha !a (PixelCMYK c m y k) = PixelCMYKA c m y k a-  {-# INLINE addAlpha #-}--  dropAlpha (PixelCMYKA c m y k _) = PixelCMYK c m y k-  {-# INLINE dropAlpha #-}---instance Functor (Pixel CMYKA) where-  fmap f (PixelCMYKA c m y k a) = PixelCMYKA (f c) (f m) (f y) (f k) (f a)-  {-# INLINE fmap #-}---instance Applicative (Pixel CMYKA) where-  pure !e = PixelCMYKA e e e e e-  {-# INLINE pure #-}-  (PixelCMYKA fc fm fy fk fa) <*> (PixelCMYKA c m y k a) =-    PixelCMYKA (fc c) (fm m) (fy y) (fk k) (fa a)-  {-# INLINE (<*>) #-}---instance Foldable (Pixel CMYKA) where-  foldr f !z (PixelCMYKA c m y k a) = f c (f m (f y (f k (f a z))))-  {-# INLINE foldr #-}--instance Traversable (Pixel CMYKA) where-  traverse f (PixelCMYKA c m y k a) = PixelCMYKA <$> f c <*> f m <*> f y <*> f k <*> f a-  {-# INLINE traverse #-}---instance Storable e => Storable (Pixel CMYKA e) where--  sizeOf _ = 5 * sizeOf (undefined :: e)-  {-# INLINE sizeOf #-}-  alignment _ = alignment (undefined :: e)-  {-# INLINE alignment #-}-  peek !p = do-    let !q = castPtr p-    c <- peek q-    m <- peekElemOff q 1-    y <- peekElemOff q 2-    k <- peekElemOff q 3-    a <- peekElemOff q 4-    return $! PixelCMYKA c m y k a-  {-# INLINE peek #-}-  poke !p (PixelCMYKA c m y k a) = do-    let !q = castPtr p-    poke q c-    pokeElemOff q 1 m-    pokeElemOff q 2 y-    pokeElemOff q 3 k-    pokeElemOff q 4 a-  {-# INLINE poke #-}
− src/Graphics/ColorSpace/Complex.hs 
@@ -1,85 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleContexts #-}-#if __GLASGOW_HASKELL__ >= 800-  {-# OPTIONS_GHC -Wno-redundant-constraints #-}-#endif--- |--- Module      : Graphics.ColorSpace.Complex--- Copyright   : (c) Alexey Kuleshevich 2016-2019--- License     : BSD3--- Maintainer  : Alexey Kuleshevich <lehins@yandex.ru>--- Stability   : experimental--- Portability : non-portable----module Graphics.ColorSpace.Complex (-  -- *** Rectangular form-  Complex(..), (+:), realPart, imagPart,-  -- *** Polar form-  mkPolar, cis, polar, magnitude, phase,-  -- *** Conjugate-  conjugate-  ) where--import Control.Applicative-import Data.Complex (Complex(..))-import qualified Data.Complex as C hiding (Complex(..))-import Graphics.ColorSpace.Internal----infix 6 +:---- | Constrcut a complex pixel from two pixels representing real and imaginary parts.------ @ PixelRGB 4 8 6 '+:' PixelRGB 7 1 1 __==__ PixelRGB (4 ':+' 7) (8 ':+' 1) (6 ':+' 1) @----(+:) :: ColorSpace cs e => Pixel cs e -> Pixel cs e -> Pixel cs (Complex e)-(+:) = liftA2 (:+)-{-# INLINE (+:) #-}---- | Extracts the real part of a complex pixel.-realPart :: (ColorSpace cs e, RealFloat e) => Pixel cs (Complex e) -> Pixel cs e-realPart = fmap C.realPart-{-# INLINE realPart #-}---- | Extracts the imaginary part of a complex pixel.-imagPart :: (ColorSpace cs e, RealFloat e) => Pixel cs (Complex e) -> Pixel cs e-imagPart = fmap C.imagPart-{-# INLINE imagPart #-}---- | Form a complex pixel from polar components of magnitude and phase.-mkPolar :: (ColorSpace cs e, RealFloat e) =>-           Pixel cs e -> Pixel cs e -> Pixel cs (Complex e)-mkPolar = liftA2 C.mkPolar-{-# INLINE mkPolar #-}---- | @'cis' t@ is a complex pixel with magnitude 1 and phase t (modulo @2*'pi'@).-cis :: (ColorSpace cs e, RealFloat e) => Pixel cs e -> Pixel cs (Complex e)-cis = fmap C.cis-{-# INLINE cis #-}---- | The function @'polar'@ takes a complex pixel and returns a (magnitude, phase)--- pair of pixels in canonical form: the magnitude is nonnegative, and the phase--- in the range @(-'pi', 'pi']@; if the magnitude is zero, then so is the phase.-polar :: (ColorSpace cs e, RealFloat e) => Pixel cs (Complex e) -> (Pixel cs e, Pixel cs e)-polar !zPx = (magnitude zPx, phase zPx)-{-# INLINE polar #-}---- | The nonnegative magnitude of a complex pixel.-magnitude :: (ColorSpace cs e, RealFloat e) => Pixel cs (Complex e) -> Pixel cs e-magnitude = fmap C.magnitude-{-# INLINE magnitude #-}---- | The phase of a complex pixel, in the range @(-'pi', 'pi']@. If the--- magnitude is zero, then so is the phase.-phase :: (ColorSpace cs e, RealFloat e) => Pixel cs (Complex e) -> Pixel cs e-phase = fmap C.phase-{-# INLINE phase #-}---- | The conjugate of a complex pixel.-conjugate :: (ColorSpace cs e, RealFloat e) => Pixel cs (Complex e) -> Pixel cs (Complex e)-conjugate = fmap C.conjugate-{-# INLINE conjugate #-}--
− src/Graphics/ColorSpace/Elevator.hs 
@@ -1,319 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE ScopedTypeVariables #-}-#if __GLASGOW_HASKELL__ >= 800-  {-# OPTIONS_GHC -Wno-redundant-constraints #-}-#endif--- |--- Module      : Graphics.ColorSpace.Elevator--- Copyright   : (c) Alexey Kuleshevich 2018-2019--- License     : BSD3--- Maintainer  : Alexey Kuleshevich <lehins@yandex.ru>--- Stability   : experimental--- Portability : non-portable----module Graphics.ColorSpace.Elevator (-  Elevator(..)-  , clamp01-  ) where--import qualified Data.Complex as C-import Data.Int-import Data.Typeable-import Data.Vector.Storable (Storable)-import Data.Vector.Unboxed (Unbox)-import Data.Word-import GHC.Float----- | A class with a set of convenient functions that allow for changing precision of--- channels within pixels, while scaling the values to keep them in an appropriate range.------ >>> let rgb = PixelRGB 0.0 0.5 1.0 :: Pixel RGB Double--- >>> eToWord8 <$> rgb--- <RGB:(0|128|255)>--- >>> eToWord16 <$> rgb--- <RGB:(0|32768|65535)>----class (Eq e, Num e, Typeable e, Unbox e, Storable e) => Elevator e where--  -- | Values are scaled to @[0, 255]@ range.-  eToWord8 :: e -> Word8--  -- | Values are scaled to @[0, 65535]@ range.-  eToWord16 :: e -> Word16--  -- | Values are scaled to @[0, 4294967295]@ range.-  eToWord32 :: e -> Word32--  -- | Values are scaled to @[0, 18446744073709551615]@ range.-  eToWord64 :: e -> Word64--  -- | Values are scaled to @[0.0, 1.0]@ range.-  eToFloat :: e -> Float--  -- | Values are scaled to @[0.0, 1.0]@ range.-  eToDouble :: e -> Double--  -- | Values are scaled from @[0.0, 1.0]@ range.-  eFromDouble :: Double -> e----- | Lower the precision-dropDown :: forall a b. (Integral a, Bounded a, Integral b, Bounded b) => a -> b-dropDown !e = fromIntegral $ fromIntegral e `div` ((maxBound :: a) `div`-                                                   fromIntegral (maxBound :: b))-{-# INLINE dropDown #-}---- | Increase the precision-raiseUp :: forall a b. (Integral a, Bounded a, Integral b, Bounded b) => a -> b-raiseUp !e = fromIntegral e * ((maxBound :: b) `div` fromIntegral (maxBound :: a))-{-# INLINE raiseUp #-}---- | Convert to fractional with value less than or equal to 1.-squashTo1 :: forall a b. (Fractional b, Integral a, Bounded a) => a -> b-squashTo1 !e = fromIntegral e / fromIntegral (maxBound :: a)-{-# INLINE squashTo1 #-}---- | Convert to integral streaching it's value up to a maximum value.-stretch :: forall a b. (RealFrac a, Floating a, Integral b, Bounded b) => a -> b-stretch !e = round (fromIntegral (maxBound :: b) * clamp01 e)-{-# INLINE stretch #-}----- | Clamp a value to @[0, 1]@ range.-clamp01 :: (Ord a, Floating a) => a -> a-clamp01 !x = min (max 0 x) 1-{-# INLINE clamp01 #-}----- | Values between @[0, 255]]@-instance Elevator Word8 where-  eToWord8 = id-  {-# INLINE eToWord8 #-}-  eToWord16 = raiseUp-  {-# INLINE eToWord16 #-}-  eToWord32 = raiseUp-  {-# INLINE eToWord32 #-}-  eToWord64 = raiseUp-  {-# INLINE eToWord64 #-}-  eToFloat = squashTo1-  {-# INLINE eToFloat #-}-  eToDouble = squashTo1-  {-# INLINE eToDouble #-}-  eFromDouble = eToWord8-  {-# INLINE eFromDouble #-}----- | Values between @[0, 65535]]@-instance Elevator Word16 where-  eToWord8 = dropDown-  {-# INLINE eToWord8 #-}-  eToWord16 = id-  {-# INLINE eToWord16 #-}-  eToWord32 = raiseUp-  {-# INLINE eToWord32 #-}-  eToWord64 = raiseUp-  {-# INLINE eToWord64 #-}-  eToFloat = squashTo1-  {-# INLINE eToFloat #-}-  eToDouble = squashTo1-  {-# INLINE eToDouble #-}-  eFromDouble = eToWord16-  {-# INLINE eFromDouble #-}----- | Values between @[0, 4294967295]@-instance Elevator Word32 where-  eToWord8 = dropDown-  {-# INLINE eToWord8 #-}-  eToWord16 = dropDown-  {-# INLINE eToWord16 #-}-  eToWord32 = id-  {-# INLINE eToWord32 #-}-  eToWord64 = raiseUp-  {-# INLINE eToWord64 #-}-  eToFloat = squashTo1-  {-# INLINE eToFloat #-}-  eToDouble = squashTo1-  {-# INLINE eToDouble #-}-  eFromDouble = eToWord32-  {-# INLINE eFromDouble #-}----- | Values between @[0, 18446744073709551615]@-instance Elevator Word64 where-  eToWord8 = dropDown-  {-# INLINE eToWord8 #-}-  eToWord16 = dropDown-  {-# INLINE eToWord16 #-}-  eToWord32 = dropDown-  {-# INLINE eToWord32 #-}-  eToWord64 = id-  {-# INLINE eToWord64 #-}-  eToFloat = squashTo1-  {-# INLINE eToFloat #-}-  eToDouble = squashTo1-  {-# INLINE eToDouble #-}-  eFromDouble = eToWord64-  {-# INLINE eFromDouble #-}---- | Values between @[0, 18446744073709551615]@ on 64bit-instance Elevator Word where-  eToWord8 = dropDown-  {-# INLINE eToWord8 #-}-  eToWord16 = dropDown-  {-# INLINE eToWord16 #-}-  eToWord32 = dropDown-  {-# INLINE eToWord32 #-}-  eToWord64 = fromIntegral-  {-# INLINE eToWord64 #-}-  eToFloat = squashTo1-  {-# INLINE eToFloat #-}-  eToDouble = squashTo1-  {-# INLINE eToDouble #-}-  eFromDouble = stretch . clamp01-  {-# INLINE eFromDouble #-}---- | Values between @[0, 127]@-instance Elevator Int8 where-  eToWord8 = fromIntegral . max 0-  {-# INLINE eToWord8 #-}-  eToWord16 = raiseUp . max 0-  {-# INLINE eToWord16 #-}-  eToWord32 = raiseUp . max 0-  {-# INLINE eToWord32 #-}-  eToWord64 = raiseUp . max 0-  {-# INLINE eToWord64 #-}-  eToFloat = squashTo1 . max 0-  {-# INLINE eToFloat #-}-  eToDouble = squashTo1 . max 0-  {-# INLINE eToDouble #-}-  eFromDouble = stretch . clamp01-  {-# INLINE eFromDouble #-}----- | Values between @[0, 32767]@-instance Elevator Int16 where-  eToWord8 = dropDown . max 0-  {-# INLINE eToWord8 #-}-  eToWord16 = fromIntegral . max 0-  {-# INLINE eToWord16 #-}-  eToWord32 = raiseUp . max 0-  {-# INLINE eToWord32 #-}-  eToWord64 = raiseUp . max 0-  {-# INLINE eToWord64 #-}-  eToFloat = squashTo1 . max 0-  {-# INLINE eToFloat #-}-  eToDouble = squashTo1 . max 0-  {-# INLINE eToDouble #-}-  eFromDouble = stretch . clamp01-  {-# INLINE eFromDouble #-}----- | Values between @[0, 2147483647]@-instance Elevator Int32 where-  eToWord8 = dropDown . max 0-  {-# INLINE eToWord8 #-}-  eToWord16 = dropDown . max 0-  {-# INLINE eToWord16 #-}-  eToWord32 = fromIntegral . max 0-  {-# INLINE eToWord32 #-}-  eToWord64 = raiseUp . max 0-  {-# INLINE eToWord64 #-}-  eToFloat = squashTo1 . max 0-  {-# INLINE eToFloat #-}-  eToDouble = squashTo1 . max 0-  {-# INLINE eToDouble #-}-  eFromDouble = stretch . clamp01-  {-# INLINE eFromDouble #-}----- | Values between @[0, 9223372036854775807]@-instance Elevator Int64 where-  eToWord8 = dropDown . max 0-  {-# INLINE eToWord8 #-}-  eToWord16 = dropDown . max 0-  {-# INLINE eToWord16 #-}-  eToWord32 = dropDown . max 0-  {-# INLINE eToWord32 #-}-  eToWord64 = fromIntegral . max 0-  {-# INLINE eToWord64 #-}-  eToFloat = squashTo1 . max 0-  {-# INLINE eToFloat #-}-  eToDouble = squashTo1 . max 0-  {-# INLINE eToDouble #-}-  eFromDouble = stretch . clamp01-  {-# INLINE eFromDouble #-}----- | Values between @[0, 9223372036854775807]@ on 64bit-instance Elevator Int where-  eToWord8 = dropDown . max 0-  {-# INLINE eToWord8 #-}-  eToWord16 = dropDown . max 0-  {-# INLINE eToWord16 #-}-  eToWord32 = dropDown . max 0-  {-# INLINE eToWord32 #-}-  eToWord64 = fromIntegral . max 0-  {-# INLINE eToWord64 #-}-  eToFloat = squashTo1 . max 0-  {-# INLINE eToFloat #-}-  eToDouble = squashTo1 . max 0-  {-# INLINE eToDouble #-}-  eFromDouble = stretch . clamp01-  {-# INLINE eFromDouble #-}----- | Values between @[0.0, 1.0]@-instance Elevator Float where-  eToWord8 = stretch . clamp01-  {-# INLINE eToWord8 #-}-  eToWord16 = stretch . clamp01-  {-# INLINE eToWord16 #-}-  eToWord32 = stretch . clamp01-  {-# INLINE eToWord32 #-}-  eToWord64 = stretch . clamp01-  {-# INLINE eToWord64 #-}-  eToFloat = id-  {-# INLINE eToFloat #-}-  eToDouble = float2Double-  {-# INLINE eToDouble #-}-  eFromDouble = eToFloat-  {-# INLINE eFromDouble #-}----- | Values between @[0.0, 1.0]@-instance Elevator Double where-  eToWord8 = stretch . clamp01-  {-# INLINE eToWord8 #-}-  eToWord16 = stretch . clamp01-  {-# INLINE eToWord16 #-}-  eToWord32 = stretch . clamp01-  {-# INLINE eToWord32 #-}-  eToWord64 = stretch . clamp01-  {-# INLINE eToWord64 #-}-  eToFloat = double2Float-  {-# INLINE eToFloat #-}-  eToDouble = id-  {-# INLINE eToDouble #-}-  eFromDouble = id-  {-# INLINE eFromDouble #-}----- | Discards imaginary part and changes precision of real part.-instance (Num e, Elevator e, RealFloat e) => Elevator (C.Complex e) where-  eToWord8 = eToWord8 . C.realPart-  {-# INLINE eToWord8 #-}-  eToWord16 = eToWord16 . C.realPart-  {-# INLINE eToWord16 #-}-  eToWord32 = eToWord32 . C.realPart-  {-# INLINE eToWord32 #-}-  eToWord64 = eToWord64 . C.realPart-  {-# INLINE eToWord64 #-}-  eToFloat = eToFloat . C.realPart-  {-# INLINE eToFloat #-}-  eToDouble = eToDouble . C.realPart-  {-# INLINE eToDouble #-}-  eFromDouble = (C.:+ 0) . eFromDouble-  {-# INLINE eFromDouble #-}
− src/Graphics/ColorSpace/HSI.hs 
@@ -1,204 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}--- |--- Module      : Graphics.ColorSpace.HSI--- Copyright   : (c) Alexey Kuleshevich 2018-2019--- License     : BSD3--- Maintainer  : Alexey Kuleshevich <lehins@yandex.ru>--- Stability   : experimental--- Portability : non-portable----module Graphics.ColorSpace.HSI (-  HSI(..), HSIA(..), Pixel(..)-  ) where--import Data.Foldable-import Data.Typeable (Typeable)-import Foreign.Ptr-import Foreign.Storable-import Graphics.ColorSpace.Internal-import Prelude hiding (map)----------------- HSI ------------------- | Hue, Saturation and Intensity color space.-data HSI = HueHSI -- ^ Hue-         | SatHSI -- ^ Saturation-         | IntHSI -- ^ Intensity-         deriving (Eq, Enum, Show, Bounded, Typeable)--data instance Pixel HSI e = PixelHSI !e !e !e deriving (Eq, Ord)---instance Show e => Show (Pixel HSI e) where-  show (PixelHSI h s i) = "<HSI:("++show h++"|"++show s++"|"++show i++")>"---instance Elevator e => ColorSpace HSI e where-  type Components HSI e = (e, e, e)--  toComponents (PixelHSI h s i) = (h, s, i)-  {-# INLINE toComponents #-}-  fromComponents (h, s, i) = PixelHSI h s i-  {-# INLINE fromComponents #-}-  getPxC (PixelHSI h _ _) HueHSI = h-  getPxC (PixelHSI _ s _) SatHSI = s-  getPxC (PixelHSI _ _ i) IntHSI = i-  {-# INLINE getPxC #-}-  setPxC (PixelHSI _ s i) HueHSI h = PixelHSI h s i-  setPxC (PixelHSI h _ i) SatHSI s = PixelHSI h s i-  setPxC (PixelHSI h s _) IntHSI i = PixelHSI h s i-  {-# INLINE setPxC #-}-  mapPxC f (PixelHSI h s i) = PixelHSI (f HueHSI h) (f SatHSI s) (f IntHSI i)-  {-# INLINE mapPxC #-}-  foldlPx = foldl'-  {-# INLINE foldlPx #-}-  foldlPx2 f !z (PixelHSI h1 s1 i1) (PixelHSI h2 s2 i2) =-    f (f (f z h1 h2) s1 s2) i1 i2-  {-# INLINE foldlPx2 #-}---instance Functor (Pixel HSI) where-  fmap f (PixelHSI h s i) = PixelHSI (f h) (f s) (f i)-  {-# INLINE fmap #-}---instance Applicative (Pixel HSI) where-  pure !e = PixelHSI e e e-  {-# INLINE pure #-}-  (PixelHSI fh fs fi) <*> (PixelHSI h s i) = PixelHSI (fh h) (fs s) (fi i)-  {-# INLINE (<*>) #-}---instance Foldable (Pixel HSI) where-  foldr f !z (PixelHSI h s i) = f h (f s (f i z))-  {-# INLINE foldr #-}--instance Traversable (Pixel HSI) where-  traverse f (PixelHSI h s i) = PixelHSI <$> f h <*> f s <*> f i-  {-# INLINE traverse #-}---instance Storable e => Storable (Pixel HSI e) where--  sizeOf _ = 3 * sizeOf (undefined :: e)-  {-# INLINE sizeOf #-}-  alignment _ = alignment (undefined :: e)-  {-# INLINE alignment #-}-  peek !p = do-    let !q = castPtr p-    h <- peek q-    s <- peekElemOff q 1-    i <- peekElemOff q 2-    return $! PixelHSI h s i-  {-# INLINE peek #-}-  poke !p (PixelHSI h s i) = do-    let !q =  castPtr p-    poke q h-    pokeElemOff q 1 s-    pokeElemOff q 2 i-  {-# INLINE poke #-}------------------ HSIA -------------------- | Hue, Saturation and Intensity color space with Alpha channel.-data HSIA = HueHSIA   -- ^ Hue-          | SatHSIA   -- ^ Saturation-          | IntHSIA   -- ^ Intensity-          | AlphaHSIA -- ^ Alpha-          deriving (Eq, Enum, Show, Bounded, Typeable)---data instance Pixel HSIA e = PixelHSIA !e !e !e !e deriving (Eq, Ord)---instance Show e => Show (Pixel HSIA e) where-  show (PixelHSIA h s i a) = "<HSIA:("++show h++"|"++show s++"|"++show i++"|"++show a++")>"---instance Elevator e => ColorSpace HSIA e where-  type Components HSIA e = (e, e, e, e)--  toComponents (PixelHSIA h s i a) = (h, s, i, a)-  {-# INLINE toComponents #-}-  fromComponents (h, s, i, a) = PixelHSIA h s i a-  {-# INLINE fromComponents #-}-  getPxC (PixelHSIA h _ _ _) HueHSIA   = h-  getPxC (PixelHSIA _ s _ _) SatHSIA   = s-  getPxC (PixelHSIA _ _ i _) IntHSIA   = i-  getPxC (PixelHSIA _ _ _ a) AlphaHSIA = a-  {-# INLINE getPxC #-}-  setPxC (PixelHSIA _ s i a) HueHSIA h   = PixelHSIA h s i a-  setPxC (PixelHSIA h _ i a) SatHSIA s   = PixelHSIA h s i a-  setPxC (PixelHSIA h s _ a) IntHSIA i   = PixelHSIA h s i a-  setPxC (PixelHSIA h s i _) AlphaHSIA a = PixelHSIA h s i a-  {-# INLINE setPxC #-}-  mapPxC f (PixelHSIA h s i a) =-    PixelHSIA (f HueHSIA h) (f SatHSIA s) (f IntHSIA i) (f AlphaHSIA a)-  {-# INLINE mapPxC #-}-  foldlPx2 f !z (PixelHSIA h1 s1 i1 a1) (PixelHSIA h2 s2 i2 a2) =-    f (f (f (f z h1 h2) s1 s2) i1 i2) a1 a2-  {-# INLINE foldlPx2 #-}---instance Elevator e => AlphaSpace HSIA e where-  type Opaque HSIA = HSI--  getAlpha (PixelHSIA _ _ _ a) = a-  {-# INLINE getAlpha #-}-  addAlpha !a (PixelHSI h s i) = PixelHSIA h s i a-  {-# INLINE addAlpha #-}-  dropAlpha (PixelHSIA h s i _) = PixelHSI h s i-  {-# INLINE dropAlpha #-}---instance Functor (Pixel HSIA) where-  fmap f (PixelHSIA h s i a) = PixelHSIA (f h) (f s) (f i) (f a)-  {-# INLINE fmap #-}---instance Applicative (Pixel HSIA) where-  pure !e = PixelHSIA e e e e-  {-# INLINE pure #-}-  (PixelHSIA fh fs fi fa) <*> (PixelHSIA h s i a) = PixelHSIA (fh h) (fs s) (fi i) (fa a)-  {-# INLINE (<*>) #-}---instance Foldable (Pixel HSIA) where-  foldr f !z (PixelHSIA h s i a) = f h (f s (f i (f a z)))-  {-# INLINE foldr #-}--instance Traversable (Pixel HSIA) where-  traverse f (PixelHSIA h s i a) = PixelHSIA <$> f h <*> f s <*> f i <*> f a-  {-# INLINE traverse #-}---instance Storable e => Storable (Pixel HSIA e) where-  sizeOf _ = 4 * sizeOf (undefined :: e)-  {-# INLINE sizeOf #-}-  alignment _ = alignment (undefined :: e)-  {-# INLINE alignment #-}-  peek !p = do-    let !q = castPtr p-    h <- peek q-    s <- peekElemOff q 1-    i <- peekElemOff q 2-    a <- peekElemOff q 3-    return $! PixelHSIA h s i a-  {-# INLINE peek #-}-  poke !p (PixelHSIA h s i a) = do-    let !q = castPtr p-    poke q h-    pokeElemOff q 1 s-    pokeElemOff q 2 i-    pokeElemOff q 3 a-  {-# INLINE poke #-}
− src/Graphics/ColorSpace/Internal.hs 
@@ -1,241 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TypeFamilies #-}--- |--- Module      : Graphics.ColorSpace.Internal--- Copyright   : (c) Alexey Kuleshevich 2018-2019--- License     : BSD3--- Maintainer  : Alexey Kuleshevich <lehins@yandex.ru>--- Stability   : experimental--- Portability : non-portable----module Graphics.ColorSpace.Internal-  ( Pixel-  , ColorSpace(..)-  , AlphaSpace(..)-  , module Graphics.ColorSpace.Elevator-  ) where--import Control.Applicative-import Control.DeepSeq (NFData(rnf), deepseq)-import Control.Monad (liftM)-import Data.Default.Class (Default(..))-import Data.Foldable-import Data.Typeable-import qualified Data.Vector.Generic as V-import qualified Data.Vector.Generic.Mutable as VM-import qualified Data.Vector.Storable as VS-import qualified Data.Vector.Unboxed as VU-import Graphics.ColorSpace.Elevator----- | A Pixel family with a color space and a precision of elements.-data family Pixel cs e :: *--class (Eq cs, Enum cs, Show cs, Bounded cs, Typeable cs,-       Functor (Pixel cs), Applicative (Pixel cs), Foldable (Pixel cs), Traversable (Pixel cs),-       Eq (Pixel cs e), VU.Unbox (Components cs e), VS.Storable (Pixel cs e), Elevator e)-      => ColorSpace cs e where--  type Components cs e--  -- | Convert a Pixel to a representation suitable for storage as an unboxed-  -- element, usually a tuple of channels.-  toComponents :: Pixel cs e -> Components cs e--  -- | Convert from an elemnt representation back to a Pixel.-  fromComponents :: Components cs e -> Pixel cs e--  -- | Construt a Pixel by replicating the same value across all of the components.-  promote :: e -> Pixel cs e-  promote = pure-  {-# INLINE promote #-}--  -- | Retrieve Pixel's component value-  getPxC :: Pixel cs e -> cs -> e--  -- | Set Pixel's component value-  setPxC :: Pixel cs e -> cs -> e -> Pixel cs e--  -- | Map a channel aware function over all Pixel's components.-  mapPxC :: (cs -> e -> e) -> Pixel cs e -> Pixel cs e--  -- | Left fold on two pixels a the same time. If accumulator is nutrual to the folding funciton-  -- then it's equivalent to @foldlPx2 f acc px1 px2 == foldl' acc (liftA2 (f acc) px1 px2)@-  foldlPx2 :: (b -> e -> e -> b) -> b -> Pixel cs e -> Pixel cs e -> b--  -- | Map a function over all Pixel's componenets.-  liftPx :: (e -> e) -> Pixel cs e -> Pixel cs e-  liftPx = fmap-  {-# INLINE liftPx #-}--  -- | Zip two Pixels with a function.-  liftPx2 :: (e -> e -> e) -> Pixel cs e -> Pixel cs e -> Pixel cs e-  liftPx2 = liftA2-  {-# INLINE liftPx2 #-}--  -- | Right fold over all Pixel's components.-  foldrPx :: (e -> b -> b) -> b -> Pixel cs e -> b-  foldrPx = foldr'-  {-# INLINE foldrPx #-}--  -- | Left strict fold over all Pixel's components.-  foldlPx :: (b -> e -> b) -> b -> Pixel cs e -> b-  foldlPx = foldl'-  {-# INLINE foldlPx #-}--  foldl1Px :: (e -> e -> e) -> Pixel cs e -> e-  foldl1Px = foldl1-  {-# INLINE foldl1Px #-}--{-# DEPRECATED liftPx "Use `fmap` from `Functor` instead" #-}-{-# DEPRECATED liftPx2 "Use `liftA2` from `Applicative` instead" #-}-{-# DEPRECATED promote "Use `pure` from `Applicative` instead" #-}-{-# DEPRECATED foldlPx "Use `foldl'` from `Foldable` instead" #-}-{-# DEPRECATED foldrPx "Use `foldr'` from `Foldable` instead" #-}-{-# DEPRECATED foldl1Px "Use `foldl1` from `Foldable` instead" #-}---- | A color space that supports transparency.-class (ColorSpace (Opaque cs) e, ColorSpace cs e) => AlphaSpace cs e where-  -- | A corresponding opaque version of this color space.-  type Opaque cs--  -- | Get an alpha channel of a transparant pixel.-  getAlpha :: Pixel cs e -> e--  -- | Add an alpha channel to an opaque pixel.-  ---  -- @ addAlpha 0 (PixelHSI 1 2 3) == PixelHSIA 1 2 3 0 @-  addAlpha :: e -> Pixel (Opaque cs) e -> Pixel cs e--  -- | Convert a transparent pixel to an opaque one by dropping the alpha-  -- channel.-  ---  -- @ dropAlpha (PixelRGBA 1 2 3 4) == PixelRGB 1 2 3 @-  ---  dropAlpha :: Pixel cs e -> Pixel (Opaque cs) e--instance ColorSpace cs e => Default (Pixel cs e) where--  def = pure 0-  {-# INLINE def #-}---instance ColorSpace cs e => Num (Pixel cs e) where-  (+)         = liftA2 (+)-  {-# INLINE (+) #-}-  (-)         = liftA2 (-)-  {-# INLINE (-) #-}-  (*)         = liftA2 (*)-  {-# INLINE (*) #-}-  abs         = fmap abs-  {-# INLINE abs #-}-  signum      = fmap signum-  {-# INLINE signum #-}-  fromInteger = pure . fromInteger-  {-# INLINE fromInteger #-}---instance (ColorSpace cs e, Fractional e) => Fractional (Pixel cs e) where-  (/)          = liftA2 (/)-  {-# INLINE (/) #-}-  recip        = fmap recip-  {-# INLINE recip #-}-  fromRational = pure . fromRational-  {-# INLINE fromRational #-}---instance (ColorSpace cs e, Floating e) => Floating (Pixel cs e) where-  pi      = pure pi-  {-# INLINE pi #-}-  exp     = fmap exp-  {-# INLINE exp #-}-  log     = fmap log-  {-# INLINE log #-}-  sin     = fmap sin-  {-# INLINE sin #-}-  cos     = fmap cos-  {-# INLINE cos #-}-  asin    = fmap asin-  {-# INLINE asin #-}-  atan    = fmap atan-  {-# INLINE atan #-}-  acos    = fmap acos-  {-# INLINE acos #-}-  sinh    = fmap sinh-  {-# INLINE sinh #-}-  cosh    = fmap cosh-  {-# INLINE cosh #-}-  asinh   = fmap asinh-  {-# INLINE asinh #-}-  atanh   = fmap atanh-  {-# INLINE atanh #-}-  acosh   = fmap acosh-  {-# INLINE acosh #-}--instance (ColorSpace cs e, Bounded e) => Bounded (Pixel cs e) where-  maxBound = pure maxBound-  {-# INLINE maxBound #-}-  minBound = pure minBound-  {-# INLINE minBound #-}--instance (ColorSpace cs e, NFData e) => NFData (Pixel cs e) where--  rnf = foldr' deepseq ()-  {-# INLINE rnf #-}----- | Unboxing of a `Pixel`.-instance ColorSpace cs e => VU.Unbox (Pixel cs e)--newtype instance VU.MVector s (Pixel cs e) = MV_Pixel (VU.MVector s (Components cs e))--instance ColorSpace cs e => VM.MVector VU.MVector (Pixel cs e) where-  basicLength (MV_Pixel mvec) = VM.basicLength mvec-  {-# INLINE basicLength #-}-  basicUnsafeSlice idx len (MV_Pixel mvec) = MV_Pixel (VM.basicUnsafeSlice idx len mvec)-  {-# INLINE basicUnsafeSlice #-}-  basicOverlaps (MV_Pixel mvec) (MV_Pixel mvec') = VM.basicOverlaps mvec mvec'-  {-# INLINE basicOverlaps #-}-  basicUnsafeNew len = MV_Pixel `liftM` VM.basicUnsafeNew len-  {-# INLINE basicUnsafeNew #-}-  basicUnsafeReplicate len val = MV_Pixel `liftM` VM.basicUnsafeReplicate len (toComponents val)-  {-# INLINE basicUnsafeReplicate #-}-  basicUnsafeRead (MV_Pixel mvec) idx = fromComponents `liftM` VM.basicUnsafeRead mvec idx-  {-# INLINE basicUnsafeRead #-}-  basicUnsafeWrite (MV_Pixel mvec) idx val = VM.basicUnsafeWrite mvec idx (toComponents val)-  {-# INLINE basicUnsafeWrite #-}-  basicClear (MV_Pixel mvec) = VM.basicClear mvec-  {-# INLINE basicClear #-}-  basicSet (MV_Pixel mvec) val = VM.basicSet mvec (toComponents val)-  {-# INLINE basicSet #-}-  basicUnsafeCopy (MV_Pixel mvec) (MV_Pixel mvec') = VM.basicUnsafeCopy mvec mvec'-  {-# INLINE basicUnsafeCopy #-}-  basicUnsafeMove (MV_Pixel mvec) (MV_Pixel mvec') = VM.basicUnsafeMove mvec mvec'-  {-# INLINE basicUnsafeMove #-}-  basicUnsafeGrow (MV_Pixel mvec) len = MV_Pixel `liftM` VM.basicUnsafeGrow mvec len-  {-# INLINE basicUnsafeGrow #-}-#if MIN_VERSION_vector(0,11,0)-  basicInitialize (MV_Pixel mvec) = VM.basicInitialize mvec-  {-# INLINE basicInitialize #-}-#endif---newtype instance VU.Vector (Pixel cs e) = V_Pixel (VU.Vector (Components cs e))--instance (ColorSpace cs e) => V.Vector VU.Vector (Pixel cs e) where-  basicUnsafeFreeze (MV_Pixel mvec) = V_Pixel `liftM` V.basicUnsafeFreeze mvec-  {-# INLINE basicUnsafeFreeze #-}-  basicUnsafeThaw (V_Pixel vec) = MV_Pixel `liftM` V.basicUnsafeThaw vec-  {-# INLINE basicUnsafeThaw #-}-  basicLength (V_Pixel vec) = V.basicLength vec-  {-# INLINE basicLength #-}-  basicUnsafeSlice idx len (V_Pixel vec) = V_Pixel (V.basicUnsafeSlice idx len vec)-  {-# INLINE basicUnsafeSlice #-}-  basicUnsafeIndexM (V_Pixel vec) idx = fromComponents `liftM` V.basicUnsafeIndexM vec idx-  {-# INLINE basicUnsafeIndexM #-}-  basicUnsafeCopy (MV_Pixel mvec) (V_Pixel vec) = V.basicUnsafeCopy mvec vec-  {-# INLINE basicUnsafeCopy #-}-  elemseq (V_Pixel vec) val = V.elemseq vec (toComponents val)-  {-# INLINE elemseq #-}
− src/Graphics/ColorSpace/RGB.hs 
@@ -1,196 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}--- |--- Module      : Graphics.ColorSpace.RGB--- Copyright   : (c) Alexey Kuleshevich 2018-2019--- License     : BSD3--- Maintainer  : Alexey Kuleshevich <lehins@yandex.ru>--- Stability   : experimental--- Portability : non-portable----module Graphics.ColorSpace.RGB (-  RGB(..), RGBA(..), Pixel(..)-  ) where--import Data.Typeable (Typeable)-import Foreign.Ptr-import Foreign.Storable-import Graphics.ColorSpace.Internal-import Prelude hiding (map)----------------- RGB ------------------- | Red, Green and Blue color space.-data RGB = RedRGB-         | GreenRGB-         | BlueRGB deriving (Eq, Enum, Show, Bounded, Typeable)---data instance Pixel RGB e = PixelRGB !e !e !e deriving (Eq, Ord)--instance Show e => Show (Pixel RGB e) where-  show (PixelRGB r g b) = "<RGB:("++show r++"|"++show g++"|"++show b++")>"---instance Elevator e => ColorSpace RGB e where-  type Components RGB e = (e, e, e)--  toComponents (PixelRGB r g b) = (r, g, b)-  {-# INLINE toComponents #-}-  fromComponents (r, g, b) = PixelRGB r g b-  {-# INLINE fromComponents #-}-  getPxC (PixelRGB r _ _) RedRGB   = r-  getPxC (PixelRGB _ g _) GreenRGB = g-  getPxC (PixelRGB _ _ b) BlueRGB  = b-  {-# INLINE getPxC #-}-  setPxC (PixelRGB _ g b) RedRGB   r = PixelRGB r g b-  setPxC (PixelRGB r _ b) GreenRGB g = PixelRGB r g b-  setPxC (PixelRGB r g _) BlueRGB  b = PixelRGB r g b-  {-# INLINE setPxC #-}-  mapPxC f (PixelRGB r g b) = PixelRGB (f RedRGB r) (f GreenRGB g) (f BlueRGB b)-  {-# INLINE mapPxC #-}-  foldlPx2 f !z (PixelRGB r1 g1 b1) (PixelRGB r2 g2 b2) =-    f (f (f z r1 r2) g1 g2) b1 b2-  {-# INLINE foldlPx2 #-}---instance Functor (Pixel RGB) where-  fmap f (PixelRGB r g b) = PixelRGB (f r) (f g) (f b)-  {-# INLINE fmap #-}---instance Applicative (Pixel RGB) where-  pure !e = PixelRGB e e e-  {-# INLINE pure #-}-  (PixelRGB fr fg fb) <*> (PixelRGB r g b) = PixelRGB (fr r) (fg g) (fb b)-  {-# INLINE (<*>) #-}---instance Foldable (Pixel RGB) where-  foldr f !z (PixelRGB r g b) = f r (f g (f b z))-  {-# INLINE foldr #-}---instance Traversable (Pixel RGB) where-  traverse f (PixelRGB r g b) = PixelRGB <$> f r <*> f g <*> f b-  {-# INLINE traverse #-}--instance Storable e => Storable (Pixel RGB e) where-  sizeOf _ = 3 * sizeOf (undefined :: e)-  {-# INLINE sizeOf #-}-  alignment _ = alignment (undefined :: e)-  {-# INLINE alignment #-}-  peek !p = do-    let !q = castPtr p-    r <- peek q-    g <- peekElemOff q 1-    b <- peekElemOff q 2-    return $! PixelRGB r g b-  {-# INLINE peek #-}-  poke !p (PixelRGB r g b) = do-    let !q = castPtr p-    poke q r-    pokeElemOff q 1 g-    pokeElemOff q 2 b-  {-# INLINE poke #-}------------------- RGBA --------------------- | Red, Green and Blue color space with Alpha channel.-data RGBA = RedRGBA-          | GreenRGBA-          | BlueRGBA-          | AlphaRGBA deriving (Eq, Enum, Show, Bounded, Typeable)--data instance Pixel RGBA e = PixelRGBA !e !e !e !e deriving (Eq, Ord)---instance Show e => Show (Pixel RGBA e) where-  show (PixelRGBA r g b a) = "<RGBA:("++show r++"|"++show g++"|"++show b++"|"++show a++")>"---instance Elevator e => ColorSpace RGBA e where-  type Components RGBA e = (e, e, e, e)--  toComponents (PixelRGBA r g b a) = (r, g, b, a)-  {-# INLINE toComponents #-}-  fromComponents (r, g, b, a) = PixelRGBA r g b a-  {-# INLINE fromComponents #-}-  getPxC (PixelRGBA r _ _ _) RedRGBA   = r-  getPxC (PixelRGBA _ g _ _) GreenRGBA = g-  getPxC (PixelRGBA _ _ b _) BlueRGBA  = b-  getPxC (PixelRGBA _ _ _ a) AlphaRGBA = a-  {-# INLINE getPxC #-}-  setPxC (PixelRGBA _ g b a) RedRGBA   r = PixelRGBA r g b a-  setPxC (PixelRGBA r _ b a) GreenRGBA g = PixelRGBA r g b a-  setPxC (PixelRGBA r g _ a) BlueRGBA  b = PixelRGBA r g b a-  setPxC (PixelRGBA r g b _) AlphaRGBA a = PixelRGBA r g b a-  {-# INLINE setPxC #-}-  mapPxC f (PixelRGBA r g b a) =-    PixelRGBA (f RedRGBA r) (f GreenRGBA g) (f BlueRGBA b) (f AlphaRGBA a)-  {-# INLINE mapPxC #-}-  foldlPx2 f !z (PixelRGBA r1 g1 b1 a1) (PixelRGBA r2 g2 b2 a2) =-    f (f (f (f z r1 r2) g1 g2) b1 b2) a1 a2-  {-# INLINE foldlPx2 #-}---instance Elevator e => AlphaSpace RGBA e where-  type Opaque RGBA = RGB--  getAlpha (PixelRGBA _ _ _ a) = a-  {-# INLINE getAlpha #-}-  addAlpha !a (PixelRGB r g b) = PixelRGBA r g b a-  {-# INLINE addAlpha #-}-  dropAlpha (PixelRGBA r g b _) = PixelRGB r g b-  {-# INLINE dropAlpha #-}---instance Functor (Pixel RGBA) where-  fmap f (PixelRGBA r g b a) = PixelRGBA (f r) (f g) (f b) (f a)-  {-# INLINE fmap #-}--instance Applicative (Pixel RGBA) where-  pure !e = PixelRGBA e e e e-  {-# INLINE pure #-}-  (PixelRGBA fr fg fb fa) <*> (PixelRGBA r g b a) = PixelRGBA (fr r) (fg g) (fb b) (fa a)-  {-# INLINE (<*>) #-}--instance Foldable (Pixel RGBA) where-  foldr f !z (PixelRGBA r g b a) = f r (f g (f b (f a z)))-  {-# INLINE foldr #-}--instance Traversable (Pixel RGBA) where-  traverse f (PixelRGBA r g b a) = PixelRGBA <$> f r <*> f g <*> f b <*> f a-  {-# INLINE traverse #-}--instance Storable e => Storable (Pixel RGBA e) where-  sizeOf _ = 4 * sizeOf (undefined :: e)-  {-# INLINE sizeOf #-}-  alignment _ = alignment (undefined :: e)-  {-# INLINE alignment #-}-  peek p = do-    let q = castPtr p-    r <- peek q-    g <- peekElemOff q 1-    b <- peekElemOff q 2-    a <- peekElemOff q 3-    return $! PixelRGBA r g b a-  {-# INLINE peek #-}-  poke p (PixelRGBA r g b a) = do-    let q = castPtr p-    poke q r-    pokeElemOff q 1 g-    pokeElemOff q 2 b-    pokeElemOff q 3 a-  {-# INLINE poke #-}
− src/Graphics/ColorSpace/X.hs 
@@ -1,132 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}--- |--- Module      : Graphics.ColorSpace.X--- Copyright   : (c) Alexey Kuleshevich 2018-2019--- License     : BSD3--- Maintainer  : Alexey Kuleshevich <lehins@yandex.ru>--- Stability   : experimental--- Portability : non-portable----module Graphics.ColorSpace.X-  ( X(..)-  , Pixel(..)-  , toPixelsX-  , fromPixelsX-  ) where--import Data.Bits (Bits)-import Data.Foldable-import Data.Typeable (Typeable)-import Foreign.Ptr-import Foreign.Storable-import Graphics.ColorSpace.Internal-import Prelude as P---- | This is a single channel colorspace, that is designed to separate Gray--- level values from other types of colorspace, hence it is not convertible to--- or from, but rather is here to allow operation on arbirtary single channel--- images. If you are looking for the actual grayscale color space.--- 'Graphics.ColorSpace.Luma.Y' should be used instead.-data X = X deriving (Eq, Enum, Bounded, Show, Typeable)---newtype instance  Pixel X e = PixelX-  { getX :: e-  } deriving (Ord, Eq, Enum, Bounded, Real, Integral, RealFrac, RealFloat, Bits)---instance Show e => Show (Pixel X e) where-  show (PixelX g) = "<X:("++show g++")>"---instance Elevator e => ColorSpace X e where-  type Components X e = e--  fromComponents = PixelX-  {-# INLINE fromComponents #-}-  toComponents (PixelX g) = g-  {-# INLINE toComponents #-}-  getPxC (PixelX g) X = g-  {-# INLINE getPxC #-}-  setPxC (PixelX _) X = PixelX-  {-# INLINE setPxC #-}-  mapPxC f (PixelX g) = PixelX (f X g)-  {-# INLINE mapPxC #-}-  foldlPx2 f !z (PixelX g1) (PixelX g2) = f z g1 g2-  {-# INLINE foldlPx2 #-}---instance Functor (Pixel X) where-  fmap f (PixelX g) = PixelX (f g)-  {-# INLINE fmap #-}---instance Applicative (Pixel X) where-  pure = PixelX-  {-# INLINE pure #-}-  (PixelX fg) <*> (PixelX g) = PixelX (fg g)-  {-# INLINE (<*>) #-}---instance Foldable (Pixel X) where-  foldr f !z (PixelX g) = f g z-  {-# INLINE foldr #-}---instance Traversable (Pixel X) where-  traverse f (PixelX x) = PixelX <$> f x-  {-# INLINE traverse #-}---instance Monad (Pixel X) where-  return = PixelX-  {-# INLINE return #-}-  (>>=) (PixelX g) f = f g-  {-# INLINE (>>=) #-}---instance Storable e => Storable (Pixel X e) where--  sizeOf _ = sizeOf (undefined :: e)-  {-# INLINE sizeOf #-}-  alignment _ = alignment (undefined :: e)-  {-# INLINE alignment #-}-  peek !p = do-    let q = castPtr p-    g <- peek q-    return (PixelX g)-  {-# INLINE peek #-}-  poke !p (PixelX g) = do-    let q = castPtr p-    poke q g-  {-# INLINE poke #-}----- | Separate a Pixel into a list of components with 'X' pixels containing every--- component from the pixel.------ >>> toPixelsX (PixelRGB 4 5 6)--- [<X:(4)>,<X:(5)>,<X:(6)>]----toPixelsX :: ColorSpace cs e => Pixel cs e -> [Pixel X e]-toPixelsX = fmap PixelX . toList---- | Combine a list of `X` pixels into a Pixel with a specified channel--- order. Not the most efficient way to construct a pixel, but might prove--- useful to someone.------ >>> fromPixelsX [(RedRGB, 3), (BlueRGB, 5), (GreenRGB, 4)]--- <RGB:(3.0|4.0|5.0)>--- >>> fromPixelsX $ zip (enumFrom RedRGB) (toPixelsX $ PixelRGB 4 5 6)--- <RGB:(4.0|5.0|6.0)>----fromPixelsX :: ColorSpace cs e => [(cs, Pixel X e)] -> Pixel cs e-fromPixelsX = foldl' f (pure 0) where-  f !px (c, PixelX x) = setPxC px c x
− src/Graphics/ColorSpace/Y.hs 
@@ -1,190 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}--- |--- Module      : Graphics.ColorSpace.Y--- Copyright   : (c) Alexey Kuleshevich 2018-2019--- License     : BSD3--- Maintainer  : Alexey Kuleshevich <lehins@yandex.ru>--- Stability   : experimental--- Portability : non-portable----module Graphics.ColorSpace.Y (-  Y(..), YA(..), Pixel(..)-  ) where--import Data.Foldable-import Data.Bits (Bits)-import Data.Typeable (Typeable)-import Foreign.Ptr-import Foreign.Storable-import Graphics.ColorSpace.Internal-import Prelude hiding (map)--------------- Y ----------------- | Luma or brightness, which is usually denoted as @Y'@.-data Y = LumaY deriving (Eq, Enum, Show, Bounded, Typeable)---newtype instance Pixel Y e = PixelY e-  deriving (Ord, Eq, Enum, Bounded, Real, Integral, RealFrac, RealFloat, Bits)--instance Show e => Show (Pixel Y e) where-  show (PixelY g) = "<Luma:("++show g++")>"--instance Elevator e => ColorSpace Y e where-  type Components Y e = e-  fromComponents = PixelY-  {-# INLINE fromComponents #-}-  toComponents (PixelY y) = y-  {-# INLINE toComponents #-}-  getPxC (PixelY y) LumaY = y-  {-# INLINE getPxC #-}-  setPxC _ LumaY = PixelY-  {-# INLINE setPxC #-}-  mapPxC f (PixelY y) = PixelY (f LumaY y)-  {-# INLINE mapPxC #-}-  foldlPx2 f !z (PixelY y1) (PixelY y2) = f z y1 y2-  {-# INLINE foldlPx2 #-}---instance Functor (Pixel Y) where-  fmap f (PixelY y) = PixelY (f y)-  {-# INLINE fmap #-}---instance Applicative (Pixel Y) where-  pure = PixelY-  {-# INLINE pure #-}-  (PixelY fy) <*> (PixelY y) = PixelY (fy y)-  {-# INLINE (<*>) #-}---instance Foldable (Pixel Y) where-  foldr f !z (PixelY y) = f y z-  {-# INLINE foldr #-}---instance Traversable (Pixel Y) where-  traverse f (PixelY y) = PixelY <$> f y-  {-# INLINE traverse #-}---instance Monad (Pixel Y) where-  return = PixelY-  {-# INLINE return #-}-  (>>=) (PixelY y) f = f y-  {-# INLINE (>>=) #-}----instance Storable e => Storable (Pixel Y e) where--  sizeOf _ = sizeOf (undefined :: e)-  {-# INLINE sizeOf #-}-  alignment _ = alignment (undefined :: e)-  {-# INLINE alignment #-}-  peek !p = do-    let !q = castPtr p-    y <- peek q-    return (PixelY y)-  {-# INLINE peek #-}-  poke !p (PixelY y) = let !q = castPtr p in poke q y-  {-# INLINE poke #-}------------------- YA ------------------ | Luma with Alpha channel.-data YA = LumaYA  -- ^ Luma-        | AlphaYA -- ^ Alpha channel-        deriving (Eq, Enum, Show, Bounded, Typeable)--data instance Pixel YA e = PixelYA !e !e deriving (Eq, Ord)---instance Show e => Show (Pixel YA e) where-  show (PixelYA y a) = "<LumaAlpha:("++show y++"|"++show a++")>"---instance Elevator e => ColorSpace YA e where-  type Components YA e = (e, e)-  fromComponents (y, a) = PixelYA y a-  {-# INLINE fromComponents #-}-  toComponents (PixelYA y a) = (y, a)-  {-# INLINE toComponents #-}-  getPxC (PixelYA y _)  LumaYA = y-  getPxC (PixelYA _ a) AlphaYA = a-  {-# INLINE getPxC #-}-  setPxC (PixelYA _ a) LumaYA  y = PixelYA y a-  setPxC (PixelYA y _) AlphaYA a = PixelYA y a-  {-# INLINE setPxC #-}-  mapPxC f (PixelYA y a) = PixelYA (f LumaYA y) (f AlphaYA a)-  {-# INLINE mapPxC #-}-  foldlPx2 f !z (PixelYA y1 a1) (PixelYA y2 a2) = f (f z y1 y2) a1 a2-  {-# INLINE foldlPx2 #-}---instance Elevator e => AlphaSpace YA e where-  type Opaque YA = Y--  getAlpha (PixelYA _ a) = a-  {-# INLINE getAlpha  #-}-  addAlpha !a (PixelY y) = PixelYA y a-  {-# INLINE addAlpha #-}-  dropAlpha (PixelYA y _) = PixelY y-  {-# INLINE dropAlpha #-}---instance Functor (Pixel YA) where-  fmap f (PixelYA y a) = PixelYA (f y) (f a)-  {-# INLINE fmap #-}---instance Applicative (Pixel YA) where-  pure !e = PixelYA e e-  {-# INLINE pure #-}-  (PixelYA fy fa) <*> (PixelYA y a) = PixelYA (fy y) (fa a)-  {-# INLINE (<*>) #-}---instance Foldable (Pixel YA) where-  foldr f !z (PixelYA y a) = f y (f a z)-  {-# INLINE foldr #-}---instance Traversable (Pixel YA) where-  traverse f (PixelYA y a) = PixelYA <$> f y <*> f a-  {-# INLINE traverse #-}---instance Storable e => Storable (Pixel YA e) where--  sizeOf _ = 2 * sizeOf (undefined :: e)-  {-# INLINE sizeOf #-}-  alignment _ = alignment (undefined :: e)-  {-# INLINE alignment #-}-  peek !p = do-    let q = castPtr p-    y <- peekElemOff q 0-    a <- peekElemOff q 1-    return $! PixelYA y a-  {-# INLINE peek #-}-  poke !p (PixelYA y a) = do-    let q = castPtr p-    pokeElemOff q 0 y-    pokeElemOff q 1 a-  {-# INLINE poke #-}-
− src/Graphics/ColorSpace/YCbCr.hs 
@@ -1,209 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}--- |--- Module      : Graphics.ColorSpace.YCbCr--- Copyright   : (c) Alexey Kuleshevich 2018-2019--- License     : BSD3--- Maintainer  : Alexey Kuleshevich <lehins@yandex.ru>--- Stability   : experimental--- Portability : non-portable----module Graphics.ColorSpace.YCbCr (-  YCbCr(..), YCbCrA(..), Pixel(..)-  ) where--import Data.Foldable-import Data.Typeable (Typeable)-import Foreign.Ptr-import Foreign.Storable-import Graphics.ColorSpace.Internal-import Prelude hiding (map)------------------- YCbCr ---------------------- | Color space is used to encode RGB information and is used in JPEG compression.-data YCbCr = LumaYCbCr  -- ^ Luma component (commonly denoted as __Y'__)-           | CBlueYCbCr -- ^ Blue difference chroma component-           | CRedYCbCr  -- ^ Red difference chroma component-           deriving (Eq, Enum, Show, Bounded, Typeable)--data instance Pixel YCbCr e = PixelYCbCr !e !e !e deriving (Eq, Ord)---instance Show e => Show (Pixel YCbCr e) where-  show (PixelYCbCr y b r) = "<YCbCr:("++show y++"|"++show b++"|"++show r++")>"---instance Elevator e => ColorSpace YCbCr e where-  type Components YCbCr e = (e, e, e)--  fromComponents (y, b, r) = PixelYCbCr y b r-  {-# INLINE fromComponents #-}-  toComponents (PixelYCbCr y b r) = (y, b, r)-  {-# INLINE toComponents #-}-  getPxC (PixelYCbCr y _ _) LumaYCbCr  = y-  getPxC (PixelYCbCr _ b _) CBlueYCbCr = b-  getPxC (PixelYCbCr _ _ r) CRedYCbCr  = r-  {-# INLINE getPxC #-}-  setPxC (PixelYCbCr _ b r) LumaYCbCr  y = PixelYCbCr y b r-  setPxC (PixelYCbCr y _ r) CBlueYCbCr b = PixelYCbCr y b r-  setPxC (PixelYCbCr y b _) CRedYCbCr  r = PixelYCbCr y b r-  {-# INLINE setPxC #-}-  mapPxC f (PixelYCbCr y b r) = PixelYCbCr (f LumaYCbCr y) (f CBlueYCbCr b) (f CRedYCbCr r)-  {-# INLINE mapPxC #-}-  foldlPx2 f !z (PixelYCbCr y1 b1 r1) (PixelYCbCr y2 b2 r2) =-    f (f (f z y1 y2) b1 b2) r1 r2-  {-# INLINE foldlPx2 #-}---instance Functor (Pixel YCbCr) where-  fmap f (PixelYCbCr y b r) = PixelYCbCr (f y) (f b) (f r)-  {-# INLINE fmap #-}---instance Applicative (Pixel YCbCr) where-  pure !e = PixelYCbCr e e e-  {-# INLINE pure #-}-  (PixelYCbCr fy fb fr) <*> (PixelYCbCr y b r) = PixelYCbCr (fy y) (fb b) (fr r)-  {-# INLINE (<*>) #-}---instance Foldable (Pixel YCbCr) where-  foldr f !z (PixelYCbCr y b r) = f y (f b (f r z))-  {-# INLINE foldr #-}---instance Traversable (Pixel YCbCr) where-  traverse f (PixelYCbCr y b r) = PixelYCbCr <$> f y <*> f b <*> f r-  {-# INLINE traverse #-}---instance Storable e => Storable (Pixel YCbCr e) where--  sizeOf _ = 3 * sizeOf (undefined :: e)-  {-# INLINE sizeOf #-}-  alignment _ = alignment (undefined :: e)-  {-# INLINE alignment #-}-  peek !p = do-    let q = castPtr p-    y <- peek q-    b <- peekElemOff q 1-    r <- peekElemOff q 2-    return $! PixelYCbCr y b r-  {-# INLINE poke #-}-  poke !p (PixelYCbCr y b r) = do-    let q = castPtr p-    pokeElemOff q 0 y-    pokeElemOff q 1 b-    pokeElemOff q 2 r-  {-# INLINE peek #-}--------------------- YCbCrA ----------------------- | YCbCr color space with Alpha channel.-data YCbCrA = LumaYCbCrA  -- ^ Luma component (commonly denoted as __Y'__)-            | CBlueYCbCrA -- ^ Blue difference chroma component-            | CRedYCbCrA  -- ^ Red difference chroma component-            | AlphaYCbCrA -- ^ Alpha component.-            deriving (Eq, Enum, Show, Bounded, Typeable)--data instance Pixel YCbCrA e = PixelYCbCrA !e !e !e !e deriving (Eq, Ord)---instance Show e => Show (Pixel YCbCrA e) where-  show (PixelYCbCrA y b r a) = "<YCbCrA:("++show y++"|"++show b++"|"++show r++"|"++show a++")>"---instance Elevator e => ColorSpace YCbCrA e where-  type Components YCbCrA e = (e, e, e, e)--  fromComponents (y, b, r, a) = PixelYCbCrA y b r a-  {-# INLINE fromComponents #-}-  toComponents (PixelYCbCrA y b r a) = (y, b, r, a)-  {-# INLINE toComponents #-}-  getPxC (PixelYCbCrA y _ _ _) LumaYCbCrA  = y-  getPxC (PixelYCbCrA _ b _ _) CBlueYCbCrA = b-  getPxC (PixelYCbCrA _ _ r _) CRedYCbCrA  = r-  getPxC (PixelYCbCrA _ _ _ a) AlphaYCbCrA = a-  {-# INLINE getPxC #-}-  setPxC (PixelYCbCrA _ b r a) LumaYCbCrA  y = PixelYCbCrA y b r a-  setPxC (PixelYCbCrA y _ r a) CBlueYCbCrA b = PixelYCbCrA y b r a-  setPxC (PixelYCbCrA y b _ a) CRedYCbCrA  r = PixelYCbCrA y b r a-  setPxC (PixelYCbCrA y b r _) AlphaYCbCrA a = PixelYCbCrA y b r a-  {-# INLINE setPxC #-}-  mapPxC f (PixelYCbCrA y b r a) =-    PixelYCbCrA (f LumaYCbCrA y) (f CBlueYCbCrA b) (f CRedYCbCrA r) (f AlphaYCbCrA a)-  {-# INLINE mapPxC #-}-  foldlPx2 f !z (PixelYCbCrA y1 b1 r1 a1) (PixelYCbCrA y2 b2 r2 a2) =-    f (f (f (f z y1 y2) b1 b2) r1 r2) a1 a2-  {-# INLINE foldlPx2 #-}---instance Elevator e => AlphaSpace YCbCrA e where-  type Opaque YCbCrA = YCbCr--  getAlpha (PixelYCbCrA _ _ _ a) = a-  {-# INLINE getAlpha #-}-  addAlpha !a (PixelYCbCr y b r) = PixelYCbCrA y b r a-  {-# INLINE addAlpha #-}-  dropAlpha (PixelYCbCrA y b r _) = PixelYCbCr y b r-  {-# INLINE dropAlpha #-}---instance Functor (Pixel YCbCrA) where-  fmap f (PixelYCbCrA y b r a) = PixelYCbCrA (f y) (f b) (f r) (f a)-  {-# INLINE fmap #-}---instance Applicative (Pixel YCbCrA) where-  pure !e = PixelYCbCrA e e e e-  {-# INLINE pure #-}-  (PixelYCbCrA fy fb fr fa) <*> (PixelYCbCrA y b r a) = PixelYCbCrA (fy y) (fb b) (fr r) (fa a)-  {-# INLINE (<*>) #-}---instance Foldable (Pixel YCbCrA) where-  foldr f !z (PixelYCbCrA y b r a) = f y (f b (f r (f a z)))-  {-# INLINE foldr #-}---instance Traversable (Pixel YCbCrA) where-  traverse f (PixelYCbCrA y b r a) = PixelYCbCrA <$> f y <*> f b <*> f r <*> f a-  {-# INLINE traverse #-}---instance Storable e => Storable (Pixel YCbCrA e) where--  sizeOf _ = 4 * sizeOf (undefined :: e)-  {-# INLINE sizeOf #-}-  alignment _ = alignment (undefined :: e)-  {-# INLINE alignment #-}-  peek !p = do-    let q = castPtr p-    y <- peekElemOff q 0-    b <- peekElemOff q 1-    r <- peekElemOff q 2-    a <- peekElemOff q 3-    return $! PixelYCbCrA y b r a-  {-# INLINE peek #-}-  poke !p (PixelYCbCrA y b r a) = do-    let q = castPtr p-    poke q y-    pokeElemOff q 1 b-    pokeElemOff q 2 r-    pokeElemOff q 3 a-  {-# INLINE poke #-}--
+ tests/Main.hs view
@@ -0,0 +1,11 @@+module Main where++import Spec (spec)+import System.IO (BufferMode (LineBuffering), hSetBuffering, hSetEncoding, stdout, utf8)+import Test.Hspec++main :: IO ()+main = do+  hSetBuffering stdout LineBuffering+  hSetEncoding stdout utf8+  hspec spec
+ tests/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=Spec #-}
+ tests/Test/Massiv/Array/IO/Image/AutoSpec.hs view
@@ -0,0 +1,154 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+module Test.Massiv.Array.IO.Image.AutoSpec (spec) where++import Data.Massiv.Array+import Data.Massiv.Array.IO+import Test.Massiv.Core+import Test.Massiv.Array.IO.Image.Common++spec :: Spec+spec =+  describe "Auto" $+  describe "Encode/Decode" $ do+    specEncodeDecodeNoErrorAuto BMP+    specEncodeDecodeNoErrorAuto GIF+    --specEncodeDecodeNoErrorAuto HDR -- Get "Invalid sanline size" from JuicyPixels+    specEncodeDecodeNoErrorAuto JPG+    specEncodeDecodeNoErrorAuto PNG+    specEncodeDecodeNoErrorAuto TGA+    specEncodeDecodeNoErrorAuto TIF+++specEncodeDecodeNoErrorAuto ::+     ( Show f+     , Readable (Auto f) (Image S (Y D65) Word8)+     , Readable (Auto f) (Image S (Y D65) Word16)+     , Readable (Auto f) (Image S (Y D65) Word32)+     , Readable (Auto f) (Image S (Y D65) Word64)+     , Readable (Auto f) (Image S (CMYK (SRGB 'NonLinear)) Word8)+     , Readable (Auto f) (Image S (CMYK (SRGB 'NonLinear)) Word16)+     , Readable (Auto f) (Image S (CMYK (SRGB 'NonLinear)) Word32)+     , Readable (Auto f) (Image S (CMYK (SRGB 'NonLinear)) Word64)+     , Readable (Auto f) (Image S (CMYK (AdobeRGB 'NonLinear)) Word8)+     , Readable (Auto f) (Image S (CMYK (AdobeRGB 'NonLinear)) Word16)+     , Readable (Auto f) (Image S (CMYK (AdobeRGB 'NonLinear)) Word32)+     , Readable (Auto f) (Image S (CMYK (AdobeRGB 'NonLinear)) Word64)+     , Readable (Auto f) (Image S (Y'CbCr SRGB) Word8)+     , Readable (Auto f) (Image S (Y'CbCr SRGB) Word16)+     , Readable (Auto f) (Image S (Y'CbCr SRGB) Word32)+     , Readable (Auto f) (Image S (Y'CbCr SRGB) Word64)+     -- (AdobeRGB 'NonLinear) doesn't have Luma instance+     -- , Readable (Auto f) (Image S (YCbCr (AdobeRGB 'NonLinear)) Word8)+     -- , Readable (Auto f) (Image S (YCbCr (AdobeRGB 'NonLinear)) Word16)+     -- , Readable (Auto f) (Image S (YCbCr (AdobeRGB 'NonLinear)) Word32)+     -- , Readable (Auto f) (Image S (YCbCr (AdobeRGB 'NonLinear)) Word64)+     , Readable (Auto f) (Image S (Alpha (Y D65)) Word8)+     , Readable (Auto f) (Image S (Alpha (Y D65)) Word16)+     , Readable (Auto f) (Image S (Alpha (Y D65)) Word32)+     , Readable (Auto f) (Image S (Alpha (Y D65)) Word64)+     , Readable (Auto f) (Image S (Alpha (SRGB 'NonLinear)) Word8)+     , Readable (Auto f) (Image S (Alpha (SRGB 'NonLinear)) Word16)+     , Readable (Auto f) (Image S (Alpha (SRGB 'NonLinear)) Word32)+     , Readable (Auto f) (Image S (Alpha (SRGB 'NonLinear)) Word64)+     , Readable (Auto f) (Image S (Alpha (AdobeRGB 'NonLinear)) Word8)+     , Readable (Auto f) (Image S (Alpha (AdobeRGB 'NonLinear)) Word16)+     , Readable (Auto f) (Image S (Alpha (AdobeRGB 'NonLinear)) Word32)+     , Readable (Auto f) (Image S (Alpha (AdobeRGB 'NonLinear)) Word64)+     , Readable (Auto f) (Image S (SRGB 'NonLinear) Word8)+     , Readable (Auto f) (Image S (SRGB 'NonLinear) Word16)+     , Readable (Auto f) (Image S (SRGB 'NonLinear) Word32)+     , Readable (Auto f) (Image S (SRGB 'NonLinear) Word64)+     , Readable (Auto f) (Image S (AdobeRGB 'NonLinear) Word8)+     , Readable (Auto f) (Image S (AdobeRGB 'NonLinear) Word16)+     , Readable (Auto f) (Image S (AdobeRGB 'NonLinear) Word32)+     , Readable (Auto f) (Image S (AdobeRGB 'NonLinear) Word64)+     , Writable (Auto f) (Image S (Y D65) Word8)+     , Writable (Auto f) (Image S (Y D65) Word16)+     , Writable (Auto f) (Image S (Y D65) Word32)+     , Writable (Auto f) (Image S (Y D65) Word64)+     , Writable (Auto f) (Image S (CMYK (SRGB 'NonLinear)) Word8)+     , Writable (Auto f) (Image S (CMYK (SRGB 'NonLinear)) Word16)+     , Writable (Auto f) (Image S (CMYK (SRGB 'NonLinear)) Word32)+     , Writable (Auto f) (Image S (CMYK (SRGB 'NonLinear)) Word64)+     , Writable (Auto f) (Image S (CMYK (AdobeRGB 'NonLinear)) Word8)+     , Writable (Auto f) (Image S (CMYK (AdobeRGB 'NonLinear)) Word16)+     , Writable (Auto f) (Image S (CMYK (AdobeRGB 'NonLinear)) Word32)+     , Writable (Auto f) (Image S (CMYK (AdobeRGB 'NonLinear)) Word64)+     , Writable (Auto f) (Image S (Y'CbCr SRGB) Word8)+     , Writable (Auto f) (Image S (Y'CbCr SRGB) Word16)+     , Writable (Auto f) (Image S (Y'CbCr SRGB) Word32)+     , Writable (Auto f) (Image S (Y'CbCr SRGB) Word64)+     -- , Writable (Auto f) (Image S (YCbCr (AdobeRGB 'NonLinear)) Word8)+     -- , Writable (Auto f) (Image S (YCbCr (AdobeRGB 'NonLinear)) Word16)+     -- , Writable (Auto f) (Image S (YCbCr (AdobeRGB 'NonLinear)) Word32)+     -- , Writable (Auto f) (Image S (YCbCr (AdobeRGB 'NonLinear)) Word64)+     , Writable (Auto f) (Image S (Alpha (Y D65)) Word8)+     , Writable (Auto f) (Image S (Alpha (Y D65)) Word16)+     , Writable (Auto f) (Image S (Alpha (Y D65)) Word32)+     , Writable (Auto f) (Image S (Alpha (Y D65)) Word64)+     , Writable (Auto f) (Image S (Alpha (SRGB 'NonLinear)) Word8)+     , Writable (Auto f) (Image S (Alpha (SRGB 'NonLinear)) Word16)+     , Writable (Auto f) (Image S (Alpha (SRGB 'NonLinear)) Word32)+     , Writable (Auto f) (Image S (Alpha (SRGB 'NonLinear)) Word64)+     , Writable (Auto f) (Image S (Alpha (AdobeRGB 'NonLinear)) Word8)+     , Writable (Auto f) (Image S (Alpha (AdobeRGB 'NonLinear)) Word16)+     , Writable (Auto f) (Image S (Alpha (AdobeRGB 'NonLinear)) Word32)+     , Writable (Auto f) (Image S (Alpha (AdobeRGB 'NonLinear)) Word64)+     , Writable (Auto f) (Image S (SRGB 'NonLinear) Word8)+     , Writable (Auto f) (Image S (SRGB 'NonLinear) Word16)+     , Writable (Auto f) (Image S (SRGB 'NonLinear) Word32)+     , Writable (Auto f) (Image S (SRGB 'NonLinear) Word64)+     , Writable (Auto f) (Image S (AdobeRGB 'NonLinear) Word8)+     , Writable (Auto f) (Image S (AdobeRGB 'NonLinear) Word16)+     , Writable (Auto f) (Image S (AdobeRGB 'NonLinear) Word32)+     , Writable (Auto f) (Image S (AdobeRGB 'NonLinear) Word64)+     )+  => f+  -> Spec+specEncodeDecodeNoErrorAuto f =+    describe (show f) $ do+      specEncodeDecodeAutoNoError @(Y D65) @Word8 f+      specEncodeDecodeAutoNoError @(Y D65) @Word16 f+      specEncodeDecodeAutoNoError @(Y D65) @Word32 f+      specEncodeDecodeAutoNoError @(Y D65) @Word64 f+      specEncodeDecodeAutoNoError @(Alpha (Y D65)) @Word8 f+      specEncodeDecodeAutoNoError @(Alpha (Y D65)) @Word16 f+      specEncodeDecodeAutoNoError @(Alpha (Y D65)) @Word32 f+      specEncodeDecodeAutoNoError @(Alpha (Y D65)) @Word64 f+      specEncodeDecodeAutoNoError @(SRGB 'NonLinear) @Word8 f+      specEncodeDecodeAutoNoError @(SRGB 'NonLinear) @Word16 f+      specEncodeDecodeAutoNoError @(SRGB 'NonLinear) @Word32 f+      specEncodeDecodeAutoNoError @(SRGB 'NonLinear) @Word64 f+      specEncodeDecodeAutoNoError @(Alpha (SRGB 'NonLinear)) @Word8 f+      specEncodeDecodeAutoNoError @(Alpha (SRGB 'NonLinear)) @Word16 f+      specEncodeDecodeAutoNoError @(Alpha (SRGB 'NonLinear)) @Word32 f+      specEncodeDecodeAutoNoError @(Alpha (SRGB 'NonLinear)) @Word64 f+      specEncodeDecodeAutoNoError @(CMYK (SRGB 'NonLinear)) @Word8 f+      specEncodeDecodeAutoNoError @(CMYK (SRGB 'NonLinear)) @Word16 f+      specEncodeDecodeAutoNoError @(CMYK (SRGB 'NonLinear)) @Word32 f+      specEncodeDecodeAutoNoError @(CMYK (SRGB 'NonLinear)) @Word64 f+      specEncodeDecodeAutoNoError @(Y'CbCr SRGB) @Word8 f+      specEncodeDecodeAutoNoError @(Y'CbCr SRGB) @Word16 f+      specEncodeDecodeAutoNoError @(Y'CbCr SRGB) @Word32 f+      specEncodeDecodeAutoNoError @(Y'CbCr SRGB) @Word64 f+      specEncodeDecodeAutoNoError @(AdobeRGB 'NonLinear) @Word8 f+      specEncodeDecodeAutoNoError @(AdobeRGB 'NonLinear) @Word16 f+      specEncodeDecodeAutoNoError @(AdobeRGB 'NonLinear) @Word32 f+      specEncodeDecodeAutoNoError @(AdobeRGB 'NonLinear) @Word64 f+      specEncodeDecodeAutoNoError @(Alpha (AdobeRGB 'NonLinear)) @Word8 f+      specEncodeDecodeAutoNoError @(Alpha (AdobeRGB 'NonLinear)) @Word16 f+      specEncodeDecodeAutoNoError @(Alpha (AdobeRGB 'NonLinear)) @Word32 f+      specEncodeDecodeAutoNoError @(Alpha (AdobeRGB 'NonLinear)) @Word64 f+      specEncodeDecodeAutoNoError @(CMYK (AdobeRGB 'NonLinear)) @Word8 f+      specEncodeDecodeAutoNoError @(CMYK (AdobeRGB 'NonLinear)) @Word16 f+      specEncodeDecodeAutoNoError @(CMYK (AdobeRGB 'NonLinear)) @Word32 f+      specEncodeDecodeAutoNoError @(CMYK (AdobeRGB 'NonLinear)) @Word64 f+      -- specEncodeDecodeAutoNoError @(YCbCr (AdobeRGB 'NonLinear)) @Word8 f+      -- specEncodeDecodeAutoNoError @(YCbCr (AdobeRGB 'NonLinear)) @Word16 f+      -- specEncodeDecodeAutoNoError @(YCbCr (AdobeRGB 'NonLinear)) @Word32 f+      -- specEncodeDecodeAutoNoError @(YCbCr (AdobeRGB 'NonLinear)) @Word64 f
+ tests/Test/Massiv/Array/IO/Image/Common.hs view
@@ -0,0 +1,127 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+module Test.Massiv.Array.IO.Image.Common where++import qualified Data.ByteString.Lazy as BL+import Data.List.NonEmpty as NE (NonEmpty(..), fromList)+import Data.Massiv.Array as A+import Data.Massiv.Array.IO+import System.Random+import Test.Massiv.Core+++elevatorGen :: (Random e, Elevator e) => Gen e+elevatorGen = choose (minValue, maxValue)++instance (Arbitrary e, Random e, Elevator e) => Arbitrary (Pixel (Y' SRGB) e) where+  arbitrary = PixelY' <$> elevatorGen+instance (Arbitrary e, Random e, Elevator e) => Arbitrary (Pixel (Alpha (Y' SRGB)) e) where+  arbitrary = PixelY'A <$> elevatorGen <*> elevatorGen+instance (Arbitrary e, Random e, Elevator e) => Arbitrary (Pixel (Y i) e) where+  arbitrary = PixelY <$> elevatorGen+instance (Arbitrary e, Random e, Elevator e) => Arbitrary (Pixel (Alpha (Y i)) e) where+  arbitrary = PixelYA <$> elevatorGen <*> elevatorGen+instance (Arbitrary e, Random e, Elevator e) => Arbitrary (Pixel (SRGB l) e) where+  arbitrary = PixelRGB <$> elevatorGen <*> elevatorGen <*> elevatorGen+instance (Arbitrary e, Random e, Elevator e) => Arbitrary (Pixel (Alpha (SRGB l)) e) where+  arbitrary = PixelRGBA <$> elevatorGen <*> elevatorGen <*> elevatorGen <*> elevatorGen+instance (Arbitrary e, Random e, Elevator e) => Arbitrary (Pixel (AdobeRGB l) e) where+  arbitrary = PixelRGB <$> elevatorGen <*> elevatorGen <*> elevatorGen+instance (Arbitrary e, Random e, Elevator e) => Arbitrary (Pixel (Alpha (AdobeRGB l)) e) where+  arbitrary = PixelRGBA <$> elevatorGen <*> elevatorGen <*> elevatorGen <*> elevatorGen+instance (Arbitrary e, Random e, Elevator e) => Arbitrary (Pixel (Y'CbCr cs) e) where+  arbitrary = PixelY'CbCr <$> elevatorGen <*> elevatorGen <*> elevatorGen+instance (Arbitrary e, Random e, Elevator e) => Arbitrary (Pixel (Alpha (Y'CbCr cs)) e) where+  arbitrary = PixelY'CbCrA <$> elevatorGen <*> elevatorGen <*> elevatorGen <*> elevatorGen+instance (Arbitrary e, Random e, Elevator e) => Arbitrary (Pixel (CMYK cs) e) where+  arbitrary = PixelCMYK <$> elevatorGen <*> elevatorGen <*> elevatorGen <*> elevatorGen+instance (Arbitrary e, Random e, Elevator e) => Arbitrary (Pixel (Alpha (CMYK cs)) e) where+  arbitrary =+    PixelCMYKA <$> elevatorGen <*> elevatorGen <*> elevatorGen <*> elevatorGen <*> elevatorGen++specEncodeNoError ::+     forall cs e f. (Writable f (Image S cs e), Arbitrary (Pixel cs e), ColorModel cs e)+  => f+  -> Spec+specEncodeNoError f =+  prop (("Image S " ++) .+        showsColorModelName (Proxy :: Proxy (Color cs e)) . (' ':) .+        showsType @e $ "") $+  property $ \ (ArrNE img :: ArrNE S Ix2 (Pixel cs e)) -> do+    bs <- encodeM f def img+    bs' <- encodeImageM imageWriteFormats ("foo" ++ ext f) img+    bs' `shouldBe` bs++specEncodeDecodeNoError ::+     forall cs e f.+     ( Readable f (Image S cs e)+     , Writable f (Image S cs e)+     , Arbitrary (Pixel cs e)+     , ColorModel cs e+     )+  => f+  -> Spec+specEncodeDecodeNoError f =+  prop (("Image S " ++) .+        showsColorModelName (Proxy :: Proxy (Color cs e)) . (' ':) .+        showsType @e $ "") $+  property $ \ (ArrNE img :: ArrNE S Ix2 (Pixel cs e)) -> do+    bs <- encodeM f def img+    img' :: Image S cs e <- decodeM f $ BL.toStrict bs+    size img' `shouldBe` size img+    bs' <- encodeImageM imageWriteFormats ("foo" ++ ext f) img+    bs' `shouldBe` bs++specEncodeDecodeAutoNoError ::+     forall cs e i f.+     ( Readable (Auto f) (Image S cs e)+     , Writable (Auto f) (Image S cs e)+     , Arbitrary (Pixel cs e)+     , ColorSpace (BaseSpace cs) i e+     , ColorSpace cs i e+     )+  => f+  -> Spec+specEncodeDecodeAutoNoError nonAutoFormat =+  prop (("Image S " ++) .+        showsColorModelName (Proxy :: Proxy (Color cs e)) . (' ':) .+        showsType @e $ "") $+  property $ \ (ArrNE img :: ArrNE S Ix2 (Pixel cs e)) -> do+    let f = Auto nonAutoFormat+    bs <- encodeM f def img+    img' :: Image S cs e <- decodeM f $ BL.toStrict bs+    size img' `shouldBe` size img+    bs' <- encodeImageM imageWriteAutoFormats ("foo" ++ ext f) img+    bs' `shouldBe` bs++specEncodeDecodeGifSequenceNoError ::+     forall cs e.+     ( Readable (Sequence GIF) [Image S cs e]+     , Writable (Sequence GIF) (NonEmpty (GifDelay, Image S cs e))+     , Arbitrary (Pixel cs e)+     , ColorModel cs e+     )+  => Spec+specEncodeDecodeGifSequenceNoError =+  prop (("Image S " ++) .+        showsColorModelName (Proxy :: Proxy (Color cs e)) . (' ':) .+        showsType @e $ "") $+  property $ forAll (genNonEmptyImagesWithGifDelay @cs @e) $ \ imgs -> do+    bs <- encodeM (Sequence GIF) def imgs+    imgs' :: [Image S cs e] <- decodeM (Sequence GIF) $ BL.toStrict bs+    Prelude.length imgs' `shouldBe` Prelude.length imgs++genNonEmptyImagesWithGifDelay ::+     forall cs e. (Storable (Color cs e), Arbitrary (Pixel cs e))+  => Gen (NonEmpty (GifDelay, Image S cs e))+genNonEmptyImagesWithGifDelay = do+  arrs <- toSameSizeNE <$> (arbitrary :: Gen (ArrNE D Ix3 (Pixel cs e)))+  Prelude.mapM (\i -> (,) <$> arbitrary <*> pure (compute i)) arrs++toSameSizeNE ::+     (Index ix, Index (Lower ix), Source r e) => ArrNE r ix e -> NonEmpty (Array r (Lower ix) e)+toSameSizeNE (ArrNE arr) = NE.fromList $ A.toList $ outerSlices arr
+ tests/Test/Massiv/Array/IO/Image/JuicyPixelsSpec.hs view
@@ -0,0 +1,78 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+module Test.Massiv.Array.IO.Image.JuicyPixelsSpec (spec) where++import Data.Massiv.Array.IO+import Test.Massiv.Core+import Test.Massiv.Array.IO.Image.Common++spec :: Spec+spec =+  describe "Readable/Writable" $ do+    describe "BMP" $ do+      specEncodeNoError @(Y' SRGB) @Word8 BMP+      specEncodeNoError @(Y D65) @Word8 BMP+      --specEncodeDecodeNoError @(Y D65) @Word8 BMP+      specEncodeDecodeNoError @(SRGB 'NonLinear) @Word8 BMP+      specEncodeDecodeNoError @(Alpha (SRGB 'NonLinear)) @Word8 BMP+    describe "GIF" $ do+      specEncodeNoError @(Y' SRGB) @Word8 GIF+      specEncodeNoError @(Y D65) @Word8 GIF+      specEncodeDecodeNoError @(SRGB 'NonLinear) @Word8 GIF+      --specEncodeGifSequenceNoError @(Y D65) @Word8+      describe "Sequenece" $ do+        specEncodeDecodeGifSequenceNoError @(SRGB 'NonLinear) @Word8+        specEncodeDecodeGifSequenceNoError @(Alpha (SRGB 'NonLinear)) @Word8+      -- TODO: read RGBA8, write Y8+    -- getting 'DecodeError "Invalid sanline size"' with seed=2023820902+    -- describe "HDR" $ do+    --   specEncodeDecodeNoError @(SRGB 'NonLinear) @Float HDR+    describe "JPG" $ do+      specEncodeDecodeNoError @(Y' SRGB) @Word8 JPG+      specEncodeDecodeNoError @(Y D65) @Word8 JPG+      specEncodeDecodeNoError @(SRGB 'NonLinear) @Word8 JPG+      specEncodeDecodeNoError @(CMYK (SRGB 'NonLinear)) @Word8 JPG+      specEncodeDecodeNoError @(Y'CbCr SRGB) @Word8 JPG+      -- TODO: read YA8+    describe "PNG" $ do+      specEncodeDecodeNoError @(Y' SRGB) @Word8 PNG+      specEncodeDecodeNoError @(Y' SRGB) @Word16 PNG+      specEncodeDecodeNoError @(Alpha (Y' SRGB)) @Word8 PNG+      specEncodeDecodeNoError @(Alpha (Y' SRGB)) @Word16 PNG+      specEncodeDecodeNoError @(Y D65) @Word8 PNG+      specEncodeDecodeNoError @(Y D65) @Word16 PNG+      specEncodeDecodeNoError @(Alpha (Y D65)) @Word8 PNG+      specEncodeDecodeNoError @(Alpha (Y D65)) @Word16 PNG+      specEncodeDecodeNoError @(SRGB 'NonLinear) @Word8 PNG+      specEncodeDecodeNoError @(SRGB 'NonLinear) @Word16 PNG+      specEncodeDecodeNoError @(Alpha (SRGB 'NonLinear)) @Word8 PNG+      specEncodeDecodeNoError @(Alpha (SRGB 'NonLinear)) @Word16 PNG+    describe "TGA" $ do+      specEncodeDecodeNoError @(Y' SRGB) @Word8 TGA+      specEncodeDecodeNoError @(Y D65) @Word8 TGA+      specEncodeDecodeNoError @(SRGB 'NonLinear) @Word8 TGA+      specEncodeDecodeNoError @(Alpha (SRGB 'NonLinear)) @Word8 TGA+    describe "TIF" $ do+      specEncodeDecodeNoError @(Y' SRGB) @Word8 TIF+      specEncodeDecodeNoError @(Y' SRGB) @Word16 TIF+      specEncodeDecodeNoError @(Y' SRGB) @Word32 TIF+      specEncodeDecodeNoError @(Y' SRGB) @Float TIF+      specEncodeDecodeNoError @(Y D65) @Word8 TIF+      specEncodeDecodeNoError @(Y D65) @Word16 TIF+      specEncodeDecodeNoError @(Y D65) @Word32 TIF+      specEncodeDecodeNoError @(Y D65) @Float TIF+      specEncodeDecodeNoError @(Alpha (Y' SRGB)) @Word8 TIF+      specEncodeDecodeNoError @(Alpha (Y' SRGB)) @Word16 TIF+      specEncodeDecodeNoError @(Alpha (Y D65)) @Word8 TIF+      specEncodeDecodeNoError @(Alpha (Y D65)) @Word16 TIF+      specEncodeDecodeNoError @(SRGB 'NonLinear) @Word8 TIF+      specEncodeDecodeNoError @(SRGB 'NonLinear) @Word16 TIF+      specEncodeDecodeNoError @(Alpha (SRGB 'NonLinear)) @Word8 TIF+      specEncodeDecodeNoError @(Alpha (SRGB 'NonLinear)) @Word16 TIF+      specEncodeDecodeNoError @(CMYK (SRGB 'NonLinear)) @Word8 TIF+      specEncodeDecodeNoError @(CMYK (SRGB 'NonLinear)) @Word16 TIF+      specEncodeNoError @(Y'CbCr SRGB) @Word8 TIF
+ tests/doctests.hs view
@@ -0,0 +1,17 @@+{-# LANGUAGE CPP #-}+module Main where++#if __GLASGOW_HASKELL__ >= 802 && __GLASGOW_HASKELL__ < 810++import Test.DocTest (doctest)++main :: IO ()+main = doctest ["src"]++#else++-- TODO: fix doctest support+main :: IO ()+main = putStrLn "\nDoctests are not supported for ghc version 8.2 and prior as well as 8.10\n"++#endif