{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE CPP #-}
module Codec.Picture.Jpg.Internal.Types( MutableMacroBlock
                              , createEmptyMutableMacroBlock
                              , printMacroBlock
                              , printPureMacroBlock
                              , DcCoefficient
                              , JpgImage( .. )
                              , JpgComponent( .. )
                              , JpgFrameHeader( .. )
                              , JpgFrame( .. )
                              , JpgFrameKind( .. )
                              , JpgScanHeader( .. )
                              , JpgQuantTableSpec( .. )
                              , JpgHuffmanTableSpec( .. )
                              , JpgImageKind( .. )
                              , JpgScanSpecification( .. )
                              , JpgColorSpace( .. )
                              , AdobeTransform( .. )
                              , JpgAdobeApp14( .. )
                              , JpgJFIFApp0( .. )
                              , JFifUnit( .. )
                              , calculateSize
                              , dctBlockSize
                              ) where


#if !MIN_VERSION_base(4,8,0)
import Control.Applicative( pure, (<*>), (<$>) )
#endif

import Control.Monad( when, replicateM, forM, forM_, unless )
import Control.Monad.ST( ST )
import Data.Bits( (.|.), (.&.), unsafeShiftL, unsafeShiftR )
import Data.List( partition )

#if !MIN_VERSION_base(4,11,0)
import Data.Monoid( (<>) )
#endif

import Foreign.Storable ( Storable )
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.Char8 as BC
import qualified Data.ByteString.Lazy as L

import Data.Int( Int16 )
import Data.Word(Word8, Word16 )
import Data.Binary( Binary(..) )

import Data.Binary.Get( Get
                      , getWord8
                      , getWord16be
                      , getByteString
                      , skip
                      , bytesRead
                      )

import Data.Binary.Put( Put
                      , putWord8
                      , putWord16be
                      , putLazyByteString
                      , putByteString
                      , runPut
                      )

import Codec.Picture.InternalHelper
import Codec.Picture.Jpg.Internal.DefaultTable
import Codec.Picture.Tiff.Internal.Types
import Codec.Picture.Tiff.Internal.Metadata( exifOffsetIfd )
import Codec.Picture.Metadata.Exif

{-import Debug.Trace-}
import Text.Printf

-- | Type only used to make clear what kind of integer we are carrying

-- Might be transformed into newtype in the future

type DcCoefficient = Int16

-- | Macroblock that can be transformed.

type MutableMacroBlock s a = M.STVector s a

data JpgFrameKind =
      JpgBaselineDCTHuffman
    | JpgExtendedSequentialDCTHuffman
    | JpgProgressiveDCTHuffman
    | JpgLosslessHuffman
    | JpgDifferentialSequentialDCTHuffman
    | JpgDifferentialProgressiveDCTHuffman
    | JpgDifferentialLosslessHuffman
    | JpgExtendedSequentialArithmetic
    | JpgProgressiveDCTArithmetic
    | JpgLosslessArithmetic
    | JpgDifferentialSequentialDCTArithmetic
    | JpgDifferentialProgressiveDCTArithmetic
    | JpgDifferentialLosslessArithmetic
    | JpgQuantizationTable
    | JpgHuffmanTableMarker
    | JpgStartOfScan
    | JpgEndOfImage
    | JpgAppSegment Word8
    | JpgExtensionSegment Word8

    | JpgRestartInterval
    | JpgRestartIntervalEnd Word8
    deriving (JpgFrameKind -> JpgFrameKind -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: JpgFrameKind -> JpgFrameKind -> Bool
$c/= :: JpgFrameKind -> JpgFrameKind -> Bool
== :: JpgFrameKind -> JpgFrameKind -> Bool
$c== :: JpgFrameKind -> JpgFrameKind -> Bool
Eq, Int -> JpgFrameKind -> ShowS
[JpgFrameKind] -> ShowS
JpgFrameKind -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [JpgFrameKind] -> ShowS
$cshowList :: [JpgFrameKind] -> ShowS
show :: JpgFrameKind -> String
$cshow :: JpgFrameKind -> String
showsPrec :: Int -> JpgFrameKind -> ShowS
$cshowsPrec :: Int -> JpgFrameKind -> ShowS
Show)

data JpgFrame =
      JpgAppFrame        !Word8 B.ByteString
    | JpgAdobeAPP14      !JpgAdobeApp14
    | JpgJFIF            !JpgJFIFApp0
    | JpgExif            ![ImageFileDirectory]
    | JpgExtension       !Word8 B.ByteString
    | JpgQuantTable      ![JpgQuantTableSpec]
    | JpgHuffmanTable    ![(JpgHuffmanTableSpec, HuffmanPackedTree)]
    | JpgScanBlob        !JpgScanHeader !L.ByteString
    | JpgScans           !JpgFrameKind !JpgFrameHeader
    | JpgIntervalRestart !Word16
    deriving Int -> JpgFrame -> ShowS
[JpgFrame] -> ShowS
JpgFrame -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [JpgFrame] -> ShowS
$cshowList :: [JpgFrame] -> ShowS
show :: JpgFrame -> String
$cshow :: JpgFrame -> String
showsPrec :: Int -> JpgFrame -> ShowS
$cshowsPrec :: Int -> JpgFrame -> ShowS
Show

data JpgColorSpace
  = JpgColorSpaceYCbCr
  | JpgColorSpaceYCC
  | JpgColorSpaceY
  | JpgColorSpaceYA
  | JpgColorSpaceYCCA
  | JpgColorSpaceYCCK
  | JpgColorSpaceCMYK
  | JpgColorSpaceRGB
  | JpgColorSpaceRGBA
  deriving Int -> JpgColorSpace -> ShowS
[JpgColorSpace] -> ShowS
JpgColorSpace -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [JpgColorSpace] -> ShowS
$cshowList :: [JpgColorSpace] -> ShowS
show :: JpgColorSpace -> String
$cshow :: JpgColorSpace -> String
showsPrec :: Int -> JpgColorSpace -> ShowS
$cshowsPrec :: Int -> JpgColorSpace -> ShowS
Show

data AdobeTransform
  = AdobeUnknown    -- ^ Value 0

  | AdobeYCbCr      -- ^ value 1

  | AdobeYCck       -- ^ value 2

  deriving Int -> AdobeTransform -> ShowS
[AdobeTransform] -> ShowS
AdobeTransform -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AdobeTransform] -> ShowS
$cshowList :: [AdobeTransform] -> ShowS
show :: AdobeTransform -> String
$cshow :: AdobeTransform -> String
showsPrec :: Int -> AdobeTransform -> ShowS
$cshowsPrec :: Int -> AdobeTransform -> ShowS
Show

data JpgAdobeApp14 = JpgAdobeApp14
  { JpgAdobeApp14 -> Word16
_adobeDctVersion :: !Word16
  , JpgAdobeApp14 -> Word16
_adobeFlag0      :: !Word16
  , JpgAdobeApp14 -> Word16
_adobeFlag1      :: !Word16
  , JpgAdobeApp14 -> AdobeTransform
_adobeTransform  :: !AdobeTransform
  }
  deriving Int -> JpgAdobeApp14 -> ShowS
[JpgAdobeApp14] -> ShowS
JpgAdobeApp14 -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [JpgAdobeApp14] -> ShowS
$cshowList :: [JpgAdobeApp14] -> ShowS
show :: JpgAdobeApp14 -> String
$cshow :: JpgAdobeApp14 -> String
showsPrec :: Int -> JpgAdobeApp14 -> ShowS
$cshowsPrec :: Int -> JpgAdobeApp14 -> ShowS
Show

-- | Size: 1

data JFifUnit
  = JFifUnitUnknown   -- ^ 0

  | JFifPixelsPerInch -- ^ 1

  | JFifPixelsPerCentimeter -- ^ 2

  deriving Int -> JFifUnit -> ShowS
[JFifUnit] -> ShowS
JFifUnit -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [JFifUnit] -> ShowS
$cshowList :: [JFifUnit] -> ShowS
show :: JFifUnit -> String
$cshow :: JFifUnit -> String
showsPrec :: Int -> JFifUnit -> ShowS
$cshowsPrec :: Int -> JFifUnit -> ShowS
Show

