    {-# LANGUAGE TupleSections #-}
    {-# LANGUAGE FlexibleContexts #-}
    {-# LANGUAGE ScopedTypeVariables #-}
    {-# LANGUAGE FlexibleInstances #-}
    {-# LANGUAGE BangPatterns #-}
    {-# LANGUAGE TypeFamilies #-}
    {-# LANGUAGE CPP #-}
    {-# OPTIONS_GHC -fspec-constr-count=5 #-}
    -- | Module used for JPEG file loading and writing.
    module Codec.Picture.Jpg( decodeJpeg
                            , decodeJpegWithMetadata
                            , encodeJpegAtQuality
                            , encodeJpegAtQualityWithMetadata
                            , encodeDirectJpegAtQualityWithMetadata
                            , encodeJpeg
                            , JpgEncodable
                            ) where

    #if !MIN_VERSION_base(4,8,0)
    import Data.Foldable( foldMap )
    import Data.Monoid( mempty )
    import Control.Applicative( pure, (<$>) )
    #endif

    import Control.Applicative( (<|>) )

    import Control.Arrow( (>>>) )
    import Control.Monad( when, forM_ )
    import Control.Monad.ST( ST, runST )
    import Control.Monad.Trans( lift )
    import Control.Monad.Trans.RWS.Strict( RWS, modify, tell, gets, execRWS )

    import Data.Bits( (.|.), unsafeShiftL )
    #if !MIN_VERSION_base(4,11,0)
    import Data.Monoid( (<>) )
    #endif
    import Data.Int( Int16, Int32 )
    import Data.Word(Word8, Word32)
    import Data.Binary( Binary(..), encode )
    import Data.STRef( newSTRef, writeSTRef, readSTRef )

    import Data.Vector( (//) )
    import Data.Vector.Unboxed( (!) )
    import qualified Data.Vector as V
    import qualified Data.Vector.Unboxed as VU
    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 L

    import Codec.Picture.InternalHelper
    import Codec.Picture.BitWriter
    import Codec.Picture.Types
    import Codec.Picture.Metadata( Metadatas
                                 , SourceFormat( SourceJpeg )
                                 , basicMetadata )
    import Codec.Picture.Tiff.Internal.Types
    import Codec.Picture.Tiff.Internal.Metadata
    import Codec.Picture.Jpg.Internal.Types
    import Codec.Picture.Jpg.Internal.Common
    import Codec.Picture.Jpg.Internal.Progressive
    import Codec.Picture.Jpg.Internal.DefaultTable
    import Codec.Picture.Jpg.Internal.FastDct
    import Codec.Picture.Jpg.Internal.Metadata

    quantize :: MacroBlock Int16 -> MutableMacroBlock s Int32
             -> ST s (MutableMacroBlock s Int32)
    quantize table block = update 0
      where update 64 = return block
            update idx = do
                val <- block `M.unsafeRead` idx
                let q = fromIntegral (table `VS.unsafeIndex` idx)
                    finalValue = (val + (q `div` 2)) `quot` q -- rounded integer division
                (block `M.unsafeWrite` idx) finalValue
                update $ idx + 1

    powerOf :: Int32 -> Word32
    powerOf 0 = 0
    powerOf n = limit 1 0
        where val = abs n
              limit range i | val < range = i
              limit range i = limit (2 * range) (i + 1)

    encodeInt :: BoolWriteStateRef s -> Word32 -> Int32 -> ST s ()
    {-# INLINE encodeInt #-}
    encodeInt st ssss n | n > 0 = writeBits' st (fromIntegral n) (fromIntegral ssss)
    encodeInt st ssss n         = writeBits' st (fromIntegral $ n - 1) (fromIntegral ssss)

    -- | Assume the macro block is initialized with zeroes
    acCoefficientsDecode :: HuffmanPackedTree -> MutableMacroBlock s Int16
                         -> BoolReader s (MutableMacroBlock s Int16)
    acCoefficientsDecode acTree mutableBlock = parseAcCoefficient 1 >> return mutableBlock
      where parseAcCoefficient n | n >= 64 = return ()
                                 | otherwise = do
                rrrrssss <- decodeRrrrSsss acTree
                case rrrrssss of
                    (  0, 0) -> return ()
                    (0xF, 0) -> parseAcCoefficient (n + 16)
                    (rrrr, ssss) -> do
                        decoded <- fromIntegral <$> decodeInt ssss
                        lift $ (mutableBlock `M.unsafeWrite` (n + rrrr)) decoded
                        parseAcCoefficient (n + rrrr + 1)

    -- | Decompress a macroblock from a bitstream given the current configuration
    -- from the frame.
    decompressMacroBlock :: HuffmanPackedTree   -- ^ Tree used for DC coefficient
                         -> HuffmanPackedTree   -- ^ Tree used for Ac coefficient
                         -> MacroBlock Int16    -- ^ Current quantization table
                         -> MutableMacroBlock s Int16    -- ^ A zigzag table, to avoid allocation
                         -> DcCoefficient       -- ^ Previous dc value
                         -> BoolReader s (DcCoefficient, MutableMacroBlock s Int16)
    decompressMacroBlock dcTree acTree quantizationTable zigzagBlock previousDc = do
        dcDeltaCoefficient <- dcCoefficientDecode dcTree
        block <- lift createEmptyMutableMacroBlock
        let neoDcCoefficient = previousDc + dcDeltaCoefficient
        lift $ (block `M.unsafeWrite` 0) neoDcCoefficient
        fullBlock <- acCoefficientsDecode acTree block
        decodedBlock <- lift $ decodeMacroBlock quantizationTable zigzagBlock fullBlock
        return (neoDcCoefficient, decodedBlock)

    pixelClamp :: Int16 -> Word8
    pixelClamp n = fromIntegral . min 255 $ max 0 n

    unpack444Y :: Int -- ^ component index
               -> Int -- ^ x
               -> Int -- ^ y
               -> MutableImage s PixelYCbCr8
               -> MutableMacroBlock s Int16
               -> ST s ()
    unpack444Y _ x y (MutableImage { mutableImageWidth = imgWidth, mutableImageData = img })
                     block = blockVert baseIdx 0 zero
      where zero = 0 :: Int
            baseIdx = x * dctBlockSize + y * dctBlockSize * imgWidth

            blockVert        _       _ j | j >= dctBlockSize = return ()
            blockVert writeIdx readingIdx j = blockHoriz writeIdx readingIdx zero
              where blockHoriz   _ readIdx i | i >= dctBlockSize = blockVert (writeIdx + imgWidth) readIdx $ j + 1
                    blockHoriz idx readIdx i = do
                        val <- pixelClamp <$> (block `M.unsafeRead` readIdx)
                        (img `M.unsafeWrite` idx) val
                        blockHoriz (idx + 1) (readIdx + 1) $ i + 1

    unpack444Ycbcr :: Int -- ^ Component index
                  -> Int -- ^ x
                  -> Int -- ^ y
                  -> MutableImage s PixelYCbCr8
                  -> MutableMacroBlock s Int16
                  -> ST s ()
    unpack444Ycbcr compIdx x y
                     (MutableImage { mutableImageWidth = imgWidth, mutableImageData = img })
                     block = blockVert baseIdx 0 zero
      where zero = 0 :: Int
            baseIdx = (x * dctBlockSize + y * dctBlockSize * imgWidth) * 3 + compIdx

            blockVert   _       _ j | j >= dctBlockSize = return ()
            blockVert idx readIdx j = do
                val0 <- pixelClamp <$> (block `M.unsafeRead` readIdx)
                val1 <- pixelClamp <$> (block `M.unsafeRead` (readIdx + 1))
                val2 <- pixelClamp <$> (block `M.unsafeRead` (readIdx + 2))
                val3 <- pixelClamp <$> (block `M.unsafeRead` (readIdx + 3))
                val4 <- pixelClamp <$> (block `M.unsafeRead` (readIdx + 4))
                val5 <- pixelClamp <$> (block `M.unsafeRead` (readIdx + 5))
                val6 <- pixelClamp <$> (block `M.unsafeRead` (readIdx + 6))
                val7 <- pixelClamp <$> (block `M.unsafeRead` (readIdx + 7))

                (img `M.unsafeWrite` idx) val0
                (img `M.unsafeWrite` (idx +  3     )) val1
                (img `M.unsafeWrite` (idx + (3 * 2))) val2
                (img `M.unsafeWrite` (idx + (3 * 3))) val3
                (img `M.unsafeWrite` (idx + (3 * 4))) val4
                (img `M.unsafeWrite` (idx + (3 * 5))) val5
                (img `M.unsafeWrite` (idx + (3 * 6))) val6
                (img `M.unsafeWrite` (idx + (3 * 7))) val7

                blockVert (idx + 3 * imgWidth) (readIdx + dctBlockSize) $ j + 1

              {-where blockHoriz   _ readIdx i | i >= 8 = blockVert (writeIdx + imgWidth * 3) readIdx $ j + 1-}
                    {-blockHoriz idx readIdx i = do-}
                        {-val <- pixelClamp <$> (block `M.unsafeRead` readIdx) -}
                        {-(img `M.unsafeWrite` idx) val-}
                        {-blockHoriz (idx + 3) (readIdx + 1) $ i + 1-}

    unpack421Ycbcr :: Int -- ^ Component index
                   -> Int -- ^ x
                   -> Int -- ^ y
                   -> MutableImage s PixelYCbCr8
                   -> MutableMacroBlock s Int16
                   -> ST s ()
    unpack421Ycbcr compIdx x y
                     (MutableImage { mutableImageWidth = imgWidth,
                                     mutableImageHeight = _, mutableImageData = img })
                     block = blockVert baseIdx 0 zero
      where zero = 0 :: Int
            baseIdx = (x * dctBlockSize + y * dctBlockSize * imgWidth) * 3 + compIdx
            lineOffset = imgWidth * 3

            blockVert        _       _ j | j >= dctBlockSize = return ()
            blockVert idx readIdx j = do
                v0 <- pixelClamp <$> (block `M.unsafeRead` readIdx)
                v1 <- pixelClamp <$> (block `M.unsafeRead` (readIdx + 1))
                v2 <- pixelClamp <$> (block `M.unsafeRead` (readIdx + 2))
                v3 <- pixelClamp <$> (block `M.unsafeRead` (readIdx + 3))
                v4 <- pixelClamp <$> (block `M.unsafeRead` (readIdx + 4))
                v5 <- pixelClamp <$> (block `M.unsafeRead` (readIdx + 5))
                v6 <- pixelClamp <$> (block `M.unsafeRead` (readIdx + 6))
                v7 <- pixelClamp <$> (block `M.unsafeRead` (readIdx + 7))

                (img `M.unsafeWrite` idx)       v0
                (img `M.unsafeWrite` (idx + 3)) v0

                (img `M.unsafeWrite` (idx + 6    ))      v1
                (img `M.unsafeWrite` (idx + 6     + 3))  v1

                (img `M.unsafeWrite` (idx + 6 * 2))      v2
                (img `M.unsafeWrite` (idx + 6 * 2 + 3))  v2

                (img `M.unsafeWrite` (idx + 6 * 3))      v3
                (img `M.unsafeWrite` (idx + 6 * 3 + 3))  v3

                (img `M.unsafeWrite` (idx + 6 * 4))      v4
                (img `M.unsafeWrite` (idx + 6 * 4 + 3))  v4

                (img `M.unsafeWrite` (idx + 6 * 5))      v5
                (img `M.unsafeWrite` (idx + 6 * 5 + 3))  v5

                (img `M.unsafeWrite` (idx + 6 * 6))      v6
                (img `M.unsafeWrite` (idx + 6 * 6 + 3))  v6

                (img `M.unsafeWrite` (idx + 6 * 7))      v7
                (img `M.unsafeWrite` (idx + 6 * 7 + 3))  v7

                blockVert (idx + lineOffset) (readIdx + dctBlockSize) $ j + 1

    type Unpacker s = Int -- ^ component index
                   -> Int -- ^ x
                   -> Int -- ^ y
                   -> MutableImage s PixelYCbCr8
                   -> MutableMacroBlock s Int16
                   -> ST s ()

    type JpgScripter s a =
        RWS () [([(JpgUnpackerParameter, Unpacker s)], L.ByteString)] JpgDecoderState a

    data JpgDecoderState = JpgDecoderState
        { dcDecoderTables       :: !(V.Vector HuffmanPackedTree)
        , acDecoderTables       :: !(V.Vector HuffmanPackedTree)
        , quantizationMatrices  :: !(V.Vector (MacroBlock Int16))
        , currentRestartInterv  :: !Int
        , currentFrame          :: Maybe JpgFrameHeader
        , app14Marker           :: !(Maybe JpgAdobeApp14)
        , app0JFifMarker        :: !(Maybe JpgJFIFApp0)
        , app1ExifMarker        :: !(Maybe [ImageFileDirectory])
        , componentIndexMapping :: ![(Word8, Int)]
        , isProgressive         :: !Bool
        , maximumHorizontalResolution :: !Int
        , maximumVerticalResolution   :: !Int
        , seenBlobs                   :: !Int
        }

    emptyDecoderState :: JpgDecoderState
    emptyDecoderState = JpgDecoderState
        { dcDecoderTables =
            let (_, dcLuma) = prepareHuffmanTable DcComponent 0 defaultDcLumaHuffmanTable
                (_, dcChroma) = prepareHuffmanTable DcComponent 1 defaultDcChromaHuffmanTable
            in
            V.fromList [ dcLuma, dcChroma, dcLuma, dcChroma ]

        , acDecoderTables =
            let (_, acLuma) = prepareHuffmanTable AcComponent 0 defaultAcLumaHuffmanTable
                (_, acChroma) = prepareHuffmanTable AcComponent 1 defaultAcChromaHuffmanTable
            in
            V.fromList [acLuma, acChroma, acLuma, acChroma]

        , quantizationMatrices = V.replicate 4 (VS.replicate (8 * 8) 1)
        , currentRestartInterv = -1
        , currentFrame         = Nothing
        , componentIndexMapping = []
        , app14Marker = Nothing
        , app0JFifMarker = Nothing
        , app1ExifMarker = Nothing
        , isProgressive        = False
        , maximumHorizontalResolution = 0
        , maximumVerticalResolution   = 0
        , seenBlobs = 0
        }

    -- | This pseudo interpreter interpret the Jpg frame for the huffman,
    -- quant table and restart interval parameters.
    jpgMachineStep :: JpgFrame -> JpgScripter s ()
    jpgMachineStep (JpgAdobeAPP14 app14) = modify $ \s ->
        s { app14Marker = Just app14 }
    jpgMachineStep (JpgExif exif) = modify $ \s ->
        s { app1ExifMarker = Just exif }
    jpgMachineStep (JpgJFIF app0) = modify $ \s ->
        s { app0JFifMarker = Just app0 }
    jpgMachineStep (JpgAppFrame _ _) = pure ()
    jpgMachineStep (JpgExtension _ _) = pure ()
    jpgMachineStep (JpgScanBlob hdr raw_data) = do
        let scanCount = length $ scans hdr
        params <- concat <$> mapM (scanSpecifier scanCount) (scans hdr)

        modify $ \st -> st { seenBlobs = seenBlobs st + 1 }
        tell [(params, raw_data)  ]
      where (selectionLow, selectionHigh) = spectralSelection hdr
            approxHigh = fromIntegral $ successiveApproxHigh hdr
            approxLow = fromIntegral $ successiveApproxLow hdr

            scanSpecifier scanCount scanSpec = do
                compMapping <- gets componentIndexMapping
                comp <- case lookup (componentSelector scanSpec) compMapping of
                    Nothing -> error "Jpg decoding error - bad component selector in blob."
                    Just v -> return v
                let maximumHuffmanTable = 4
                    dcIndex = min (maximumHuffmanTable - 1)
                                . fromIntegral $ dcEntropyCodingTable scanSpec
                    acIndex = min (maximumHuffmanTable - 1)
                                . fromIntegral $ acEntropyCodingTable scanSpec

                dcTree <- gets $ (V.! dcIndex) . dcDecoderTables
                acTree <- gets $ (V.! acIndex) . acDecoderTables
                isProgressiveImage <- gets isProgressive
                maxiW <- gets maximumHorizontalResolution
                maxiH <- gets maximumVerticalResolution
                restart <- gets currentRestartInterv
                frameInfo <- gets currentFrame
                blobId <- gets seenBlobs
                case frameInfo of
                  Nothing -> error "Jpg decoding error - no previous frame"
                  Just v -> do
                     let compDesc = jpgComponents v !! comp
                         compCount = length $ jpgComponents v
                         xSampling = fromIntegral $ horizontalSamplingFactor compDesc
                         ySampling = fromIntegral $ verticalSamplingFactor compDesc
                         componentSubSampling =
                            (maxiW - xSampling + 1, maxiH - ySampling + 1)
                         (xCount, yCount)
                            | scanCount > 1 || isProgressiveImage = (xSampling, ySampling)
                            | otherwise = (1, 1)

                     pure [ (JpgUnpackerParameter
                             { dcHuffmanTree = dcTree
                             , acHuffmanTree = acTree
                             , componentIndex = comp
                             , restartInterval = fromIntegral restart
                             , componentWidth = xSampling
                             , componentHeight = ySampling
                             , subSampling = componentSubSampling
                             , successiveApprox = (approxLow, approxHigh)
                             , readerIndex = blobId
                             , indiceVector =
                                 if scanCount == 1 then 0 else 1
                             , coefficientRange =
                                 ( fromIntegral selectionLow
                                 , fromIntegral selectionHigh )
                             , blockIndex = y * xSampling + x
                             , blockMcuX = x
                             , blockMcuY = y
                             }, unpackerDecision compCount componentSubSampling)
                                 | y <- [0 .. yCount - 1]
                                 , x <- [0 .. xCount - 1] ]

    jpgMachineStep (JpgScans kind hdr) = modify $ \s ->
       s { currentFrame = Just hdr
         , componentIndexMapping =
              [(componentIdentifier comp, ix) | (ix, comp) <- zip [0..] $ jpgComponents hdr]
         , isProgressive = case kind of
                JpgProgressiveDCTHuffman -> True
                _ -> False
         , maximumHorizontalResolution =
             fromIntegral $ maximum horizontalResolutions
         , maximumVerticalResolution =
             fromIntegral $ maximum verticalResolutions
         }
        where components = jpgComponents hdr
              horizontalResolutions = map horizontalSamplingFactor components
              verticalResolutions = map verticalSamplingFactor components
    jpgMachineStep (JpgIntervalRestart restart) =
        modify $ \s -> s { currentRestartInterv = fromIntegral restart }
    jpgMachineStep (JpgHuffmanTable tables) = mapM_ placeHuffmanTrees tables
      where placeHuffmanTrees (spec, tree) = case huffmanTableClass spec of
                DcComponent -> modify $ \s ->
                  if idx >= V.length (dcDecoderTables s) then s
                  else
                    let neu = dcDecoderTables s // [(idx, tree)] in
                    s { dcDecoderTables = neu }
                        where idx = fromIntegral $ huffmanTableDest spec

                AcComponent -> modify $ \s ->
                  if idx >= V.length (acDecoderTables s) then s
                  else
                    s { acDecoderTables = acDecoderTables s // [(idx, tree)] }
                        where idx = fromIntegral $ huffmanTableDest spec

    jpgMachineStep (JpgQuantTable tables) = mapM_ placeQuantizationTables tables
      where placeQuantizationTables table = do
                let idx = fromIntegral $ quantDestination table
                    tableData = quantTable table
                modify $ \s ->
                    s { quantizationMatrices =  quantizationMatrices s // [(idx, tableData)] }

    unpackerDecision :: Int -> (Int, Int) -> Unpacker s
    unpackerDecision 1 (1, 1) = unpack444Y
    unpackerDecision 3 (1, 1) = unpack444Ycbcr
    unpackerDecision _ (2, 1) = unpack421Ycbcr
    unpackerDecision compCount (xScalingFactor, yScalingFactor) =
        unpackMacroBlock compCount xScalingFactor yScalingFactor

    decodeImage :: JpgFrameHeader
                -> V.Vector (MacroBlock Int16)
                -> [([(JpgUnpackerParameter, Unpacker s)], L.ByteString)]
                -> MutableImage s PixelYCbCr8 -- ^ Result image to write into
                -> ST s (MutableImage s PixelYCbCr8)
    decodeImage frame quants lst outImage = do
      let compCount = length $ jpgComponents frame
      zigZagArray <- createEmptyMutableMacroBlock
      dcArray <- M.replicate compCount 0  :: ST s (M.STVector s DcCoefficient)
      resetCounter <- newSTRef restartIntervalValue

      forM_ lst $ \(params, str) -> do
        let componentsInfo = V.fromList params
            compReader = initBoolStateJpg . B.concat $ L.toChunks str
            maxiW = maximum [fst $ subSampling c | (c,_) <- params]
            maxiH = maximum [snd $ subSampling c | (c,_) <- params]

            imageBlockWidth = toBlockSize imgWidth
            imageBlockHeight = toBlockSize imgHeight

            imageMcuWidth = (imageBlockWidth + (maxiW - 1)) `div` maxiW
            imageMcuHeight = (imageBlockHeight + (maxiH - 1)) `div` maxiH

        execBoolReader compReader $ rasterMap imageMcuWidth imageMcuHeight $ \x y -> do
          resetLeft <- lift $ readSTRef resetCounter
          if resetLeft == 0 then do
            lift $ M.set dcArray 0
            byteAlignJpg
            _restartCode <- decodeRestartInterval
            lift $ resetCounter `writeSTRef` (restartIntervalValue - 1)
          else
            lift $ resetCounter `writeSTRef` (resetLeft - 1)

          V.forM_ componentsInfo $ \(comp, unpack) -> do
            let compIdx = componentIndex comp
                dcTree = dcHuffmanTree comp
                acTree = acHuffmanTree comp
                quantId = fromIntegral .  quantizationTableDest
                        $ jpgComponents frame !! compIdx
                qTable = quants V.! min 3 quantId
                xd = blockMcuX comp
                yd = blockMcuY comp
                (subX, subY) = subSampling comp
            dc <- lift $ dcArray `M.unsafeRead` compIdx
            (dcCoeff, block) <-
                  decompressMacroBlock dcTree acTree qTable zigZagArray $ fromIntegral dc
            lift $ (dcArray `M.unsafeWrite` compIdx) dcCoeff
            let verticalLimited = y == imageMcuHeight - 1
            if (x == imageMcuWidth - 1) || verticalLimited then
              lift $ unpackMacroBlock imgComponentCount
                                      subX subY compIdx
                                      (x * maxiW + xd) (y * maxiH + yd) outImage block
            else
              lift $ unpack compIdx (x * maxiW + xd) (y * maxiH + yd) outImage block

      return outImage

      where imgComponentCount = length $ jpgComponents frame

            imgWidth = fromIntegral $ jpgWidth frame
            imgHeight = fromIntegral $ jpgHeight frame
            restartIntervalValue = case lst of
                    ((p,_):_,_): _ -> restartInterval p
                    _ -> -1

    gatherImageKind :: [JpgFrame] -> Maybe JpgImageKind
    gatherImageKind lst = case [k | JpgScans k _ <- lst, isDctSpecifier k] of
        [JpgBaselineDCTHuffman] -> Just BaseLineDCT
        [JpgProgressiveDCTHuffman] -> Just ProgressiveDCT
        [JpgExtendedSequentialDCTHuffman] -> Just BaseLineDCT
        _ -> Nothing
      where isDctSpecifier JpgProgressiveDCTHuffman = True
            isDctSpecifier JpgBaselineDCTHuffman = True
            isDctSpecifier JpgExtendedSequentialDCTHuffman = True
            isDctSpecifier _ = False

    gatherScanInfo :: JpgImage -> (JpgFrameKind, JpgFrameHeader)
    gatherScanInfo img = head [(a, b) | JpgScans a b <- jpgFrame img]

    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 ->
         let ymg = Image w h $ VS.map (255-) imgData :: Image PixelYCbCrK8 in
         return . ImageCMYK8 $ convertImage ymg
      JpgColorSpaceYCbCr -> return . ImageYCbCr8 $ Image w h imgData
      JpgColorSpaceRGB -> return . ImageRGB8 $ Image w h imgData
      JpgColorSpaceYA -> return . ImageYA8 $ Image w h imgData
      JpgColorSpaceY -> return . ImageY8 $ Image w h imgData
      colorSpace -> Left $ "Wrong color space : " ++ show colorSpace

    colorSpaceOfAdobe :: Int -> JpgAdobeApp14 -> Maybe JpgColorSpace
    colorSpaceOfAdobe compCount app = case (compCount, _adobeTransform app) of
      (3, AdobeYCbCr) -> pure JpgColorSpaceYCbCr
      (1, AdobeUnknown) -> pure JpgColorSpaceY
      (3, AdobeUnknown) -> pure JpgColorSpaceRGB
      (4, AdobeYCck) -> pure JpgColorSpaceYCCK
      {-(4, AdobeUnknown) -> pure JpgColorSpaceCMYKInverted-}
      _ -> Nothing

    colorSpaceOfState :: JpgDecoderState -> Maybe JpgColorSpace
    colorSpaceOfState st = do
      hdr <- currentFrame st
      let compStr = [toEnum . fromEnum $ componentIdentifier comp
                            | comp <- jpgComponents hdr]
          app14 = do
            marker <- app14Marker st
            colorSpaceOfAdobe (length compStr) marker
      app14 <|> colorSpaceOfComponentStr compStr

    colorSpaceOfComponentStr :: String -> Maybe JpgColorSpace
    colorSpaceOfComponentStr s = case s of
      [_] -> pure  JpgColorSpaceY
      [_,_] -> pure  JpgColorSpaceYA
      "\0\1\2" -> pure  JpgColorSpaceYCbCr
      "\1\2\3" -> pure  JpgColorSpaceYCbCr
      "RGB" -> pure  JpgColorSpaceRGB
      "YCc" -> pure  JpgColorSpaceYCC
      [_,_,_] -> pure  JpgColorSpaceYCbCr

      "RGBA" -> pure  JpgColorSpaceRGBA
      "YCcA" -> pure  JpgColorSpaceYCCA
      "CMYK" -> pure  JpgColorSpaceCMYK
      "YCcK" -> pure  JpgColorSpaceYCCK
      [_,_,_,_] -> pure  JpgColorSpaceCMYK
      _ -> Nothing

    -- | Try to decompress and decode a jpeg file. The colorspace is still
    -- YCbCr if you want to perform computation on the luma part. You can convert it
    -- to RGB using 'convertImage' from the 'ColorSpaceConvertible' typeclass.
    --
    -- This function can output the following images:
    --
    --  * 'ImageY8'
    --
    --  * 'ImageYA8'
    --
    --  * 'ImageRGB8'
    --
    --  * 'ImageCMYK8'
    --
    --  * 'ImageYCbCr8'
    --
    decodeJpeg :: B.ByteString -> Either String DynamicImage
    decodeJpeg = fmap fst . decodeJpegWithMetadata

    -- | Equivalent to 'decodeJpeg' but also extracts metadatas.
    --
    -- Extract the following metadatas from the JFIF block:
    --
    --  * 'Codec.Picture.Metadata.DpiX'
    --  * 'Codec.Picture.Metadata.DpiY'
    --
    -- Exif metadata are also extracted if present.
    --
    decodeJpegWithMetadata :: B.ByteString -> Either String (DynamicImage, Metadatas)
    decodeJpegWithMetadata file = case runGetStrict get file of
      Left err -> Left err
      Right img -> case imgKind of
         Just BaseLineDCT ->
           let (st, arr) = decodeBaseline
               jfifMeta = foldMap extractMetadatas $ app0JFifMarker st
               exifMeta = foldMap extractTiffMetadata $ app1ExifMarker st
               meta = sizeMeta <> jfifMeta <> exifMeta
           in
           (, meta) <$>
               dynamicOfColorSpace (colorSpaceOfState st) imgWidth imgHeight arr
         Just ProgressiveDCT ->
           let (st, arr) = decodeProgressive
               jfifMeta = foldMap extractMetadatas $ app0JFifMarker st
               exifMeta = foldMap extractTiffMetadata $ app1ExifMarker st
               meta = sizeMeta <> jfifMeta <> exifMeta
           in
           (, meta) <$>
               dynamicOfColorSpace (colorSpaceOfState st) imgWidth imgHeight arr
         _ -> Left "Unknown JPG kind"
        where
          compCount = length $ jpgComponents scanInfo
          (_,scanInfo) = gatherScanInfo img

          imgKind = gatherImageKind $ jpgFrame img
          imgWidth = fromIntegral $ jpgWidth scanInfo
          imgHeight = fromIntegral $ jpgHeight scanInfo

          sizeMeta = basicMetadata SourceJpeg imgWidth imgHeight

          imageSize = imgWidth * imgHeight * compCount

          decodeProgressive = runST $ do
            let (st, wrotten) =
                   execRWS (mapM_ jpgMachineStep (jpgFrame img)) () emptyDecoderState
                Just fHdr = currentFrame st
            fimg <-
                progressiveUnpack
                    (maximumHorizontalResolution st, maximumVerticalResolution st)
                    fHdr
                    (quantizationMatrices st)
                    wrotten
            frozen <- unsafeFreezeImage fimg
            return (st, imageData frozen)

          decodeBaseline = runST $ do
            let (st, wrotten) =
                  execRWS (mapM_ jpgMachineStep (jpgFrame img)) () emptyDecoderState
                Just fHdr = currentFrame st
            resultImage <- M.new imageSize
            let wrapped = MutableImage imgWidth imgHeight resultImage
            fImg <- decodeImage
                fHdr
                (quantizationMatrices st)
                wrotten
                wrapped
            frozen <- unsafeFreezeImage fImg
            return (st, imageData frozen)

    extractBlock :: forall s px. (PixelBaseComponent px ~ Word8)
                 => Image px       -- ^ Source image
                 -> MutableMacroBlock s Int16      -- ^ Mutable block where to put extracted block
                 -> Int                     -- ^ Plane
                 -> Int                     -- ^ X sampling factor
                 -> Int                     -- ^ Y sampling factor
                 -> Int                     -- ^ Sample per pixel
                 -> Int                     -- ^ Block x
                 -> Int                     -- ^ Block y
                 -> ST s (MutableMacroBlock s Int16)
    extractBlock (Image { imageWidth = w, imageHeight = h, imageData = src })
                 block 1 1 sampCount plane bx by | (bx * dctBlockSize) + 7 < w && (by * 8) + 7 < h = do
        let baseReadIdx = (by * dctBlockSize * w) + bx * dctBlockSize
        sequence_ [(block `M.unsafeWrite` (y * dctBlockSize + x)) val
                            | y <- [0 .. dctBlockSize - 1]
                            , let blockReadIdx = baseReadIdx + y * w
                            , x <- [0 .. dctBlockSize - 1]
                            , let val = fromIntegral $ src `VS.unsafeIndex` ((blockReadIdx + x) * sampCount + plane)
                            ]
        return block
    extractBlock (Image { imageWidth = w, imageHeight = h, imageData = src })
                 block sampWidth sampHeight sampCount plane bx by = do
        let accessPixel x y | x < w && y < h = let idx = (y * w + x) * sampCount + plane in src `VS.unsafeIndex` idx
                            | x >= w = accessPixel (w - 1) y
                            | otherwise = accessPixel x (h - 1)

            pixelPerCoeff = fromIntegral $ sampWidth * sampHeight

            blockVal x y = sum [fromIntegral $ accessPixel (xBase + dx) (yBase + dy)
                                    | dy <- [0 .. sampHeight - 1]
                                    , dx <- [0 .. sampWidth - 1] ] `div` pixelPerCoeff
                where xBase = blockXBegin + x * sampWidth
                      yBase = blockYBegin + y * sampHeight

            blockXBegin = bx * dctBlockSize * sampWidth
            blockYBegin = by * dctBlockSize * sampHeight

        sequence_ [(block `M.unsafeWrite` (y * dctBlockSize + x)) $ blockVal x y | y <- [0 .. 7], x <- [0 .. 7] ]
        return block

    serializeMacroBlock :: BoolWriteStateRef s
                        -> HuffmanWriterCode -> HuffmanWriterCode
                        -> MutableMacroBlock s Int32
                        -> ST s ()
    serializeMacroBlock !st !dcCode !acCode !blk =
     (blk `M.unsafeRead` 0) >>= (fromIntegral >>> encodeDc) >> writeAcs (0, 1) >> return ()
      where writeAcs acc@(_, 63) =
                (blk `M.unsafeRead` 63) >>= (fromIntegral >>> encodeAcCoefs acc) >> return ()
            writeAcs acc@(_, i ) =
                (blk `M.unsafeRead`  i) >>= (fromIntegral >>> encodeAcCoefs acc) >>= writeAcs

            encodeDc n = writeBits' st (fromIntegral code) (fromIntegral bitCount)
                            >> when (ssss /= 0) (encodeInt st ssss n)
                where ssss = powerOf $ fromIntegral n
                      (bitCount, code) = dcCode `V.unsafeIndex` fromIntegral ssss

            encodeAc 0         0 = writeBits' st (fromIntegral code) $ fromIntegral bitCount
                where (bitCount, code) = acCode `V.unsafeIndex` 0

            encodeAc zeroCount n | zeroCount >= 16 =
              writeBits' st (fromIntegral code) (fromIntegral bitCount) >>  encodeAc (zeroCount - 16) n
                where (bitCount, code) = acCode `V.unsafeIndex` 0xF0
            encodeAc zeroCount n =
              writeBits' st (fromIntegral code) (fromIntegral bitCount) >> encodeInt st ssss n
                where rrrr = zeroCount `unsafeShiftL` 4
                      ssss = powerOf $ fromIntegral n
                      rrrrssss = rrrr .|. ssss
                      (bitCount, code) = acCode `V.unsafeIndex` fromIntegral rrrrssss

            encodeAcCoefs (            _, 63) 0 = encodeAc 0 0 >> return (0, 64)
            encodeAcCoefs (zeroRunLength,  i) 0 = return (zeroRunLength + 1, i + 1)
            encodeAcCoefs (zeroRunLength,  i) n =
                encodeAc zeroRunLength n >> return (0, i + 1)

    encodeMacroBlock :: QuantificationTable
                     -> MutableMacroBlock s Int32
                     -> MutableMacroBlock s Int32
                     -> Int16
                     -> MutableMacroBlock s Int16
                     -> ST s (Int32, MutableMacroBlock s Int32)
    encodeMacroBlock quantTableOfComponent workData finalData prev_dc block = do
     -- the inverse level shift is performed internally by the fastDCT routine
     blk <- fastDctLibJpeg workData block
            >>= zigZagReorderForward finalData
            >>= quantize quantTableOfComponent
     dc <- blk `M.unsafeRead` 0
     (blk `M.unsafeWrite` 0) $ dc - fromIntegral prev_dc
     return (dc, blk)

    divUpward :: (Integral a) => a -> a -> a
    divUpward n dividor = val + (if rest /= 0 then 1 else 0)
        where (val, rest) = n `divMod` dividor

    prepareHuffmanTable :: DctComponent -> Word8 -> HuffmanTable
                        -> (JpgHuffmanTableSpec, HuffmanPackedTree)
    prepareHuffmanTable classVal dest tableDef =
       (JpgHuffmanTableSpec { huffmanTableClass = classVal
                            , huffmanTableDest  = dest
                            , huffSizes = sizes
                            , huffCodes = V.fromListN 16
                                [VU.fromListN (fromIntegral $ sizes ! i) lst
                                                    | (i, lst) <- zip [0..] tableDef ]
                            }, VS.singleton 0)
          where sizes = VU.fromListN 16 $ map (fromIntegral . length) tableDef

    -- | Encode an image in jpeg at a reasonnable quality level.
    -- If you want better quality or reduced file size, you should
    -- use `encodeJpegAtQuality`
    encodeJpeg :: Image PixelYCbCr8 -> L.ByteString
    encodeJpeg = encodeJpegAtQuality 50

    defaultHuffmanTables :: [(JpgHuffmanTableSpec, HuffmanPackedTree)]
    defaultHuffmanTables =
        [ prepareHuffmanTable DcComponent 0 defaultDcLumaHuffmanTable
        , prepareHuffmanTable AcComponent 0 defaultAcLumaHuffmanTable
        , prepareHuffmanTable DcComponent 1 defaultDcChromaHuffmanTable
        , prepareHuffmanTable AcComponent 1 defaultAcChromaHuffmanTable
        ]

    lumaQuantTableAtQuality :: Int -> QuantificationTable
    lumaQuantTableAtQuality qual = scaleQuantisationMatrix qual defaultLumaQuantizationTable

    chromaQuantTableAtQuality :: Int -> QuantificationTable
    chromaQuantTableAtQuality qual =
      scaleQuantisationMatrix qual defaultChromaQuantizationTable

    zigzaggedQuantificationSpec :: Int -> [JpgQuantTableSpec]
    zigzaggedQuantificationSpec qual =
      [ JpgQuantTableSpec { quantPrecision = 0, quantDestination = 0, quantTable = luma }
      , JpgQuantTableSpec { quantPrecision = 0, quantDestination = 1, quantTable = chroma }
      ]
      where
        luma = zigZagReorderForwardv $ lumaQuantTableAtQuality qual
        chroma = zigZagReorderForwardv $ chromaQuantTableAtQuality qual

    -- | Function to call to encode an image to jpeg.
    -- The quality factor should be between 0 and 100 (100 being
    -- the best quality).
    encodeJpegAtQuality :: Word8                -- ^ Quality factor
                        -> Image PixelYCbCr8    -- ^ Image to encode
                        -> L.ByteString         -- ^ Encoded JPEG
    encodeJpegAtQuality quality = encodeJpegAtQualityWithMetadata quality mempty

    -- | Record gathering all information to encode a component
    -- from the source image. Previously was a huge tuple
    -- burried in the code
    data EncoderState = EncoderState
      { _encComponentIndex :: !Int
      , _encBlockWidth     :: !Int
      , _encBlockHeight    :: !Int
      , _encQuantTable     :: !QuantificationTable
      , _encDcHuffman      :: !HuffmanWriterCode
      , _encAcHuffman      :: !HuffmanWriterCode
      }

    -- | Helper type class describing all JPG-encodable pixel types
    class (Pixel px, PixelBaseComponent px ~ Word8) => JpgEncodable px where
      additionalBlocks :: Image px -> [JpgFrame]
      additionalBlocks _ = []

      componentsOfColorSpace :: Image px -> [JpgComponent]

      encodingState :: Int -> Image px -> V.Vector EncoderState

      imageHuffmanTables :: Image px -> [(JpgHuffmanTableSpec, HuffmanPackedTree)]
      imageHuffmanTables _ = defaultHuffmanTables

      scanSpecificationOfColorSpace :: Image px -> [JpgScanSpecification]

      quantTableSpec :: Image px -> Int -> [JpgQuantTableSpec]
      quantTableSpec _ qual = take 1 $ zigzaggedQuantificationSpec qual

      maximumSubSamplingOf :: Image px -> Int
      maximumSubSamplingOf _ = 1

    instance JpgEncodable Pixel8 where
      scanSpecificationOfColorSpace _ =
        [ JpgScanSpecification { componentSelector = 1
                               , dcEntropyCodingTable = 0
                               , acEntropyCodingTable = 0
                               }
        ]

      componentsOfColorSpace _ =
        [ JpgComponent { componentIdentifier      = 1
                       , horizontalSamplingFactor = 1
                       , verticalSamplingFactor   = 1
                       , quantizationTableDest    = 0
                       }
        ]

      imageHuffmanTables _ =
        [ prepareHuffmanTable DcComponent 0 defaultDcLumaHuffmanTable
        , prepareHuffmanTable AcComponent 0 defaultAcLumaHuffmanTable
        ]

      encodingState qual _ = V.singleton EncoderState
         { _encComponentIndex = 0
         , _encBlockWidth     = 1
         , _encBlockHeight    = 1
         , _encQuantTable     = zigZagReorderForwardv $ lumaQuantTableAtQuality qual
         , _encDcHuffman      = makeInverseTable defaultDcLumaHuffmanTree
         , _encAcHuffman      = makeInverseTable defaultAcLumaHuffmanTree
         }

    instance JpgEncodable PixelYCbCr8 where
      maximumSubSamplingOf _ = 2
      quantTableSpec _ qual = zigzaggedQuantificationSpec qual
      scanSpecificationOfColorSpace _ =
        [ JpgScanSpecification { componentSelector = 1
                               , dcEntropyCodingTable = 0
                               , acEntropyCodingTable = 0
                               }
        , JpgScanSpecification { componentSelector = 2
                               , dcEntropyCodingTable = 1
                               , acEntropyCodingTable = 1
                               }
        , JpgScanSpecification { componentSelector = 3
                               , dcEntropyCodingTable = 1
                               , acEntropyCodingTable = 1
                               }
        ]

      componentsOfColorSpace _ =
        [ JpgComponent { componentIdentifier      = 1
                       , horizontalSamplingFactor = 2
                       , verticalSamplingFactor   = 2
                       , quantizationTableDest    = 0
                       }
        , JpgComponent { componentIdentifier      = 2
                       , horizontalSamplingFactor = 1
                       , verticalSamplingFactor   = 1
                       , quantizationTableDest    = 1
                       }
        , JpgComponent { componentIdentifier      = 3
                       , horizontalSamplingFactor = 1
                       , verticalSamplingFactor   = 1
                       , quantizationTableDest    = 1
                       }
        ]

      encodingState qual _ = V.fromListN 3 [lumaState, chromaState, chromaState { _encComponentIndex = 2 }]
        where
          lumaState = EncoderState
            { _encComponentIndex = 0
            , _encBlockWidth     = 2
            , _encBlockHeight    = 2
            , _encQuantTable     = zigZagReorderForwardv $ lumaQuantTableAtQuality qual
            , _encDcHuffman      = makeInverseTable defaultDcLumaHuffmanTree
            , _encAcHuffman      = makeInverseTable defaultAcLumaHuffmanTree
            }
          chromaState = EncoderState
            { _encComponentIndex = 1
            , _encBlockWidth     = 1
            , _encBlockHeight    = 1
            , _encQuantTable     = zigZagReorderForwardv $ chromaQuantTableAtQuality qual
            , _encDcHuffman      = makeInverseTable defaultDcChromaHuffmanTree
            , _encAcHuffman      = makeInverseTable defaultAcChromaHuffmanTree
            }

    instance JpgEncodable PixelRGB8 where
      additionalBlocks _ = [JpgAdobeAPP14 adobe14] where
        adobe14 = JpgAdobeApp14
            { _adobeDctVersion = 100
            , _adobeFlag0      = 0
            , _adobeFlag1      = 0
            , _adobeTransform  = AdobeUnknown
            }

      imageHuffmanTables _ =
        [ prepareHuffmanTable DcComponent 0 defaultDcLumaHuffmanTable
        , prepareHuffmanTable AcComponent 0 defaultAcLumaHuffmanTable
        ]

      scanSpecificationOfColorSpace _ = fmap build "RGB" where
        build c = JpgScanSpecification
          { componentSelector = fromIntegral $ fromEnum c
          , dcEntropyCodingTable = 0
          , acEntropyCodingTable = 0
          }

      componentsOfColorSpace _ = fmap build "RGB" where
        build c = JpgComponent
          { componentIdentifier      = fromIntegral $ fromEnum c
          , horizontalSamplingFactor = 1
          , verticalSamplingFactor   = 1
          , quantizationTableDest    = 0
          }

      encodingState qual _ = V.fromListN 3 $ fmap build [0 .. 2] where
        build ix = EncoderState
          { _encComponentIndex = ix
          , _encBlockWidth     = 1
          , _encBlockHeight    = 1
          , _encQuantTable     = zigZagReorderForwardv $ lumaQuantTableAtQuality qual
          , _encDcHuffman      = makeInverseTable defaultDcLumaHuffmanTree
          , _encAcHuffman      = makeInverseTable defaultAcLumaHuffmanTree
          }

    instance JpgEncodable PixelCMYK8 where
      additionalBlocks _ = [] where
        _adobe14 = JpgAdobeApp14
            { _adobeDctVersion = 100
            , _adobeFlag0      = 32768
            , _adobeFlag1      = 0
            , _adobeTransform  = AdobeYCck
            }

      imageHuffmanTables _ =
        [ prepareHuffmanTable DcComponent 0 defaultDcLumaHuffmanTable
        , prepareHuffmanTable AcComponent 0 defaultAcLumaHuffmanTable
        ]

      scanSpecificationOfColorSpace _ = fmap build "CMYK" where
        build c = JpgScanSpecification
          { componentSelector = fromIntegral $ fromEnum c
          , dcEntropyCodingTable = 0
          , acEntropyCodingTable = 0
          }

      componentsOfColorSpace _ = fmap build "CMYK" where
        build c = JpgComponent
          { componentIdentifier      = fromIntegral $ fromEnum c
          , horizontalSamplingFactor = 1
          , verticalSamplingFactor   = 1
          , quantizationTableDest    = 0
          }

      encodingState qual _ = V.fromListN 4 $ fmap build [0 .. 3] where
        build ix = EncoderState
          { _encComponentIndex = ix
          , _encBlockWidth     = 1
          , _encBlockHeight    = 1
          , _encQuantTable     = zigZagReorderForwardv $ lumaQuantTableAtQuality qual
          , _encDcHuffman      = makeInverseTable defaultDcLumaHuffmanTree
          , _encAcHuffman      = makeInverseTable defaultAcLumaHuffmanTree
          }

    -- | Equivalent to 'encodeJpegAtQuality', but will store the following
    -- metadatas in the file using a JFIF block:
    --
    --  * 'Codec.Picture.Metadata.DpiX'
    --  * 'Codec.Picture.Metadata.DpiY'
    --
    encodeJpegAtQualityWithMetadata :: Word8                -- ^ Quality factor
                                    -> Metadatas
                                    -> Image PixelYCbCr8    -- ^ Image to encode
                                    -> L.ByteString         -- ^ Encoded JPEG
    encodeJpegAtQualityWithMetadata = encodeDirectJpegAtQualityWithMetadata

    -- | Equivalent to 'encodeJpegAtQuality', but will store the following
    -- metadatas in the file using a JFIF block:
    --
    --  * 'Codec.Picture.Metadata.DpiX'
    --  * 'Codec.Picture.Metadata.DpiY'
    --
    -- This function also allow to create JPEG files with the following color
    -- space:
    --
    --  * Y ('Pixel8') for greyscale.
    --  * RGB ('PixelRGB8') with no color downsampling on any plane
    --  * CMYK ('PixelCMYK8') with no color downsampling on any plane
    --
    encodeDirectJpegAtQualityWithMetadata :: forall px. (JpgEncodable px)
                                          => Word8                -- ^ Quality factor
                                          -> Metadatas
                                          -> Image px             -- ^ Image to encode
                                          -> L.ByteString         -- ^ Encoded JPEG
    encodeDirectJpegAtQualityWithMetadata quality metas img = encode finalImage where
      !w = imageWidth img
      !h = imageHeight img
      !exifMeta = case encodeTiffStringMetadata metas of
         [] -> []
         lst -> [JpgExif lst]
      finalImage = JpgImage $
          encodeMetadatas metas ++
          exifMeta ++
          additionalBlocks img ++
          [ JpgQuantTable $ quantTableSpec img (fromIntegral quality)
          , JpgScans JpgBaselineDCTHuffman hdr
          , JpgHuffmanTable $ imageHuffmanTables img
          , JpgScanBlob scanHeader encodedImage
          ]

      !outputComponentCount = componentCount (undefined :: px)

      scanHeader = scanHeader'{ scanLength = fromIntegral $ calculateSize scanHeader' }
      scanHeader' = JpgScanHeader
          { scanLength = 0
          , scanComponentCount = fromIntegral outputComponentCount
          , scans = scanSpecificationOfColorSpace img
          , spectralSelection = (0, 63)
          , successiveApproxHigh = 0
          , successiveApproxLow  = 0
          }

      hdr = hdr' { jpgFrameHeaderLength   = fromIntegral $ calculateSize hdr' }
      hdr' = JpgFrameHeader
        { jpgFrameHeaderLength   = 0
        , jpgSamplePrecision     = 8
        , jpgHeight              = fromIntegral h
        , jpgWidth               = fromIntegral w
        , jpgImageComponentCount = fromIntegral outputComponentCount
        , jpgComponents          = componentsOfColorSpace img
        }

      !maxSampling = maximumSubSamplingOf img
      !horizontalMetaBlockCount = w `divUpward` (dctBlockSize * maxSampling)
      !verticalMetaBlockCount = h `divUpward` (dctBlockSize * maxSampling)
      !componentDef = encodingState (fromIntegral quality) img

      encodedImage = runST $ do
        dc_table <- M.replicate outputComponentCount 0
        block <- createEmptyMutableMacroBlock
        workData <- createEmptyMutableMacroBlock
        zigzaged <- createEmptyMutableMacroBlock
        writeState <- newWriteStateRef

        rasterMap horizontalMetaBlockCount verticalMetaBlockCount $ \mx my ->
          V.forM_ componentDef $ \(EncoderState comp sizeX sizeY table dc ac) ->
            let !xSamplingFactor = maxSampling - sizeX + 1
                !ySamplingFactor = maxSampling - sizeY + 1
                !extractor = extractBlock img block xSamplingFactor ySamplingFactor outputComponentCount
            in
            rasterMap sizeX sizeY $ \subX subY -> do
              let !blockY = my * sizeY + subY
                  !blockX = mx * sizeX + subX
              prev_dc <- dc_table `M.unsafeRead` comp
              extracted <- extractor comp blockX blockY
              (dc_coeff, neo_block) <- encodeMacroBlock table workData zigzaged prev_dc extracted
              (dc_table `M.unsafeWrite` comp) $ fromIntegral dc_coeff
              serializeMacroBlock writeState dc ac neo_block

        finalizeBoolWriter writeState