massiv-io 0.1.9.0 → 0.2.0.0

raw patch · 35 files changed

+3172/−4220 lines, 35 filesdep +Colordep +QuickCheckdep +doctestdep −directorydep −processdep ~JuicyPixelsdep ~basedep ~filepathbuild-type:Customsetup-changedbinary-addedPVP ok

version bump matches the API change (PVP)

Dependencies added: Color, QuickCheck, doctest, exceptions, hspec, massiv-io, massiv-test, random, template-haskell, unliftio

Dependencies removed: directory, process

Dependency ranges changed: JuicyPixels, base, filepath, massiv

API changes (from Hackage documentation)

Files

• CHANGELOG.md +10/−0
• LICENSE +1/−1
• Setup.hs +31/−0
• files/_frog.jpg binary
• files/frog.jpg binary
• massiv-io.cabal +63/−22
• src/Data/Massiv/Array/IO.hs +219/−120
• src/Data/Massiv/Array/IO/Base.hs +132/−70
• src/Data/Massiv/Array/IO/Image.hs +92/−80
• src/Data/Massiv/Array/IO/Image/JuicyPixels.hs +51/−1023
• src/Data/Massiv/Array/IO/Image/JuicyPixels/BMP.hs +190/−0
• src/Data/Massiv/Array/IO/Image/JuicyPixels/Base.hs +359/−0
• src/Data/Massiv/Array/IO/Image/JuicyPixels/GIF.hs +330/−0
• src/Data/Massiv/Array/IO/Image/JuicyPixels/HDR.hs +146/−0
• src/Data/Massiv/Array/IO/Image/JuicyPixels/JPG.hs +221/−0
• src/Data/Massiv/Array/IO/Image/JuicyPixels/PNG.hs +268/−0
• src/Data/Massiv/Array/IO/Image/JuicyPixels/TGA.hs +183/−0
• src/Data/Massiv/Array/IO/Image/JuicyPixels/TIF.hs +366/−0
• src/Data/Massiv/Array/IO/Image/Netpbm.hs +170/−110
• src/Graphics/ColorModel.hs +14/−0
• src/Graphics/ColorSpace.hs +0/−727
• src/Graphics/ColorSpace/Binary.hs +0/−270
• src/Graphics/ColorSpace/CMYK.hs +0/−221
• src/Graphics/ColorSpace/Complex.hs +0/−85
• src/Graphics/ColorSpace/Elevator.hs +0/−319
• src/Graphics/ColorSpace/HSI.hs +0/−204
• src/Graphics/ColorSpace/Internal.hs +0/−241
• src/Graphics/ColorSpace/RGB.hs +0/−196
• src/Graphics/ColorSpace/X.hs +0/−132
• src/Graphics/ColorSpace/Y.hs +0/−190
• src/Graphics/ColorSpace/YCbCr.hs +0/−209
• tests/Data/Massiv/Array/IOSpec.hs +303/−0
• tests/Main.hs +10/−0
• tests/Spec.hs +1/−0
• tests/doctests.hs +12/−0

@@ -1,3 +1,13 @@+# 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.

@@ -1,4 +1,4 @@-Copyright Alexey Kuleshevich (c) 2017+Copyright Alexey Kuleshevich (c) 2017-2020  All rights reserved. 