instance Binary JFifUnit where
  put :: JFifUnit -> Put
put JFifUnit
v = Word8 -> Put
putWord8 forall a b. (a -> b) -> a -> b
$ case JFifUnit
v of
    JFifUnit
JFifUnitUnknown -> Word8
0
    JFifUnit
JFifPixelsPerInch -> Word8
1
    JFifUnit
JFifPixelsPerCentimeter -> Word8
2
  get :: Get JFifUnit
get = do
    Word8
v <- Get Word8
getWord8
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ case Word8
v of
      Word8
0 -> JFifUnit
JFifUnitUnknown
      Word8
1 -> JFifUnit
JFifPixelsPerInch
      Word8
2 -> JFifUnit
JFifPixelsPerCentimeter
      Word8
_ -> JFifUnit
JFifUnitUnknown

data JpgJFIFApp0 = JpgJFIFApp0
  { JpgJFIFApp0 -> JFifUnit
_jfifUnit      :: !JFifUnit
  , JpgJFIFApp0 -> Word16
_jfifDpiX      :: !Word16
  , JpgJFIFApp0 -> Word16
_jfifDpiY      :: !Word16
  , JpgJFIFApp0 -> Maybe Int
_jfifThumbnail :: !(Maybe {- (Image PixelRGB8) -} Int)
  }
  deriving Int -> JpgJFIFApp0 -> ShowS
[JpgJFIFApp0] -> ShowS
JpgJFIFApp0 -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [JpgJFIFApp0] -> ShowS
$cshowList :: [JpgJFIFApp0] -> ShowS
show :: JpgJFIFApp0 -> String
$cshow :: JpgJFIFApp0 -> String
showsPrec :: Int -> JpgJFIFApp0 -> ShowS
$cshowsPrec :: Int -> JpgJFIFApp0 -> ShowS
Show

instance Binary JpgJFIFApp0 where
  get :: Get JpgJFIFApp0
get = do
    ByteString
sig <- Int -> Get ByteString
getByteString Int
5
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString
sig forall a. Eq a => a -> a -> Bool
/= String -> ByteString
BC.pack String
"JFIF\0") forall a b. (a -> b) -> a -> b
$
        forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Invalid JFIF signature"
    Word8
major <- Get Word8
getWord8
    Word8
minor <- Get Word8
getWord8
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Word8
major forall a. Eq a => a -> a -> Bool
/= Word8
1 Bool -> Bool -> Bool
&& Word8
minor forall a. Ord a => a -> a -> Bool
> Word8
2) forall a b. (a -> b) -> a -> b
$
        forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Unrecognize JFIF version"
    JFifUnit
unit <- forall t. Binary t => Get t
get
    Word16
dpiX <- Get Word16
getWord16be
    Word16
dpiY <- Get Word16
getWord16be
    Word8
w <- Get Word8
getWord8
    Word8
h <- Get Word8
getWord8
    let pxCount :: Word8
pxCount = Word8
3 forall a. Num a => a -> a -> a
* Word8
w forall a. Num a => a -> a -> a
* Word8
h
    Maybe Int
img <- case Word8
pxCount of
      Word8
0 -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
      Word8
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ JpgJFIFApp0
        { _jfifUnit :: JFifUnit
_jfifUnit      = JFifUnit
unit
        , _jfifDpiX :: Word16
_jfifDpiX      = Word16
dpiX
        , _jfifDpiY :: Word16
_jfifDpiY      = Word16
dpiY
        , _jfifThumbnail :: Maybe Int
_jfifThumbnail = Maybe Int
img
        }


  put :: JpgJFIFApp0 -> Put
put JpgJFIFApp0
jfif = do
    ByteString -> Put
putByteString forall a b. (a -> b) -> a -> b
$ String -> ByteString
BC.pack String
"JFIF\0" -- 5

    Word8 -> Put
putWord8 Word8
1                       -- 1 6

    Word8 -> Put
putWord8 Word8
2                       -- 1 7

    forall t. Binary t => t -> Put
put forall a b. (a -> b) -> a -> b
$ JpgJFIFApp0 -> JFifUnit
_jfifUnit JpgJFIFApp0
jfif             -- 1 8

    Word16 -> Put
putWord16be forall a b. (a -> b) -> a -> b
$ JpgJFIFApp0 -> Word16
_jfifDpiX JpgJFIFApp0
jfif     -- 2 10

    Word16 -> Put
putWord16be forall a b. (a -> b) -> a -> b
$ JpgJFIFApp0 -> Word16
_jfifDpiY JpgJFIFApp0
jfif     -- 2 12

    Word8 -> Put
putWord8 Word8
0                       -- 1 13

    Word8 -> Put
putWord8 Word8
0                       -- 1 14


{-Thumbnail width (tw) 	1 	Horizontal size of embedded JFIF thumbnail in pixels-}
{-Thumbnail height (th) 	1 	Vertical size of embedded JFIF thumbnail in pixels-}
{-Thumbnail data 	3 × tw × th 	Uncompressed 24 bit RGB raster thumbnail-}

instance Binary AdobeTransform where
  put :: AdobeTransform -> Put
put AdobeTransform
v = case AdobeTransform
v of
    AdobeTransform
AdobeUnknown -> Word8 -> Put
putWord8 Word8
0
    AdobeTransform
AdobeYCbCr -> Word8 -> Put
putWord8 Word8
1
    AdobeTransform
AdobeYCck -> Word8 -> Put
putWord8 Word8
2

  get :: Get AdobeTransform
get = do
    Word8
v <- Get Word8
getWord8
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ case Word8
v of
      Word8
0 -> AdobeTransform
AdobeUnknown
      Word8
1 -> AdobeTransform
AdobeYCbCr
      Word8
2 -> AdobeTransform
AdobeYCck
      Word8
_ -> AdobeTransform
AdobeUnknown

instance Binary JpgAdobeApp14 where
  get :: Get JpgAdobeApp14
get = do
    let sig :: ByteString
sig = String -> ByteString
BC.pack String
"Adobe"
    ByteString
fileSig <- Int -> Get ByteString
getByteString Int
5
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString
fileSig forall a. Eq a => a -> a -> Bool
/= ByteString
sig) forall a b. (a -> b) -> a -> b
$
       forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Invalid Adobe APP14 marker"
    Word16
version <- Get Word16
getWord16be
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Word16
version forall a. Eq a => a -> a -> Bool
/= Word16
100) forall a b. (a -> b) -> a -> b
$
       forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Invalid Adobe APP14 version " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Word16
version
    Word16 -> Word16 -> Word16 -> AdobeTransform -> JpgAdobeApp14
JpgAdobeApp14 Word16
version
                  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word16
getWord16be
                  forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get Word16
getWord16be forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall t. Binary t => Get t
get

  put :: JpgAdobeApp14 -> Put
put (JpgAdobeApp14 Word16
v Word16
f0 Word16
f1 AdobeTransform
t) = do
    ByteString -> Put
putByteString forall a b. (a -> b) -> a -> b
$ String -> ByteString
BC.pack String
"Adobe"
    Word16 -> Put
putWord16be Word16
v
    Word16 -> Put
putWord16be Word16
f0
    Word16 -> Put
putWord16be Word16
f1
    forall t. Binary t => t -> Put
put AdobeTransform
t


data JpgFrameHeader = JpgFrameHeader
    { JpgFrameHeader -> Word16
jpgFrameHeaderLength   :: !Word16
    , JpgFrameHeader -> Word8
jpgSamplePrecision     :: !Word8
    , JpgFrameHeader -> Word16
jpgHeight              :: !Word16
    , JpgFrameHeader -> Word16
jpgWidth               :: !Word16
    , JpgFrameHeader -> Word8
jpgImageComponentCount :: !Word8
    , JpgFrameHeader -> [JpgComponent]
jpgComponents          :: ![JpgComponent]
    }
    deriving Int -> JpgFrameHeader -> ShowS
[JpgFrameHeader] -> ShowS
JpgFrameHeader -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [JpgFrameHeader] -> ShowS
$cshowList :: [JpgFrameHeader] -> ShowS
show :: JpgFrameHeader -> String
$cshow :: JpgFrameHeader -> String
showsPrec :: Int -> JpgFrameHeader -> ShowS
$cshowsPrec :: Int -> JpgFrameHeader -> ShowS
Show


