JuicyPixels 3.2.8.1 → 3.2.8.2
raw patch · 5 files changed
+1428/−1424 lines, 5 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- JuicyPixels.cabal +2/−2
- changelog +5/−0
- src/Codec/Picture/Jpg.hs +4/−5
- src/Codec/Picture/Tga.hs +527/−527
- src/Codec/Picture/Tiff.hs +890/−890
JuicyPixels.cabal view
@@ -1,5 +1,5 @@ Name: JuicyPixels -Version: 3.2.8.1 +Version: 3.2.8.2 Synopsis: Picture loading/serialization (in png, jpeg, bitmap, gif, tga, tiff and radiance) Description: <<data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAMAAAADABAMAAACg8nE0AAAAElBMVEUAAABJqDSTWEL/qyb///8AAABH/1GTAAAAAXRSTlMAQObYZgAAAN5JREFUeF7s1sEJgFAQxFBbsAV72v5bEVYWPwT/XDxmCsi7zvHXavYREBDI3XP2GgICqBBYuwIC+/rVayPUAyAg0HvIXBcQoDFDGnUBgWQQ2Bx3AYFaRoBpAQHWb3bt2ARgGAiCYFFuwf3X5HA/McgGJWI2FdykCv4aBYzmKwDwvl6NVmUAAK2vlwEALK7fo88GANB6HQsAAAAAAAAA7P94AQCzswEAAAAAAAAAAAAAAAAAAICzh4UAO4zWAYBfRutHA4Bn5C69JhowAMGoBaMWDG0wCkbBKBgFo2AUAACPmegUST/IJAAAAABJRU5ErkJggg==>> @@ -28,7 +28,7 @@ Source-Repository this Type: git Location: git://github.com/Twinside/Juicy.Pixels.git - Tag: v3.2.8.1 + Tag: v3.2.8.2 Flag Mmap Description: Enable the file loading via mmap (memory map)
changelog view
@@ -1,6 +1,11 @@ Change log ========== +v3.2.8.2 June 2017 +------------------ + + * Fix: usage of fail in Either monad, giving an unwanted exception + v3.2.8.1 March 2016 -------------------
src/Codec/Picture/Jpg.hs view
@@ -483,10 +483,9 @@ gatherScanInfo :: JpgImage -> (JpgFrameKind, JpgFrameHeader) gatherScanInfo img = head [(a, b) | JpgScans a b <- jpgFrame img] -dynamicOfColorSpace :: (Monad m) - => Maybe JpgColorSpace -> Int -> Int -> VS.Vector Word8 - -> m DynamicImage -dynamicOfColorSpace Nothing _ _ _ = fail "Unknown color space" +dynamicOfColorSpace :: Maybe JpgColorSpace -> Int -> Int -> VS.Vector Word8 + -> Either String DynamicImage +dynamicOfColorSpace Nothing _ _ _ = Left "Unknown color space" dynamicOfColorSpace (Just color) w h imgData = case color of JpgColorSpaceCMYK -> return . ImageCMYK8 $ Image w h imgData JpgColorSpaceYCCK -> @@ -496,7 +495,7 @@ JpgColorSpaceRGB -> return . ImageRGB8 $ Image w h imgData JpgColorSpaceYA -> return . ImageYA8 $ Image w h imgData JpgColorSpaceY -> return . ImageY8 $ Image w h imgData - colorSpace -> fail $ "Wrong color space : " ++ show colorSpace + colorSpace -> Left $ "Wrong color space : " ++ show colorSpace colorSpaceOfAdobe :: Int -> JpgAdobeApp14 -> Maybe JpgColorSpace colorSpaceOfAdobe compCount app = case (compCount, _adobeTransform app) of
src/Codec/Picture/Tga.hs view
@@ -1,527 +1,527 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE CPP #-}--- | Module implementing function to read and write--- Targa (*.tga) files.-module Codec.Picture.Tga( decodeTga- , decodeTgaWithMetadata- , decodeTgaWithPaletteAndMetadata- , TgaSaveable- , encodeTga- , writeTga- ) where--#if !MIN_VERSION_base(4,8,0)-import Data.Monoid( mempty )-import Control.Applicative( (<*>), pure, (<$>) )-#endif--import Control.Arrow( first )-import Control.Monad.ST( ST, runST )-import Data.Bits( (.&.)- , (.|.)- , bit- , testBit- , setBit- , unsafeShiftL- , unsafeShiftR )-import Data.Word( Word8, Word16 )-import Data.Binary( Binary( .. ), encode )-import Data.Binary.Get( Get- , getByteString - , getWord8- , getWord16le- )-import Data.Binary.Put( putWord8- , putWord16le- , putByteString- )--import qualified Data.ByteString as B-import qualified Data.ByteString.Lazy as Lb-import qualified Data.ByteString.Unsafe as U-import qualified Data.Vector.Storable.Mutable as M--import Codec.Picture.Types-import Codec.Picture.InternalHelper-import Codec.Picture.Metadata( Metadatas- , SourceFormat( SourceTGA )- , basicMetadata )-import Codec.Picture.VectorByteConversion--data TgaColorMapType- = ColorMapWithoutTable- | ColorMapWithTable- | ColorMapUnknown Word8--instance Binary TgaColorMapType where- get = do- v <- getWord8- return $ case v of- 0 -> ColorMapWithoutTable- 1 -> ColorMapWithTable- n -> ColorMapUnknown n-- put v = case v of- ColorMapWithoutTable -> putWord8 0- ColorMapWithTable -> putWord8 1- (ColorMapUnknown vv) -> putWord8 vv--data TgaImageType- = ImageTypeNoData Bool- | ImageTypeColorMapped Bool- | ImageTypeTrueColor Bool- | ImageTypeMonochrome Bool--isRleEncoded :: TgaImageType -> Bool-isRleEncoded v = case v of- ImageTypeNoData yn -> yn- ImageTypeColorMapped yn -> yn- ImageTypeTrueColor yn -> yn- ImageTypeMonochrome yn -> yn--imageTypeOfCode :: Monad m => Word8 -> m TgaImageType-imageTypeOfCode v = case v .&. 3 of- 0 -> return $ ImageTypeNoData isEncoded- 1 -> return $ ImageTypeColorMapped isEncoded- 2 -> return $ ImageTypeTrueColor isEncoded- 3 -> return $ ImageTypeMonochrome isEncoded- _ -> fail $ "Unknown TGA image type " ++ show v- where- isEncoded = testBit v 3--codeOfImageType :: TgaImageType -> Word8-codeOfImageType v = case v of- ImageTypeNoData encoded -> setVal 0 encoded- ImageTypeColorMapped encoded -> setVal 1 encoded- ImageTypeTrueColor encoded -> setVal 2 encoded- ImageTypeMonochrome encoded -> setVal 3 encoded- where- setVal vv True = setBit vv 3- setVal vv False = vv--instance Binary TgaImageType where- get = getWord8 >>= imageTypeOfCode- put = putWord8 . codeOfImageType- -data TgaImageDescription = TgaImageDescription- { _tgaIdXOrigin :: Bool- , _tgaIdYOrigin :: Bool- , _tgaIdAttributeBits :: Word8- }--instance Binary TgaImageDescription where- put desc = putWord8 $ xOrig .|. yOrig .|. attr- where- xOrig | _tgaIdXOrigin desc = bit 4- | otherwise = 0-- yOrig | not $ _tgaIdYOrigin desc = bit 5- | otherwise = 0- - attr = _tgaIdAttributeBits desc .&. 0xF-- get = toDescr <$> getWord8 where- toDescr v = TgaImageDescription- { _tgaIdXOrigin = testBit v 4- , _tgaIdYOrigin = not $ testBit v 5- , _tgaIdAttributeBits = v .&. 0xF- }--data TgaHeader = TgaHeader- { _tgaHdrIdLength :: {-# UNPACK #-} !Word8- , _tgaHdrColorMapType :: !TgaColorMapType- , _tgaHdrImageType :: !TgaImageType- , _tgaHdrMapStart :: {-# UNPACK #-} !Word16- , _tgaHdrMapLength :: {-# UNPACK #-} !Word16- , _tgaHdrMapDepth :: {-# UNPACK #-} !Word8- , _tgaHdrXOffset :: {-# UNPACK #-} !Word16- , _tgaHdrYOffset :: {-# UNPACK #-} !Word16- , _tgaHdrWidth :: {-# UNPACK #-} !Word16- , _tgaHdrHeight :: {-# UNPACK #-} !Word16- , _tgaHdrPixelDepth :: {-# UNPACK #-} !Word8- , _tgaHdrImageDescription :: {-# UNPACK #-} !TgaImageDescription- }--instance Binary TgaHeader where- get = TgaHeader- <$> g8 <*> get <*> get <*> g16 <*> g16 <*> g8- <*> g16 <*> g16 <*> g16 <*> g16 <*> g8 <*> get- where g16 = getWord16le- g8 = getWord8-- put v = do- let p8 = putWord8- p16 = putWord16le- p8 $ _tgaHdrIdLength v- put $ _tgaHdrColorMapType v- put $ _tgaHdrImageType v-- p16 $ _tgaHdrMapStart v- p16 $ _tgaHdrMapLength v- p8 $ _tgaHdrMapDepth v- p16 $ _tgaHdrXOffset v- p16 $ _tgaHdrYOffset v- p16 $ _tgaHdrWidth v- p16 $ _tgaHdrHeight v- p8 $ _tgaHdrPixelDepth v- put $ _tgaHdrImageDescription v---data TgaFile = TgaFile- { _tgaFileHeader :: !TgaHeader- , _tgaFileId :: !B.ByteString- , _tgaPalette :: !B.ByteString- , _tgaFileRest :: !B.ByteString- }--getPalette :: TgaHeader -> Get B.ByteString-getPalette hdr | _tgaHdrMapLength hdr <= 0 = return mempty-getPalette hdr = getByteString $ bytePerPixel * pixelCount- where- bytePerPixel = fromIntegral $ _tgaHdrMapDepth hdr `div` 8- pixelCount = fromIntegral $ _tgaHdrMapLength hdr--instance Binary TgaFile where- get = do- hdr <- get- validateTga hdr- fileId <- getByteString . fromIntegral $ _tgaHdrIdLength hdr- palette <- getPalette hdr- rest <- getRemainingBytes-- return TgaFile {- _tgaFileHeader = hdr- , _tgaFileId = fileId- , _tgaPalette = palette- , _tgaFileRest = rest- }-- put file = do- put $ _tgaFileHeader file- putByteString $ _tgaFileId file- putByteString $ _tgaPalette file- putByteString $ _tgaFileRest file--data Depth8 = Depth8-data Depth15 = Depth15-data Depth24 = Depth24-data Depth32 = Depth32--class (Pixel (Unpacked a)) => TGAPixel a where- type Unpacked a- packedByteSize :: a -> Int- tgaUnpack :: a -> B.ByteString -> Int -> Unpacked a--instance TGAPixel Depth8 where- type Unpacked Depth8 = Pixel8- packedByteSize _ = 1- tgaUnpack _ = U.unsafeIndex--instance TGAPixel Depth15 where- type Unpacked Depth15 = PixelRGBA8- packedByteSize _ = 2- tgaUnpack _ str ix = PixelRGBA8 r g b a- where- v0 = U.unsafeIndex str ix- v1 = U.unsafeIndex str $ ix + 1- r = (v1 .&. 0x7c) `unsafeShiftL` 1;- g = ((v1 .&. 0x03) `unsafeShiftL` 6) .|. ((v0 .&. 0xe0) `unsafeShiftR` 2);- b = (v0 .&. 0x1f) `unsafeShiftL` 3- a = 255 -- v1 .&. 0x80--instance TGAPixel Depth24 where- type Unpacked Depth24 = PixelRGB8- packedByteSize _ = 3- tgaUnpack _ str ix = PixelRGB8 r g b- where- b = U.unsafeIndex str ix- g = U.unsafeIndex str (ix + 1)- r = U.unsafeIndex str (ix + 2)--instance TGAPixel Depth32 where- type Unpacked Depth32 = PixelRGBA8- packedByteSize _ = 4- tgaUnpack _ str ix = PixelRGBA8 r g b a- where- b = U.unsafeIndex str ix- g = U.unsafeIndex str (ix + 1)- r = U.unsafeIndex str (ix + 2)- a = U.unsafeIndex str (ix + 3)--prepareUnpacker :: TgaFile- -> (forall tgapx. (TGAPixel tgapx) => tgapx -> TgaFile -> Image (Unpacked tgapx))- -> Either String DynamicImage-prepareUnpacker file f =- let hdr = _tgaFileHeader file- flipper :: (Pixel px) => Image px -> Image px- flipper = flipImage $ _tgaHdrImageDescription hdr- in- case _tgaHdrPixelDepth hdr of- 8 -> pure . ImageY8 . flipper $ f Depth8 file- 16 -> pure . ImageRGBA8 . flipper $ f Depth15 file- 24 -> pure . ImageRGB8 . flipper $ f Depth24 file- 32 -> pure . ImageRGBA8 . flipper $ f Depth32 file- n -> fail $ "Invalid bit depth (" ++ show n ++ ")"--toPaletted :: (Pixel px)- => (Image Pixel8 -> Palette' px -> PalettedImage) -> Image px- -> DynamicImage- -> Either String PalettedImage-toPaletted f palette (ImageY8 img) = pure $ f img pal where- pal = Palette' - { _paletteSize = imageWidth palette- , _paletteData = imageData palette- }-toPaletted _ _ _ = fail "Bad colorspace for image"--unparse :: TgaFile -> Either String (PalettedImage, Metadatas)-unparse file =- let hdr = _tgaFileHeader file- imageType = _tgaHdrImageType hdr-- unpacker :: forall tgapx. (TGAPixel tgapx)- => tgapx -> TgaFile -> Image (Unpacked tgapx)- unpacker | isRleEncoded imageType = unpackRLETga- | otherwise = unpackUncompressedTga-- metas = basicMetadata SourceTGA (_tgaHdrWidth hdr) (_tgaHdrHeight hdr)- decodedPalette = unparse file- { _tgaFileHeader = hdr- { _tgaHdrHeight = 1- , _tgaHdrWidth = _tgaHdrMapLength hdr- , _tgaHdrPixelDepth = _tgaHdrMapDepth hdr- , _tgaHdrImageType = ImageTypeTrueColor False- }- , _tgaFileRest = _tgaPalette file- }- in- case imageType of- ImageTypeNoData _ -> fail "No data detected in TGA file"- ImageTypeTrueColor _ ->- fmap ((, metas) . TrueColorImage) $ prepareUnpacker file unpacker- ImageTypeMonochrome _ ->- fmap ((, metas) . TrueColorImage) $ prepareUnpacker file unpacker- ImageTypeColorMapped _ ->- case decodedPalette of- Left str -> Left str- Right (TrueColorImage (ImageY8 img), _) ->- fmap (, metas) $ prepareUnpacker file unpacker >>= toPaletted PalettedY8 img- Right (TrueColorImage (ImageRGB8 img), _) ->- fmap (, metas) $ prepareUnpacker file unpacker >>= toPaletted PalettedRGB8 img- Right (TrueColorImage (ImageRGBA8 img), _) ->- fmap (, metas) $ prepareUnpacker file unpacker >>= toPaletted PalettedRGBA8 img- Right _ -> fail "Unknown pixel type"--writeRun :: (Pixel px)- => M.STVector s (PixelBaseComponent px) -> Int -> px -> Int- -> ST s Int-writeRun imgData localMaxi px = run- where- writeDelta = componentCount px- run writeIndex - | writeIndex >= localMaxi = return writeIndex- run writeIndex = do- unsafeWritePixel imgData writeIndex px- run $ writeIndex + writeDelta--copyData :: forall tgapx s- . (TGAPixel tgapx)- => tgapx- -> M.STVector s (PixelBaseComponent (Unpacked tgapx))- -> B.ByteString- -> Int -> Int- -> Int -> Int- -> ST s (Int, Int)-copyData tgapx imgData readData maxi maxRead = go- where- readDelta = packedByteSize tgapx- writeDelta = componentCount (undefined :: Unpacked tgapx)-- go writeIndex readIndex- | writeIndex >= maxi ||- readIndex >= maxRead = return (writeIndex, readIndex)- go writeIndex readIndex = do- let px = tgaUnpack tgapx readData readIndex :: Unpacked tgapx- unsafeWritePixel imgData writeIndex px- go (writeIndex + writeDelta) (readIndex + readDelta)--unpackUncompressedTga :: forall tgapx- . (TGAPixel tgapx)- => tgapx -- ^ Type witness- -> TgaFile- -> Image (Unpacked tgapx)-unpackUncompressedTga tga file = runST $ do- img <- MutableImage width height <$> M.new maxi- let imgData = mutableImageData img- _ <- copyData tga imgData readData maxi maxRead 0 0- unsafeFreezeImage img-- where- hdr = _tgaFileHeader file- width = fromIntegral $ _tgaHdrWidth hdr- height = fromIntegral $ _tgaHdrHeight hdr- readData = _tgaFileRest file- compCount = componentCount (undefined :: Unpacked tgapx)- maxi = width * height * compCount- maxRead = B.length readData--isRleChunk :: Word8 -> Bool-isRleChunk v = testBit v 7--runLength :: Word8 -> Int-runLength v = fromIntegral (v .&. 0x7F) + 1--unpackRLETga :: forall tgapx- . (TGAPixel tgapx)- => tgapx -- ^ Type witness- -> TgaFile- -> Image (Unpacked tgapx)-unpackRLETga tga file = runST $ do- img <- MutableImage width height <$> M.new maxi- let imgData = mutableImageData img-- go writeIndex readIndex- | writeIndex >= maxi = return () - | readIndex >= maxRead = return ()- go writeIndex readIndex = do- let code = U.unsafeIndex readData readIndex- copyMax = min maxi $ writeIndex + runLength code * compCount- - if isRleChunk code then do- let px = tgaUnpack tga readData (readIndex + 1) :: Unpacked tgapx- lastWriteIndex <- writeRun imgData copyMax px writeIndex- go lastWriteIndex $ readIndex + 1 + readDelta-- else do- (newWrite, newRead) <-- copyData tga imgData readData copyMax maxRead- writeIndex (readIndex + 1)- go newWrite newRead-- go 0 0- unsafeFreezeImage img-- where- hdr = _tgaFileHeader file- width = fromIntegral $ _tgaHdrWidth hdr- height = fromIntegral $ _tgaHdrHeight hdr- readData = _tgaFileRest file- compCount = componentCount (undefined :: Unpacked tgapx)- maxi = width * height * compCount- maxRead = B.length readData- readDelta = packedByteSize tga--flipImage :: (Pixel px)- => TgaImageDescription -> Image px -> Image px-flipImage desc img- | xFlip && yFlip =- generateImage (\x y -> pixelAt img (wMax - x) (hMax - y)) w h- | xFlip =- generateImage (\x y -> pixelAt img (wMax - x) y) w h- | yFlip =- generateImage (\x y -> pixelAt img x (hMax - y)) w h- | otherwise = img- where- xFlip = _tgaIdXOrigin desc- yFlip = _tgaIdYOrigin desc- w = imageWidth img- h = imageHeight img-- !wMax = w - 1- !hMax = h - 1--validateTga :: (Monad m) => TgaHeader -> m ()-validateTga hdr- | _tgaHdrWidth hdr <= 0 = fail "Width is null or negative"- | _tgaHdrHeight hdr <= 0 = fail "Height is null or negative"-validateTga _ = return ()---- | Transform a raw tga image to an image, without modifying--- the underlying pixel type.------ This function can output the following images:------ * 'ImageY8'------ * 'ImageRGB8'------ * 'ImageRGBA8'----decodeTga :: B.ByteString -> Either String DynamicImage-decodeTga byte = fst <$> decodeTgaWithMetadata byte---- | Equivalent to decodeTga but also provide metadata-decodeTgaWithMetadata :: B.ByteString -> Either String (DynamicImage, Metadatas)-decodeTgaWithMetadata byte = first palettedToTrueColor <$> decodeTgaWithPaletteAndMetadata byte---- | Equivalent to decodeTga but with metdata and palette if any-decodeTgaWithPaletteAndMetadata :: B.ByteString -> Either String (PalettedImage, Metadatas)-decodeTgaWithPaletteAndMetadata byte = runGetStrict get byte >>= unparse---- | This typeclass determine if a pixel can be saved in the--- TGA format.-class TgaSaveable a where- tgaDataOfImage :: Image a -> B.ByteString- tgaPixelDepthOfImage :: Image a -> Word8- tgaTypeOfImage :: Image a -> TgaImageType--instance TgaSaveable Pixel8 where- tgaDataOfImage = toByteString . imageData- tgaPixelDepthOfImage _ = 8- tgaTypeOfImage _ = ImageTypeMonochrome False--instance TgaSaveable PixelRGB8 where- tgaPixelDepthOfImage _ = 24- tgaTypeOfImage _ = ImageTypeTrueColor False- tgaDataOfImage = toByteString . imageData . pixelMap flipRgb- where- flipRgb (PixelRGB8 r g b) = PixelRGB8 b g r--instance TgaSaveable PixelRGBA8 where- tgaPixelDepthOfImage _ = 32- tgaTypeOfImage _ = ImageTypeTrueColor False- tgaDataOfImage = toByteString . imageData . pixelMap flipRgba- where- flipRgba (PixelRGBA8 r g b a) = PixelRGBA8 b g r a---- | Helper function to directly write an image a tga on disk.-writeTga :: (TgaSaveable pixel) => FilePath -> Image pixel -> IO ()-writeTga path img = Lb.writeFile path $ encodeTga img---- | Transform a compatible image to a raw bytestring--- representing a Targa file.-encodeTga :: (TgaSaveable px) => Image px -> Lb.ByteString-encodeTga img = encode file- where- file = TgaFile- { _tgaFileHeader = TgaHeader- { _tgaHdrIdLength = 0- , _tgaHdrColorMapType = ColorMapWithoutTable- , _tgaHdrImageType = tgaTypeOfImage img- , _tgaHdrMapStart = 0- , _tgaHdrMapLength = 0- , _tgaHdrMapDepth = 0- , _tgaHdrXOffset = 0- , _tgaHdrYOffset = 0- , _tgaHdrWidth = fromIntegral $ imageWidth img- , _tgaHdrHeight = fromIntegral $ imageHeight img- , _tgaHdrPixelDepth = tgaPixelDepthOfImage img- , _tgaHdrImageDescription = TgaImageDescription- { _tgaIdXOrigin = False- , _tgaIdYOrigin = False- , _tgaIdAttributeBits = 0- }- }- , _tgaFileId = mempty- , _tgaPalette = mempty- , _tgaFileRest = tgaDataOfImage img- }--{-# ANN module "HLint: ignore Reduce duplication" #-}-+{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE CPP #-} +-- | Module implementing function to read and write +-- Targa (*.tga) files. +module Codec.Picture.Tga( decodeTga + , decodeTgaWithMetadata + , decodeTgaWithPaletteAndMetadata + , TgaSaveable + , encodeTga + , writeTga + ) where + +#if !MIN_VERSION_base(4,8,0) +import Data.Monoid( mempty ) +import Control.Applicative( (<*>), pure, (<$>) ) +#endif + +import Control.Arrow( first ) +import Control.Monad.ST( ST, runST ) +import Data.Bits( (.&.) + , (.|.) + , bit + , testBit + , setBit + , unsafeShiftL + , unsafeShiftR ) +import Data.Word( Word8, Word16 ) +import Data.Binary( Binary( .. ), encode ) +import Data.Binary.Get( Get + , getByteString + , getWord8 + , getWord16le + ) +import Data.Binary.Put( putWord8 + , putWord16le + , putByteString + ) + +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as Lb +import qualified Data.ByteString.Unsafe as U +import qualified Data.Vector.Storable.Mutable as M + +import Codec.Picture.Types +import Codec.Picture.InternalHelper +import Codec.Picture.Metadata( Metadatas + , SourceFormat( SourceTGA ) + , basicMetadata ) +import Codec.Picture.VectorByteConversion + +data TgaColorMapType + = ColorMapWithoutTable + | ColorMapWithTable + | ColorMapUnknown Word8 + +instance Binary TgaColorMapType where + get = do + v <- getWord8 + return $ case v of + 0 -> ColorMapWithoutTable + 1 -> ColorMapWithTable + n -> ColorMapUnknown n + + put v = case v of + ColorMapWithoutTable -> putWord8 0 + ColorMapWithTable -> putWord8 1 + (ColorMapUnknown vv) -> putWord8 vv + +data TgaImageType + = ImageTypeNoData Bool + | ImageTypeColorMapped Bool + | ImageTypeTrueColor Bool + | ImageTypeMonochrome Bool + +isRleEncoded :: TgaImageType -> Bool +isRleEncoded v = case v of + ImageTypeNoData yn -> yn + ImageTypeColorMapped yn -> yn + ImageTypeTrueColor yn -> yn + ImageTypeMonochrome yn -> yn + +imageTypeOfCode :: Word8 -> Get TgaImageType +imageTypeOfCode v = case v .&. 3 of + 0 -> return $ ImageTypeNoData isEncoded + 1 -> return $ ImageTypeColorMapped isEncoded + 2 -> return $ ImageTypeTrueColor isEncoded + 3 -> return $ ImageTypeMonochrome isEncoded + _ -> fail $ "Unknown TGA image type " ++ show v + where + isEncoded = testBit v 3 + +codeOfImageType :: TgaImageType -> Word8 +codeOfImageType v = case v of + ImageTypeNoData encoded -> setVal 0 encoded + ImageTypeColorMapped encoded -> setVal 1 encoded + ImageTypeTrueColor encoded -> setVal 2 encoded + ImageTypeMonochrome encoded -> setVal 3 encoded + where + setVal vv True = setBit vv 3 + setVal vv False = vv + +instance Binary TgaImageType where + get = getWord8 >>= imageTypeOfCode + put = putWord8 . codeOfImageType + +data TgaImageDescription = TgaImageDescription + { _tgaIdXOrigin :: Bool + , _tgaIdYOrigin :: Bool + , _tgaIdAttributeBits :: Word8 + } + +instance Binary TgaImageDescription where + put desc = putWord8 $ xOrig .|. yOrig .|. attr + where + xOrig | _tgaIdXOrigin desc = bit 4 + | otherwise = 0 + + yOrig | not $ _tgaIdYOrigin desc = bit 5 + | otherwise = 0 + + attr = _tgaIdAttributeBits desc .&. 0xF + + get = toDescr <$> getWord8 where + toDescr v = TgaImageDescription + { _tgaIdXOrigin = testBit v 4 + , _tgaIdYOrigin = not $ testBit v 5 + , _tgaIdAttributeBits = v .&. 0xF + } + +data TgaHeader = TgaHeader + { _tgaHdrIdLength :: {-# UNPACK #-} !Word8 + , _tgaHdrColorMapType :: !TgaColorMapType + , _tgaHdrImageType :: !TgaImageType + , _tgaHdrMapStart :: {-# UNPACK #-} !Word16 + , _tgaHdrMapLength :: {-# UNPACK #-} !Word16 + , _tgaHdrMapDepth :: {-# UNPACK #-} !Word8 + , _tgaHdrXOffset :: {-# UNPACK #-} !Word16 + , _tgaHdrYOffset :: {-# UNPACK #-} !Word16 + , _tgaHdrWidth :: {-# UNPACK #-} !Word16 + , _tgaHdrHeight :: {-# UNPACK #-} !Word16 + , _tgaHdrPixelDepth :: {-# UNPACK #-} !Word8 + , _tgaHdrImageDescription :: {-# UNPACK #-} !TgaImageDescription + } + +instance Binary TgaHeader where + get = TgaHeader + <$> g8 <*> get <*> get <*> g16 <*> g16 <*> g8 + <*> g16 <*> g16 <*> g16 <*> g16 <*> g8 <*> get + where g16 = getWord16le + g8 = getWord8 + + put v = do + let p8 = putWord8 + p16 = putWord16le + p8 $ _tgaHdrIdLength v + put $ _tgaHdrColorMapType v + put $ _tgaHdrImageType v + + p16 $ _tgaHdrMapStart v + p16 $ _tgaHdrMapLength v + p8 $ _tgaHdrMapDepth v + p16 $ _tgaHdrXOffset v + p16 $ _tgaHdrYOffset v + p16 $ _tgaHdrWidth v + p16 $ _tgaHdrHeight v + p8 $ _tgaHdrPixelDepth v + put $ _tgaHdrImageDescription v + + +data TgaFile = TgaFile + { _tgaFileHeader :: !TgaHeader + , _tgaFileId :: !B.ByteString + , _tgaPalette :: !B.ByteString + , _tgaFileRest :: !B.ByteString + } + +getPalette :: TgaHeader -> Get B.ByteString +getPalette hdr | _tgaHdrMapLength hdr <= 0 = return mempty +getPalette hdr = getByteString $ bytePerPixel * pixelCount + where + bytePerPixel = fromIntegral $ _tgaHdrMapDepth hdr `div` 8 + pixelCount = fromIntegral $ _tgaHdrMapLength hdr + +instance Binary TgaFile where + get = do + hdr <- get + validateTga hdr + fileId <- getByteString . fromIntegral $ _tgaHdrIdLength hdr + palette <- getPalette hdr + rest <- getRemainingBytes + + return TgaFile { + _tgaFileHeader = hdr + , _tgaFileId = fileId + , _tgaPalette = palette + , _tgaFileRest = rest + } + + put file = do + put $ _tgaFileHeader file + putByteString $ _tgaFileId file + putByteString $ _tgaPalette file + putByteString $ _tgaFileRest file + +data Depth8 = Depth8 +data Depth15 = Depth15 +data Depth24 = Depth24 +data Depth32 = Depth32 + +class (Pixel (Unpacked a)) => TGAPixel a where + type Unpacked a + packedByteSize :: a -> Int + tgaUnpack :: a -> B.ByteString -> Int -> Unpacked a + +instance TGAPixel Depth8 where + type Unpacked Depth8 = Pixel8 + packedByteSize _ = 1 + tgaUnpack _ = U.unsafeIndex + +instance TGAPixel Depth15 where + type Unpacked Depth15 = PixelRGBA8 + packedByteSize _ = 2 + tgaUnpack _ str ix = PixelRGBA8 r g b a + where + v0 = U.unsafeIndex str ix + v1 = U.unsafeIndex str $ ix + 1 + r = (v1 .&. 0x7c) `unsafeShiftL` 1; + g = ((v1 .&. 0x03) `unsafeShiftL` 6) .|. ((v0 .&. 0xe0) `unsafeShiftR` 2); + b = (v0 .&. 0x1f) `unsafeShiftL` 3 + a = 255 -- v1 .&. 0x80 + +instance TGAPixel Depth24 where + type Unpacked Depth24 = PixelRGB8 + packedByteSize _ = 3 + tgaUnpack _ str ix = PixelRGB8 r g b + where + b = U.unsafeIndex str ix + g = U.unsafeIndex str (ix + 1) + r = U.unsafeIndex str (ix + 2) + +instance TGAPixel Depth32 where + type Unpacked Depth32 = PixelRGBA8 + packedByteSize _ = 4 + tgaUnpack _ str ix = PixelRGBA8 r g b a + where + b = U.unsafeIndex str ix + g = U.unsafeIndex str (ix + 1) + r = U.unsafeIndex str (ix + 2) + a = U.unsafeIndex str (ix + 3) + +prepareUnpacker :: TgaFile + -> (forall tgapx. (TGAPixel tgapx) => tgapx -> TgaFile -> Image (Unpacked tgapx)) + -> Either String DynamicImage +prepareUnpacker file f = + let hdr = _tgaFileHeader file + flipper :: (Pixel px) => Image px -> Image px + flipper = flipImage $ _tgaHdrImageDescription hdr + in + case _tgaHdrPixelDepth hdr of + 8 -> pure . ImageY8 . flipper $ f Depth8 file + 16 -> pure . ImageRGBA8 . flipper $ f Depth15 file + 24 -> pure . ImageRGB8 . flipper $ f Depth24 file + 32 -> pure . ImageRGBA8 . flipper $ f Depth32 file + n -> Left $ "Invalid bit depth (" ++ show n ++ ")" + +toPaletted :: (Pixel px) + => (Image Pixel8 -> Palette' px -> PalettedImage) -> Image px + -> DynamicImage + -> Either String PalettedImage +toPaletted f palette (ImageY8 img) = pure $ f img pal where + pal = Palette' + { _paletteSize = imageWidth palette + , _paletteData = imageData palette + } +toPaletted _ _ _ = Left "Bad colorspace for image" + +unparse :: TgaFile -> Either String (PalettedImage, Metadatas) +unparse file = + let hdr = _tgaFileHeader file + imageType = _tgaHdrImageType hdr + + unpacker :: forall tgapx. (TGAPixel tgapx) + => tgapx -> TgaFile -> Image (Unpacked tgapx) + unpacker | isRleEncoded imageType = unpackRLETga + | otherwise = unpackUncompressedTga + + metas = basicMetadata SourceTGA (_tgaHdrWidth hdr) (_tgaHdrHeight hdr) + decodedPalette = unparse file + { _tgaFileHeader = hdr + { _tgaHdrHeight = 1 + , _tgaHdrWidth = _tgaHdrMapLength hdr + , _tgaHdrPixelDepth = _tgaHdrMapDepth hdr + , _tgaHdrImageType = ImageTypeTrueColor False + } + , _tgaFileRest = _tgaPalette file + } + in + case imageType of + ImageTypeNoData _ -> Left "No data detected in TGA file" + ImageTypeTrueColor _ -> + fmap ((, metas) . TrueColorImage) $ prepareUnpacker file unpacker + ImageTypeMonochrome _ -> + fmap ((, metas) . TrueColorImage) $ prepareUnpacker file unpacker + ImageTypeColorMapped _ -> + case decodedPalette of + Left str -> Left str + Right (TrueColorImage (ImageY8 img), _) -> + fmap (, metas) $ prepareUnpacker file unpacker >>= toPaletted PalettedY8 img + Right (TrueColorImage (ImageRGB8 img), _) -> + fmap (, metas) $ prepareUnpacker file unpacker >>= toPaletted PalettedRGB8 img + Right (TrueColorImage (ImageRGBA8 img), _) -> + fmap (, metas) $ prepareUnpacker file unpacker >>= toPaletted PalettedRGBA8 img + Right _ -> Left "Unknown pixel type" + +writeRun :: (Pixel px) + => M.STVector s (PixelBaseComponent px) -> Int -> px -> Int + -> ST s Int +writeRun imgData localMaxi px = run + where + writeDelta = componentCount px + run writeIndex + | writeIndex >= localMaxi = return writeIndex + run writeIndex = do + unsafeWritePixel imgData writeIndex px + run $ writeIndex + writeDelta + +copyData :: forall tgapx s + . (TGAPixel tgapx) + => tgapx + -> M.STVector s (PixelBaseComponent (Unpacked tgapx)) + -> B.ByteString + -> Int -> Int + -> Int -> Int + -> ST s (Int, Int) +copyData tgapx imgData readData maxi maxRead = go + where + readDelta = packedByteSize tgapx + writeDelta = componentCount (undefined :: Unpacked tgapx) + + go writeIndex readIndex + | writeIndex >= maxi || + readIndex >= maxRead = return (writeIndex, readIndex) + go writeIndex readIndex = do + let px = tgaUnpack tgapx readData readIndex :: Unpacked tgapx + unsafeWritePixel imgData writeIndex px + go (writeIndex + writeDelta) (readIndex + readDelta) + +unpackUncompressedTga :: forall tgapx + . (TGAPixel tgapx) + => tgapx -- ^ Type witness + -> TgaFile + -> Image (Unpacked tgapx) +unpackUncompressedTga tga file = runST $ do + img <- MutableImage width height <$> M.new maxi + let imgData = mutableImageData img + _ <- copyData tga imgData readData maxi maxRead 0 0 + unsafeFreezeImage img + + where + hdr = _tgaFileHeader file + width = fromIntegral $ _tgaHdrWidth hdr + height = fromIntegral $ _tgaHdrHeight hdr + readData = _tgaFileRest file + compCount = componentCount (undefined :: Unpacked tgapx) + maxi = width * height * compCount + maxRead = B.length readData + +isRleChunk :: Word8 -> Bool +isRleChunk v = testBit v 7 + +runLength :: Word8 -> Int +runLength v = fromIntegral (v .&. 0x7F) + 1 + +unpackRLETga :: forall tgapx + . (TGAPixel tgapx) + => tgapx -- ^ Type witness + -> TgaFile + -> Image (Unpacked tgapx) +unpackRLETga tga file = runST $ do + img <- MutableImage width height <$> M.new maxi + let imgData = mutableImageData img + + go writeIndex readIndex + | writeIndex >= maxi = return () + | readIndex >= maxRead = return () + go writeIndex readIndex = do + let code = U.unsafeIndex readData readIndex + copyMax = min maxi $ writeIndex + runLength code * compCount + + if isRleChunk code then do + let px = tgaUnpack tga readData (readIndex + 1) :: Unpacked tgapx + lastWriteIndex <- writeRun imgData copyMax px writeIndex + go lastWriteIndex $ readIndex + 1 + readDelta + + else do + (newWrite, newRead) <- + copyData tga imgData readData copyMax maxRead + writeIndex (readIndex + 1) + go newWrite newRead + + go 0 0 + unsafeFreezeImage img + + where + hdr = _tgaFileHeader file + width = fromIntegral $ _tgaHdrWidth hdr + height = fromIntegral $ _tgaHdrHeight hdr + readData = _tgaFileRest file + compCount = componentCount (undefined :: Unpacked tgapx) + maxi = width * height * compCount + maxRead = B.length readData + readDelta = packedByteSize tga + +flipImage :: (Pixel px) + => TgaImageDescription -> Image px -> Image px +flipImage desc img + | xFlip && yFlip = + generateImage (\x y -> pixelAt img (wMax - x) (hMax - y)) w h + | xFlip = + generateImage (\x y -> pixelAt img (wMax - x) y) w h + | yFlip = + generateImage (\x y -> pixelAt img x (hMax - y)) w h + | otherwise = img + where + xFlip = _tgaIdXOrigin desc + yFlip = _tgaIdYOrigin desc + w = imageWidth img + h = imageHeight img + + !wMax = w - 1 + !hMax = h - 1 + +validateTga :: TgaHeader -> Get () +validateTga hdr + | _tgaHdrWidth hdr <= 0 = fail "Width is null or negative" + | _tgaHdrHeight hdr <= 0 = fail "Height is null or negative" +validateTga _ = return () + +-- | Transform a raw tga image to an image, without modifying +-- the underlying pixel type. +-- +-- This function can output the following images: +-- +-- * 'ImageY8' +-- +-- * 'ImageRGB8' +-- +-- * 'ImageRGBA8' +-- +decodeTga :: B.ByteString -> Either String DynamicImage +decodeTga byte = fst <$> decodeTgaWithMetadata byte + +-- | Equivalent to decodeTga but also provide metadata +decodeTgaWithMetadata :: B.ByteString -> Either String (DynamicImage, Metadatas) +decodeTgaWithMetadata byte = first palettedToTrueColor <$> decodeTgaWithPaletteAndMetadata byte + +-- | Equivalent to decodeTga but with metdata and palette if any +decodeTgaWithPaletteAndMetadata :: B.ByteString -> Either String (PalettedImage, Metadatas) +decodeTgaWithPaletteAndMetadata byte = runGetStrict get byte >>= unparse + +-- | This typeclass determine if a pixel can be saved in the +-- TGA format. +class TgaSaveable a where + tgaDataOfImage :: Image a -> B.ByteString + tgaPixelDepthOfImage :: Image a -> Word8 + tgaTypeOfImage :: Image a -> TgaImageType + +instance TgaSaveable Pixel8 where + tgaDataOfImage = toByteString . imageData + tgaPixelDepthOfImage _ = 8 + tgaTypeOfImage _ = ImageTypeMonochrome False + +instance TgaSaveable PixelRGB8 where + tgaPixelDepthOfImage _ = 24 + tgaTypeOfImage _ = ImageTypeTrueColor False + tgaDataOfImage = toByteString . imageData . pixelMap flipRgb + where + flipRgb (PixelRGB8 r g b) = PixelRGB8 b g r + +instance TgaSaveable PixelRGBA8 where + tgaPixelDepthOfImage _ = 32 + tgaTypeOfImage _ = ImageTypeTrueColor False + tgaDataOfImage = toByteString . imageData . pixelMap flipRgba + where + flipRgba (PixelRGBA8 r g b a) = PixelRGBA8 b g r a + +-- | Helper function to directly write an image a tga on disk. +writeTga :: (TgaSaveable pixel) => FilePath -> Image pixel -> IO () +writeTga path img = Lb.writeFile path $ encodeTga img + +-- | Transform a compatible image to a raw bytestring +-- representing a Targa file. +encodeTga :: (TgaSaveable px) => Image px -> Lb.ByteString +encodeTga img = encode file + where + file = TgaFile + { _tgaFileHeader = TgaHeader + { _tgaHdrIdLength = 0 + , _tgaHdrColorMapType = ColorMapWithoutTable + , _tgaHdrImageType = tgaTypeOfImage img + , _tgaHdrMapStart = 0 + , _tgaHdrMapLength = 0 + , _tgaHdrMapDepth = 0 + , _tgaHdrXOffset = 0 + , _tgaHdrYOffset = 0 + , _tgaHdrWidth = fromIntegral $ imageWidth img + , _tgaHdrHeight = fromIntegral $ imageHeight img + , _tgaHdrPixelDepth = tgaPixelDepthOfImage img + , _tgaHdrImageDescription = TgaImageDescription + { _tgaIdXOrigin = False + , _tgaIdYOrigin = False + , _tgaIdAttributeBits = 0 + } + } + , _tgaFileId = mempty + , _tgaPalette = mempty + , _tgaFileRest = tgaDataOfImage img + } + +{-# ANN module "HLint: ignore Reduce duplication" #-} +
src/Codec/Picture/Tiff.hs view
@@ -1,890 +1,890 @@-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE CPP #-}--- | Module implementing TIFF decoding.------ Supported compression schemes:------ * Uncompressed------ * PackBits------ * LZW------ Supported bit depth:------ * 2 bits------ * 4 bits------ * 8 bits------ * 16 bits----module Codec.Picture.Tiff( decodeTiff- , decodeTiffWithMetadata- , decodeTiffWithPaletteAndMetadata- , TiffSaveable- , encodeTiff- , writeTiff- ) where--#if !MIN_VERSION_base(4,8,0)-import Control.Applicative( (<$>), (<*>), pure )-import Data.Monoid( mempty )-#endif--import Control.Arrow( first )-import Control.Monad( when, foldM_, unless, forM_ )-import Control.Monad.ST( ST, runST )-import Control.Monad.Writer.Strict( execWriter, tell, Writer )-import Data.Int( Int8 )-import Data.Word( Word8, Word16, Word32 )-import Data.Bits( (.&.), (.|.), unsafeShiftL, unsafeShiftR )-import Data.Binary.Get( Get )-import Data.Binary.Put( runPut )--import qualified Data.Vector as V-import qualified Data.Vector.Storable as VS-import qualified Data.Vector.Storable.Mutable as M-import qualified Data.ByteString as B-import qualified Data.ByteString.Lazy as Lb-import qualified Data.ByteString.Unsafe as BU--import Foreign.Storable( sizeOf )--import Codec.Picture.Metadata.Exif-import Codec.Picture.Metadata( Metadatas )-import Codec.Picture.InternalHelper-import Codec.Picture.BitWriter-import Codec.Picture.Types-import Codec.Picture.Gif.LZW-import Codec.Picture.Tiff.Types-import Codec.Picture.Tiff.Metadata-import Codec.Picture.VectorByteConversion( toByteString )--data TiffInfo = TiffInfo- { tiffHeader :: TiffHeader- , tiffWidth :: Word32- , tiffHeight :: Word32- , tiffColorspace :: TiffColorspace- , tiffSampleCount :: Word32- , tiffRowPerStrip :: Word32- , tiffPlaneConfiguration :: TiffPlanarConfiguration- , tiffSampleFormat :: [TiffSampleFormat]- , tiffBitsPerSample :: V.Vector Word32- , tiffCompression :: TiffCompression- , tiffStripSize :: V.Vector Word32- , tiffOffsets :: V.Vector Word32- , tiffPalette :: Maybe (Image PixelRGB16)- , tiffYCbCrSubsampling :: V.Vector Word32- , tiffExtraSample :: Maybe ExtraSample- , tiffPredictor :: Predictor- , tiffMetadatas :: Metadatas- }--unLong :: String -> ExifData -> Get (V.Vector Word32)-unLong _ (ExifShorts v) = pure $ V.map fromIntegral v-unLong _ (ExifLongs v) = pure v-unLong errMessage _ = fail errMessage--findIFD :: String -> ExifTag -> [ImageFileDirectory]- -> Get ImageFileDirectory-findIFD errorMessage tag lst =- case [v | v <- lst, ifdIdentifier v == tag] of- [] -> fail errorMessage- (x:_) -> pure x--findPalette :: [ImageFileDirectory] -> Get (Maybe (Image PixelRGB16))-findPalette ifds =- case [v | v <- ifds, ifdIdentifier v == TagColorMap] of- (ImageFileDirectory { ifdExtended = ExifShorts vec }:_) ->- pure . Just . Image pixelCount 1 $ VS.generate (V.length vec) axx- where pixelCount = V.length vec `div` 3- axx v = vec `V.unsafeIndex` (idx + color * pixelCount)- where (idx, color) = v `divMod` 3-- _ -> pure Nothing--findIFDData :: String -> ExifTag -> [ImageFileDirectory] -> Get Word32-findIFDData msg tag lst = ifdOffset <$> findIFD msg tag lst--findIFDDefaultData :: Word32 -> ExifTag -> [ImageFileDirectory] -> Get Word32-findIFDDefaultData d tag lst =- case [v | v <- lst, ifdIdentifier v == tag] of- [] -> pure d- (x:_) -> pure $ ifdOffset x--findIFDExt :: String -> ExifTag -> [ImageFileDirectory] -> Get ExifData-findIFDExt msg tag lst = do- val <- findIFD msg tag lst- case val of- ImageFileDirectory- { ifdCount = 1, ifdOffset = ofs, ifdType = TypeShort } ->- pure . ExifShorts . V.singleton $ fromIntegral ofs- ImageFileDirectory- { ifdCount = 1, ifdOffset = ofs, ifdType = TypeLong } ->- pure . ExifLongs . V.singleton $ fromIntegral ofs- ImageFileDirectory { ifdExtended = v } -> pure v---findIFDExtDefaultData :: [Word32] -> ExifTag -> [ImageFileDirectory]- -> Get [Word32]-findIFDExtDefaultData d tag lst =- case [v | v <- lst, ifdIdentifier v == tag] of- [] -> pure d- (ImageFileDirectory { ifdExtended = ExifNone }:_) -> return d- (x:_) -> V.toList <$> unLong errorMessage (ifdExtended x)- where errorMessage =- "Can't parse tag " ++ show tag ++ " " ++ show (ifdExtended x)---- It's temporary, remove once tiff decoding is better--- handled.-{- -instance Show (Image PixelRGB16) where- show _ = "Image PixelRGB16"--}-copyByteString :: B.ByteString -> M.STVector s Word8 -> Int -> Int -> (Word32, Word32)- -> ST s Int-copyByteString str vec stride startWrite (from, count) = inner startWrite fromi- where fromi = fromIntegral from- maxi = fromi + fromIntegral count-- inner writeIdx i | i >= maxi = pure writeIdx- inner writeIdx i = do- let v = str `BU.unsafeIndex` i- (vec `M.unsafeWrite` writeIdx) v- inner (writeIdx + stride) $ i + 1--unpackPackBit :: B.ByteString -> M.STVector s Word8 -> Int -> Int- -> (Word32, Word32)- -> ST s Int-unpackPackBit str outVec stride writeIndex (offset, size) = loop fromi writeIndex- where fromi = fromIntegral offset- maxi = fromi + fromIntegral size-- replicateByte writeIdx _ 0 = pure writeIdx- replicateByte writeIdx v count = do- (outVec `M.unsafeWrite` writeIdx) v- replicateByte (writeIdx + stride) v $ count - 1-- loop i writeIdx | i >= maxi = pure writeIdx- loop i writeIdx = choice- {-where v = fromIntegral (str `BU.unsafeIndex` i) :: Int8-}- where v = fromIntegral (str `B.index` i) :: Int8-- choice- -- data- | 0 <= v =- copyByteString str outVec stride writeIdx- (fromIntegral $ i + 1, fromIntegral v + 1)- >>= loop (i + 2 + fromIntegral v)- -- run- | -127 <= v = do- {-let nextByte = str `BU.unsafeIndex` (i + 1)-}- let nextByte = str `B.index` (i + 1)- count = negate (fromIntegral v) + 1 :: Int- replicateByte writeIdx nextByte count- >>= loop (i + 2)-- -- noop- | otherwise = loop writeIdx $ i + 1--uncompressAt :: TiffCompression- -> B.ByteString -> M.STVector s Word8 -> Int -> Int -> (Word32, Word32)- -> ST s Int-uncompressAt CompressionNone = copyByteString-uncompressAt CompressionPackBit = unpackPackBit-uncompressAt CompressionLZW = \str outVec _stride writeIndex (offset, size) -> do- let toDecode = B.take (fromIntegral size) $ B.drop (fromIntegral offset) str- runBoolReader $ decodeLzwTiff toDecode outVec writeIndex- return 0-uncompressAt _ = error "Unhandled compression"--class Unpackable a where- type StorageType a :: *-- outAlloc :: a -> Int -> ST s (M.STVector s (StorageType a))-- -- | Final image and size, return offset and vector- allocTempBuffer :: a -> M.STVector s (StorageType a) -> Int- -> ST s (M.STVector s Word8)-- offsetStride :: a -> Int -> Int -> (Int, Int)-- mergeBackTempBuffer :: a -- ^ Type witness, just for the type checker.- -> Endianness- -> M.STVector s Word8 -- ^ Temporary buffer handling decompression.- -> Int -- ^ Line size in pixels- -> Int -- ^ Write index, in bytes- -> Word32 -- ^ size, in bytes- -> Int -- ^ Stride- -> M.STVector s (StorageType a) -- ^ Final buffer- -> ST s ()---- | The Word8 instance is just a passthrough, to avoid--- copying memory twice-instance Unpackable Word8 where- type StorageType Word8 = Word8-- offsetStride _ i stride = (i, stride)- allocTempBuffer _ buff _ = pure buff- mergeBackTempBuffer _ _ _ _ _ _ _ _ = pure ()- outAlloc _ count = M.replicate count 0 -- M.new--instance Unpackable Word16 where- type StorageType Word16 = Word16-- offsetStride _ _ _ = (0, 1)- outAlloc _ = M.new- allocTempBuffer _ _ s = M.new $ s * 2- mergeBackTempBuffer _ EndianLittle tempVec _ index size stride outVec =- looperLe index 0- where looperLe _ readIndex | readIndex >= fromIntegral size = pure ()- looperLe writeIndex readIndex = do- v1 <- tempVec `M.read` readIndex- v2 <- tempVec `M.read` (readIndex + 1)- let finalValue =- (fromIntegral v2 `unsafeShiftL` 8) .|. fromIntegral v1- (outVec `M.write` writeIndex) finalValue-- looperLe (writeIndex + stride) (readIndex + 2)- mergeBackTempBuffer _ EndianBig tempVec _ index size stride outVec =- looperBe index 0- where looperBe _ readIndex | readIndex >= fromIntegral size = pure ()- looperBe writeIndex readIndex = do- v1 <- tempVec `M.read` readIndex- v2 <- tempVec `M.read` (readIndex + 1)- let finalValue =- (fromIntegral v1 `unsafeShiftL` 8) .|. fromIntegral v2- (outVec `M.write` writeIndex) finalValue-- looperBe (writeIndex + stride) (readIndex + 2)--instance Unpackable Word32 where- type StorageType Word32 = Word32-- offsetStride _ _ _ = (0, 1)- outAlloc _ = M.new- allocTempBuffer _ _ s = M.new $ s * 4- mergeBackTempBuffer _ EndianLittle tempVec _ index size stride outVec =- looperLe index 0- where looperLe _ readIndex | readIndex >= fromIntegral size = pure ()- looperLe writeIndex readIndex = do- v1 <- tempVec `M.read` readIndex- v2 <- tempVec `M.read` (readIndex + 1)- v3 <- tempVec `M.read` (readIndex + 2)- v4 <- tempVec `M.read` (readIndex + 3)- let finalValue =- (fromIntegral v4 `unsafeShiftL` 24) .|.- (fromIntegral v3 `unsafeShiftL` 16) .|.- (fromIntegral v2 `unsafeShiftL` 8) .|.- fromIntegral v1- (outVec `M.write` writeIndex) finalValue-- looperLe (writeIndex + stride) (readIndex + 4)- mergeBackTempBuffer _ EndianBig tempVec _ index size stride outVec =- looperBe index 0- where looperBe _ readIndex | readIndex >= fromIntegral size = pure ()- looperBe writeIndex readIndex = do- v1 <- tempVec `M.read` readIndex- v2 <- tempVec `M.read` (readIndex + 1)- v3 <- tempVec `M.read` (readIndex + 2)- v4 <- tempVec `M.read` (readIndex + 3)- let finalValue =- (fromIntegral v1 `unsafeShiftL` 24) .|.- (fromIntegral v2 `unsafeShiftL` 16) .|.- (fromIntegral v3 `unsafeShiftL` 8) .|.- fromIntegral v4- (outVec `M.write` writeIndex) finalValue-- looperBe (writeIndex + stride) (readIndex + 4)--data Pack4 = Pack4--instance Unpackable Pack4 where- type StorageType Pack4 = Word8- allocTempBuffer _ _ = M.new- offsetStride _ _ _ = (0, 1)- outAlloc _ = M.new- mergeBackTempBuffer _ _ tempVec lineSize index size stride outVec =- inner 0 index pxCount- where pxCount = lineSize `div` stride-- maxWrite = M.length outVec- inner readIdx writeIdx _- | readIdx >= fromIntegral size || writeIdx >= maxWrite = pure ()- inner readIdx writeIdx line- | line <= 0 = inner readIdx (writeIdx + line * stride) pxCount- inner readIdx writeIdx line = do- v <- tempVec `M.read` readIdx- let high = (v `unsafeShiftR` 4) .&. 0xF- low = v .&. 0xF- (outVec `M.write` writeIdx) high- when (writeIdx + stride < maxWrite) $- (outVec `M.write` (writeIdx + stride)) low-- inner (readIdx + 1) (writeIdx + 2 * stride) (line - 2)--data Pack2 = Pack2--instance Unpackable Pack2 where- type StorageType Pack2 = Word8- allocTempBuffer _ _ = M.new- offsetStride _ _ _ = (0, 1)- outAlloc _ = M.new- mergeBackTempBuffer _ _ tempVec lineSize index size stride outVec =- inner 0 index pxCount- where pxCount = lineSize `div` stride-- maxWrite = M.length outVec- inner readIdx writeIdx _- | readIdx >= fromIntegral size || writeIdx >= maxWrite = pure ()- inner readIdx writeIdx line- | line <= 0 = inner readIdx (writeIdx + line * stride) pxCount- inner readIdx writeIdx line = do- v <- tempVec `M.read` readIdx- let v0 = (v `unsafeShiftR` 6) .&. 0x3- v1 = (v `unsafeShiftR` 4) .&. 0x3- v2 = (v `unsafeShiftR` 2) .&. 0x3- v3 = v .&. 0x3-- (outVec `M.write` writeIdx) v0- when (writeIdx + 1 * stride < maxWrite) $- (outVec `M.write` (writeIdx + stride)) v1-- when (writeIdx + 2 * stride < maxWrite) $- (outVec `M.write` (writeIdx + stride * 2)) v2-- when (writeIdx + 3 * stride < maxWrite) $- (outVec `M.write` (writeIdx + stride * 3)) v3-- inner (readIdx + 1) (writeIdx + 4 * stride) (line - 4)--data Pack12 = Pack12--instance Unpackable Pack12 where- type StorageType Pack12 = Word16- allocTempBuffer _ _ = M.new- offsetStride _ _ _ = (0, 1)- outAlloc _ = M.new- mergeBackTempBuffer _ _ tempVec lineSize index size stride outVec =- inner 0 index pxCount- where pxCount = lineSize `div` stride-- maxWrite = M.length outVec- inner readIdx writeIdx _- | readIdx >= fromIntegral size || writeIdx >= maxWrite = pure ()- inner readIdx writeIdx line- | line <= 0 = inner readIdx (writeIdx + line * stride) pxCount- inner readIdx writeIdx line = do- v0 <- tempVec `M.read` readIdx- v1 <- if readIdx + 1 < fromIntegral size- then tempVec `M.read` (readIdx + 1)- else pure 0- v2 <- if readIdx + 2 < fromIntegral size- then tempVec `M.read` (readIdx + 2)- else pure 0-- let high0 = fromIntegral v0 `unsafeShiftL` 4- low0 = (fromIntegral v1 `unsafeShiftR` 4) .&. 0xF-- p0 = high0 .|. low0-- high1 = (fromIntegral v1 .&. 0xF) `unsafeShiftL` 8- low1 = fromIntegral v2- p1 = high1 .|. low1-- (outVec `M.write` writeIdx) p0- when (writeIdx + 1 * stride < maxWrite) $- (outVec `M.write` (writeIdx + stride)) p1-- inner (readIdx + 3) (writeIdx + 2 * stride) (line - 2)--data YCbCrSubsampling = YCbCrSubsampling- { ycbcrWidth :: !Int- , ycbcrHeight :: !Int- , ycbcrImageWidth :: !Int- , ycbcrStripHeight :: !Int- }--instance Unpackable YCbCrSubsampling where- type StorageType YCbCrSubsampling = Word8-- offsetStride _ _ _ = (0, 1)- outAlloc _ = M.new- allocTempBuffer _ _ = M.new- mergeBackTempBuffer subSampling _ tempVec _ index size _ outVec =- foldM_ unpacker 0 [(bx, by) | by <- [0, h .. lineCount - 1]- , bx <- [0, w .. imgWidth - 1]]- where w = ycbcrWidth subSampling- h = ycbcrHeight subSampling- imgWidth = ycbcrImageWidth subSampling- lineCount = ycbcrStripHeight subSampling-- lumaCount = w * h- blockSize = lumaCount + 2-- maxOut = M.length outVec-- unpacker readIdx _ | readIdx >= fromIntegral size * 3 = pure readIdx- unpacker readIdx (bx, by) = do- cb <- tempVec `M.read` (readIdx + lumaCount)- cr <- tempVec `M.read` (readIdx + lumaCount + 1)-- let pixelIndices =- [index + ((by + y) * imgWidth + bx + x) * 3 | y <- [0 .. h - 1], x <- [0 .. w - 1]]-- writer readIndex writeIdx | writeIdx + 3 > maxOut = pure readIndex- writer readIndex writeIdx = do- y <- tempVec `M.read` readIndex- (outVec `M.write` writeIdx) y- (outVec `M.write` (writeIdx + 1)) cb- (outVec `M.write` (writeIdx + 2)) cr- return $ readIndex + 1-- foldM_ writer readIdx pixelIndices-- return $ readIdx + blockSize--gatherStrips :: ( Unpackable comp- , Pixel pixel- , StorageType comp ~ PixelBaseComponent pixel- )- => comp -> B.ByteString -> TiffInfo -> Image pixel-gatherStrips comp str nfo = runST $ do- let width = fromIntegral $ tiffWidth nfo- height = fromIntegral $ tiffHeight nfo- sampleCount = if tiffSampleCount nfo /= 0- then fromIntegral $ tiffSampleCount nfo- else V.length $ tiffBitsPerSample nfo-- rowPerStrip = fromIntegral $ tiffRowPerStrip nfo- endianness = hdrEndianness $ tiffHeader nfo-- stripCount = V.length $ tiffOffsets nfo- compression = tiffCompression nfo-- outVec <- outAlloc comp $ width * height * sampleCount- tempVec <- allocTempBuffer comp outVec- (rowPerStrip * width * sampleCount)-- let mutableImage = MutableImage- { mutableImageWidth = fromIntegral width- , mutableImageHeight = fromIntegral height- , mutableImageData = outVec- }-- case tiffPlaneConfiguration nfo of- PlanarConfigContig -> V.mapM_ unpacker sizes- where unpacker (idx, stripSampleCount, offset, packedSize) = do- let (writeIdx, tempStride) = offsetStride comp idx 1- _ <- uncompressAt compression str tempVec tempStride- writeIdx (offset, packedSize)- let typ :: M.MVector s a -> a- typ = const undefined- sampleSize = sizeOf (typ outVec)- mergeBackTempBuffer comp endianness tempVec (width * sampleCount)- idx (fromIntegral $ stripSampleCount * sampleSize) 1 outVec--- fullStripSampleCount = rowPerStrip * width * sampleCount- startWriteOffset = V.generate stripCount (fullStripSampleCount *)- stripSampleCounts = V.map strip startWriteOffset- where- strip start = min fullStripSampleCount (width * height * sampleCount - start)-- sizes = V.zip4 startWriteOffset stripSampleCounts- (tiffOffsets nfo) (tiffStripSize nfo)-- PlanarConfigSeparate -> V.mapM_ unpacker sizes- where unpacker (idx, offset, size) = do- let (writeIdx, tempStride) = offsetStride comp idx stride- _ <- uncompressAt compression str tempVec tempStride- writeIdx (offset, size)- mergeBackTempBuffer comp endianness tempVec (width * sampleCount)- idx size stride outVec-- stride = V.length $ tiffOffsets nfo- idxVector = V.enumFromN 0 stride- sizes = V.zip3 idxVector (tiffOffsets nfo) (tiffStripSize nfo)-- when (tiffPredictor nfo == PredictorHorizontalDifferencing) $ do- let f _ c1 c2 = c1 + c2- forM_ [0 .. height - 1] $ \y ->- forM_ [1 .. width - 1] $ \x -> do- p <- readPixel mutableImage (x - 1) y- q <- readPixel mutableImage x y- writePixel mutableImage x y $ mixWith f p q-- unsafeFreezeImage mutableImage--ifdSingleLong :: ExifTag -> Word32 -> Writer [ImageFileDirectory] ()-ifdSingleLong tag = ifdMultiLong tag . V.singleton--ifdSingleShort :: Endianness -> ExifTag -> Word16- -> Writer [ImageFileDirectory] ()-ifdSingleShort endian tag = ifdMultiShort endian tag . V.singleton . fromIntegral--ifdMultiLong :: ExifTag -> V.Vector Word32 -> Writer [ImageFileDirectory] ()-ifdMultiLong tag v = tell . pure $ ImageFileDirectory- { ifdIdentifier = tag- , ifdType = TypeLong- , ifdCount = fromIntegral $ V.length v- , ifdOffset = offset- , ifdExtended = extended- }- where (offset, extended)- | V.length v > 1 = (0, ExifLongs v)- | otherwise = (V.head v, ExifNone)--ifdMultiShort :: Endianness -> ExifTag -> V.Vector Word32- -> Writer [ImageFileDirectory] ()-ifdMultiShort endian tag v = tell . pure $ ImageFileDirectory- { ifdIdentifier = tag- , ifdType = TypeShort- , ifdCount = size- , ifdOffset = offset- , ifdExtended = extended- }- where size = fromIntegral $ V.length v- (offset, extended)- | size > 2 = (0, ExifShorts $ V.map fromIntegral v)- | size == 2 =- let v1 = fromIntegral $ V.head v- v2 = fromIntegral $ v `V.unsafeIndex` 1- in- case endian of- EndianLittle -> (v2 `unsafeShiftL` 16 .|. v1, ExifNone)- EndianBig -> (v1 `unsafeShiftL` 16 .|. v2, ExifNone)-- | otherwise = case endian of- EndianLittle -> (V.head v, ExifNone)- EndianBig -> (V.head v `unsafeShiftL` 16, ExifNone)--instance BinaryParam B.ByteString TiffInfo where- putP rawData nfo = putP rawData (tiffHeader nfo, list) where- endianness = hdrEndianness $ tiffHeader nfo-- ifdShort = ifdSingleShort endianness- ifdShorts = ifdMultiShort endianness-- list = execWriter $ do- ifdSingleLong TagImageWidth $ tiffWidth nfo- ifdSingleLong TagImageLength $ tiffHeight nfo- ifdShorts TagBitsPerSample $ tiffBitsPerSample nfo- ifdSingleLong TagSamplesPerPixel $ tiffSampleCount nfo- ifdSingleLong TagRowPerStrip $ tiffRowPerStrip nfo- ifdShort TagPhotometricInterpretation- . packPhotometricInterpretation- $ tiffColorspace nfo- ifdShort TagPlanarConfiguration- . constantToPlaneConfiguration $ tiffPlaneConfiguration nfo- ifdShort TagCompression . packCompression- $ tiffCompression nfo- ifdMultiLong TagStripOffsets $ tiffOffsets nfo-- ifdMultiLong TagStripByteCounts $ tiffStripSize nfo-- maybe (return ())- (ifdShort TagExtraSample . codeOfExtraSample)- $ tiffExtraSample nfo-- let subSampling = tiffYCbCrSubsampling nfo- unless (V.null subSampling) $- ifdShorts TagYCbCrSubsampling subSampling-- getP rawData = do- (hdr, cleaned) <- getP rawData-- let dataFind str tag = findIFDData str tag cleaned- dataDefault def tag = findIFDDefaultData def tag cleaned- extFind str tag = findIFDExt str tag cleaned- extDefault def tag = findIFDExtDefaultData def tag cleaned-- TiffInfo hdr- <$> dataFind "Can't find width" TagImageWidth- <*> dataFind "Can't find height" TagImageLength- <*> (dataFind "Can't find color space" TagPhotometricInterpretation- >>= unpackPhotometricInterpretation)- <*> dataFind "Can't find sample per pixel" TagSamplesPerPixel- <*> dataFind "Can't find row per strip" TagRowPerStrip- <*> (dataDefault 1 TagPlanarConfiguration- >>= planarConfgOfConstant)- <*> (extDefault [1] TagSampleFormat- >>= mapM unpackSampleFormat)- <*> (extFind "Can't find bit per sample" TagBitsPerSample- >>= unLong "Can't find bit depth")- <*> (dataFind "Can't find Compression" TagCompression- >>= unPackCompression)- <*> (extFind "Can't find byte counts" TagStripByteCounts- >>= unLong "Can't find bit per sample")- <*> (extFind "Strip offsets missing" TagStripOffsets- >>= unLong "Can't find strip offsets")- <*> findPalette cleaned- <*> (V.fromList <$> extDefault [2, 2] TagYCbCrSubsampling)- <*> pure Nothing- <*> (dataDefault 1 TagPredictor- >>= predictorOfConstant)- <*> pure (extractTiffMetadata cleaned)--palette16Of :: Image PixelRGB16 -> Palette' PixelRGB16-palette16Of p = Palette'- { _paletteSize = imageWidth p- , _paletteData = imageData p- }--unpack :: B.ByteString -> TiffInfo -> Either String PalettedImage--- | while mandatory some images don't put correct--- rowperstrip. So replacing 0 with actual image height.-unpack file nfo@TiffInfo { tiffRowPerStrip = 0 } =- unpack file $ nfo { tiffRowPerStrip = tiffHeight nfo }-unpack file nfo@TiffInfo { tiffColorspace = TiffPaleted- , tiffBitsPerSample = lst- , tiffSampleFormat = format- , tiffPalette = Just p- }- | lst == V.singleton 8 && format == [TiffSampleUint] =- pure . PalettedRGB16 (gatherStrips (0 :: Word8) file nfo) $ palette16Of p- | lst == V.singleton 4 && format == [TiffSampleUint] =- pure . PalettedRGB16 (gatherStrips Pack4 file nfo) $ palette16Of p- | lst == V.singleton 2 && format == [TiffSampleUint] =- pure . PalettedRGB16 (gatherStrips Pack2 file nfo) $ palette16Of p--unpack file nfo@TiffInfo { tiffColorspace = TiffCMYK- , tiffBitsPerSample = lst- , tiffSampleFormat = format }- | lst == V.fromList [8, 8, 8, 8] && all (TiffSampleUint ==) format =- pure . TrueColorImage . ImageCMYK8 $ gatherStrips (0 :: Word8) file nfo-- | lst == V.fromList [16, 16, 16, 16] && all (TiffSampleUint ==) format =- pure . TrueColorImage . ImageCMYK16 $ gatherStrips (0 :: Word16) file nfo--unpack file nfo@TiffInfo { tiffColorspace = TiffMonochromeWhite0 } = do- img <- unpack file (nfo { tiffColorspace = TiffMonochrome })- case img of- TrueColorImage (ImageY8 i) -> pure . TrueColorImage . ImageY8 $ pixelMap (maxBound -) i- TrueColorImage (ImageY16 i) -> pure . TrueColorImage . ImageY16 $ pixelMap (maxBound -) i- TrueColorImage (ImageYA8 i) -> let negative (PixelYA8 y a) = PixelYA8 (maxBound - y) a- in pure . TrueColorImage . ImageYA8 $ pixelMap negative i- TrueColorImage (ImageYA16 i) -> let negative (PixelYA16 y a) = PixelYA16 (maxBound - y) a- in pure . TrueColorImage . ImageYA16 $ pixelMap negative i- _ -> fail "Unsupported color type used with colorspace MonochromeWhite0"--unpack file nfo@TiffInfo { tiffColorspace = TiffMonochrome- , tiffBitsPerSample = lst- , tiffSampleFormat = format }- | lst == V.singleton 2 && all (TiffSampleUint ==) format =- pure . TrueColorImage . ImageY8 . pixelMap (colorMap (0x55 *)) $ gatherStrips Pack2 file nfo- | lst == V.singleton 4 && all (TiffSampleUint ==) format =- pure . TrueColorImage . ImageY8 . pixelMap (colorMap (0x11 *)) $ gatherStrips Pack4 file nfo- | lst == V.singleton 8 && all (TiffSampleUint ==) format =- pure . TrueColorImage . ImageY8 $ gatherStrips (0 :: Word8) file nfo- | lst == V.singleton 12 && all (TiffSampleUint ==) format =- pure . TrueColorImage . ImageY16 . pixelMap (colorMap expand12to16) $ gatherStrips Pack12 file nfo- | lst == V.singleton 16 && all (TiffSampleUint ==) format =- pure . TrueColorImage . ImageY16 $ gatherStrips (0 :: Word16) file nfo- | lst == V.singleton 32 && all (TiffSampleUint ==) format =- let toWord16 v = fromIntegral $ v `unsafeShiftR` 16- img = gatherStrips (0 :: Word32) file nfo :: Image Pixel32- in- pure . TrueColorImage . ImageY16 $ pixelMap toWord16 img- | lst == V.fromList [2, 2] && all (TiffSampleUint ==) format =- pure . TrueColorImage . ImageYA8 . pixelMap (colorMap (0x55 *)) $ gatherStrips Pack2 file nfo- | lst == V.fromList [4, 4] && all (TiffSampleUint ==) format =- pure . TrueColorImage . ImageYA8 . pixelMap (colorMap (0x11 *)) $ gatherStrips Pack4 file nfo- | lst == V.fromList [8, 8] && all (TiffSampleUint ==) format =- pure . TrueColorImage . ImageYA8 $ gatherStrips (0 :: Word8) file nfo- | lst == V.fromList [12, 12] && all (TiffSampleUint ==) format =- pure . TrueColorImage . ImageYA16 . pixelMap (colorMap expand12to16) $ gatherStrips Pack12 file nfo- | lst == V.fromList [16, 16] && all (TiffSampleUint ==) format =- pure . TrueColorImage . ImageYA16 $ gatherStrips (0 :: Word16) file nfo- where- expand12to16 x = x `unsafeShiftL` 4 + x `unsafeShiftR` (12 - 4)--unpack file nfo@TiffInfo { tiffColorspace = TiffYCbCr- , tiffBitsPerSample = lst- , tiffPlaneConfiguration = PlanarConfigContig- , tiffSampleFormat = format }- | lst == V.fromList [8, 8, 8] && all (TiffSampleUint ==) format =- pure . TrueColorImage . ImageYCbCr8 $ gatherStrips cbcrConf file nfo- where defaulting 0 = 2- defaulting n = n-- w = defaulting $ tiffYCbCrSubsampling nfo V.! 0- h = defaulting $ tiffYCbCrSubsampling nfo V.! 1- cbcrConf = YCbCrSubsampling- { ycbcrWidth = fromIntegral w- , ycbcrHeight = fromIntegral h- , ycbcrImageWidth = fromIntegral $ tiffWidth nfo- , ycbcrStripHeight = fromIntegral $ tiffRowPerStrip nfo- }--unpack file nfo@TiffInfo { tiffColorspace = TiffRGB- , tiffBitsPerSample = lst- , tiffSampleFormat = format }- | lst == V.fromList [2, 2, 2] && all (TiffSampleUint ==) format =- pure . TrueColorImage . ImageRGB8 . pixelMap (colorMap (0x55 *)) $ gatherStrips Pack2 file nfo- | lst == V.fromList [4, 4, 4] && all (TiffSampleUint ==) format =- pure . TrueColorImage . ImageRGB8 . pixelMap (colorMap (0x11 *)) $ gatherStrips Pack4 file nfo- | lst == V.fromList [8, 8, 8] && all (TiffSampleUint ==) format =- pure . TrueColorImage . ImageRGB8 $ gatherStrips (0 :: Word8) file nfo- | lst == V.fromList [8, 8, 8, 8] && all (TiffSampleUint ==) format =- pure . TrueColorImage . ImageRGBA8 $ gatherStrips (0 :: Word8) file nfo- | lst == V.fromList [16, 16, 16] && all (TiffSampleUint ==) format =- pure . TrueColorImage . ImageRGB16 $ gatherStrips (0 :: Word16) file nfo- | lst == V.fromList [16, 16, 16, 16] && all (TiffSampleUint ==) format =- pure . TrueColorImage . ImageRGBA16 $ gatherStrips (0 :: Word16) file nfo-unpack file nfo@TiffInfo { tiffColorspace = TiffMonochrome- , tiffBitsPerSample = lst- , tiffSampleFormat = format }- -- some files are a little bit borked...- | lst == V.fromList [8, 8, 8] && all (TiffSampleUint ==) format =- pure . TrueColorImage . ImageRGB8 $ gatherStrips (0 :: Word8) file nfo--unpack _ _ = fail "Failure to unpack TIFF file"---- | Decode a tiff encoded image while preserving the underlying--- pixel type (except for Y32 which is truncated to 16 bits).------ This function can output the following images:------ * 'ImageY8'------ * 'ImageY16'------ * 'ImageYA8'------ * 'ImageYA16'------ * 'ImageRGB8'------ * 'ImageRGB16'------ * 'ImageRGBA8'------ * 'ImageRGBA16'------ * 'ImageCMYK8'------ * 'ImageCMYK16'----decodeTiff :: B.ByteString -> Either String DynamicImage-decodeTiff = fmap fst . decodeTiffWithMetadata ---- | Like 'decodeTiff' but also provides some metdata present--- in the Tiff file.------ The metadata extracted are the 'Codec.Picture.Metadata.DpiX' &--- 'Codec.Picture.Metadata.DpiY' information alongside the EXIF informations.-decodeTiffWithMetadata :: B.ByteString -> Either String (DynamicImage, Metadatas)-decodeTiffWithMetadata str = first palettedToTrueColor <$> decodeTiffWithPaletteAndMetadata str---- | Decode TIFF and provide separated palette and metadata-decodeTiffWithPaletteAndMetadata :: B.ByteString -> Either String (PalettedImage, Metadatas)-decodeTiffWithPaletteAndMetadata file = runGetStrict (getP file) file >>= go- where- go tinfo = (, tiffMetadatas tinfo) <$> unpack file tinfo- ---- | Class defining which pixel types can be serialized in a--- Tiff file.-class (Pixel px) => TiffSaveable px where- colorSpaceOfPixel :: px -> TiffColorspace-- extraSampleCodeOfPixel :: px -> Maybe ExtraSample- extraSampleCodeOfPixel _ = Nothing-- subSamplingInfo :: px -> V.Vector Word32- subSamplingInfo _ = V.empty--instance TiffSaveable Pixel8 where- colorSpaceOfPixel _ = TiffMonochrome--instance TiffSaveable Pixel16 where- colorSpaceOfPixel _ = TiffMonochrome--instance TiffSaveable PixelYA8 where- colorSpaceOfPixel _ = TiffMonochrome- extraSampleCodeOfPixel _ = Just ExtraSampleUnassociatedAlpha--instance TiffSaveable PixelYA16 where- colorSpaceOfPixel _ = TiffMonochrome- extraSampleCodeOfPixel _ = Just ExtraSampleUnassociatedAlpha--instance TiffSaveable PixelCMYK8 where- colorSpaceOfPixel _ = TiffCMYK--instance TiffSaveable PixelCMYK16 where- colorSpaceOfPixel _ = TiffCMYK--instance TiffSaveable PixelRGB8 where- colorSpaceOfPixel _ = TiffRGB--instance TiffSaveable PixelRGB16 where- colorSpaceOfPixel _ = TiffRGB--instance TiffSaveable PixelRGBA8 where- colorSpaceOfPixel _ = TiffRGB- extraSampleCodeOfPixel _ = Just ExtraSampleUnassociatedAlpha--instance TiffSaveable PixelRGBA16 where- colorSpaceOfPixel _ = TiffRGB- extraSampleCodeOfPixel _ = Just ExtraSampleUnassociatedAlpha--instance TiffSaveable PixelYCbCr8 where- colorSpaceOfPixel _ = TiffYCbCr- subSamplingInfo _ = V.fromListN 2 [1, 1]---- | Transform an image into a Tiff encoded bytestring, ready to be--- written as a file.-encodeTiff :: forall px. (TiffSaveable px) => Image px -> Lb.ByteString-encodeTiff img = runPut $ putP rawPixelData hdr- where intSampleCount = componentCount (undefined :: px)- sampleCount = fromIntegral intSampleCount-- sampleType = undefined :: PixelBaseComponent px- pixelData = imageData img-- rawPixelData = toByteString pixelData- width = fromIntegral $ imageWidth img- height = fromIntegral $ imageHeight img- intSampleSize = sizeOf sampleType- sampleSize = fromIntegral intSampleSize- bitPerSample = sampleSize * 8- imageSize = width * height * sampleCount * sampleSize- headerSize = 8-- hdr = TiffInfo- { tiffHeader = TiffHeader- { hdrEndianness = EndianLittle- , hdrOffset = headerSize + imageSize- }- , tiffWidth = width- , tiffHeight = height- , tiffColorspace = colorSpaceOfPixel (undefined :: px)- , tiffSampleCount = fromIntegral sampleCount- , tiffRowPerStrip = fromIntegral $ imageHeight img- , tiffPlaneConfiguration = PlanarConfigContig- , tiffSampleFormat = [TiffSampleUint]- , tiffBitsPerSample = V.replicate intSampleCount bitPerSample- , tiffCompression = CompressionNone- , tiffStripSize = V.singleton imageSize- , tiffOffsets = V.singleton headerSize- , tiffPalette = Nothing- , tiffYCbCrSubsampling = subSamplingInfo (undefined :: px)- , tiffExtraSample = extraSampleCodeOfPixel (undefined :: px)- , tiffPredictor = PredictorNone -- not used when writing- , tiffMetadatas = mempty- }---- | Helper function to directly write an image as a tiff on disk.-writeTiff :: (TiffSaveable pixel) => FilePath -> Image pixel -> IO ()-writeTiff path img = Lb.writeFile path $ encodeTiff img--{-# ANN module "HLint: ignore Reduce duplication" #-}-+{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE CPP #-} +-- | Module implementing TIFF decoding. +-- +-- Supported compression schemes: +-- +-- * Uncompressed +-- +-- * PackBits +-- +-- * LZW +-- +-- Supported bit depth: +-- +-- * 2 bits +-- +-- * 4 bits +-- +-- * 8 bits +-- +-- * 16 bits +-- +module Codec.Picture.Tiff( decodeTiff + , decodeTiffWithMetadata + , decodeTiffWithPaletteAndMetadata + , TiffSaveable + , encodeTiff + , writeTiff + ) where + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative( (<$>), (<*>), pure ) +import Data.Monoid( mempty ) +#endif + +import Control.Arrow( first ) +import Control.Monad( when, foldM_, unless, forM_ ) +import Control.Monad.ST( ST, runST ) +import Control.Monad.Writer.Strict( execWriter, tell, Writer ) +import Data.Int( Int8 ) +import Data.Word( Word8, Word16, Word32 ) +import Data.Bits( (.&.), (.|.), unsafeShiftL, unsafeShiftR ) +import Data.Binary.Get( Get ) +import Data.Binary.Put( runPut ) + +import qualified Data.Vector as V +import qualified Data.Vector.Storable as VS +import qualified Data.Vector.Storable.Mutable as M +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as Lb +import qualified Data.ByteString.Unsafe as BU + +import Foreign.Storable( sizeOf ) + +import Codec.Picture.Metadata.Exif +import Codec.Picture.Metadata( Metadatas ) +import Codec.Picture.InternalHelper +import Codec.Picture.BitWriter +import Codec.Picture.Types +import Codec.Picture.Gif.LZW +import Codec.Picture.Tiff.Types +import Codec.Picture.Tiff.Metadata +import Codec.Picture.VectorByteConversion( toByteString ) + +data TiffInfo = TiffInfo + { tiffHeader :: TiffHeader + , tiffWidth :: Word32 + , tiffHeight :: Word32 + , tiffColorspace :: TiffColorspace + , tiffSampleCount :: Word32 + , tiffRowPerStrip :: Word32 + , tiffPlaneConfiguration :: TiffPlanarConfiguration + , tiffSampleFormat :: [TiffSampleFormat] + , tiffBitsPerSample :: V.Vector Word32 + , tiffCompression :: TiffCompression + , tiffStripSize :: V.Vector Word32 + , tiffOffsets :: V.Vector Word32 + , tiffPalette :: Maybe (Image PixelRGB16) + , tiffYCbCrSubsampling :: V.Vector Word32 + , tiffExtraSample :: Maybe ExtraSample + , tiffPredictor :: Predictor + , tiffMetadatas :: Metadatas + } + +unLong :: String -> ExifData -> Get (V.Vector Word32) +unLong _ (ExifShorts v) = pure $ V.map fromIntegral v +unLong _ (ExifLongs v) = pure v +unLong errMessage _ = fail errMessage + +findIFD :: String -> ExifTag -> [ImageFileDirectory] + -> Get ImageFileDirectory +findIFD errorMessage tag lst = + case [v | v <- lst, ifdIdentifier v == tag] of + [] -> fail errorMessage + (x:_) -> pure x + +findPalette :: [ImageFileDirectory] -> Get (Maybe (Image PixelRGB16)) +findPalette ifds = + case [v | v <- ifds, ifdIdentifier v == TagColorMap] of + (ImageFileDirectory { ifdExtended = ExifShorts vec }:_) -> + pure . Just . Image pixelCount 1 $ VS.generate (V.length vec) axx + where pixelCount = V.length vec `div` 3 + axx v = vec `V.unsafeIndex` (idx + color * pixelCount) + where (idx, color) = v `divMod` 3 + + _ -> pure Nothing + +findIFDData :: String -> ExifTag -> [ImageFileDirectory] -> Get Word32 +findIFDData msg tag lst = ifdOffset <$> findIFD msg tag lst + +findIFDDefaultData :: Word32 -> ExifTag -> [ImageFileDirectory] -> Get Word32 +findIFDDefaultData d tag lst = + case [v | v <- lst, ifdIdentifier v == tag] of + [] -> pure d + (x:_) -> pure $ ifdOffset x + +findIFDExt :: String -> ExifTag -> [ImageFileDirectory] -> Get ExifData +findIFDExt msg tag lst = do + val <- findIFD msg tag lst + case val of + ImageFileDirectory + { ifdCount = 1, ifdOffset = ofs, ifdType = TypeShort } -> + pure . ExifShorts . V.singleton $ fromIntegral ofs + ImageFileDirectory + { ifdCount = 1, ifdOffset = ofs, ifdType = TypeLong } -> + pure . ExifLongs . V.singleton $ fromIntegral ofs + ImageFileDirectory { ifdExtended = v } -> pure v + + +findIFDExtDefaultData :: [Word32] -> ExifTag -> [ImageFileDirectory] + -> Get [Word32] +findIFDExtDefaultData d tag lst = + case [v | v <- lst, ifdIdentifier v == tag] of + [] -> pure d + (ImageFileDirectory { ifdExtended = ExifNone }:_) -> return d + (x:_) -> V.toList <$> unLong errorMessage (ifdExtended x) + where errorMessage = + "Can't parse tag " ++ show tag ++ " " ++ show (ifdExtended x) + +-- It's temporary, remove once tiff decoding is better +-- handled. +{- +instance Show (Image PixelRGB16) where + show _ = "Image PixelRGB16" +-} +copyByteString :: B.ByteString -> M.STVector s Word8 -> Int -> Int -> (Word32, Word32) + -> ST s Int +copyByteString str vec stride startWrite (from, count) = inner startWrite fromi + where fromi = fromIntegral from + maxi = fromi + fromIntegral count + + inner writeIdx i | i >= maxi = pure writeIdx + inner writeIdx i = do + let v = str `BU.unsafeIndex` i + (vec `M.unsafeWrite` writeIdx) v + inner (writeIdx + stride) $ i + 1 + +unpackPackBit :: B.ByteString -> M.STVector s Word8 -> Int -> Int + -> (Word32, Word32) + -> ST s Int +unpackPackBit str outVec stride writeIndex (offset, size) = loop fromi writeIndex + where fromi = fromIntegral offset + maxi = fromi + fromIntegral size + + replicateByte writeIdx _ 0 = pure writeIdx + replicateByte writeIdx v count = do + (outVec `M.unsafeWrite` writeIdx) v + replicateByte (writeIdx + stride) v $ count - 1 + + loop i writeIdx | i >= maxi = pure writeIdx + loop i writeIdx = choice + {-where v = fromIntegral (str `BU.unsafeIndex` i) :: Int8-} + where v = fromIntegral (str `B.index` i) :: Int8 + + choice + -- data + | 0 <= v = + copyByteString str outVec stride writeIdx + (fromIntegral $ i + 1, fromIntegral v + 1) + >>= loop (i + 2 + fromIntegral v) + -- run + | -127 <= v = do + {-let nextByte = str `BU.unsafeIndex` (i + 1)-} + let nextByte = str `B.index` (i + 1) + count = negate (fromIntegral v) + 1 :: Int + replicateByte writeIdx nextByte count + >>= loop (i + 2) + + -- noop + | otherwise = loop writeIdx $ i + 1 + +uncompressAt :: TiffCompression + -> B.ByteString -> M.STVector s Word8 -> Int -> Int -> (Word32, Word32) + -> ST s Int +uncompressAt CompressionNone = copyByteString +uncompressAt CompressionPackBit = unpackPackBit +uncompressAt CompressionLZW = \str outVec _stride writeIndex (offset, size) -> do + let toDecode = B.take (fromIntegral size) $ B.drop (fromIntegral offset) str + runBoolReader $ decodeLzwTiff toDecode outVec writeIndex + return 0 +uncompressAt _ = error "Unhandled compression" + +class Unpackable a where + type StorageType a :: * + + outAlloc :: a -> Int -> ST s (M.STVector s (StorageType a)) + + -- | Final image and size, return offset and vector + allocTempBuffer :: a -> M.STVector s (StorageType a) -> Int + -> ST s (M.STVector s Word8) + + offsetStride :: a -> Int -> Int -> (Int, Int) + + mergeBackTempBuffer :: a -- ^ Type witness, just for the type checker. + -> Endianness + -> M.STVector s Word8 -- ^ Temporary buffer handling decompression. + -> Int -- ^ Line size in pixels + -> Int -- ^ Write index, in bytes + -> Word32 -- ^ size, in bytes + -> Int -- ^ Stride + -> M.STVector s (StorageType a) -- ^ Final buffer + -> ST s () + +-- | The Word8 instance is just a passthrough, to avoid +-- copying memory twice +instance Unpackable Word8 where + type StorageType Word8 = Word8 + + offsetStride _ i stride = (i, stride) + allocTempBuffer _ buff _ = pure buff + mergeBackTempBuffer _ _ _ _ _ _ _ _ = pure () + outAlloc _ count = M.replicate count 0 -- M.new + +instance Unpackable Word16 where + type StorageType Word16 = Word16 + + offsetStride _ _ _ = (0, 1) + outAlloc _ = M.new + allocTempBuffer _ _ s = M.new $ s * 2 + mergeBackTempBuffer _ EndianLittle tempVec _ index size stride outVec = + looperLe index 0 + where looperLe _ readIndex | readIndex >= fromIntegral size = pure () + looperLe writeIndex readIndex = do + v1 <- tempVec `M.read` readIndex + v2 <- tempVec `M.read` (readIndex + 1) + let finalValue = + (fromIntegral v2 `unsafeShiftL` 8) .|. fromIntegral v1 + (outVec `M.write` writeIndex) finalValue + + looperLe (writeIndex + stride) (readIndex + 2) + mergeBackTempBuffer _ EndianBig tempVec _ index size stride outVec = + looperBe index 0 + where looperBe _ readIndex | readIndex >= fromIntegral size = pure () + looperBe writeIndex readIndex = do + v1 <- tempVec `M.read` readIndex + v2 <- tempVec `M.read` (readIndex + 1) + let finalValue = + (fromIntegral v1 `unsafeShiftL` 8) .|. fromIntegral v2 + (outVec `M.write` writeIndex) finalValue + + looperBe (writeIndex + stride) (readIndex + 2) + +instance Unpackable Word32 where + type StorageType Word32 = Word32 + + offsetStride _ _ _ = (0, 1) + outAlloc _ = M.new + allocTempBuffer _ _ s = M.new $ s * 4 + mergeBackTempBuffer _ EndianLittle tempVec _ index size stride outVec = + looperLe index 0 + where looperLe _ readIndex | readIndex >= fromIntegral size = pure () + looperLe writeIndex readIndex = do + v1 <- tempVec `M.read` readIndex + v2 <- tempVec `M.read` (readIndex + 1) + v3 <- tempVec `M.read` (readIndex + 2) + v4 <- tempVec `M.read` (readIndex + 3) + let finalValue = + (fromIntegral v4 `unsafeShiftL` 24) .|. + (fromIntegral v3 `unsafeShiftL` 16) .|. + (fromIntegral v2 `unsafeShiftL` 8) .|. + fromIntegral v1 + (outVec `M.write` writeIndex) finalValue + + looperLe (writeIndex + stride) (readIndex + 4) + mergeBackTempBuffer _ EndianBig tempVec _ index size stride outVec = + looperBe index 0 + where looperBe _ readIndex | readIndex >= fromIntegral size = pure () + looperBe writeIndex readIndex = do + v1 <- tempVec `M.read` readIndex + v2 <- tempVec `M.read` (readIndex + 1) + v3 <- tempVec `M.read` (readIndex + 2) + v4 <- tempVec `M.read` (readIndex + 3) + let finalValue = + (fromIntegral v1 `unsafeShiftL` 24) .|. + (fromIntegral v2 `unsafeShiftL` 16) .|. + (fromIntegral v3 `unsafeShiftL` 8) .|. + fromIntegral v4 + (outVec `M.write` writeIndex) finalValue + + looperBe (writeIndex + stride) (readIndex + 4) + +data Pack4 = Pack4 + +instance Unpackable Pack4 where + type StorageType Pack4 = Word8 + allocTempBuffer _ _ = M.new + offsetStride _ _ _ = (0, 1) + outAlloc _ = M.new + mergeBackTempBuffer _ _ tempVec lineSize index size stride outVec = + inner 0 index pxCount + where pxCount = lineSize `div` stride + + maxWrite = M.length outVec + inner readIdx writeIdx _ + | readIdx >= fromIntegral size || writeIdx >= maxWrite = pure () + inner readIdx writeIdx line + | line <= 0 = inner readIdx (writeIdx + line * stride) pxCount + inner readIdx writeIdx line = do + v <- tempVec `M.read` readIdx + let high = (v `unsafeShiftR` 4) .&. 0xF + low = v .&. 0xF + (outVec `M.write` writeIdx) high + when (writeIdx + stride < maxWrite) $ + (outVec `M.write` (writeIdx + stride)) low + + inner (readIdx + 1) (writeIdx + 2 * stride) (line - 2) + +data Pack2 = Pack2 + +instance Unpackable Pack2 where + type StorageType Pack2 = Word8 + allocTempBuffer _ _ = M.new + offsetStride _ _ _ = (0, 1) + outAlloc _ = M.new + mergeBackTempBuffer _ _ tempVec lineSize index size stride outVec = + inner 0 index pxCount + where pxCount = lineSize `div` stride + + maxWrite = M.length outVec + inner readIdx writeIdx _ + | readIdx >= fromIntegral size || writeIdx >= maxWrite = pure () + inner readIdx writeIdx line + | line <= 0 = inner readIdx (writeIdx + line * stride) pxCount + inner readIdx writeIdx line = do + v <- tempVec `M.read` readIdx + let v0 = (v `unsafeShiftR` 6) .&. 0x3 + v1 = (v `unsafeShiftR` 4) .&. 0x3 + v2 = (v `unsafeShiftR` 2) .&. 0x3 + v3 = v .&. 0x3 + + (outVec `M.write` writeIdx) v0 + when (writeIdx + 1 * stride < maxWrite) $ + (outVec `M.write` (writeIdx + stride)) v1 + + when (writeIdx + 2 * stride < maxWrite) $ + (outVec `M.write` (writeIdx + stride * 2)) v2 + + when (writeIdx + 3 * stride < maxWrite) $ + (outVec `M.write` (writeIdx + stride * 3)) v3 + + inner (readIdx + 1) (writeIdx + 4 * stride) (line - 4) + +data Pack12 = Pack12 + +instance Unpackable Pack12 where + type StorageType Pack12 = Word16 + allocTempBuffer _ _ = M.new + offsetStride _ _ _ = (0, 1) + outAlloc _ = M.new + mergeBackTempBuffer _ _ tempVec lineSize index size stride outVec = + inner 0 index pxCount + where pxCount = lineSize `div` stride + + maxWrite = M.length outVec + inner readIdx writeIdx _ + | readIdx >= fromIntegral size || writeIdx >= maxWrite = pure () + inner readIdx writeIdx line + | line <= 0 = inner readIdx (writeIdx + line * stride) pxCount + inner readIdx writeIdx line = do + v0 <- tempVec `M.read` readIdx + v1 <- if readIdx + 1 < fromIntegral size + then tempVec `M.read` (readIdx + 1) + else pure 0 + v2 <- if readIdx + 2 < fromIntegral size + then tempVec `M.read` (readIdx + 2) + else pure 0 + + let high0 = fromIntegral v0 `unsafeShiftL` 4 + low0 = (fromIntegral v1 `unsafeShiftR` 4) .&. 0xF + + p0 = high0 .|. low0 + + high1 = (fromIntegral v1 .&. 0xF) `unsafeShiftL` 8 + low1 = fromIntegral v2 + p1 = high1 .|. low1 + + (outVec `M.write` writeIdx) p0 + when (writeIdx + 1 * stride < maxWrite) $ + (outVec `M.write` (writeIdx + stride)) p1 + + inner (readIdx + 3) (writeIdx + 2 * stride) (line - 2) + +data YCbCrSubsampling = YCbCrSubsampling + { ycbcrWidth :: !Int + , ycbcrHeight :: !Int + , ycbcrImageWidth :: !Int + , ycbcrStripHeight :: !Int + } + +instance Unpackable YCbCrSubsampling where + type StorageType YCbCrSubsampling = Word8 + + offsetStride _ _ _ = (0, 1) + outAlloc _ = M.new + allocTempBuffer _ _ = M.new + mergeBackTempBuffer subSampling _ tempVec _ index size _ outVec = + foldM_ unpacker 0 [(bx, by) | by <- [0, h .. lineCount - 1] + , bx <- [0, w .. imgWidth - 1]] + where w = ycbcrWidth subSampling + h = ycbcrHeight subSampling + imgWidth = ycbcrImageWidth subSampling + lineCount = ycbcrStripHeight subSampling + + lumaCount = w * h + blockSize = lumaCount + 2 + + maxOut = M.length outVec + + unpacker readIdx _ | readIdx >= fromIntegral size * 3 = pure readIdx + unpacker readIdx (bx, by) = do + cb <- tempVec `M.read` (readIdx + lumaCount) + cr <- tempVec `M.read` (readIdx + lumaCount + 1) + + let pixelIndices = + [index + ((by + y) * imgWidth + bx + x) * 3 | y <- [0 .. h - 1], x <- [0 .. w - 1]] + + writer readIndex writeIdx | writeIdx + 3 > maxOut = pure readIndex + writer readIndex writeIdx = do + y <- tempVec `M.read` readIndex + (outVec `M.write` writeIdx) y + (outVec `M.write` (writeIdx + 1)) cb + (outVec `M.write` (writeIdx + 2)) cr + return $ readIndex + 1 + + foldM_ writer readIdx pixelIndices + + return $ readIdx + blockSize + +gatherStrips :: ( Unpackable comp + , Pixel pixel + , StorageType comp ~ PixelBaseComponent pixel + ) + => comp -> B.ByteString -> TiffInfo -> Image pixel +gatherStrips comp str nfo = runST $ do + let width = fromIntegral $ tiffWidth nfo + height = fromIntegral $ tiffHeight nfo + sampleCount = if tiffSampleCount nfo /= 0 + then fromIntegral $ tiffSampleCount nfo + else V.length $ tiffBitsPerSample nfo + + rowPerStrip = fromIntegral $ tiffRowPerStrip nfo + endianness = hdrEndianness $ tiffHeader nfo + + stripCount = V.length $ tiffOffsets nfo + compression = tiffCompression nfo + + outVec <- outAlloc comp $ width * height * sampleCount + tempVec <- allocTempBuffer comp outVec + (rowPerStrip * width * sampleCount) + + let mutableImage = MutableImage + { mutableImageWidth = fromIntegral width + , mutableImageHeight = fromIntegral height + , mutableImageData = outVec + } + + case tiffPlaneConfiguration nfo of + PlanarConfigContig -> V.mapM_ unpacker sizes + where unpacker (idx, stripSampleCount, offset, packedSize) = do + let (writeIdx, tempStride) = offsetStride comp idx 1 + _ <- uncompressAt compression str tempVec tempStride + writeIdx (offset, packedSize) + let typ :: M.MVector s a -> a + typ = const undefined + sampleSize = sizeOf (typ outVec) + mergeBackTempBuffer comp endianness tempVec (width * sampleCount) + idx (fromIntegral $ stripSampleCount * sampleSize) 1 outVec + + + fullStripSampleCount = rowPerStrip * width * sampleCount + startWriteOffset = V.generate stripCount (fullStripSampleCount *) + stripSampleCounts = V.map strip startWriteOffset + where + strip start = min fullStripSampleCount (width * height * sampleCount - start) + + sizes = V.zip4 startWriteOffset stripSampleCounts + (tiffOffsets nfo) (tiffStripSize nfo) + + PlanarConfigSeparate -> V.mapM_ unpacker sizes + where unpacker (idx, offset, size) = do + let (writeIdx, tempStride) = offsetStride comp idx stride + _ <- uncompressAt compression str tempVec tempStride + writeIdx (offset, size) + mergeBackTempBuffer comp endianness tempVec (width * sampleCount) + idx size stride outVec + + stride = V.length $ tiffOffsets nfo + idxVector = V.enumFromN 0 stride + sizes = V.zip3 idxVector (tiffOffsets nfo) (tiffStripSize nfo) + + when (tiffPredictor nfo == PredictorHorizontalDifferencing) $ do + let f _ c1 c2 = c1 + c2 + forM_ [0 .. height - 1] $ \y -> + forM_ [1 .. width - 1] $ \x -> do + p <- readPixel mutableImage (x - 1) y + q <- readPixel mutableImage x y + writePixel mutableImage x y $ mixWith f p q + + unsafeFreezeImage mutableImage + +ifdSingleLong :: ExifTag -> Word32 -> Writer [ImageFileDirectory] () +ifdSingleLong tag = ifdMultiLong tag . V.singleton + +ifdSingleShort :: Endianness -> ExifTag -> Word16 + -> Writer [ImageFileDirectory] () +ifdSingleShort endian tag = ifdMultiShort endian tag . V.singleton . fromIntegral + +ifdMultiLong :: ExifTag -> V.Vector Word32 -> Writer [ImageFileDirectory] () +ifdMultiLong tag v = tell . pure $ ImageFileDirectory + { ifdIdentifier = tag + , ifdType = TypeLong + , ifdCount = fromIntegral $ V.length v + , ifdOffset = offset + , ifdExtended = extended + } + where (offset, extended) + | V.length v > 1 = (0, ExifLongs v) + | otherwise = (V.head v, ExifNone) + +ifdMultiShort :: Endianness -> ExifTag -> V.Vector Word32 + -> Writer [ImageFileDirectory] () +ifdMultiShort endian tag v = tell . pure $ ImageFileDirectory + { ifdIdentifier = tag + , ifdType = TypeShort + , ifdCount = size + , ifdOffset = offset + , ifdExtended = extended + } + where size = fromIntegral $ V.length v + (offset, extended) + | size > 2 = (0, ExifShorts $ V.map fromIntegral v) + | size == 2 = + let v1 = fromIntegral $ V.head v + v2 = fromIntegral $ v `V.unsafeIndex` 1 + in + case endian of + EndianLittle -> (v2 `unsafeShiftL` 16 .|. v1, ExifNone) + EndianBig -> (v1 `unsafeShiftL` 16 .|. v2, ExifNone) + + | otherwise = case endian of + EndianLittle -> (V.head v, ExifNone) + EndianBig -> (V.head v `unsafeShiftL` 16, ExifNone) + +instance BinaryParam B.ByteString TiffInfo where + putP rawData nfo = putP rawData (tiffHeader nfo, list) where + endianness = hdrEndianness $ tiffHeader nfo + + ifdShort = ifdSingleShort endianness + ifdShorts = ifdMultiShort endianness + + list = execWriter $ do + ifdSingleLong TagImageWidth $ tiffWidth nfo + ifdSingleLong TagImageLength $ tiffHeight nfo + ifdShorts TagBitsPerSample $ tiffBitsPerSample nfo + ifdSingleLong TagSamplesPerPixel $ tiffSampleCount nfo + ifdSingleLong TagRowPerStrip $ tiffRowPerStrip nfo + ifdShort TagPhotometricInterpretation + . packPhotometricInterpretation + $ tiffColorspace nfo + ifdShort TagPlanarConfiguration + . constantToPlaneConfiguration $ tiffPlaneConfiguration nfo + ifdShort TagCompression . packCompression + $ tiffCompression nfo + ifdMultiLong TagStripOffsets $ tiffOffsets nfo + + ifdMultiLong TagStripByteCounts $ tiffStripSize nfo + + maybe (return ()) + (ifdShort TagExtraSample . codeOfExtraSample) + $ tiffExtraSample nfo + + let subSampling = tiffYCbCrSubsampling nfo + unless (V.null subSampling) $ + ifdShorts TagYCbCrSubsampling subSampling + + getP rawData = do + (hdr, cleaned) <- getP rawData + + let dataFind str tag = findIFDData str tag cleaned + dataDefault def tag = findIFDDefaultData def tag cleaned + extFind str tag = findIFDExt str tag cleaned + extDefault def tag = findIFDExtDefaultData def tag cleaned + + TiffInfo hdr + <$> dataFind "Can't find width" TagImageWidth + <*> dataFind "Can't find height" TagImageLength + <*> (dataFind "Can't find color space" TagPhotometricInterpretation + >>= unpackPhotometricInterpretation) + <*> dataFind "Can't find sample per pixel" TagSamplesPerPixel + <*> dataFind "Can't find row per strip" TagRowPerStrip + <*> (dataDefault 1 TagPlanarConfiguration + >>= planarConfgOfConstant) + <*> (extDefault [1] TagSampleFormat + >>= mapM unpackSampleFormat) + <*> (extFind "Can't find bit per sample" TagBitsPerSample + >>= unLong "Can't find bit depth") + <*> (dataFind "Can't find Compression" TagCompression + >>= unPackCompression) + <*> (extFind "Can't find byte counts" TagStripByteCounts + >>= unLong "Can't find bit per sample") + <*> (extFind "Strip offsets missing" TagStripOffsets + >>= unLong "Can't find strip offsets") + <*> findPalette cleaned + <*> (V.fromList <$> extDefault [2, 2] TagYCbCrSubsampling) + <*> pure Nothing + <*> (dataDefault 1 TagPredictor + >>= predictorOfConstant) + <*> pure (extractTiffMetadata cleaned) + +palette16Of :: Image PixelRGB16 -> Palette' PixelRGB16 +palette16Of p = Palette' + { _paletteSize = imageWidth p + , _paletteData = imageData p + } + +unpack :: B.ByteString -> TiffInfo -> Either String PalettedImage +-- | while mandatory some images don't put correct +-- rowperstrip. So replacing 0 with actual image height. +unpack file nfo@TiffInfo { tiffRowPerStrip = 0 } = + unpack file $ nfo { tiffRowPerStrip = tiffHeight nfo } +unpack file nfo@TiffInfo { tiffColorspace = TiffPaleted + , tiffBitsPerSample = lst + , tiffSampleFormat = format + , tiffPalette = Just p + } + | lst == V.singleton 8 && format == [TiffSampleUint] = + pure . PalettedRGB16 (gatherStrips (0 :: Word8) file nfo) $ palette16Of p + | lst == V.singleton 4 && format == [TiffSampleUint] = + pure . PalettedRGB16 (gatherStrips Pack4 file nfo) $ palette16Of p + | lst == V.singleton 2 && format == [TiffSampleUint] = + pure . PalettedRGB16 (gatherStrips Pack2 file nfo) $ palette16Of p + +unpack file nfo@TiffInfo { tiffColorspace = TiffCMYK + , tiffBitsPerSample = lst + , tiffSampleFormat = format } + | lst == V.fromList [8, 8, 8, 8] && all (TiffSampleUint ==) format = + pure . TrueColorImage . ImageCMYK8 $ gatherStrips (0 :: Word8) file nfo + + | lst == V.fromList [16, 16, 16, 16] && all (TiffSampleUint ==) format = + pure . TrueColorImage . ImageCMYK16 $ gatherStrips (0 :: Word16) file nfo + +unpack file nfo@TiffInfo { tiffColorspace = TiffMonochromeWhite0 } = do + img <- unpack file (nfo { tiffColorspace = TiffMonochrome }) + case img of + TrueColorImage (ImageY8 i) -> pure . TrueColorImage . ImageY8 $ pixelMap (maxBound -) i + TrueColorImage (ImageY16 i) -> pure . TrueColorImage . ImageY16 $ pixelMap (maxBound -) i + TrueColorImage (ImageYA8 i) -> let negative (PixelYA8 y a) = PixelYA8 (maxBound - y) a + in pure . TrueColorImage . ImageYA8 $ pixelMap negative i + TrueColorImage (ImageYA16 i) -> let negative (PixelYA16 y a) = PixelYA16 (maxBound - y) a + in pure . TrueColorImage . ImageYA16 $ pixelMap negative i + _ -> Left "Unsupported color type used with colorspace MonochromeWhite0" + +unpack file nfo@TiffInfo { tiffColorspace = TiffMonochrome + , tiffBitsPerSample = lst + , tiffSampleFormat = format } + | lst == V.singleton 2 && all (TiffSampleUint ==) format = + pure . TrueColorImage . ImageY8 . pixelMap (colorMap (0x55 *)) $ gatherStrips Pack2 file nfo + | lst == V.singleton 4 && all (TiffSampleUint ==) format = + pure . TrueColorImage . ImageY8 . pixelMap (colorMap (0x11 *)) $ gatherStrips Pack4 file nfo + | lst == V.singleton 8 && all (TiffSampleUint ==) format = + pure . TrueColorImage . ImageY8 $ gatherStrips (0 :: Word8) file nfo + | lst == V.singleton 12 && all (TiffSampleUint ==) format = + pure . TrueColorImage . ImageY16 . pixelMap (colorMap expand12to16) $ gatherStrips Pack12 file nfo + | lst == V.singleton 16 && all (TiffSampleUint ==) format = + pure . TrueColorImage . ImageY16 $ gatherStrips (0 :: Word16) file nfo + | lst == V.singleton 32 && all (TiffSampleUint ==) format = + let toWord16 v = fromIntegral $ v `unsafeShiftR` 16 + img = gatherStrips (0 :: Word32) file nfo :: Image Pixel32 + in + pure . TrueColorImage . ImageY16 $ pixelMap toWord16 img + | lst == V.fromList [2, 2] && all (TiffSampleUint ==) format = + pure . TrueColorImage . ImageYA8 . pixelMap (colorMap (0x55 *)) $ gatherStrips Pack2 file nfo + | lst == V.fromList [4, 4] && all (TiffSampleUint ==) format = + pure . TrueColorImage . ImageYA8 . pixelMap (colorMap (0x11 *)) $ gatherStrips Pack4 file nfo + | lst == V.fromList [8, 8] && all (TiffSampleUint ==) format = + pure . TrueColorImage . ImageYA8 $ gatherStrips (0 :: Word8) file nfo + | lst == V.fromList [12, 12] && all (TiffSampleUint ==) format = + pure . TrueColorImage . ImageYA16 . pixelMap (colorMap expand12to16) $ gatherStrips Pack12 file nfo + | lst == V.fromList [16, 16] && all (TiffSampleUint ==) format = + pure . TrueColorImage . ImageYA16 $ gatherStrips (0 :: Word16) file nfo + where + expand12to16 x = x `unsafeShiftL` 4 + x `unsafeShiftR` (12 - 4) + +unpack file nfo@TiffInfo { tiffColorspace = TiffYCbCr + , tiffBitsPerSample = lst + , tiffPlaneConfiguration = PlanarConfigContig + , tiffSampleFormat = format } + | lst == V.fromList [8, 8, 8] && all (TiffSampleUint ==) format = + pure . TrueColorImage . ImageYCbCr8 $ gatherStrips cbcrConf file nfo + where defaulting 0 = 2 + defaulting n = n + + w = defaulting $ tiffYCbCrSubsampling nfo V.! 0 + h = defaulting $ tiffYCbCrSubsampling nfo V.! 1 + cbcrConf = YCbCrSubsampling + { ycbcrWidth = fromIntegral w + , ycbcrHeight = fromIntegral h + , ycbcrImageWidth = fromIntegral $ tiffWidth nfo + , ycbcrStripHeight = fromIntegral $ tiffRowPerStrip nfo + } + +unpack file nfo@TiffInfo { tiffColorspace = TiffRGB + , tiffBitsPerSample = lst + , tiffSampleFormat = format } + | lst == V.fromList [2, 2, 2] && all (TiffSampleUint ==) format = + pure . TrueColorImage . ImageRGB8 . pixelMap (colorMap (0x55 *)) $ gatherStrips Pack2 file nfo + | lst == V.fromList [4, 4, 4] && all (TiffSampleUint ==) format = + pure . TrueColorImage . ImageRGB8 . pixelMap (colorMap (0x11 *)) $ gatherStrips Pack4 file nfo + | lst == V.fromList [8, 8, 8] && all (TiffSampleUint ==) format = + pure . TrueColorImage . ImageRGB8 $ gatherStrips (0 :: Word8) file nfo + | lst == V.fromList [8, 8, 8, 8] && all (TiffSampleUint ==) format = + pure . TrueColorImage . ImageRGBA8 $ gatherStrips (0 :: Word8) file nfo + | lst == V.fromList [16, 16, 16] && all (TiffSampleUint ==) format = + pure . TrueColorImage . ImageRGB16 $ gatherStrips (0 :: Word16) file nfo + | lst == V.fromList [16, 16, 16, 16] && all (TiffSampleUint ==) format = + pure . TrueColorImage . ImageRGBA16 $ gatherStrips (0 :: Word16) file nfo +unpack file nfo@TiffInfo { tiffColorspace = TiffMonochrome + , tiffBitsPerSample = lst + , tiffSampleFormat = format } + -- some files are a little bit borked... + | lst == V.fromList [8, 8, 8] && all (TiffSampleUint ==) format = + pure . TrueColorImage . ImageRGB8 $ gatherStrips (0 :: Word8) file nfo + +unpack _ _ = Left "Failure to unpack TIFF file" + +-- | Decode a tiff encoded image while preserving the underlying +-- pixel type (except for Y32 which is truncated to 16 bits). +-- +-- This function can output the following images: +-- +-- * 'ImageY8' +-- +-- * 'ImageY16' +-- +-- * 'ImageYA8' +-- +-- * 'ImageYA16' +-- +-- * 'ImageRGB8' +-- +-- * 'ImageRGB16' +-- +-- * 'ImageRGBA8' +-- +-- * 'ImageRGBA16' +-- +-- * 'ImageCMYK8' +-- +-- * 'ImageCMYK16' +-- +decodeTiff :: B.ByteString -> Either String DynamicImage +decodeTiff = fmap fst . decodeTiffWithMetadata + +-- | Like 'decodeTiff' but also provides some metdata present +-- in the Tiff file. +-- +-- The metadata extracted are the 'Codec.Picture.Metadata.DpiX' & +-- 'Codec.Picture.Metadata.DpiY' information alongside the EXIF informations. +decodeTiffWithMetadata :: B.ByteString -> Either String (DynamicImage, Metadatas) +decodeTiffWithMetadata str = first palettedToTrueColor <$> decodeTiffWithPaletteAndMetadata str + +-- | Decode TIFF and provide separated palette and metadata +decodeTiffWithPaletteAndMetadata :: B.ByteString -> Either String (PalettedImage, Metadatas) +decodeTiffWithPaletteAndMetadata file = runGetStrict (getP file) file >>= go + where + go tinfo = (, tiffMetadatas tinfo) <$> unpack file tinfo + + +-- | Class defining which pixel types can be serialized in a +-- Tiff file. +class (Pixel px) => TiffSaveable px where + colorSpaceOfPixel :: px -> TiffColorspace + + extraSampleCodeOfPixel :: px -> Maybe ExtraSample + extraSampleCodeOfPixel _ = Nothing + + subSamplingInfo :: px -> V.Vector Word32 + subSamplingInfo _ = V.empty + +instance TiffSaveable Pixel8 where + colorSpaceOfPixel _ = TiffMonochrome + +instance TiffSaveable Pixel16 where + colorSpaceOfPixel _ = TiffMonochrome + +instance TiffSaveable PixelYA8 where + colorSpaceOfPixel _ = TiffMonochrome + extraSampleCodeOfPixel _ = Just ExtraSampleUnassociatedAlpha + +instance TiffSaveable PixelYA16 where + colorSpaceOfPixel _ = TiffMonochrome + extraSampleCodeOfPixel _ = Just ExtraSampleUnassociatedAlpha + +instance TiffSaveable PixelCMYK8 where + colorSpaceOfPixel _ = TiffCMYK + +instance TiffSaveable PixelCMYK16 where + colorSpaceOfPixel _ = TiffCMYK + +instance TiffSaveable PixelRGB8 where + colorSpaceOfPixel _ = TiffRGB + +instance TiffSaveable PixelRGB16 where + colorSpaceOfPixel _ = TiffRGB + +instance TiffSaveable PixelRGBA8 where + colorSpaceOfPixel _ = TiffRGB + extraSampleCodeOfPixel _ = Just ExtraSampleUnassociatedAlpha + +instance TiffSaveable PixelRGBA16 where + colorSpaceOfPixel _ = TiffRGB + extraSampleCodeOfPixel _ = Just ExtraSampleUnassociatedAlpha + +instance TiffSaveable PixelYCbCr8 where + colorSpaceOfPixel _ = TiffYCbCr + subSamplingInfo _ = V.fromListN 2 [1, 1] + +-- | Transform an image into a Tiff encoded bytestring, ready to be +-- written as a file. +encodeTiff :: forall px. (TiffSaveable px) => Image px -> Lb.ByteString +encodeTiff img = runPut $ putP rawPixelData hdr + where intSampleCount = componentCount (undefined :: px) + sampleCount = fromIntegral intSampleCount + + sampleType = undefined :: PixelBaseComponent px + pixelData = imageData img + + rawPixelData = toByteString pixelData + width = fromIntegral $ imageWidth img + height = fromIntegral $ imageHeight img + intSampleSize = sizeOf sampleType + sampleSize = fromIntegral intSampleSize + bitPerSample = sampleSize * 8 + imageSize = width * height * sampleCount * sampleSize + headerSize = 8 + + hdr = TiffInfo + { tiffHeader = TiffHeader + { hdrEndianness = EndianLittle + , hdrOffset = headerSize + imageSize + } + , tiffWidth = width + , tiffHeight = height + , tiffColorspace = colorSpaceOfPixel (undefined :: px) + , tiffSampleCount = fromIntegral sampleCount + , tiffRowPerStrip = fromIntegral $ imageHeight img + , tiffPlaneConfiguration = PlanarConfigContig + , tiffSampleFormat = [TiffSampleUint] + , tiffBitsPerSample = V.replicate intSampleCount bitPerSample + , tiffCompression = CompressionNone + , tiffStripSize = V.singleton imageSize + , tiffOffsets = V.singleton headerSize + , tiffPalette = Nothing + , tiffYCbCrSubsampling = subSamplingInfo (undefined :: px) + , tiffExtraSample = extraSampleCodeOfPixel (undefined :: px) + , tiffPredictor = PredictorNone -- not used when writing + , tiffMetadatas = mempty + } + +-- | Helper function to directly write an image as a tiff on disk. +writeTiff :: (TiffSaveable pixel) => FilePath -> Image pixel -> IO () +writeTiff path img = Lb.writeFile path $ encodeTiff img + +{-# ANN module "HLint: ignore Reduce duplication" #-} +