@@ -1,2 +1,33 @@+{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -Wall #-}+module Main (main) where++#ifndef MIN_VERSION_cabal_doctest+#define MIN_VERSION_cabal_doctest(x,y,z) 0+#endif++#if MIN_VERSION_cabal_doctest(1,0,0)++import Distribution.Extra.Doctest ( defaultMainWithDoctests )+main :: IO ()+main = defaultMainWithDoctests "doctests"++#else++#ifdef MIN_VERSION_Cabal+-- If the macro is defined, we have new cabal-install,+-- but for some reason we don't have cabal-doctest in package-db+--+-- Probably we are running cabal sdist, when otherwise using new-build+-- workflow+#warning You are configuring this package without cabal-doctest installed. \+         The doctests test-suite will not work as a result. \+         To fix this, install cabal-doctest before configuring.+#endif+ import Distribution.Simple++main :: IO () main = defaultMain++#endif

binary file changed (absent → 124229 bytes)

binary file changed (absent → 82430 bytes)

@@ -1,5 +1,5 @@ name:                massiv-io-version:             0.1.9.0+version:             0.2.0.0 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@@ -9,41 +9,46 @@ license-file:        LICENSE author:              Alexey Kuleshevich maintainer:          alexey@kuleshevi.ch-copyright:           2018-2019 Alexey Kuleshevich+copyright:           2018-2020 Alexey Kuleshevich category:            Data, Data Structures-build-type:          Simple+build-type:          Custom+extra-doc-files:     files/*.jpg extra-source-files:  README.md                    , CHANGELOG.md-cabal-version:       >=1.10+cabal-version:       >=1.18+custom-setup+  setup-depends:+      base+    , Cabal+    , cabal-doctest >=1.0.6  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.1.2                      , data-default-class                      , deepseq-                     , directory-                     , filepath        >= 1.0-                     , massiv          >= 0.1.1-                     , process-                     , JuicyPixels     >= 3.2.7+                     , exceptions+                     , filepath+                     , massiv          >= 0.3+                     , JuicyPixels     >= 3.3                      , netpbm+                     , unliftio        >= 0.2.12                      , vector          >= 0.10   default-language:    Haskell2010   ghc-options:         -Wall@@ -55,6 +60,42 @@     else       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:      Data.Massiv.Array.IOSpec+                    , Spec+  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+               , template-haskell+  default-language:    Haskell2010  source-repository head   type:     git

@@ -8,16 +8,21 @@ {-# LANGUAGE TypeSynonymInstances #-} -- | -- Module      : Data.Massiv.Array.IO--- Copyright   : (c) Alexey Kuleshevich 2018-2019+-- Copyright   : (c) Alexey Kuleshevich 2018-2020 -- 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@@ -36,27 +41,37 @@   , 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(..), convertEither,+                                          convertImage, 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 (bracket)+import UnliftIO.IO.File+import UnliftIO.Process (readProcess)   -- | External viewing application to use for displaying images.@@ -72,136 +87,217 @@   --- | 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:+--+-- >>> 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 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.+--+-- >>> frogYCbCr <- readImage "files/frog.jpg" :: IO (Image S (YCbCr SRGB) Word8)+-- >>> frogAdobeRGB = convertImage frogYCbCr :: Image D AdobeRGB 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+-- >>> frog <- readImage "files/frog.jpg" :: IO (Image S (YCbCr 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 Word8)+-- *** Exception: ConvertError "Cannot decode JPG image <Image S YCbCr Word8> as <Image S RGB 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 (YCbCr SRGB) Word8)+-- >>> let frogSRGB = convertImage frogYCbCr :: Image D SRGB Word8+--+-- A simpler approach to achieve the same effect would be to use `readImageAuto`:+--+-- >>> frogSRGB' <- readImageAuto "files/frog.jpg" :: IO (Image S SRGB Word8)+-- >>> compute frogSRGB == frogSRGB'+-- True+--+-- @since 0.1.0+readImage ::+     (ColorSpace cs i 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 works 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 at compile time.+--+-- >>> frogCMYK <- readImageAuto "files/frog.jpg" :: IO (Image S (CMYK SRGB) Double)+-- >>> size frogCMYK+-- Sz (200 :. 320)+--+-- @since 0.1.0+readImageAuto ::+     (Mutable r Ix2 (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 Ix2 (Pixel cs e), ColorSpace cs i e, MonadIO m) => FilePath -> Image r cs e -> m ()+writeImage path img = liftIO (encodeImageM imageWriteFormats path img >>= writeLazyAtomically path)  --- | 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 (YCbCr SRGB) Word8)+-- >>> writeImageAuto "files/frog.tiff" (convertImage frogYCbCr :: Image D (CMYK AdobeRGB) 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 Ix2 (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)    -- | 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 ()+  -> 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 img =-  if block-    then display-    else img `seq` void (forkIO display)+  liftIO $ do+    bs <- encodeM (Auto TIF) () img+    (if block then id else void . forkIO) $ display bs   where-    display = do+    display bs = do       tmpDir <- fmap (</> "massiv-io") getTemporaryDirectory       createDirectoryIfMissing True tmpDir       bracket         (openBinaryTempFile tmpDir "tmp-img.tiff")         (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 @`displayImage`+-- `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 +311,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 +345,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__: ('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'),+    ('PixelYCbCr', 'Word8')+    * __write__: ('PixelY' 'Word8'), ('PixelRGB' 'Word8'), ('PixelCMYK' 'Word8'),+    ('PixelYCbCr', '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__: ('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__: ('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'), ('PixelYCbCr' 'Word8')  * 'PBM': -    * __read__: ('Binary' 'Bit')+    * __read__: ('PixelY' 'Bit')     * Also supports sequence of images in one file, when read as @['PBM']@  * 'PGM': -    * __read__: ('Y' 'Word8'), ('Y' 'Word16')+    * __read__: ('PixelY' 'Word8'), ('PixelY' 'Word16')     * Also supports sequence of images in one file, when read as @['PGM']@  * 'PPM': -    * __read__: ('RGB' 'Word8'), ('RGB' 'Word16')+    * __read__: ('PixelRGB' 'Word8'), ('PixelRGB' 'Word16')     * Also supports sequence of images in one file, when read as @['PPM']@  -}

@@ -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-2020 -- License     : BSD3 -- Maintainer  : Alexey Kuleshevich <lehins@yandex.ru> -- Stability   : experimental@@ -16,29 +19,37 @@ module Data.Massiv.Array.IO.Base   ( FileFormat(..)   , Readable(..)+  , decode'   , Writable(..)+  , encode'   , ConvertError(..)   , EncodeError(..)   , DecodeError(..)   , Sequence(..)   , Auto(..)   , Image-  , defaultReadOptions+  , convertImage+  , toImageBaseModel+  , fromImageBaseModel   , defaultWriteOptions+  , encodeError+  , decodeError   , toProxy   , fromMaybeEncode-  , fromEitherDecode+  , fromMaybeDecode   , convertEither+  , MonadThrow(..)   ) where +import Unsafe.Coerce import Control.Exception (Exception, throw)+import Control.Monad.Catch (MonadThrow(..)) import qualified Data.ByteString as B (ByteString) import qualified Data.ByteString.Lazy as BL (ByteString) import Data.Default.Class (Default(..))-import Data.Massiv.Array-import Data.Maybe (fromMaybe)+import Data.Massiv.Array as A import Data.Typeable-import Graphics.ColorSpace (ColorSpace, Pixel)+import Graphics.Pixel.ColorSpace  type Image r cs e = Array r Ix2 (Pixel cs e) @@ -63,11 +74,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 +86,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 +108,144 @@   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  --- | File formats that can be read into an Array.-class Readable f arr where+-- | 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, ()) -  -- | Decode a `B.ByteString` into an Array.-  decode :: f -> ReadOptions f -> B.ByteString -> arr+-- | Encode an array into a `BL.ByteString`.+encode' :: Writable f arr => f -> WriteOptions f -> arr -> BL.ByteString+encode' f opts = either throw id . encodeM f opts +-- | Decode a `B.ByteString` into an Array.+decode' :: Readable f arr => f -> B.ByteString -> arr+decode' f = either throw id . 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   -- | 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 ::+     (Source r' Ix2 (Pixel cs' e'), ColorSpace cs' i' e', ColorSpace cs i e)+  => Image r' cs' e'+  -> Image D cs e+convertImage = A.map convertPixel++-- | Cast an array. This is theoretically unsafe operation, but for all current `ColorSpace`+-- instances this function is perfectly safe.+--+-- @since 0.2.0+toImageBaseModel :: Array S Ix2 (Pixel cs e) -> Array S Ix2 (Pixel (BaseModel cs) e)+toImageBaseModel = unsafeCoerce+++-- | Cast an array. This is theoretically unsafe operation, but for all current `ColorSpace`+-- instances this function is perfectly safe.+--+-- @since 0.2.0+fromImageBaseModel :: Array S Ix2 (Pixel (BaseModel cs) e) -> Array S Ix2 (Pixel cs e)+fromImageBaseModel = unsafeCoerce 

@@ -2,29 +2,30 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeSynonymInstances #-} -- | -- Module      : Data.Massiv.Array.IO.Image--- Copyright   : (c) Alexey Kuleshevich 2018-2019+-- Copyright   : (c) Alexey Kuleshevich 2018-2020 -- 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+  , Encode+  , encodeImageM   , imageWriteFormats   , imageWriteAutoFormats   , Decode-  , decodeImage+  , decodeImageM   , 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)@@ -32,133 +33,144 @@ 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)    data Encode out where-  EncodeAs :: (FileFormat f, Writable f out) => f -> Encode out+  EncodeAs+    :: 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 (EncodeAs f _) = show f  instance FileFormat (Encode (Image r cs e)) where-  ext (EncodeAs f) = ext f+  ext (EncodeAs f _) = ext f -  exts (EncodeAs f) = exts f+  exts (EncodeAs f _) = exts f  instance Writable (Encode (Image r cs e)) (Image r cs e) where-  encode (EncodeAs f) _ = encode f (defaultWriteOptions f)+  encodeM (EncodeAs f enc) _ = enc f + -- | 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+  -> m BL.ByteString+encodeImageM 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+    []    -> throwM $ EncodeError $ "File format is not supported: " ++ ext'+    (f:_) -> encodeM f () img ++ -- | 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 Ix2 (Pixel cs e), ColorSpace cs i e) => [Encode (Image r cs e)] imageWriteFormats =-  [ EncodeAs BMP-  , EncodeAs GIF-  , EncodeAs HDR-  , EncodeAs JPG-  , EncodeAs PNG-  , EncodeAs TGA-  , EncodeAs TIF+  [ EncodeAs BMP (\ f -> encodeBMP f def . toImageBaseModel . computeSource)+  , EncodeAs GIF (\ f -> encodeGIF f def . toImageBaseModel . computeSource)+  , EncodeAs HDR (\ f -> encodeHDR f def . toImageBaseModel . computeSource)+  , EncodeAs JPG (\ f -> encodeJPG f def . toImageBaseModel . computeSource)+  , EncodeAs PNG (\ f -> encodePNG f . toImageBaseModel . computeSource)+  , EncodeAs TGA (\ f -> encodeTGA f . toImageBaseModel . computeSource)+  , EncodeAs TIF (\ f -> encodeTIF f . toImageBaseModel . computeSource)   ]  -- | 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 Ix2 (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)+  [ EncodeAs (Auto BMP) (\f -> pure . encodeAutoBMP f def)+  , EncodeAs (Auto GIF) (`encodeAutoGIF` def)+  , EncodeAs (Auto HDR) (\f -> pure . encodeAutoHDR f def)+  , EncodeAs (Auto JPG) (\f -> pure . encodeAutoJPG f def)+  , EncodeAs (Auto PNG) (\f -> pure . encodeAutoPNG f)+  , EncodeAs (Auto TGA) (\f -> pure . encodeAutoTGA f)+  , EncodeAs (Auto TIF) (\f -> pure . encodeAutoTIF f)   ]    data Decode out where-  DecodeAs :: (FileFormat f, Readable f out) => f -> Decode out+  DecodeAs+    :: 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 (DecodeAs f _) = show f  instance FileFormat (Decode (Image r cs e)) where-  ext (DecodeAs f) = ext f+  ext (DecodeAs f _) = ext f -  exts (DecodeAs f) = exts f+  exts (DecodeAs f _) = exts f  instance Readable (Decode (Image r cs e)) (Image r cs e) where-  decode (DecodeAs f) _ = decode f (defaultReadOptions f)+  decodeM (DecodeAs f dec) = dec f + -- | 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+  -> m (Image r cs e)+decodeImageM 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+    []    -> throwM $ DecodeError $ "File format is not supported: " ++ ext'+    (f:_) -> decodeM f bs --- | 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 :: ColorSpace cs i 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+  [ DecodeAs BMP (\f -> fmap fromImageBaseModel . decodeBMP f)+  , DecodeAs GIF (\f -> fmap fromImageBaseModel . decodeGIF f)+  , DecodeAs HDR (\f -> fmap fromImageBaseModel . decodeHDR f)+  , DecodeAs JPG (\f -> fmap fromImageBaseModel . decodeJPG f)+  , DecodeAs PNG (\f -> fmap fromImageBaseModel . decodePNG f)+  , DecodeAs TGA (\f -> fmap fromImageBaseModel . decodeTGA f)+  , DecodeAs TIF (\f -> fmap fromImageBaseModel . decodeTIF f)+  , DecodeAs PBM (\f -> fmap (fromImageBaseModel . fst) . decodeNetpbmImage f)+  , DecodeAs PGM (\f -> fmap (fromImageBaseModel . fst) . decodeNetpbmImage f)+  , DecodeAs PPM (\f -> fmap (fromImageBaseModel . fst) . decodeNetpbmImage f)   ] --- | 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)+  :: (Mutable r Ix2 (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)+  [ DecodeAs (Auto BMP) decodeAutoBMP+  , DecodeAs (Auto GIF) decodeAutoGIF+  , DecodeAs (Auto HDR) decodeAutoHDR+  , DecodeAs (Auto JPG) decodeAutoJPG+  , DecodeAs (Auto PNG) decodeAutoPNG+  , DecodeAs (Auto TGA) decodeAutoTGA+  , DecodeAs (Auto TIF) decodeAutoTIF+  , DecodeAs (Auto PBM) (\f -> fmap fst . decodeAutoNetpbmImage f)+  , DecodeAs (Auto PGM) (\f -> fmap fst . decodeAutoNetpbmImage f)+  , DecodeAs (Auto PPM) (\f -> fmap fst . decodeAutoNetpbmImage f)   ]++

@@ -1,1023 +1,51 @@-{-# 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-2020+-- 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+  , 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

@@ -0,0 +1,190 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+-- |+-- Module      : Data.Massiv.Array.IO.Image.JuicyPixels.BMP+-- Copyright   : (c) Alexey Kuleshevich 2019-2020+-- 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 S CM.Y 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 D65) Word8) where+  encodeM f opts = encodeM f opts . toImageBaseModel++instance Writable BMP (Image S SRGB Word8) where+  encodeM f opts = encodeM f opts . toImageBaseModel++instance Writable BMP (Image S (Alpha SRGB) Word8) where+  encodeM f opts = encodeM f opts . toImageBaseModel++instance (ColorSpace cs i e, ColorSpace (BaseSpace cs) i e, Source r Ix2 (Pixel cs e)) =>+         Writable (Auto BMP) (Image r cs e) where+  encodeM f opts = pure . encodeAutoBMP f opts+++instance Readable BMP (Image S CM.Y 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 D65) Word8) where+  decodeWithMetadataM f = fmap (first fromImageBaseModel) . decodeWithMetadataM f++instance Readable BMP (Image S SRGB Word8) where+  decodeWithMetadataM f = fmap (first fromImageBaseModel) . decodeWithMetadataM f++instance Readable BMP (Image S (Alpha SRGB) 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)++-- | 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)+++-- | Decode a Bitmap Image+decodeAutoBMP ::+     (Mutable r Ix2 (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)++-- | Decode a Bitmap Image+decodeAutoWithMetadataBMP ::+     (Mutable r Ix2 (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)++instance (Mutable r Ix2 (Pixel cs e), ColorSpace cs i e) =>+         Readable (Auto BMP) (Image r cs e) where+  decodeM = decodeAutoBMP+  decodeWithMetadataM = decodeAutoWithMetadataBMP++encodeBMP ::+     forall r cs e m.+     (ColorModel cs e, Source r Ix2 (Pixel cs e), MonadThrow m)+  => BMP+  -> BitmapOptions+  -> Image r cs e+  -> m BL.ByteString+encodeBMP f BitmapOptions {bitmapMetadata} img =+  fromMaybeEncode f (Proxy :: Proxy (Image r cs e)) $ do+    Refl <- eqT :: Maybe (e :~: Word8)+    msum+      [ do Refl <- eqT :: Maybe (cs :~: CM.Y)+           pure $ JP.encodeBitmapWithMetadata bitmapMetadata $ toJPImageY8 img+      , do Refl <- eqT :: Maybe (cs :~: CM.RGB)+           pure $ JP.encodeBitmapWithMetadata bitmapMetadata $ toJPImageRGB8 img+      , do Refl <- eqT :: Maybe (cs :~: Alpha CM.RGB)+           pure $ JP.encodeBitmapWithMetadata bitmapMetadata $ toJPImageRGBA8 img+      ]++++encodeAutoBMP ::+     forall r cs i e. (ColorSpace (BaseSpace cs) i e, ColorSpace cs i e, Source r Ix2 (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 (BaseModel cs :~: CM.Y)+         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 ix a)+      => (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

@@ -0,0 +1,359 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+-- |+-- Module      : Data.Massiv.Array.IO.Image.JuicyPixels.Base+-- Copyright   : (c) Alexey Kuleshevich 2019-2020+-- 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+  , fromDynamicImage+  , fromDynamicImageAuto+  -- * Conversion to sRGB+  , toYCbCr8+  , toCMYK8+  , toCMYK16+  , toSRGB8+  , toSRGB16+  , toSRGBA8+  , toSRGBA16+  ) where++import Prelude as P+import qualified Codec.Picture as JP+import qualified Codec.Picture.Types as JP+import Control.Monad (guard, unless)+import Data.Massiv.Array as A+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.Pixel.ColorSpace+import qualified Graphics.Pixel as CM++--------------------------------------------------------------------------------+-- 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) (fromMaybeDecode f showJP fromDynamicImage)+++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 <- fromMaybeDecode f showJP fromDynamicImage jp+      pure (i, meta)++convertAutoWithMetadata ::+     (MonadThrow m, FileFormat f, Mutable r Ix2 (Pixel cs e), ColorSpace cs i e)+  => Auto f+  -> Either String (JP.DynamicImage, Metadata f)+  -> m (Image r cs e, Metadata f)+convertAutoWithMetadata f decoded =+  case decoded of+    Left err -> throwM $ DecodeError err+    Right (jp, meta) -> do+      i <- fromMaybeDecode f showJP fromDynamicImageAuto jp+      pure (i, meta)++convertAutoWith ::+     (MonadThrow m, FileFormat f, Mutable r Ix2 (Pixel cs e), ColorSpace cs i e)+  => Auto f+  -> Either String JP.DynamicImage+  -> m (Image r cs e)+convertAutoWith f = either (throwM . DecodeError) (fromMaybeDecode f showJP fromDynamicImageAuto)+++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 (fromMaybeDecode f showJP fromDynamicImage) jpImgs+++convertAutoSequenceWith ::+     (MonadThrow m, FileFormat (Sequence f), Mutable r Ix2 (Pixel cs e), ColorSpace cs i e)+  => Auto (Sequence f)+  -> Either String [JP.DynamicImage]+  -> m [Image r cs e]+convertAutoSequenceWith f ejpImgs = do+  jpImgs <- decodeError ejpImgs+  P.traverse (fromMaybeDecode f showJP fromDynamicImageAuto) jpImgs+++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.Y Word8)+      fromJPImageUnsafe jimg+    JP.ImageY16 jimg -> do+      Refl <- eqT :: Maybe (Pixel cs e :~: Pixel CM.Y Word16)+      fromJPImageUnsafe jimg+    JP.ImageY32 jimg -> do+      Refl <- eqT :: Maybe (Pixel cs e :~: Pixel CM.Y Word32)+      fromJPImageUnsafe jimg+    JP.ImageYF jimg -> do+      Refl <- eqT :: Maybe (Pixel cs e :~: Pixel CM.Y Float)+      fromJPImageUnsafe jimg+    JP.ImageYA8 jimg -> do+      Refl <- eqT :: Maybe (Pixel cs e :~: Pixel (Alpha CM.Y) Word8)+      fromJPImageUnsafe jimg+    JP.ImageYA16 jimg -> do+      Refl <- eqT :: Maybe (Pixel cs e :~: Pixel (Alpha CM.Y) Word16)+      fromJPImageUnsafe jimg+    JP.ImageRGB8 jimg -> do+      Refl <- eqT :: Maybe (Pixel cs e :~: Pixel CM.RGB Word8)+      fromJPImageUnsafe jimg+    JP.ImageRGB16 jimg -> do+      Refl <- eqT :: Maybe (Pixel cs e :~: Pixel CM.RGB Word16)+      fromJPImageUnsafe jimg+    JP.ImageRGBF jimg -> do+      Refl <- eqT :: Maybe (Pixel cs e :~: Pixel CM.RGB Float)+      fromJPImageUnsafe jimg+    JP.ImageRGBA8 jimg -> do+      Refl <- eqT :: Maybe (Pixel cs e :~: Pixel (Alpha CM.RGB) Word8)+      fromJPImageUnsafe jimg+    JP.ImageRGBA16 jimg -> do+      Refl <- eqT :: Maybe (Pixel cs e :~: Pixel (Alpha CM.RGB) Word16)+      fromJPImageUnsafe jimg+    JP.ImageYCbCr8 jimg -> do+      Refl <- eqT :: Maybe (Pixel cs e :~: Pixel CM.YCbCr Word8)+      fromJPImageUnsafe jimg+    JP.ImageCMYK8 jimg -> do+      Refl <- eqT :: Maybe (Pixel cs e :~: Pixel CM.CMYK Word8)+      fromJPImageUnsafe jimg+    JP.ImageCMYK16 jimg -> do+      Refl <- eqT :: Maybe (Pixel cs e :~: Pixel CM.CMYK Word16)+      fromJPImageUnsafe jimg+++fromDynamicImageAuto ::+     forall r cs i e. (Mutable r Ix2 (Pixel cs e), ColorSpace cs i e)+  => JP.DynamicImage+  -> Maybe (Image r cs e)+fromDynamicImageAuto jpDynImg =+  case jpDynImg of+    JP.ImageY8 jimg ->+      compute . convertImage <$> (fromJPImageUnsafe jimg :: Maybe (Image S (Y D65) Word8))+    JP.ImageY16 jimg ->+      compute . convertImage <$> (fromJPImageUnsafe jimg :: Maybe (Image S (Y D65) Word16))+    JP.ImageY32 jimg ->+      compute . convertImage <$> (fromJPImageUnsafe jimg :: Maybe (Image S (Y D65) Word32))+    JP.ImageYF jimg ->+      compute . convertImage <$> (fromJPImageUnsafe jimg :: Maybe (Image S (Y D65) Float))+    JP.ImageYA8 jimg ->+      compute . convertImage <$> (fromJPImageUnsafe jimg :: Maybe (Image S (Alpha (Y D65)) Word8))+    JP.ImageYA16 jimg ->+      compute . convertImage <$> (fromJPImageUnsafe jimg :: Maybe (Image S (Alpha (Y D65)) Word16))+    JP.ImageRGB8 jimg ->+      compute . convertImage <$> (fromJPImageUnsafe jimg :: Maybe (Image S SRGB Word8))+    JP.ImageRGB16 jimg ->+      compute . convertImage <$> (fromJPImageUnsafe jimg :: Maybe (Image S SRGB Word16))+    JP.ImageRGBF jimg ->+      compute . convertImage <$> (fromJPImageUnsafe jimg :: Maybe (Image S SRGB Float))+    JP.ImageRGBA8 jimg ->+      compute . convertImage <$> (fromJPImageUnsafe jimg :: Maybe (Image S (Alpha SRGB) Word8))+    JP.ImageRGBA16 jimg ->+      compute . convertImage <$> (fromJPImageUnsafe jimg :: Maybe (Image S (Alpha SRGB) Word16))+    JP.ImageYCbCr8 jimg ->+      compute . convertImage <$> (fromJPImageUnsafe jimg :: Maybe (Image S (YCbCr SRGB) Word8))+    JP.ImageCMYK8 jimg ->+      compute . convertImage <$> (fromJPImageUnsafe jimg :: Maybe (Image S (CMYK SRGB) Word8))+    JP.ImageCMYK16 jimg ->+      compute . convertImage <$> (fromJPImageUnsafe jimg :: Maybe (Image S (CMYK SRGB) Word16))++++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 Ix2 (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 Ix2 (Pixel CM.Y Word8) => Image r CM.Y Word8 -> JP.Image JP.Pixel8+toJPImageY8 = toJPImageUnsafe+{-# INLINE toJPImageY8 #-}++toJPImageY16 :: Source r Ix2 (Pixel CM.Y Word16) => Image r CM.Y Word16 -> JP.Image JP.Pixel16+toJPImageY16 = toJPImageUnsafe+{-# INLINE toJPImageY16 #-}++toJPImageY32 :: Source r Ix2 (Pixel CM.Y Word32) => Image r CM.Y Word32 -> JP.Image JP.Pixel32+toJPImageY32 = toJPImageUnsafe+{-# INLINE toJPImageY32 #-}++toJPImageYF :: Source r Ix2 (Pixel CM.Y Float) => Image r CM.Y Float -> JP.Image JP.PixelF+toJPImageYF = toJPImageUnsafe+{-# INLINE toJPImageYF #-}++toJPImageYA8 ::+     Source r Ix2 (Pixel (Alpha CM.Y) Word8) => Image r (Alpha CM.Y) Word8 -> JP.Image JP.PixelYA8+toJPImageYA8 = toJPImageUnsafe+{-# INLINE toJPImageYA8 #-}++toJPImageYA16 ::+     Source r Ix2 (Pixel (Alpha CM.Y) Word16)+  => Image r (Alpha CM.Y) Word16+  -> JP.Image JP.PixelYA16+toJPImageYA16 = toJPImageUnsafe+{-# INLINE toJPImageYA16 #-}++toJPImageRGB8 :: Source r Ix2 (Pixel CM.RGB Word8) => Image r CM.RGB Word8 -> JP.Image JP.PixelRGB8+toJPImageRGB8 = toJPImageUnsafe+{-# INLINE toJPImageRGB8 #-}++toJPImageRGB16 ::+     Source r Ix2 (Pixel CM.RGB Word16) => Image r CM.RGB Word16 -> JP.Image JP.PixelRGB16+toJPImageRGB16 = toJPImageUnsafe+{-# INLINE toJPImageRGB16 #-}++toJPImageRGBF :: Source r Ix2 (Pixel CM.RGB Float) => Image r CM.RGB Float -> JP.Image JP.PixelRGBF+toJPImageRGBF = toJPImageUnsafe+{-# INLINE toJPImageRGBF #-}++toJPImageRGBA8 ::+     Source r Ix2 (Pixel (Alpha CM.RGB) Word8)+  => Image r (Alpha CM.RGB) Word8+  -> JP.Image JP.PixelRGBA8+toJPImageRGBA8 = toJPImageUnsafe+{-# INLINE toJPImageRGBA8 #-}++toJPImageRGBA16 ::+     Source r Ix2 (Pixel (Alpha CM.RGB) Word16)+  => Image r (Alpha CM.RGB) Word16+  -> JP.Image JP.PixelRGBA16+toJPImageRGBA16 = toJPImageUnsafe+{-# INLINE toJPImageRGBA16 #-}+++toJPImageYCbCr8 ::+     Source r Ix2 (Pixel CM.YCbCr Word8) => Image r CM.YCbCr Word8 -> JP.Image JP.PixelYCbCr8+toJPImageYCbCr8 = toJPImageUnsafe+{-# INLINE toJPImageYCbCr8 #-}++toJPImageCMYK8 ::+     Source r Ix2 (Pixel CM.CMYK Word8) => Image r CM.CMYK Word8 -> JP.Image JP.PixelCMYK8+toJPImageCMYK8 = toJPImageUnsafe+{-# INLINE toJPImageCMYK8 #-}++toJPImageCMYK16 ::+     Source r Ix2 (Pixel CM.CMYK Word16) => Image r CM.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 #-}++-- 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 (YCbCr 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) 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) 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 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 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) 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) Word16)

@@ -0,0 +1,330 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+-- |+-- Module      : Data.Massiv.Array.IO.Image.JuicyPixels.GIF+-- Copyright   : (c) Alexey Kuleshevich 2019-2020+-- 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 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+import Data.List.NonEmpty as NE++--------------------------------------------------------------------------------+-- 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 S CM.Y 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 D65) Word8) where+  encodeM GIF opts = encodeM GIF opts . toImageBaseModel++instance Writable GIF (Image S SRGB Word8) where+  encodeM GIF opts = encodeM GIF opts . toImageBaseModel++encodePalettizedRGB ::+     (MonadThrow m, Source r Ix2 (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 Ix2 (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 Word8) where+  decodeM f = fmap fromImageBaseModel . decodeM f+  decodeWithMetadataM f = fmap (first fromImageBaseModel) . decodeWithMetadataM f++instance Readable GIF (Image S (Alpha SRGB) 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)++-- | 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)+++-- | Decode a Gif Image+decodeAutoGIF ::+     (Mutable r Ix2 (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)++-- | Decode a Gif Image+decodeAutoWithMetadataGIF ::+     (Mutable r Ix2 (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)+++instance (Mutable r Ix2 (Pixel cs e), ColorSpace cs i e) =>+         Readable (Auto GIF) (Image r cs e) where+  decodeM = decodeAutoGIF+  decodeWithMetadataM = decodeAutoWithMetadataGIF++encodeGIF ::+     forall r cs e m.+     (ColorModel cs e, Source r Ix2 (Pixel cs e), MonadThrow m)+  => GIF+  -> GifOptions+  -> Image r cs e+  -> m BL.ByteString+encodeGIF f opts img =+  fallbackEncodePalettizedRGB $ do+    Refl <- eqT :: Maybe (cs :~: CM.Y)+    Refl <- eqT :: Maybe (e :~: Word8)+    pure $ JP.encodeGifImage $ toJPImageY8 img+  where+    fallbackEncodePalettizedRGB =+      \case+        Just bs -> pure bs+        Nothing+          | Just Refl <- (eqT :: Maybe (e :~: Word8))+          , Just Refl <- (eqT :: Maybe (cs :~: CM.RGB)) -> encodePalettizedRGB opts img+        Nothing -> fromMaybeEncode f (Proxy :: Proxy (Image r cs e)) Nothing+++encodeAutoGIF ::+     forall r cs i e m. (ColorSpace cs i e, Source r Ix2 (Pixel cs e), MonadThrow m)+  => Auto GIF+  -> GifOptions+  -> Image r cs e+  -> m BL.ByteString+encodeAutoGIF _ opts img =+  fallbackEncodePalettizedRGB $ do+    Refl <- eqT :: Maybe (BaseModel cs :~: CM.Y)+    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+  , 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 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) Word8] where+  decodeM f = fmap (fmap fromImageBaseModel) . decodeM f+  decodeWithMetadataM f = fmap (first (fmap fromImageBaseModel)) . decodeWithMetadataM f+++instance (Mutable r Ix2 (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 ::+     (Mutable r Ix2 (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 ::+     (Mutable r Ix2 (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.Y 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, 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, 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 = JP.DisposalAny+                  , JP.gfPixels = img+                  }+      }+    where+      (rows :. cols) = foldl1 (liftIndex2 max) $ fmap (unSz . size . snd) gifs+++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 Word8)) where+  encodeM f opts = encodeM f opts . fmap (fmap toImageBaseModel)++instance (Mutable r Ix2 (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 Word8)))

@@ -0,0 +1,146 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+-- |+-- Module      : Data.Massiv.Array.IO.Image.JuicyPixels.HDR+-- Copyright   : (c) Alexey Kuleshevich 2019-2020+-- 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 Float) where+  encodeM f opts = encodeM f opts . toImageBaseModel++instance (ColorSpace cs i e, ColorSpace (BaseSpace cs) i e, Source r Ix2 (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 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)++-- | 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)+++-- | Decode a HDR Image+decodeAutoHDR ::+     (Mutable r Ix2 (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)++-- | Decode a HDR Image+decodeAutoWithMetadataHDR ::+     (Mutable r Ix2 (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)++instance (Mutable r Ix2 (Pixel cs e), ColorSpace cs i e) =>+         Readable (Auto HDR) (Image r cs e) where+  decodeM = decodeAutoHDR+  decodeWithMetadataM = decodeAutoWithMetadataHDR++encodeHDR ::+     forall r cs e m.+     (ColorModel cs e, Source r Ix2 (Pixel cs e), MonadThrow m)+  => HDR+  -> HdrOptions+  -> Image r cs e+  -> m BL.ByteString+encodeHDR f opts img =+  fromMaybeEncode f (Proxy :: Proxy (Image r cs e)) $ do+    Refl <- eqT :: Maybe (e :~: Float)+    Refl <- eqT :: Maybe (cs :~: CM.RGB)+    pure $ getHdrEncoder opts $ toJPImageRGBF img++++encodeAutoHDR ::+     forall r cs i e. (ColorSpace cs i e, Source r Ix2 (Pixel cs e))+  => Auto HDR+  -> HdrOptions+  -> Image r cs e+  -> BL.ByteString+encodeAutoHDR _ opts = toHdr (toPixelBaseModel . toSRGBF)+  where+    toSRGBF = convertPixel :: Pixel cs e -> Pixel SRGB Float+    toHdr :: Source r Ix2 a => (a -> Pixel CM.RGB Float) -> Array r Ix2 a -> BL.ByteString+    toHdr adjustPixel = getHdrEncoder opts . toJPImageRGBF . A.map adjustPixel

@@ -0,0 +1,221 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+-- |+-- Module      : Data.Massiv.Array.IO.Image.JuicyPixels.JPG+-- Copyright   : (c) Alexey Kuleshevich 2019-2020+-- 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 S CM.Y 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 D65) Word8) where+  encodeM f opts = encodeM f opts . toImageBaseModel++instance Writable JPG (Image S SRGB Word8) where+  encodeM f opts = encodeM f opts . toImageBaseModel++instance Writable JPG (Image S (YCbCr SRGB) Word8) where+  encodeM f opts = encodeM f opts . toImageBaseModel++instance Writable JPG (Image S (CMYK SRGB) Word8) where+  encodeM f opts = encodeM f opts . toImageBaseModel++instance (ColorSpace cs i e, ColorSpace (BaseSpace cs) i e, Source r Ix2 (Pixel cs e)) =>+         Writable (Auto JPG) (Image r cs e) where+  encodeM f opts = pure . encodeAutoJPG f opts+++instance Readable JPG (Image S CM.Y Word8) where+  decodeWithMetadataM = decodeWithMetadataJPG++instance Readable JPG (Image S (Alpha CM.Y) 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 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 Word8) where+  decodeWithMetadataM f = fmap (first fromImageBaseModel) . decodeWithMetadataM f++instance Readable JPG (Image S (CMYK SRGB) Word8) where+  decodeWithMetadataM f = fmap (first fromImageBaseModel) . decodeWithMetadataM f++instance Readable JPG (Image S (YCbCr 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)++-- | 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)+++-- | Decode a Jpeg Image+decodeAutoJPG ::+     (Mutable r Ix2 (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)++-- | Decode a Jpeg Image+decodeAutoWithMetadataJPG ::+     (Mutable r Ix2 (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)++instance (Mutable r Ix2 (Pixel cs e), ColorSpace cs i e) =>+         Readable (Auto JPG) (Image r cs e) where+  decodeM = decodeAutoJPG+  decodeWithMetadataM = decodeAutoWithMetadataJPG++encodeJPG ::+     forall r cs e m.+     (ColorModel cs e, Source r Ix2 (Pixel cs e), MonadThrow m)+  => JPG+  -> JpegOptions+  -> Image r cs e+  -> m BL.ByteString+encodeJPG f JpegOptions {jpegQuality, jpegMetadata} img =+  fromMaybeEncode f (Proxy :: Proxy (Image r cs e)) $ do+    Refl <- eqT :: Maybe (e :~: Word8)+    msum+      [ do Refl <- eqT :: Maybe (cs :~: CM.Y)+           pure $+             JP.encodeDirectJpegAtQualityWithMetadata jpegQuality jpegMetadata $ toJPImageY8 img+      , do Refl <- eqT :: Maybe (cs :~: CM.RGB)+           pure $+             JP.encodeDirectJpegAtQualityWithMetadata jpegQuality jpegMetadata $ toJPImageRGB8 img+      , do Refl <- eqT :: Maybe (cs :~: CM.YCbCr)+           pure $ JP.encodeJpegAtQualityWithMetadata jpegQuality jpegMetadata $ toJPImageYCbCr8 img+      , do Refl <- eqT :: Maybe (cs :~: CM.CMYK)+           pure $+             JP.encodeDirectJpegAtQualityWithMetadata jpegQuality jpegMetadata $ toJPImageCMYK8 img+      ]++++encodeAutoJPG ::+     forall r cs i e. (ColorSpace (BaseSpace cs) i e, ColorSpace cs i e, Source r Ix2 (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 (BaseModel cs :~: CM.Y)+         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 ix a)+      => (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

@@ -0,0 +1,268 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+-- |+-- Module      : Data.Massiv.Array.IO.Image.JuicyPixels.PNG+-- Copyright   : (c) Alexey Kuleshevich 2019-2020+-- 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 S CM.Y Word8) where+  encodeM PNG _ img = pure $ JP.encodePng (toJPImageY8 img)++instance Writable PNG (Image S CM.Y Word16) where+  encodeM PNG _ img = pure $ JP.encodePng (toJPImageY16 img)++instance Writable PNG (Image S (Alpha CM.Y) Word8) where+  encodeM PNG _ img = pure $ JP.encodePng (toJPImageYA8 img)++instance Writable PNG (Image S (Alpha CM.Y) 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 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 Word8) where+  encodeM f opts = encodeM f opts . toImageBaseModel++instance Writable PNG (Image S SRGB Word16) where+  encodeM f opts = encodeM f opts . toImageBaseModel++instance Writable PNG (Image S (Alpha SRGB) Word8) where+  encodeM f opts = encodeM f opts . toImageBaseModel++instance Writable PNG (Image S (Alpha SRGB) Word16) where+  encodeM f opts = encodeM f opts . toImageBaseModel++instance (ColorSpace cs i e, ColorSpace (BaseSpace cs) i e, Source r Ix2 (Pixel cs e)) =>+         Writable (Auto PNG) (Image r cs e) where+  encodeM f _ = pure . encodeAutoPNG f+++instance Readable PNG (Image S CM.Y Word8) where+  decodeWithMetadataM = decodeWithMetadataPNG++instance Readable PNG (Image S CM.Y Word16) where+  decodeWithMetadataM = decodeWithMetadataPNG++instance Readable PNG (Image S (Alpha CM.Y) Word8) where+  decodeWithMetadataM = decodeWithMetadataPNG++instance Readable PNG (Image S (Alpha CM.Y) 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 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 Word8) where+  decodeWithMetadataM f = fmap (first fromImageBaseModel) . decodeWithMetadataPNG f++instance Readable PNG (Image S SRGB Word16) where+  decodeWithMetadataM f = fmap (first fromImageBaseModel) . decodeWithMetadataPNG f++instance Readable PNG (Image S (Alpha SRGB) Word8) where+  decodeWithMetadataM f = fmap (first fromImageBaseModel) . decodeWithMetadataPNG f++instance Readable PNG (Image S (Alpha SRGB) 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)++-- | 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)+++-- | Decode a Png Image+decodeAutoPNG ::+     (Mutable r Ix2 (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)++-- | Decode a Png Image+decodeAutoWithMetadataPNG ::+     (Mutable r Ix2 (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)++instance (Mutable r Ix2 (Pixel cs e), ColorSpace cs i e) =>+         Readable (Auto PNG) (Image r cs e) where+  decodeM = decodeAutoPNG+  decodeWithMetadataM = decodeAutoWithMetadataPNG++encodePNG ::+     forall r cs e m.+     (ColorModel cs e, Source r Ix2 (Pixel cs e), MonadThrow m)+  => PNG+  -> Image r cs e+  -> m BL.ByteString+encodePNG f img =+  fromMaybeEncode f (Proxy :: Proxy (Image r cs e)) $+  msum+    [ do Refl <- eqT :: Maybe (cs :~: CM.Y)+         msum+           [ do Refl <- eqT :: Maybe (e :~: Word8)+                pure $ JP.encodePng $ toJPImageY8 img+           , do Refl <- eqT :: Maybe (e :~: Word16)+                pure $ JP.encodePng $ toJPImageY16 img+           ]+    , do Refl <- eqT :: Maybe (cs :~: Alpha CM.Y)+         msum+           [ do Refl <- eqT :: Maybe (e :~: Word8)+                pure $ JP.encodePng $ toJPImageYA8 img+           , do Refl <- eqT :: Maybe (e :~: Word16)+                pure $ JP.encodePng $ toJPImageYA16 img+           ]+    , do Refl <- eqT :: Maybe (cs :~: CM.RGB)+         msum+           [ do Refl <- eqT :: Maybe (e :~: Word8)+                pure $ JP.encodePng $ toJPImageRGB8 img+           , do Refl <- eqT :: Maybe (e :~: Word16)+                pure $ JP.encodePng $ toJPImageRGB16 img+           ]+    , do Refl <- eqT :: Maybe (cs :~: Alpha CM.RGB)+         msum+           [ do Refl <- eqT :: Maybe (e :~: Word8)+                pure $ JP.encodePng $ toJPImageRGBA8 img+           , do Refl <- eqT :: Maybe (e :~: Word16)+                pure $ JP.encodePng $ toJPImageRGBA16 img+           ]+    ]+++encodeAutoPNG ::+     forall r cs i e. (ColorSpace (BaseSpace cs) i e, ColorSpace cs i e, Source r Ix2 (Pixel cs e))+  => Auto PNG+  -> Image r cs e+  -> BL.ByteString+encodeAutoPNG _ img =+  fromMaybe (toPng toJPImageRGB16 toSRGB16 img) $+  msum+    [ do Refl <- eqT :: Maybe (BaseModel cs :~: CM.Y)+         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.Y)+         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 ix a)+      => (Array D ix b -> JP.Image px)+      -> (a -> b)+      -> Array r ix a+      -> BL.ByteString+    toPng toJP adjustPixel = JP.encodePng . toJP . A.map adjustPixel

@@ -0,0 +1,183 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+-- |+-- Module      : Data.Massiv.Array.IO.Image.JuicyPixels.TGA+-- Copyright   : (c) Alexey Kuleshevich 2019-2020+-- 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 S CM.Y 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 D65) Word8) where+  encodeM f opts = encodeM f opts . toImageBaseModel++instance Writable TGA (Image S SRGB Word8) where+  encodeM f opts = encodeM f opts . toImageBaseModel++instance Writable TGA (Image S (Alpha SRGB) Word8) where+  encodeM f opts = encodeM f opts . toImageBaseModel+++instance (ColorSpace cs i e, ColorSpace (BaseSpace cs) i e, Source r Ix2 (Pixel cs e)) =>+         Writable (Auto TGA) (Image r cs e) where+  encodeM f _ = pure . encodeAutoTGA f+++instance Readable TGA (Image S CM.Y 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 D65) Word8) where+  decodeWithMetadataM f = fmap (first fromImageBaseModel) . decodeWithMetadataM f++instance Readable TGA (Image S SRGB Word8) where+  decodeWithMetadataM f = fmap (first fromImageBaseModel) . decodeWithMetadataM f++instance Readable TGA (Image S (Alpha SRGB) 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)++-- | 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)+++-- | Decode a Tga Image+decodeAutoTGA ::+     (Mutable r Ix2 (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)++-- | Decode a Tga Image+decodeAutoWithMetadataTGA ::+     (Mutable r Ix2 (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)+++instance (Mutable r Ix2 (Pixel cs e), ColorSpace cs i e) =>+         Readable (Auto TGA) (Image r cs e) where+  decodeWithMetadataM = decodeAutoWithMetadataTGA++encodeTGA ::+     forall r cs e m.+     (ColorModel cs e, Source r Ix2 (Pixel cs e), MonadThrow m)+  => TGA+  -> Image r cs e+  -> m BL.ByteString+encodeTGA f img =+  fromMaybeEncode f (Proxy :: Proxy (Image r cs e)) $+  msum+    [ do Refl <- eqT :: Maybe (cs :~: CM.Y)+         Refl <- eqT :: Maybe (e :~: Word8)+         pure $ JP.encodeTga $ toJPImageY8 img+    , do Refl <- eqT :: Maybe (cs :~: CM.RGB)+         Refl <- eqT :: Maybe (e :~: Word8)+         pure $ JP.encodeTga $ toJPImageRGB8 img+    , do Refl <- eqT :: Maybe (cs :~: Alpha CM.RGB)+         Refl <- eqT :: Maybe (e :~: Word8)+         pure $ JP.encodeTga $ toJPImageRGBA8 img+    ]+++encodeAutoTGA ::+     forall r cs i e.+     ( ColorSpace (BaseSpace cs) i e+     , ColorSpace cs i e+     , Source r Ix2 (Pixel cs e)+     )+  => Auto TGA+  -> Image r cs e+  -> BL.ByteString+encodeAutoTGA _ img =+  fromMaybe (toTga toJPImageRGB8 toSRGB8 img) $+  msum+    [ do Refl <- eqT :: Maybe (BaseModel cs :~: CM.Y)+         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 ix a)+      => (Array D ix b -> JP.Image px)+      -> (a -> b)+      -> Array r ix a+      -> BL.ByteString+    toTga toJP adjustPixel = JP.encodeTga . toJP . A.map adjustPixel

@@ -0,0 +1,366 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+-- |+-- Module      : Data.Massiv.Array.IO.Image.JuicyPixels.TIF+-- Copyright   : (c) Alexey Kuleshevich 2019-2020+-- 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 S CM.Y Word8) where+  encodeM TIF _ img = pure $ JP.encodeTiff (toJPImageY8 img)++instance Writable TIF (Image S CM.Y Word16) where+  encodeM TIF _ img = pure $ JP.encodeTiff (toJPImageY16 img)++instance Writable TIF (Image S CM.Y Word32) where+  encodeM TIF _ img = pure $ JP.encodeTiff (toJPImageY32 img)++instance Writable TIF (Image S CM.Y Float) where+  encodeM TIF _ img = pure $ JP.encodeTiff (toJPImageYF img)++instance Writable TIF (Image S (Alpha CM.Y) Word8) where+  encodeM TIF _ img = pure $ JP.encodeTiff (toJPImageYA8 img)++instance Writable TIF (Image S (Alpha CM.Y) 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 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 Word8) where+  encodeM f opts = encodeM f opts . toImageBaseModel++instance Writable TIF (Image S SRGB Word16) where+  encodeM f opts = encodeM f opts . toImageBaseModel++instance Writable TIF (Image S (Alpha SRGB) Word8) where+  encodeM f opts = encodeM f opts . toImageBaseModel++instance Writable TIF (Image S (Alpha SRGB) Word16) where+  encodeM f opts = encodeM f opts . toImageBaseModel++instance Writable TIF (Image S (YCbCr SRGB) Word8) where+  encodeM f opts = encodeM f opts . toImageBaseModel++instance Writable TIF (Image S (CMYK SRGB) Word8) where+  encodeM f opts = encodeM f opts . toImageBaseModel++instance Writable TIF (Image S (CMYK SRGB) Word16) where+  encodeM f opts = encodeM f opts . toImageBaseModel++instance (ColorSpace cs i e, ColorSpace (BaseSpace cs) i e, Source r Ix2 (Pixel cs e)) =>+         Writable (Auto TIF) (Image r cs e) where+  encodeM f _ = pure . encodeAutoTIF f+++instance Readable TIF (Image S CM.Y Word8) where+  decodeWithMetadataM = decodeWithMetadataTIF++instance Readable TIF (Image S CM.Y Word16) where+  decodeWithMetadataM = decodeWithMetadataTIF++instance Readable TIF (Image S CM.Y Word32) where+  decodeWithMetadataM = decodeWithMetadataTIF++instance Readable TIF (Image S CM.Y Float) where+  decodeWithMetadataM = decodeWithMetadataTIF++instance Readable TIF (Image S (Alpha CM.Y) Word8) where+  decodeWithMetadataM = decodeWithMetadataTIF++instance Readable TIF (Image S (Alpha CM.Y) 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 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 Word8) where+  decodeWithMetadataM f = fmap (first fromImageBaseModel) . decodeWithMetadataM f++instance Readable TIF (Image S SRGB Word16) where+  decodeWithMetadataM f = fmap (first fromImageBaseModel) . decodeWithMetadataM f++instance Readable TIF (Image S (Alpha SRGB) Word8) where+  decodeWithMetadataM f = fmap (first fromImageBaseModel) . decodeWithMetadataM f++instance Readable TIF (Image S (Alpha SRGB) Word16) where+  decodeWithMetadataM f = fmap (first fromImageBaseModel) . decodeWithMetadataM f++instance Readable TIF (Image S (CMYK SRGB) Word8) where+  decodeWithMetadataM f = fmap (first fromImageBaseModel) . decodeWithMetadataM f++instance Readable TIF (Image S (CMYK SRGB) 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)++-- | 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)+++-- | Decode a Tiff Image+decodeAutoTIF ::+     (Mutable r Ix2 (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)++-- | Decode a Tiff Image+decodeAutoWithMetadataTIF ::+     (Mutable r Ix2 (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)++instance (Mutable r Ix2 (Pixel cs e), ColorSpace cs i e) =>+         Readable (Auto TIF) (Image r cs e) where+  decodeM = decodeAutoTIF+  decodeWithMetadataM = decodeAutoWithMetadataTIF++encodeTIF ::+     forall r cs e m.+     (ColorModel cs e, Source r Ix2 (Pixel cs e), MonadThrow m)+  => TIF+  -> Image r cs e+  -> m BL.ByteString+encodeTIF f img =+  fromMaybeEncode f (Proxy :: Proxy (Image r cs e)) $+  msum+    [ do Refl <- eqT :: Maybe (cs :~: CM.Y)+         msum+           [ do Refl <- eqT :: Maybe (e :~: Word8)+                pure $ JP.encodeTiff $ toJPImageY8 img+           , do Refl <- eqT :: Maybe (e :~: Word16)+                pure $ JP.encodeTiff $ toJPImageY16 img+           , do Refl <- eqT :: Maybe (e :~: Word32)+                pure $ JP.encodeTiff $ toJPImageY32 img+           , do Refl <- eqT :: Maybe (e :~: Float)+                pure $ JP.encodeTiff $ toJPImageYF img+           ]+    , do Refl <- eqT :: Maybe (cs :~: Alpha CM.Y)+         msum+           [ do Refl <- eqT :: Maybe (e :~: Word8)+                pure $ JP.encodeTiff $ toJPImageYA8 img+           , do Refl <- eqT :: Maybe (e :~: Word16)+                pure $ JP.encodeTiff $ toJPImageYA16 img+           ]+    , do Refl <- eqT :: Maybe (cs :~: CM.RGB)+         msum+           [ do Refl <- eqT :: Maybe (e :~: Word8)+                pure $ JP.encodeTiff $ toJPImageRGB8 img+           , do Refl <- eqT :: Maybe (e :~: Word16)+                pure $ JP.encodeTiff $ toJPImageRGB16 img+           ]+    , do Refl <- eqT :: Maybe (cs :~: Alpha CM.RGB)+         msum+           [ do Refl <- eqT :: Maybe (e :~: Word8)+                pure $ JP.encodeTiff $ toJPImageRGBA8 img+           , do Refl <- eqT :: Maybe (e :~: Word16)+                pure $ JP.encodeTiff $ toJPImageRGBA16 img+           ]+    , do Refl <- eqT :: Maybe (cs :~: CM.YCbCr)+         Refl <- eqT :: Maybe (e :~: Word8)+         pure $ JP.encodeTiff $ toJPImageYCbCr8 img+    , do Refl <- eqT :: Maybe (cs :~: CM.CMYK)+         msum+           [ do Refl <- eqT :: Maybe (e :~: Word8)+                pure $ JP.encodeTiff $ toJPImageCMYK8 img+           , do Refl <- eqT :: Maybe (e :~: Word16)+                pure $ JP.encodeTiff $ toJPImageCMYK16 img+           ]+    ]++++encodeAutoTIF ::+     forall r cs i e. (ColorSpace (BaseSpace cs) i e, ColorSpace cs i e, Source r Ix2 (Pixel cs e))+  => Auto TIF+  -> Image r cs e+  -> BL.ByteString+encodeAutoTIF _ img =+  fromMaybe (toTiff toJPImageRGB8 toSRGB8 img) $+  msum+    [ do Refl <- eqT :: Maybe (BaseModel cs :~: CM.Y)+         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.Y)+         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 ix a)+      => (Array D ix b -> JP.Image px)+      -> (a -> b)+      -> Array r ix a+      -> BL.ByteString+    toTiff toJP adjustPixel = JP.encodeTiff . toJP . A.map adjustPixel

@@ -1,17 +1,18 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE RankNTypes #-} {-# 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-2020 -- License     : BSD3 -- Maintainer  : Alexey Kuleshevich <lehins@yandex.ru> -- Stability   : experimental@@ -25,156 +26,134 @@   , 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.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 -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 +-- | Try to decode a Netpbm image, while auto converting the colorspace.+--+-- @since 0.2.0+decodeAutoNetpbmImage ::+     (FileFormat f, Mutable r Ix2 (Pixel cs e), MonadThrow m, ColorSpace cs i e)+  => f+  -> B.ByteString+  -> m (Image r cs e, Maybe B.ByteString)+decodeAutoNetpbmImage = decodePPM fromNetpbmImageAuto +-- | Try to decode a Netpbm image sequence, while auto converting the colorspace.+--+-- @since 0.2.0+decodeAutoNetpbmImageSequence ::+     (FileFormat (Sequence f), Mutable r Ix2 (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 -decodePPMs :: (FileFormat f, Mutable r Ix2 (Pixel cs e), ColorSpace cs e) =>-              f-           -> (Netpbm.PPM -> Maybe (Image r cs e))+decodePPMs :: (FileFormat f, Mutable r Ix2 (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, Mutable r Ix2 (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 #-}  @@ -190,47 +169,128 @@ 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.Y 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.Y 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.Y Word8) where+  decodeWithMetadataM = decodeNetpbmImage+instance Readable PGM (Image S CM.Y Word16) where+  decodeWithMetadataM = decodeNetpbmImage+++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.Y Word8] where+  decodeWithMetadataM = decodePPMs fromNetpbmImage+instance Readable (Sequence PGM) [Image S CM.Y Word16] where+  decodeWithMetadataM = decodePPMs fromNetpbmImage+++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 Word8) where+  decodeWithMetadataM f = fmap (first fromImageBaseModel) . decodeWithMetadataM f+instance Readable PPM (Image S SRGB 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 Word8] where+  decodeWithMetadataM f = fmap (first (fmap fromImageBaseModel)) . decodeWithMetadataM f+instance Readable (Sequence PPM) [Image S SRGB 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.Y 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.Y 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.Y 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 (Mutable r Ix2 (Pixel cs e), ColorSpace cs i e) =>+         Readable (Auto PBM) (Image r cs e) where+  decodeWithMetadataM = decodeAutoNetpbmImage+instance (Mutable r Ix2 (Pixel cs e), ColorSpace cs i e) =>+         Readable (Auto (Sequence PBM)) [Image r cs e] where+  decodeWithMetadataM = decodeAutoNetpbmImageSequence++instance (Mutable r Ix2 (Pixel cs e), ColorSpace cs i e) =>+         Readable (Auto PGM) (Image r cs e) where+  decodeWithMetadataM = decodeAutoNetpbmImage+instance (Mutable r Ix2 (Pixel cs e), ColorSpace cs i e) =>+         Readable (Auto (Sequence PGM)) [Image r cs e] where+  decodeWithMetadataM = decodeAutoNetpbmImageSequence++instance (Mutable r Ix2 (Pixel cs e), ColorSpace cs i e) =>+         Readable (Auto PPM) (Image r cs e) where+  decodeWithMetadataM = decodeAutoNetpbmImage+instance (Mutable r Ix2 (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 . (Mutable r Ix2 (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 Word8))     PpmPixelDataRGB16 v ->-      (fromNetpbmImageUnsafe m n v :: Maybe (Image S RGB Word16)) >>= toAnyCS-+      compute . convertImage <$> (fromNetpbmImageUnsafe m n v :: Maybe (Image S SRGB Word16))

@@ -0,0 +1,14 @@+-- |+-- Module      : Graphics.ColorModel+-- Copyright   : (c) Alexey Kuleshevich 2020+-- 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

@@ -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 #-}

@@ -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 #-}

@@ -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 #-}

@@ -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 #-}--

@@ -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 #-}

@@ -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 #-}

@@ -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 #-}

@@ -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 #-}

@@ -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