instance SizeCalculable JpgFrameHeader where
    calculateSize :: JpgFrameHeader -> Int
calculateSize JpgFrameHeader
hdr = Int
2 forall a. Num a => a -> a -> a
+ Int
1 forall a. Num a => a -> a -> a
+ Int
2 forall a. Num a => a -> a -> a
+ Int
2 forall a. Num a => a -> a -> a
+ Int
1
                      forall a. Num a => a -> a -> a
+ forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [forall a. SizeCalculable a => a -> Int
calculateSize JpgComponent
c | JpgComponent
c <- JpgFrameHeader -> [JpgComponent]
jpgComponents JpgFrameHeader
hdr]

data JpgComponent = JpgComponent
    { JpgComponent -> Word8
componentIdentifier       :: !Word8
      -- | Stored with 4 bits

    , JpgComponent -> Word8
horizontalSamplingFactor  :: !Word8
      -- | Stored with 4 bits

    , JpgComponent -> Word8
verticalSamplingFactor    :: !Word8
    , JpgComponent -> Word8
quantizationTableDest     :: !Word8
    }
    deriving Int -> JpgComponent -> ShowS
[JpgComponent] -> ShowS
JpgComponent -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [JpgComponent] -> ShowS
$cshowList :: [JpgComponent] -> ShowS
show :: JpgComponent -> String
$cshow :: JpgComponent -> String
showsPrec :: Int -> JpgComponent -> ShowS
$cshowsPrec :: Int -> JpgComponent -> ShowS
Show

instance SizeCalculable JpgComponent where
    calculateSize :: JpgComponent -> Int
calculateSize JpgComponent
_ = Int
3

data JpgImage = JpgImage { JpgImage -> [JpgFrame]
jpgFrame :: [JpgFrame] }
    deriving Int -> JpgImage -> ShowS
[JpgImage] -> ShowS
JpgImage -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [JpgImage] -> ShowS
$cshowList :: [JpgImage] -> ShowS
show :: JpgImage -> String
$cshow :: JpgImage -> String
showsPrec :: Int -> JpgImage -> ShowS
$cshowsPrec :: Int -> JpgImage -> ShowS
Show

data JpgScanSpecification = JpgScanSpecification
    { JpgScanSpecification -> Word8
componentSelector :: !Word8
      -- | Encoded as 4 bits

    , JpgScanSpecification -> Word8
dcEntropyCodingTable :: !Word8
      -- | Encoded as 4 bits

    , JpgScanSpecification -> Word8
acEntropyCodingTable :: !Word8

    }
    deriving Int -> JpgScanSpecification -> ShowS
[JpgScanSpecification] -> ShowS
JpgScanSpecification -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [JpgScanSpecification] -> ShowS
$cshowList :: [JpgScanSpecification] -> ShowS
show :: JpgScanSpecification -> String
$cshow :: JpgScanSpecification -> String
showsPrec :: Int -> JpgScanSpecification -> ShowS
$cshowsPrec :: Int -> JpgScanSpecification -> ShowS
Show

instance SizeCalculable JpgScanSpecification where
    calculateSize :: JpgScanSpecification -> Int
calculateSize JpgScanSpecification
_ = Int
2

data JpgScanHeader = JpgScanHeader
    { JpgScanHeader -> Word16
scanLength :: !Word16
    , JpgScanHeader -> Word8
scanComponentCount :: !Word8
    , JpgScanHeader -> [JpgScanSpecification]
scans :: [JpgScanSpecification]

      -- | (begin, end)

    , JpgScanHeader -> (Word8, Word8)
spectralSelection    :: (Word8, Word8)

      -- | Encoded as 4 bits

    , JpgScanHeader -> Word8
successiveApproxHigh :: !Word8

      -- | Encoded as 4 bits

    , JpgScanHeader -> Word8
successiveApproxLow :: !Word8
    }
    deriving Int -> JpgScanHeader -> ShowS
[JpgScanHeader] -> ShowS
JpgScanHeader -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [JpgScanHeader] -> ShowS
$cshowList :: [JpgScanHeader] -> ShowS
show :: JpgScanHeader -> String
$cshow :: JpgScanHeader -> String
showsPrec :: Int -> JpgScanHeader -> ShowS
$cshowsPrec :: Int -> JpgScanHeader -> ShowS
Show

instance SizeCalculable JpgScanHeader where
    calculateSize :: JpgScanHeader -> Int
calculateSize JpgScanHeader
hdr = Int
2 forall a. Num a => a -> a -> a
+ Int
1
                      forall a. Num a => a -> a -> a
+ forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [forall a. SizeCalculable a => a -> Int
calculateSize JpgScanSpecification
c | JpgScanSpecification
c <- JpgScanHeader -> [JpgScanSpecification]
scans JpgScanHeader
hdr]
                      forall a. Num a => a -> a -> a
+ Int
2
                      forall a. Num a => a -> a -> a
+ Int
1

data JpgQuantTableSpec = JpgQuantTableSpec
    { -- | Stored on 4 bits

      JpgQuantTableSpec -> Word8
quantPrecision     :: !Word8

      -- | Stored on 4 bits

    , JpgQuantTableSpec -> Word8
quantDestination   :: !Word8

    , JpgQuantTableSpec -> MacroBlock Int16
quantTable         :: MacroBlock Int16
    }
    deriving Int -> JpgQuantTableSpec -> ShowS
[JpgQuantTableSpec] -> ShowS
JpgQuantTableSpec -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [JpgQuantTableSpec] -> ShowS
$cshowList :: [JpgQuantTableSpec] -> ShowS
show :: JpgQuantTableSpec -> String
$cshow :: JpgQuantTableSpec -> String
showsPrec :: Int -> JpgQuantTableSpec -> ShowS
$cshowsPrec :: Int -> JpgQuantTableSpec -> ShowS
Show

class SizeCalculable a where
    calculateSize :: a -> Int

-- | Type introduced only to avoid some typeclass overlapping

-- problem

newtype TableList a = TableList [a]

instance (SizeCalculable a, Binary a) => Binary (TableList a) where
    put :: TableList a -> Put
put (TableList [a]
lst) = do
        Word16 -> Put
putWord16be forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [forall a. SizeCalculable a => a -> Int
calculateSize a
table | a
table <- [a]
lst] forall a. Num a => a -> a -> a
+ Int
2
        forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall t. Binary t => t -> Put
put [a]
lst

    get :: Get (TableList a)
get = forall a. [a] -> TableList a
TableList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Get Word16
getWord16be forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Word16
s -> Int -> Get [a]
innerParse (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
s forall a. Num a => a -> a -> a
- Int
2))
      where innerParse :: Int -> Get [a]
            innerParse :: Int -> Get [a]
innerParse Int
0    = forall (m :: * -> *) a. Monad m => a -> m a
return []
            innerParse Int
size = do
                Int
onStart <- forall a b. (Integral a, Num b) => a -> b
fromIntegral forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Int64
bytesRead
                a
table <- forall t. Binary t => Get t
get
                Int
onEnd <- forall a b. (Integral a, Num b) => a -> b
fromIntegral forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Int64
bytesRead
                (a
table forall a. a -> [a] -> [a]
:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Get [a]
innerParse (Int
size forall a. Num a => a -> a -> a
- (Int
onEnd forall a. Num a => a -> a -> a
- Int
onStart))

instance SizeCalculable JpgQuantTableSpec where
    calculateSize :: JpgQuantTableSpec -> Int
calculateSize JpgQuantTableSpec
table =
        Int
1 forall a. Num a => a -> a -> a
+ (forall a b. (Integral a, Num b) => a -> b
fromIntegral (JpgQuantTableSpec -> Word8
quantPrecision JpgQuantTableSpec
table) forall a. Num a => a -> a -> a
+ Int
1) forall a. Num a => a -> a -> a
* Int
64

instance Binary JpgQuantTableSpec where
    put :: JpgQuantTableSpec -> Put
put JpgQuantTableSpec
table = do
        let precision :: Word8
precision = JpgQuantTableSpec -> Word8
quantPrecision JpgQuantTableSpec
table
        Word8 -> Word8 -> Put
put4BitsOfEach Word8
precision (JpgQuantTableSpec -> Word8
quantDestination JpgQuantTableSpec
table)
        forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall a. Storable a => Vector a -> [a]
VS.toList forall a b. (a -> b) -> a -> b
$ JpgQuantTableSpec -> MacroBlock Int16
quantTable JpgQuantTableSpec
table) forall a b. (a -> b) -> a -> b
$ \Int16
coeff ->
            if Word8
precision forall a. Eq a => a -> a -> Bool
== Word8
0 then Word8 -> Put
putWord8 forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int16
coeff
                             else Word16 -> Put
putWord16be forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int16
coeff

    get :: Get JpgQuantTableSpec
get = do
        (Word8
precision, Word8
dest) <- Get (Word8, Word8)
get4BitOfEach
        [Int16]
coeffs <- forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
64 forall a b. (a -> b) -> a -> b
$ if Word8
precision forall a. Eq a => a -> a -> Bool
== Word8
0
                then forall a b. (Integral a, Num b) => a -> b
fromIntegral forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word8
getWord8
                else forall a b. (Integral a, Num b) => a -> b
fromIntegral forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word16
getWord16be
        forall (m :: * -> *) a. Monad m => a -> m a
return JpgQuantTableSpec
            { quantPrecision :: Word8
quantPrecision = Word8
precision
            , quantDestination :: Word8
quantDestination = Word8
dest
            , quantTable :: MacroBlock Int16
quantTable = forall a. Storable a => Int -> [a] -> Vector a
VS.fromListN Int
64 [Int16]
coeffs
            }

data JpgHuffmanTableSpec = JpgHuffmanTableSpec
    { -- | 0 : DC, 1 : AC, stored on 4 bits

      JpgHuffmanTableSpec -> DctComponent
huffmanTableClass       :: !DctComponent
      -- | Stored on 4 bits

    , JpgHuffmanTableSpec -> Word8
huffmanTableDest        :: !Word8

    , JpgHuffmanTableSpec -> Vector Word8
huffSizes :: !(VU.Vector Word8)
    , JpgHuffmanTableSpec -> Vector (Vector Word8)
huffCodes :: !(V.Vector (VU.Vector Word8))
    }
    deriving Int -> JpgHuffmanTableSpec -> ShowS
[JpgHuffmanTableSpec] -> ShowS
JpgHuffmanTableSpec -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [JpgHuffmanTableSpec] -> ShowS
$cshowList :: [JpgHuffmanTableSpec] -> ShowS
show :: JpgHuffmanTableSpec -> String
$cshow :: JpgHuffmanTableSpec -> String
showsPrec :: Int -> JpgHuffmanTableSpec -> ShowS
$cshowsPrec :: Int -> JpgHuffmanTableSpec -> ShowS
Show

instance SizeCalculable JpgHuffmanTableSpec where
    calculateSize :: JpgHuffmanTableSpec -> Int
calculateSize JpgHuffmanTableSpec
table = Int
1 forall a. Num a => a -> a -> a
+ Int
16 forall a. Num a => a -> a -> a
+ forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
e | Word8
e <- forall a. Unbox a => Vector a -> [a]
VU.toList forall a b. (a -> b) -> a -> b
$ JpgHuffmanTableSpec -> Vector Word8
huffSizes JpgHuffmanTableSpec
table]

instance Binary JpgHuffmanTableSpec where
    put :: JpgHuffmanTableSpec -> Put
put JpgHuffmanTableSpec
table = do
        let classVal :: Word8
classVal = if JpgHuffmanTableSpec -> DctComponent
huffmanTableClass JpgHuffmanTableSpec
table forall a. Eq a => a -> a -> Bool
== DctComponent
DcComponent
                          then Word8
0 else Word8
1
        Word8 -> Word8 -> Put
put4BitsOfEach Word8
classVal forall a b. (a -> b) -> a -> b
$ JpgHuffmanTableSpec -> Word8
huffmanTableDest JpgHuffmanTableSpec
table
        forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall t. Binary t => t -> Put
put forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Unbox a => Vector a -> [a]
VU.toList forall a b. (a -> b) -> a -> b
$ JpgHuffmanTableSpec -> Vector Word8
huffSizes JpgHuffmanTableSpec
table
        forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
0 .. Int
15] forall a b. (a -> b) -> a -> b
$ \Int
i ->
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (JpgHuffmanTableSpec -> Vector Word8
huffSizes JpgHuffmanTableSpec
table forall a. Unbox a => Vector a -> Int -> a
! Int
i forall a. Eq a => a -> a -> Bool
/= Word8
0)
                 (let elements :: [Word8]
elements = forall a. Unbox a => Vector a -> [a]
VU.toList forall a b. (a -> b) -> a -> b
$ JpgHuffmanTableSpec -> Vector (Vector Word8)
huffCodes JpgHuffmanTableSpec
table forall a. Vector a -> Int -> a
V.! Int
i
                  in forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall t. Binary t => t -> Put
put [Word8]
elements)

    get :: Get JpgHuffmanTableSpec
get = do
        (Word8
huffClass, Word8
huffDest) <- Get (Word8, Word8)
get4BitOfEach
        [Word8]
sizes <- forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
16 Get Word8
getWord8
        [Vector Word8]
codes <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Word8]
sizes forall a b. (a -> b) -> a -> b
$ \Word8
s ->
            forall (m :: * -> *) a.
(Monad m, Unbox a) =>
Int -> m a -> m (Vector a)
VU.replicateM (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
s) Get Word8
getWord8
        forall (m :: * -> *) a. Monad m => a -> m a
return JpgHuffmanTableSpec
            { huffmanTableClass :: DctComponent
huffmanTableClass =
                if Word8
huffClass forall a. Eq a => a -> a -> Bool
== Word8
0 then DctComponent
DcComponent else DctComponent
AcComponent
            , huffmanTableDest :: Word8
huffmanTableDest = Word8
huffDest
            , huffSizes :: Vector Word8
huffSizes = forall a. Unbox a => Int -> [a] -> Vector a
VU.fromListN Int
16 [Word8]
sizes
            , huffCodes :: Vector (Vector Word8)
huffCodes = forall a. Int -> [a] -> Vector a
V.fromListN Int
16 [Vector Word8]
codes
            }

instance Binary JpgImage where
    put :: JpgImage -> Put
put (JpgImage { jpgFrame :: JpgImage -> [JpgFrame]
jpgFrame = [JpgFrame]
frames }) =
        Word8 -> Put
putWord8 Word8
0xFF forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Word8 -> Put
putWord8 Word8
0xD8 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ JpgFrame -> Put
putFrame [JpgFrame]
frames
            forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Word8 -> Put
putWord8 Word8
0xFF forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Word8 -> Put
putWord8 Word8
0xD9

    get :: Get JpgImage
get = do
        let startOfImageMarker :: Word8
startOfImageMarker = Word8
0xD8
            -- endOfImageMarker = 0xD9

        Word8 -> Word8 -> Get ()
checkMarker Word8
commonMarkerFirstByte Word8
startOfImageMarker
        Get ()
eatUntilCode
        [JpgFrame]
frames <- Get [JpgFrame]
parseFrames
        {-checkMarker commonMarkerFirstByte endOfImageMarker-}
        forall (m :: * -> *) a. Monad m => a -> m a
return JpgImage { jpgFrame :: [JpgFrame]
jpgFrame = [JpgFrame]
frames }

eatUntilCode :: Get ()
eatUntilCode :: Get ()
eatUntilCode = do
    Word8
code <- Get Word8
getWord8
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Word8
code forall a. Eq a => a -> a -> Bool
== Word8
0xFF) Get ()
eatUntilCode

takeCurrentFrame :: Get B.ByteString
takeCurrentFrame :: Get ByteString
takeCurrentFrame = do
    Word16
size <- Get Word16
getWord16be
    Int -> Get ByteString
getByteString (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
size forall a. Num a => a -> a -> a
- Int
2)

putFrame :: JpgFrame -> Put
putFrame :: JpgFrame -> Put
putFrame (JpgAdobeAPP14 JpgAdobeApp14
adobe) = 
    forall t. Binary t => t -> Put
put (Word8 -> JpgFrameKind
JpgAppSegment Word8
14) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Word16 -> Put
putWord16be Word16
14 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall t. Binary t => t -> Put
put JpgAdobeApp14
adobe
putFrame (JpgJFIF JpgJFIFApp0
jfif) =
    forall t. Binary t => t -> Put
put (Word8 -> JpgFrameKind
JpgAppSegment Word8
0) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Word16 -> Put
putWord16be (Word16
14forall a. Num a => a -> a -> a
+Word16
2) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall t. Binary t => t -> Put
put JpgJFIFApp0
jfif
putFrame (JpgExif [ImageFileDirectory]
exif) = [ImageFileDirectory] -> Put
putExif [ImageFileDirectory]
exif
putFrame (JpgAppFrame Word8
appCode ByteString
str) =
    forall t. Binary t => t -> Put
put (Word8 -> JpgFrameKind
JpgAppSegment Word8
appCode) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Word16 -> Put
putWord16be (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ ByteString -> Int
B.length ByteString
str) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall t. Binary t => t -> Put
put ByteString
str
putFrame (JpgExtension Word8
appCode ByteString
str) =
    forall t. Binary t => t -> Put
put (Word8 -> JpgFrameKind
JpgExtensionSegment Word8
appCode) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Word16 -> Put
putWord16be (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ ByteString -> Int
B.length ByteString
str) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall t. Binary t => t -> Put
put ByteString
str
putFrame (JpgQuantTable [JpgQuantTableSpec]
tables) =
    forall t. Binary t => t -> Put
put JpgFrameKind
JpgQuantizationTable forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall t. Binary t => t -> Put
put (forall a. [a] -> TableList a
TableList [JpgQuantTableSpec]
tables)
putFrame (JpgHuffmanTable [(JpgHuffmanTableSpec, HuffmanPackedTree)]
tables) =
    forall t. Binary t => t -> Put
put JpgFrameKind
JpgHuffmanTableMarker forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall t. Binary t => t -> Put
put (forall a. [a] -> TableList a
TableList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(JpgHuffmanTableSpec, HuffmanPackedTree)]
tables)
putFrame (JpgIntervalRestart Word16
size) =
    forall t. Binary t => t -> Put
put JpgFrameKind
JpgRestartInterval forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall t. Binary t => t -> Put
put (Word16 -> RestartInterval
RestartInterval Word16
size)
putFrame (JpgScanBlob JpgScanHeader
hdr ByteString
blob) =
    forall t. Binary t => t -> Put
put JpgFrameKind
JpgStartOfScan forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall t. Binary t => t -> Put
put JpgScanHeader
hdr forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ByteString -> Put
putLazyByteString ByteString
blob
putFrame (JpgScans JpgFrameKind
kind JpgFrameHeader
hdr) =
    forall t. Binary t => t -> Put
put JpgFrameKind
kind forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall t. Binary t => t -> Put
put JpgFrameHeader
hdr

--------------------------------------------------

----            Serialization instances

--------------------------------------------------

commonMarkerFirstByte :: Word8
commonMarkerFirstByte :: Word8
commonMarkerFirstByte = Word8
0xFF

checkMarker :: Word8 -> Word8 -> Get ()
checkMarker :: Word8 -> Word8 -> Get ()
checkMarker Word8
b1 Word8
b2 = do
    Word8
rb1 <- Get Word8
getWord8
    Word8
rb2 <- Get Word8
getWord8
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Word8
rb1 forall a. Eq a => a -> a -> Bool
/= Word8
b1 Bool -> Bool -> Bool
|| Word8
rb2 forall a. Eq a => a -> a -> Bool
/= Word8
b2)
         (forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Invalid marker used")

extractScanContent :: L.ByteString -> (L.ByteString, L.ByteString)
extractScanContent :: ByteString -> (ByteString, ByteString)
extractScanContent ByteString
str = Int64 -> (ByteString, ByteString)
aux Int64
0
  where maxi :: Int64
maxi = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ ByteString -> Int64
L.length ByteString
str forall a. Num a => a -> a -> a
- Int64
1

        aux :: Int64 -> (ByteString, ByteString)
aux Int64
n | Int64
n forall a. Ord a => a -> a -> Bool
>= Int64
maxi = (ByteString
str, ByteString
L.empty)
              | Word8
v forall a. Eq a => a -> a -> Bool
== Word8
0xFF Bool -> Bool -> Bool
&& Word8
vNext forall a. Eq a => a -> a -> Bool
/= Word8
0 Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
isReset = Int64 -> ByteString -> (ByteString, ByteString)
L.splitAt Int64
n ByteString
str
              | Bool
otherwise = Int64 -> (ByteString, ByteString)
aux (Int64
n forall a. Num a => a -> a -> a
+ Int64
1)
            where v :: Word8
v = ByteString
str HasCallStack => ByteString -> Int64 -> Word8
`L.index` Int64
n
                  vNext :: Word8
vNext = ByteString
str HasCallStack => ByteString -> Int64 -> Word8
`L.index` (Int64
n forall a. Num a => a -> a -> a
+ Int64
1)
                  isReset :: Bool
isReset = Word8
0xD0 forall a. Ord a => a -> a -> Bool
<= Word8
vNext Bool -> Bool -> Bool
&& Word8
vNext forall a. Ord a => a -> a -> Bool
<= Word8
0xD7

parseAdobe14 :: B.ByteString -> [JpgFrame] -> [JpgFrame]
parseAdobe14 :: ByteString -> [JpgFrame] -> [JpgFrame]
parseAdobe14 ByteString
str [JpgFrame]
lst = [JpgFrame]
go where
  go :: [JpgFrame]
go = case forall a. Get a -> ByteString -> Either String a
runGetStrict forall t. Binary t => Get t
get ByteString
str of
    Left String
_err -> [JpgFrame]
lst
    Right JpgAdobeApp14
app14 -> JpgAdobeApp14 -> JpgFrame
JpgAdobeAPP14 JpgAdobeApp14
app14 forall a. a -> [a] -> [a]
: [JpgFrame]
lst

-- | Parse JFIF or JFXX information. Right now only JFIF.

parseJF__  :: B.ByteString -> [JpgFrame] -> [JpgFrame]
parseJF__ :: ByteString -> [JpgFrame] -> [JpgFrame]
parseJF__  ByteString
str [JpgFrame]
lst = [JpgFrame]
go where
  go :: [JpgFrame]
go = case forall a. Get a -> ByteString -> Either String a
runGetStrict forall t. Binary t => Get t
get ByteString
str of
    Left String
_err -> [JpgFrame]
lst
    Right JpgJFIFApp0
jfif -> JpgJFIFApp0 -> JpgFrame
JpgJFIF JpgJFIFApp0
jfif forall a. a -> [a] -> [a]
: [JpgFrame]
lst

parseExif :: B.ByteString -> [JpgFrame] -> [JpgFrame]
parseExif :: ByteString -> [JpgFrame] -> [JpgFrame]
parseExif ByteString
str [JpgFrame]
lst 
  | ByteString
exifHeader ByteString -> ByteString -> Bool
`B.isPrefixOf` ByteString
str = [JpgFrame]
go
  | Bool
otherwise = [JpgFrame]
lst
  where
    exifHeader :: ByteString
exifHeader = String -> ByteString
BC.pack String
"Exif\0\0"
    tiff :: ByteString
tiff = Int -> ByteString -> ByteString
B.drop (ByteString -> Int
B.length ByteString
exifHeader) ByteString
str
    go :: [JpgFrame]
go = case forall a. Get a -> ByteString -> Either String a
runGetStrict (forall a b. BinaryParam a b => a -> Get b
getP ByteString
tiff) ByteString
tiff of
      Left String
_err -> [JpgFrame]
lst
      Right (TiffHeader
_hdr :: TiffHeader, []) -> [JpgFrame]
lst
      Right (TiffHeader
_hdr :: TiffHeader, [ImageFileDirectory]
ifds : [[ImageFileDirectory]]
_) -> [ImageFileDirectory] -> JpgFrame
JpgExif [ImageFileDirectory]
ifds forall a. a -> [a] -> [a]
: [JpgFrame]
lst

putExif :: [ImageFileDirectory] -> Put
putExif :: [ImageFileDirectory] -> Put
putExif [ImageFileDirectory]
ifds = Put
putAll where
  hdr :: TiffHeader
hdr = TiffHeader
    { hdrEndianness :: Endianness
hdrEndianness = Endianness
EndianBig
    , hdrOffset :: Word32
hdrOffset = Word32
8
    }

  ifdList :: [[ImageFileDirectory]]
ifdList = case forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (ExifTag -> Bool
isInIFD0 forall b c a. (b -> c) -> (a -> b) -> a -> c
. ImageFileDirectory -> ExifTag
ifdIdentifier) [ImageFileDirectory]
ifds of
    ([ImageFileDirectory]
ifd0, []) -> [[ImageFileDirectory]
ifd0]
    ([ImageFileDirectory]
ifd0, [ImageFileDirectory]
ifdExif) -> [[ImageFileDirectory]
ifd0 forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. Applicative f => a -> f a
pure ImageFileDirectory
exifOffsetIfd, [ImageFileDirectory]
ifdExif]
  
  exifBlob :: ByteString
exifBlob = Put -> ByteString
runPut forall a b. (a -> b) -> a -> b
$ do
    ByteString -> Put
putByteString forall a b. (a -> b) -> a -> b
$ String -> ByteString
BC.pack String
"Exif\0\0"
    forall a b. BinaryParam a b => a -> b -> Put
putP ByteString
BC.empty (TiffHeader
hdr, [[ImageFileDirectory]]
ifdList)

  putAll :: Put
putAll = do
    forall t. Binary t => t -> Put
put (Word8 -> JpgFrameKind
JpgAppSegment Word8
1)
    Word16 -> Put
putWord16be forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ ByteString -> Int64
L.length ByteString
exifBlob forall a. Num a => a -> a -> a
+ Int64
2
    ByteString -> Put
putLazyByteString ByteString
exifBlob

parseFrames :: Get [JpgFrame]
parseFrames :: Get [JpgFrame]
parseFrames = do
    JpgFrameKind
kind <- forall t. Binary t => Get t
get
    let parseNextFrame :: Get [JpgFrame]
parseNextFrame = do
            Word8
word <- Get Word8
getWord8
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Word8
word forall a. Eq a => a -> a -> Bool
/= Word8
0xFF) forall a b. (a -> b) -> a -> b
$ do
                Int64
readedData <- Get Int64
bytesRead
                forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Invalid Frame marker (" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Word8
word
                     forall a. [a] -> [a] -> [a]
++ String
", bytes read : " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int64
readedData forall a. [a] -> [a] -> [a]
++ String
")"
            Get [JpgFrame]
parseFrames

    case JpgFrameKind
kind of
        JpgFrameKind
JpgEndOfImage -> forall (m :: * -> *) a. Monad m => a -> m a
return []
        JpgAppSegment Word8
0 ->
            ByteString -> [JpgFrame] -> [JpgFrame]
parseJF__ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get ByteString
takeCurrentFrame forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get [JpgFrame]
parseNextFrame
        JpgAppSegment Word8
1 ->
            ByteString -> [JpgFrame] -> [JpgFrame]
parseExif forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get ByteString
takeCurrentFrame forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get [JpgFrame]
parseNextFrame
        JpgAppSegment Word8
14 ->
            ByteString -> [JpgFrame] -> [JpgFrame]
parseAdobe14 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get ByteString
takeCurrentFrame forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get [JpgFrame]
parseNextFrame
        JpgAppSegment Word8
c ->
            (\ByteString
frm [JpgFrame]
lst -> Word8 -> ByteString -> JpgFrame
JpgAppFrame Word8
c ByteString
frm forall a. a -> [a] -> [a]
: [JpgFrame]
lst) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get ByteString
takeCurrentFrame forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get [JpgFrame]
parseNextFrame
        JpgExtensionSegment Word8
c ->
            (\ByteString
frm [JpgFrame]
lst -> Word8 -> ByteString -> JpgFrame
JpgExtension Word8
c ByteString
frm forall a. a -> [a] -> [a]
: [JpgFrame]
lst) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get ByteString
takeCurrentFrame forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get [JpgFrame]
parseNextFrame
        JpgFrameKind
JpgQuantizationTable ->
            (\(TableList [JpgQuantTableSpec]
quants) [JpgFrame]
lst -> [JpgQuantTableSpec] -> JpgFrame
JpgQuantTable [JpgQuantTableSpec]
quants forall a. a -> [a] -> [a]
: [JpgFrame]
lst) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall t. Binary t => Get t
get forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get [JpgFrame]
parseNextFrame
        JpgFrameKind
JpgRestartInterval ->
            (\(RestartInterval Word16
i) [JpgFrame]
lst -> Word16 -> JpgFrame
JpgIntervalRestart Word16
i forall a. a -> [a] -> [a]
: [JpgFrame]
lst) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall t. Binary t => Get t
get forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get [JpgFrame]
parseNextFrame
        JpgFrameKind
JpgHuffmanTableMarker ->
            (\(TableList [JpgHuffmanTableSpec]
huffTables) [JpgFrame]
lst ->
                    [(JpgHuffmanTableSpec, HuffmanPackedTree)] -> JpgFrame
JpgHuffmanTable [(JpgHuffmanTableSpec
t, HuffmanTree -> HuffmanPackedTree
packHuffmanTree forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector (Vector Word8) -> HuffmanTree
buildPackedHuffmanTree forall a b. (a -> b) -> a -> b
$ JpgHuffmanTableSpec -> Vector (Vector Word8)
huffCodes JpgHuffmanTableSpec
t) | JpgHuffmanTableSpec
t <- [JpgHuffmanTableSpec]
huffTables] forall a. a -> [a] -> [a]
: [JpgFrame]
lst)
                    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall t. Binary t => Get t
get forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get [JpgFrame]
parseNextFrame
        JpgFrameKind
JpgStartOfScan ->
            (\JpgScanHeader
frm ByteString
imgData ->
                let (ByteString
d, ByteString
other) = ByteString -> (ByteString, ByteString)
extractScanContent ByteString
imgData
                in
                case forall a. Get a -> ByteString -> Either String a
runGet Get [JpgFrame]
parseFrames (Int64 -> ByteString -> ByteString
L.drop Int64
1 ByteString
other) of
                  Left String
_ -> [JpgScanHeader -> ByteString -> JpgFrame
JpgScanBlob JpgScanHeader
frm ByteString
d]
                  Right [JpgFrame]
lst -> JpgScanHeader -> ByteString -> JpgFrame
JpgScanBlob JpgScanHeader
frm ByteString
d forall a. a -> [a] -> [a]
: [JpgFrame]
lst
            ) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall t. Binary t => Get t
get forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get ByteString
getRemainingLazyBytes

        JpgFrameKind
_ -> (\JpgFrameHeader
hdr [JpgFrame]
lst -> JpgFrameKind -> JpgFrameHeader -> JpgFrame
JpgScans JpgFrameKind
kind JpgFrameHeader
hdr forall a. a -> [a] -> [a]
: [JpgFrame]
lst) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall t. Binary t => Get t
get forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get [JpgFrame]
parseNextFrame

buildPackedHuffmanTree :: V.Vector (VU.Vector Word8) -> HuffmanTree
buildPackedHuffmanTree :: Vector (Vector Word8) -> HuffmanTree
buildPackedHuffmanTree = [[Word8]] -> HuffmanTree
buildHuffmanTree forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a. Unbox a => Vector a -> [a]
VU.toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Vector a -> [a]
V.toList

secondStartOfFrameByteOfKind :: JpgFrameKind -> Word8
secondStartOfFrameByteOfKind :: JpgFrameKind -> Word8
secondStartOfFrameByteOfKind = JpgFrameKind -> Word8
aux
  where
    aux :: JpgFrameKind -> Word8
aux JpgFrameKind
JpgBaselineDCTHuffman = Word8
0xC0
    aux JpgFrameKind
JpgExtendedSequentialDCTHuffman = Word8
0xC1
    aux JpgFrameKind
JpgProgressiveDCTHuffman = Word8
0xC2
    aux JpgFrameKind
JpgLosslessHuffman = Word8
0xC3
    aux JpgFrameKind
JpgDifferentialSequentialDCTHuffman = Word8
0xC5
    aux JpgFrameKind
JpgDifferentialProgressiveDCTHuffman = Word8
0xC6
    aux JpgFrameKind
JpgDifferentialLosslessHuffman = Word8
0xC7
    aux JpgFrameKind
JpgExtendedSequentialArithmetic = Word8
0xC9
    aux JpgFrameKind
JpgProgressiveDCTArithmetic = Word8
0xCA
    aux JpgFrameKind
JpgLosslessArithmetic = Word8
0xCB
    aux JpgFrameKind
JpgHuffmanTableMarker = Word8
0xC4
    aux JpgFrameKind
JpgDifferentialSequentialDCTArithmetic = Word8
0xCD
    aux JpgFrameKind
JpgDifferentialProgressiveDCTArithmetic = Word8
0xCE
    aux JpgFrameKind
JpgDifferentialLosslessArithmetic = Word8
0xCF
    aux JpgFrameKind
JpgEndOfImage = Word8
0xD9
    aux JpgFrameKind
JpgQuantizationTable = Word8
0xDB
    aux JpgFrameKind
JpgStartOfScan = Word8
0xDA
    aux JpgFrameKind
JpgRestartInterval = Word8
0xDD
    aux (JpgRestartIntervalEnd Word8
v) = Word8
v
    aux (JpgAppSegment Word8
a) = (Word8
a forall a. Num a => a -> a -> a
+ Word8
0xE0)
    aux (JpgExtensionSegment Word8
a) = Word8
a

data JpgImageKind = BaseLineDCT | ProgressiveDCT

instance Binary JpgFrameKind where
    put :: JpgFrameKind -> Put
put JpgFrameKind
v = Word8 -> Put
putWord8 Word8
0xFF forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall t. Binary t => t -> Put
put (JpgFrameKind -> Word8
secondStartOfFrameByteOfKind JpgFrameKind
v)
    get :: Get JpgFrameKind
get = do
        -- no lookahead :(

        {-word <- getWord8-}
        Word8
word2 <- Get Word8
getWord8
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case Word8
word2 of
            Word8
0xC0 -> JpgFrameKind
JpgBaselineDCTHuffman
            Word8
0xC1 -> JpgFrameKind
JpgExtendedSequentialDCTHuffman
            Word8
0xC2 -> JpgFrameKind
JpgProgressiveDCTHuffman
            Word8
0xC3 -> JpgFrameKind
JpgLosslessHuffman
            Word8
0xC4 -> JpgFrameKind
JpgHuffmanTableMarker
            Word8
0xC5 -> JpgFrameKind
JpgDifferentialSequentialDCTHuffman
            Word8
0xC6 -> JpgFrameKind
JpgDifferentialProgressiveDCTHuffman
            Word8
0xC7 -> JpgFrameKind
JpgDifferentialLosslessHuffman
            Word8
0xC9 -> JpgFrameKind
JpgExtendedSequentialArithmetic
            Word8
0xCA -> JpgFrameKind
JpgProgressiveDCTArithmetic
            Word8
0xCB -> JpgFrameKind
JpgLosslessArithmetic
            Word8
0xCD -> JpgFrameKind
JpgDifferentialSequentialDCTArithmetic
            Word8
0xCE -> JpgFrameKind
JpgDifferentialProgressiveDCTArithmetic
            Word8
0xCF -> JpgFrameKind
JpgDifferentialLosslessArithmetic
            Word8
0xD9 -> JpgFrameKind
JpgEndOfImage
            Word8
0xDA -> JpgFrameKind
JpgStartOfScan
            Word8
0xDB -> JpgFrameKind
JpgQuantizationTable
            Word8
0xDD -> JpgFrameKind
JpgRestartInterval
            Word8
a | Word8
a forall a. Ord a => a -> a -> Bool
>= Word8
0xF0 -> Word8 -> JpgFrameKind
JpgExtensionSegment Word8
a
              | Word8
a forall a. Ord a => a -> a -> Bool
>= Word8
0xE0 -> Word8 -> JpgFrameKind
JpgAppSegment (Word8
a forall a. Num a => a -> a -> a
- Word8
0xE0)
              | Word8
a forall a. Ord a => a -> a -> Bool
>= Word8
0xD0 Bool -> Bool -> Bool
&& Word8
a forall a. Ord a => a -> a -> Bool
<= Word8
0xD7 -> Word8 -> JpgFrameKind
JpgRestartIntervalEnd Word8
a
              | Bool
otherwise -> forall a. HasCallStack => String -> a
error (String
"Invalid frame marker (" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Word8
a forall a. [a] -> [a] -> [a]
++ String
")")

put4BitsOfEach :: Word8 -> Word8 -> Put
put4BitsOfEach :: Word8 -> Word8 -> Put
put4BitsOfEach Word8
a Word8
b = forall t. Binary t => t -> Put
put forall a b. (a -> b) -> a -> b
$ (Word8
a forall a. Bits a => a -> Int -> a
`unsafeShiftL` Int
4) forall a. Bits a => a -> a -> a
.|. Word8
b

get4BitOfEach :: Get (Word8, Word8)
get4BitOfEach :: Get (Word8, Word8)
get4BitOfEach = do
    Word8
val <- forall t. Binary t => Get t
get
    forall (m :: * -> *) a. Monad m => a -> m a
return ((Word8
val forall a. Bits a => a -> Int -> a
`unsafeShiftR` Int
4) forall a. Bits a => a -> a -> a
.&. Word8
0xF, Word8
val forall a. Bits a => a -> a -> a
.&. Word8
0xF)

newtype RestartInterval = RestartInterval Word16

instance Binary RestartInterval where
    put :: RestartInterval -> Put
put (RestartInterval Word16
i) = Word16 -> Put
putWord16be Word16
4 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Word16 -> Put
putWord16be Word16
i
    get :: Get RestartInterval
get = do
        Word16
size <- Get Word16
getWord16be
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Word16
size forall a. Eq a => a -> a -> Bool
/= Word16
4) (forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Invalid jpeg restart interval size")
        Word16 -> RestartInterval
RestartInterval forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word16
getWord16be

instance Binary JpgComponent where
    get :: Get JpgComponent
get = do
        Word8
ident <- Get Word8
getWord8
        (Word8
horiz, Word8
vert) <- Get (Word8, Word8)
get4BitOfEach
        Word8
quantTableIndex <- Get Word8
getWord8
        forall (m :: * -> *) a. Monad m => a -> m a
return JpgComponent
            { componentIdentifier :: Word8
componentIdentifier = Word8
ident
            , horizontalSamplingFactor :: Word8
horizontalSamplingFactor = Word8
horiz
            , verticalSamplingFactor :: Word8
verticalSamplingFactor = Word8
vert
            , quantizationTableDest :: Word8
quantizationTableDest = Word8
quantTableIndex
            }
    put :: JpgComponent -> Put
put JpgComponent
v = do
        forall t. Binary t => t -> Put
put forall a b. (a -> b) -> a -> b
$ JpgComponent -> Word8
componentIdentifier JpgComponent
v
        Word8 -> Word8 -> Put
put4BitsOfEach (JpgComponent -> Word8
horizontalSamplingFactor JpgComponent
v) forall a b. (a -> b) -> a -> b
$ JpgComponent -> Word8
verticalSamplingFactor JpgComponent
v
        forall t. Binary t => t -> Put
put forall a b. (a -> b) -> a -> b
$ JpgComponent -> Word8
quantizationTableDest JpgComponent
v

instance Binary JpgFrameHeader where
    get :: Get JpgFrameHeader
get = do
        Int
beginOffset <- forall a b. (Integral a, Num b) => a -> b
fromIntegral forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Int64
bytesRead
        Word16
frmHLength <- Get Word16
getWord16be
        Word8
samplePrec <- Get Word8
getWord8
        Word16
h <- Get Word16
getWord16be
        Word16
w <- Get Word16
getWord16be
        Word8
compCount <- Get Word8
getWord8
        [JpgComponent]
components <- forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
compCount) forall t. Binary t => Get t
get
        Int
endOffset <- forall a b. (Integral a, Num b) => a -> b
fromIntegral forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Int64
bytesRead
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
beginOffset forall a. Num a => a -> a -> a
- Int
endOffset forall a. Ord a => a -> a -> Bool
< forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
frmHLength)
             (Int -> Get ()
skip forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
frmHLength forall a. Num a => a -> a -> a
- (Int
endOffset forall a. Num a => a -> a -> a
- Int
beginOffset))
        forall (m :: * -> *) a. Monad m => a -> m a
return JpgFrameHeader
            { jpgFrameHeaderLength :: Word16
jpgFrameHeaderLength = Word16
frmHLength
            , jpgSamplePrecision :: Word8
jpgSamplePrecision = Word8
samplePrec
            , jpgHeight :: Word16
jpgHeight = Word16
h
            , jpgWidth :: Word16
jpgWidth = Word16
w
            , jpgImageComponentCount :: Word8
jpgImageComponentCount = Word8
compCount
            , jpgComponents :: [JpgComponent]
jpgComponents = [JpgComponent]
components
            }

    put :: JpgFrameHeader -> Put
put JpgFrameHeader
v = do
        Word16 -> Put
putWord16be forall a b. (a -> b) -> a -> b
$ JpgFrameHeader -> Word16
jpgFrameHeaderLength JpgFrameHeader
v
        Word8 -> Put
putWord8    forall a b. (a -> b) -> a -> b
$ JpgFrameHeader -> Word8
jpgSamplePrecision JpgFrameHeader
v
        Word16 -> Put
putWord16be forall a b. (a -> b) -> a -> b
$ JpgFrameHeader -> Word16
jpgHeight JpgFrameHeader
v
        Word16 -> Put
putWord16be forall a b. (a -> b) -> a -> b
$ JpgFrameHeader -> Word16
jpgWidth JpgFrameHeader
v
        Word8 -> Put
putWord8    forall a b. (a -> b) -> a -> b
$ JpgFrameHeader -> Word8
jpgImageComponentCount JpgFrameHeader
v
        forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall t. Binary t => t -> Put
put   forall a b. (a -> b) -> a -> b
$ JpgFrameHeader -> [JpgComponent]
jpgComponents JpgFrameHeader
v

instance Binary JpgScanSpecification where
    put :: JpgScanSpecification -> Put
put JpgScanSpecification
v = do
        forall t. Binary t => t -> Put
put forall a b. (a -> b) -> a -> b
$ JpgScanSpecification -> Word8
componentSelector JpgScanSpecification
v
        Word8 -> Word8 -> Put
put4BitsOfEach (JpgScanSpecification -> Word8
dcEntropyCodingTable JpgScanSpecification
v) forall a b. (a -> b) -> a -> b
$ JpgScanSpecification -> Word8
acEntropyCodingTable JpgScanSpecification
v

    get :: Get JpgScanSpecification
get = do
        Word8
compSel <- forall t. Binary t => Get t
get
        (Word8
dc, Word8
ac) <- Get (Word8, Word8)
get4BitOfEach
        forall (m :: * -> *) a. Monad m => a -> m a
return JpgScanSpecification {
            componentSelector :: Word8
componentSelector = Word8
compSel
          , dcEntropyCodingTable :: Word8
dcEntropyCodingTable = Word8
dc
          , acEntropyCodingTable :: Word8
acEntropyCodingTable = Word8
ac
          }

instance Binary JpgScanHeader where
    get :: Get JpgScanHeader
get = do
        Word16
thisScanLength <- Get Word16
getWord16be
        Word8
compCount <- Get Word8
getWord8
        [JpgScanSpecification]
comp <- forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
compCount) forall t. Binary t => Get t
get
        Word8
specBeg <- forall t. Binary t => Get t
get
        Word8
specEnd <- forall t. Binary t => Get t
get
        (Word8
approxHigh, Word8
approxLow) <- Get (Word8, Word8)
get4BitOfEach

        forall (m :: * -> *) a. Monad m => a -> m a
return JpgScanHeader {
            scanLength :: Word16
scanLength = Word16
thisScanLength,
            scanComponentCount :: Word8
scanComponentCount = Word8
compCount,
            scans :: [JpgScanSpecification]
scans = [JpgScanSpecification]
comp,
            spectralSelection :: (Word8, Word8)
spectralSelection = (Word8
specBeg, Word8
specEnd),
            successiveApproxHigh :: Word8
successiveApproxHigh = Word8
approxHigh,
            successiveApproxLow :: Word8
successiveApproxLow = Word8
approxLow
        }

    put :: JpgScanHeader -> Put
put JpgScanHeader
v = do
        Word16 -> Put
putWord16be forall a b. (a -> b) -> a -> b
$ JpgScanHeader -> Word16
scanLength JpgScanHeader
v
        Word8 -> Put
putWord8 forall a b. (a -> b) -> a -> b
$ JpgScanHeader -> Word8
scanComponentCount JpgScanHeader
v
        forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall t. Binary t => t -> Put
put forall a b. (a -> b) -> a -> b
$ JpgScanHeader -> [JpgScanSpecification]
scans JpgScanHeader
v
        Word8 -> Put
putWord8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ JpgScanHeader -> (Word8, Word8)
spectralSelection JpgScanHeader
v
        Word8 -> Put
putWord8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ JpgScanHeader -> (Word8, Word8)
spectralSelection JpgScanHeader
v
        Word8 -> Word8 -> Put
put4BitsOfEach (JpgScanHeader -> Word8
successiveApproxHigh JpgScanHeader
v) forall a b. (a -> b) -> a -> b
$ JpgScanHeader -> Word8
successiveApproxLow JpgScanHeader
v

{-# INLINE createEmptyMutableMacroBlock #-}
-- | Create a new macroblock with the good array size

createEmptyMutableMacroBlock :: (Storable a, Num a) => ST s (MutableMacroBlock s a)
createEmptyMutableMacroBlock :: forall a s. (Storable a, Num a) => ST s (MutableMacroBlock s a)
createEmptyMutableMacroBlock = forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
Int -> a -> m (MVector (PrimState m) a)
M.replicate Int
64 a
0

printMacroBlock :: (Storable a, PrintfArg a)
                => MutableMacroBlock s a -> ST s String
printMacroBlock :: forall a s.
(Storable a, PrintfArg a) =>
MutableMacroBlock s a -> ST s String
printMacroBlock MutableMacroBlock s a
block = Int -> ST s String
pLn Int
0
    where pLn :: Int -> ST s String
pLn Int
64 = forall (m :: * -> *) a. Monad m => a -> m a
return String
"===============================\n"
          pLn Int
i = do
              a
v <- MutableMacroBlock s a
block forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
MVector (PrimState m) a -> Int -> m a
`M.unsafeRead` Int
i
              String
vn <- Int -> ST s String
pLn (Int
iforall a. Num a => a -> a -> a
+Int
1)
              forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall r. PrintfType r => String -> r
printf (if Int
i forall a. Integral a => a -> a -> a
`mod` Int
8 forall a. Eq a => a -> a -> Bool
== Int
0 then String
"\n%5d " else String
"%5d ") a
v forall a. [a] -> [a] -> [a]
++ String
vn

printPureMacroBlock :: (Storable a, PrintfArg a) => MacroBlock a -> String
printPureMacroBlock :: forall a. (Storable a, PrintfArg a) => MacroBlock a -> String
printPureMacroBlock MacroBlock a
block = Int -> String
pLn Int
0
    where pLn :: Int -> String
pLn Int
64 = String
"===============================\n"
          pLn Int
i = String
str forall a. [a] -> [a] -> [a]
++ Int -> String
pLn (Int
i forall a. Num a => a -> a -> a
+ Int
1)
            where str :: String
str | Int
i forall a. Integral a => a -> a -> a
`mod` Int
8 forall a. Eq a => a -> a -> Bool
== Int
0 = forall r. PrintfType r => String -> r
printf String
"\n%5d " a
v
                      | Bool
otherwise = forall r. PrintfType r => String -> r
printf String
"%5d" a
v
                  v :: a
v = MacroBlock a
block forall a. Storable a => Vector a -> Int -> a
VS.! Int
i


{-# INLINE dctBlockSize #-}
dctBlockSize :: Num a => a
dctBlockSize :: forall a. Num a => a
dctBlockSize = a
8