{-# 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
(JpgFrameKind -> JpgFrameKind -> Bool)
-> (JpgFrameKind -> JpgFrameKind -> Bool) -> Eq JpgFrameKind
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
(Int -> JpgFrameKind -> ShowS)
-> (JpgFrameKind -> String)
-> ([JpgFrameKind] -> ShowS)
-> Show JpgFrameKind
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
(Int -> JpgFrame -> ShowS)
-> (JpgFrame -> String) -> ([JpgFrame] -> ShowS) -> Show JpgFrame
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
(Int -> JpgColorSpace -> ShowS)
-> (JpgColorSpace -> String)
-> ([JpgColorSpace] -> ShowS)
-> Show JpgColorSpace
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
(Int -> AdobeTransform -> ShowS)
-> (AdobeTransform -> String)
-> ([AdobeTransform] -> ShowS)
-> Show AdobeTransform
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
(Int -> JpgAdobeApp14 -> ShowS)
-> (JpgAdobeApp14 -> String)
-> ([JpgAdobeApp14] -> ShowS)
-> Show JpgAdobeApp14
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
(Int -> JFifUnit -> ShowS)
-> (JFifUnit -> String) -> ([JFifUnit] -> ShowS) -> Show JFifUnit
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 (Word8 -> Put) -> Word8 -> Put
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
    JFifUnit -> Get JFifUnit
forall (f :: * -> *) a. Applicative f => a -> f a
pure (JFifUnit -> Get JFifUnit) -> JFifUnit -> Get JFifUnit
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
(Int -> JpgJFIFApp0 -> ShowS)
-> (JpgJFIFApp0 -> String)
-> ([JpgJFIFApp0] -> ShowS)
-> Show JpgJFIFApp0
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
    Bool -> Get () -> Get ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString
sig ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/= String -> ByteString
BC.pack String
"JFIF\0") (Get () -> Get ()) -> Get () -> Get ()
forall a b. (a -> b) -> a -> b
$
        String -> Get ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Invalid JFIF signature"
    Word8
major <- Get Word8
getWord8
    Word8
minor <- Get Word8
getWord8
    Bool -> Get () -> Get ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Word8
major Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word8
1 Bool -> Bool -> Bool
&& Word8
minor Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
> Word8
2) (Get () -> Get ()) -> Get () -> Get ()
forall a b. (a -> b) -> a -> b
$
        String -> Get ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Unrecognize JFIF version"
    JFifUnit
unit <- Get JFifUnit
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 Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
* Word8
w Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
* Word8
h
    Maybe Int
img <- case Word8
pxCount of
      Word8
0 -> Maybe Int -> Get (Maybe Int)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Int
forall a. Maybe a
Nothing
      Word8
_ -> Maybe Int -> Get (Maybe Int)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Int
forall a. Maybe a
Nothing
    JpgJFIFApp0 -> Get JpgJFIFApp0
forall (m :: * -> *) a. Monad m => a -> m a
return (JpgJFIFApp0 -> Get JpgJFIFApp0) -> JpgJFIFApp0 -> Get JpgJFIFApp0
forall a b. (a -> b) -> a -> b
$ JpgJFIFApp0 :: JFifUnit -> Word16 -> Word16 -> Maybe Int -> JpgJFIFApp0
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 (ByteString -> Put) -> ByteString -> Put
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

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

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

    Word16 -> Put
putWord16be (Word16 -> Put) -> Word16 -> Put
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
    AdobeTransform -> Get AdobeTransform
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AdobeTransform -> Get AdobeTransform)
-> AdobeTransform -> Get AdobeTransform
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
    Bool -> Get () -> Get ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString
fileSig ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/= ByteString
sig) (Get () -> Get ()) -> Get () -> Get ()
forall a b. (a -> b) -> a -> b
$
       String -> Get ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Invalid Adobe APP14 marker"
    Word16
version <- Get Word16
getWord16be
    Bool -> Get () -> Get ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Word16
version Word16 -> Word16 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word16
100) (Get () -> Get ()) -> Get () -> Get ()
forall a b. (a -> b) -> a -> b
$
       String -> Get ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Get ()) -> String -> Get ()
forall a b. (a -> b) -> a -> b
$ String
"Invalid Adobe APP14 version " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Word16 -> String
forall a. Show a => a -> String
show Word16
version
    Word16 -> Word16 -> Word16 -> AdobeTransform -> JpgAdobeApp14
JpgAdobeApp14 Word16
version
                  (Word16 -> Word16 -> AdobeTransform -> JpgAdobeApp14)
-> Get Word16 -> Get (Word16 -> AdobeTransform -> JpgAdobeApp14)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word16
getWord16be
                  Get (Word16 -> AdobeTransform -> JpgAdobeApp14)
-> Get Word16 -> Get (AdobeTransform -> JpgAdobeApp14)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get Word16
getWord16be Get (AdobeTransform -> JpgAdobeApp14)
-> Get AdobeTransform -> Get JpgAdobeApp14
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get AdobeTransform
forall t. Binary t => Get t
get

  put :: JpgAdobeApp14 -> Put
put (JpgAdobeApp14 Word16
v Word16
f0 Word16
f1 AdobeTransform
t) = do
    ByteString -> Put
putByteString (ByteString -> Put) -> ByteString -> Put
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
    AdobeTransform -> Put
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
(Int -> JpgFrameHeader -> ShowS)
-> (JpgFrameHeader -> String)
-> ([JpgFrameHeader] -> ShowS)
-> Show JpgFrameHeader
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 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
                      Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [JpgComponent -> Int
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
(Int -> JpgComponent -> ShowS)
-> (JpgComponent -> String)
-> ([JpgComponent] -> ShowS)
-> Show JpgComponent
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
(Int -> JpgImage -> ShowS)
-> (JpgImage -> String) -> ([JpgImage] -> ShowS) -> Show JpgImage
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
(Int -> JpgScanSpecification -> ShowS)
-> (JpgScanSpecification -> String)
-> ([JpgScanSpecification] -> ShowS)
-> Show JpgScanSpecification
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
(Int -> JpgScanHeader -> ShowS)
-> (JpgScanHeader -> String)
-> ([JpgScanHeader] -> ShowS)
-> Show JpgScanHeader
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 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
                      Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [JpgScanSpecification -> Int
forall a. SizeCalculable a => a -> Int
calculateSize JpgScanSpecification
c | JpgScanSpecification
c <- JpgScanHeader -> [JpgScanSpecification]
scans JpgScanHeader
hdr]
                      Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2
                      Int -> Int -> Int
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
(Int -> JpgQuantTableSpec -> ShowS)
-> (JpgQuantTableSpec -> String)
-> ([JpgQuantTableSpec] -> ShowS)
-> Show JpgQuantTableSpec
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 (Word16 -> Put) -> (Int -> Word16) -> Int -> Put
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Put) -> Int -> Put
forall a b. (a -> b) -> a -> b
$ [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [a -> Int
forall a. SizeCalculable a => a -> Int
calculateSize a
table | a
table <- [a]
lst] Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2
        (a -> Put) -> [a] -> Put
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ a -> Put
forall t. Binary t => t -> Put
put [a]
lst

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

instance SizeCalculable JpgQuantTableSpec where
    calculateSize :: JpgQuantTableSpec -> Int
calculateSize JpgQuantTableSpec
table =
        Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (JpgQuantTableSpec -> Word8
quantPrecision JpgQuantTableSpec
table) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Int -> Int -> Int
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)
        [Int16] -> (Int16 -> Put) -> Put
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (MacroBlock Int16 -> [Int16]
forall a. Storable a => Vector a -> [a]
VS.toList (MacroBlock Int16 -> [Int16]) -> MacroBlock Int16 -> [Int16]
forall a b. (a -> b) -> a -> b
$ JpgQuantTableSpec -> MacroBlock Int16
quantTable JpgQuantTableSpec
table) ((Int16 -> Put) -> Put) -> (Int16 -> Put) -> Put
forall a b. (a -> b) -> a -> b
$ \Int16
coeff ->
            if Word8
precision Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
0 then Word8 -> Put
putWord8 (Word8 -> Put) -> Word8 -> Put
forall a b. (a -> b) -> a -> b
$ Int16 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int16
coeff
                             else Word16 -> Put
putWord16be (Word16 -> Put) -> Word16 -> Put
forall a b. (a -> b) -> a -> b
$ Int16 -> Word16
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 <- Int -> Get Int16 -> Get [Int16]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
64 (Get Int16 -> Get [Int16]) -> Get Int16 -> Get [Int16]
forall a b. (a -> b) -> a -> b
$ if Word8
precision Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
0
                then Word8 -> Int16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8 -> Int16) -> Get Word8 -> Get Int16
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word8
getWord8
                else Word16 -> Int16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word16 -> Int16) -> Get Word16 -> Get Int16
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word16
getWord16be
        JpgQuantTableSpec -> Get JpgQuantTableSpec
forall (m :: * -> *) a. Monad m => a -> m a
return JpgQuantTableSpec :: Word8 -> Word8 -> MacroBlock Int16 -> JpgQuantTableSpec
JpgQuantTableSpec
            { quantPrecision :: Word8
quantPrecision = Word8
precision
            , quantDestination :: Word8
quantDestination = Word8
dest
            , quantTable :: MacroBlock Int16
quantTable = Int -> [Int16] -> MacroBlock Int16
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
(Int -> JpgHuffmanTableSpec -> ShowS)
-> (JpgHuffmanTableSpec -> String)
-> ([JpgHuffmanTableSpec] -> ShowS)
-> Show JpgHuffmanTableSpec
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 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
16 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
e | Word8
e <- Vector Word8 -> [Word8]
forall a. Unbox a => Vector a -> [a]
VU.toList (Vector Word8 -> [Word8]) -> Vector Word8 -> [Word8]
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 DctComponent -> DctComponent -> Bool
forall a. Eq a => a -> a -> Bool
== DctComponent
DcComponent
                          then Word8
0 else Word8
1
        Word8 -> Word8 -> Put
put4BitsOfEach Word8
classVal (Word8 -> Put) -> Word8 -> Put
forall a b. (a -> b) -> a -> b
$ JpgHuffmanTableSpec -> Word8
huffmanTableDest JpgHuffmanTableSpec
table
        (Word8 -> Put) -> [Word8] -> Put
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Word8 -> Put
forall t. Binary t => t -> Put
put ([Word8] -> Put)
-> (Vector Word8 -> [Word8]) -> Vector Word8 -> Put
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector Word8 -> [Word8]
forall a. Unbox a => Vector a -> [a]
VU.toList (Vector Word8 -> Put) -> Vector Word8 -> Put
forall a b. (a -> b) -> a -> b
$ JpgHuffmanTableSpec -> Vector Word8
huffSizes JpgHuffmanTableSpec
table
        [Int] -> (Int -> Put) -> Put
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
0 .. Int
15] ((Int -> Put) -> Put) -> (Int -> Put) -> Put
forall a b. (a -> b) -> a -> b
$ \Int
i ->
            Bool -> Put -> Put
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (JpgHuffmanTableSpec -> Vector Word8
huffSizes JpgHuffmanTableSpec
table Vector Word8 -> Int -> Word8
forall a. Unbox a => Vector a -> Int -> a
! Int
i Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word8
0)
                 (let elements :: [Word8]
elements = Vector Word8 -> [Word8]
forall a. Unbox a => Vector a -> [a]
VU.toList (Vector Word8 -> [Word8]) -> Vector Word8 -> [Word8]
forall a b. (a -> b) -> a -> b
$ JpgHuffmanTableSpec -> Vector (Vector Word8)
huffCodes JpgHuffmanTableSpec
table Vector (Vector Word8) -> Int -> Vector Word8
forall a. Vector a -> Int -> a
V.! Int
i
                  in (Word8 -> Put) -> [Word8] -> Put
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Word8 -> Put
forall t. Binary t => t -> Put
put [Word8]
elements)

    get :: Get JpgHuffmanTableSpec
get = do
        (Word8
huffClass, Word8
huffDest) <- Get (Word8, Word8)
get4BitOfEach
        [Word8]
sizes <- Int -> Get Word8 -> Get [Word8]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
16 Get Word8
getWord8
        [Vector Word8]
codes <- [Word8] -> (Word8 -> Get (Vector Word8)) -> Get [Vector Word8]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Word8]
sizes ((Word8 -> Get (Vector Word8)) -> Get [Vector Word8])
-> (Word8 -> Get (Vector Word8)) -> Get [Vector Word8]
forall a b. (a -> b) -> a -> b
$ \Word8
s ->
            Int -> Get Word8 -> Get (Vector Word8)
forall (m :: * -> *) a.
(Monad m, Unbox a) =>
Int -> m a -> m (Vector a)
VU.replicateM (Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
s) Get Word8
getWord8
        JpgHuffmanTableSpec -> Get JpgHuffmanTableSpec
forall (m :: * -> *) a. Monad m => a -> m a
return JpgHuffmanTableSpec :: DctComponent
-> Word8
-> Vector Word8
-> Vector (Vector Word8)
-> JpgHuffmanTableSpec
JpgHuffmanTableSpec
            { huffmanTableClass :: DctComponent
huffmanTableClass =
                if Word8
huffClass Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
0 then DctComponent
DcComponent else DctComponent
AcComponent
            , huffmanTableDest :: Word8
huffmanTableDest = Word8
huffDest
            , huffSizes :: Vector Word8
huffSizes = Int -> [Word8] -> Vector Word8
forall a. Unbox a => Int -> [a] -> Vector a
VU.fromListN Int
16 [Word8]
sizes
            , huffCodes :: Vector (Vector Word8)
huffCodes = Int -> [Vector Word8] -> Vector (Vector Word8)
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 Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Word8 -> Put
putWord8 Word8
0xD8 Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (JpgFrame -> Put) -> [JpgFrame] -> Put
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ JpgFrame -> Put
putFrame [JpgFrame]
frames
            Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Word8 -> Put
putWord8 Word8
0xFF Put -> Put -> Put
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-}
        JpgImage -> Get JpgImage
forall (m :: * -> *) a. Monad m => a -> m a
return JpgImage :: [JpgFrame] -> JpgImage
JpgImage { jpgFrame :: [JpgFrame]
jpgFrame = [JpgFrame]
frames }

eatUntilCode :: Get ()
eatUntilCode :: Get ()
eatUntilCode = do
    Word8
code <- Get Word8
getWord8
    Bool -> Get () -> Get ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Word8
code Word8 -> Word8 -> Bool
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 (Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
size Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
2)

putFrame :: JpgFrame -> Put
putFrame :: JpgFrame -> Put
putFrame (JpgAdobeAPP14 JpgAdobeApp14
adobe) = 
    JpgFrameKind -> Put
forall t. Binary t => t -> Put
put (Word8 -> JpgFrameKind
JpgAppSegment Word8
14) Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Word16 -> Put
putWord16be Word16
14 Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> JpgAdobeApp14 -> Put
forall t. Binary t => t -> Put
put JpgAdobeApp14
adobe
putFrame (JpgJFIF JpgJFIFApp0
jfif) =
    JpgFrameKind -> Put
forall t. Binary t => t -> Put
put (Word8 -> JpgFrameKind
JpgAppSegment Word8
0) Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Word16 -> Put
putWord16be (Word16
14Word16 -> Word16 -> Word16
forall a. Num a => a -> a -> a
+Word16
2) Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> JpgJFIFApp0 -> Put
forall t. Binary t => t -> Put
put JpgJFIFApp0
jfif
putFrame (JpgExif [ImageFileDirectory]
exif) = [ImageFileDirectory] -> Put
putExif [ImageFileDirectory]
exif
putFrame (JpgAppFrame Word8
appCode ByteString
str) =
    JpgFrameKind -> Put
forall t. Binary t => t -> Put
put (Word8 -> JpgFrameKind
JpgAppSegment Word8
appCode) Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Word16 -> Put
putWord16be (Int -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word16) -> Int -> Word16
forall a b. (a -> b) -> a -> b
$ ByteString -> Int
B.length ByteString
str) Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ByteString -> Put
forall t. Binary t => t -> Put
put ByteString
str
putFrame (JpgExtension Word8
appCode ByteString
str) =
    JpgFrameKind -> Put
forall t. Binary t => t -> Put
put (Word8 -> JpgFrameKind
JpgExtensionSegment Word8
appCode) Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Word16 -> Put
putWord16be (Int -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word16) -> Int -> Word16
forall a b. (a -> b) -> a -> b
$ ByteString -> Int
B.length ByteString
str) Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ByteString -> Put
forall t. Binary t => t -> Put
put ByteString
str
putFrame (JpgQuantTable [JpgQuantTableSpec]
tables) =
    JpgFrameKind -> Put
forall t. Binary t => t -> Put
put JpgFrameKind
JpgQuantizationTable Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TableList JpgQuantTableSpec -> Put
forall t. Binary t => t -> Put
put ([JpgQuantTableSpec] -> TableList JpgQuantTableSpec
forall a. [a] -> TableList a
TableList [JpgQuantTableSpec]
tables)
putFrame (JpgHuffmanTable [(JpgHuffmanTableSpec, HuffmanPackedTree)]
tables) =
    JpgFrameKind -> Put
forall t. Binary t => t -> Put
put JpgFrameKind
JpgHuffmanTableMarker Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TableList JpgHuffmanTableSpec -> Put
forall t. Binary t => t -> Put
put ([JpgHuffmanTableSpec] -> TableList JpgHuffmanTableSpec
forall a. [a] -> TableList a
TableList ([JpgHuffmanTableSpec] -> TableList JpgHuffmanTableSpec)
-> [JpgHuffmanTableSpec] -> TableList JpgHuffmanTableSpec
forall a b. (a -> b) -> a -> b
$ ((JpgHuffmanTableSpec, HuffmanPackedTree) -> JpgHuffmanTableSpec)
-> [(JpgHuffmanTableSpec, HuffmanPackedTree)]
-> [JpgHuffmanTableSpec]
forall a b. (a -> b) -> [a] -> [b]
map (JpgHuffmanTableSpec, HuffmanPackedTree) -> JpgHuffmanTableSpec
forall a b. (a, b) -> a
fst [(JpgHuffmanTableSpec, HuffmanPackedTree)]
tables)
putFrame (JpgIntervalRestart Word16
size) =
    JpgFrameKind -> Put
forall t. Binary t => t -> Put
put JpgFrameKind
JpgRestartInterval Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> RestartInterval -> Put
forall t. Binary t => t -> Put
put (Word16 -> RestartInterval
RestartInterval Word16
size)
putFrame (JpgScanBlob JpgScanHeader
hdr ByteString
blob) =
    JpgFrameKind -> Put
forall t. Binary t => t -> Put
put JpgFrameKind
JpgStartOfScan Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> JpgScanHeader -> Put
forall t. Binary t => t -> Put
put JpgScanHeader
hdr Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ByteString -> Put
putLazyByteString ByteString
blob
putFrame (JpgScans JpgFrameKind
kind JpgFrameHeader
hdr) =
    JpgFrameKind -> Put
forall t. Binary t => t -> Put
put JpgFrameKind
kind Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> JpgFrameHeader -> Put
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
    Bool -> Get () -> Get ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Word8
rb1 Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word8
b1 Bool -> Bool -> Bool
|| Word8
rb2 Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word8
b2)
         (String -> Get ()
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 = Int64 -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> Int64) -> Int64 -> Int64
forall a b. (a -> b) -> a -> b
$ ByteString -> Int64
L.length ByteString
str Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
- Int64
1

        aux :: Int64 -> (ByteString, ByteString)
aux Int64
n | Int64
n Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
>= Int64
maxi = (ByteString
str, ByteString
L.empty)
              | Word8
v Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
0xFF Bool -> Bool -> Bool
&& Word8
vNext Word8 -> Word8 -> Bool
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 Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
1)
            where v :: Word8
v = ByteString
str ByteString -> Int64 -> Word8
`L.index` Int64
n
                  vNext :: Word8
vNext = ByteString
str ByteString -> Int64 -> Word8
`L.index` (Int64
n Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
1)
                  isReset :: Bool
isReset = Word8
0xD0 Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8
vNext Bool -> Bool -> Bool
&& Word8
vNext Word8 -> Word8 -> Bool
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 Get JpgAdobeApp14 -> ByteString -> Either String JpgAdobeApp14
forall a. Get a -> ByteString -> Either String a
runGetStrict Get JpgAdobeApp14
forall t. Binary t => Get t
get ByteString
str of
    Left String
_err -> [JpgFrame]
lst
    Right JpgAdobeApp14
app14 -> JpgAdobeApp14 -> JpgFrame
JpgAdobeAPP14 JpgAdobeApp14
app14 JpgFrame -> [JpgFrame] -> [JpgFrame]
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 Get JpgJFIFApp0 -> ByteString -> Either String JpgJFIFApp0
forall a. Get a -> ByteString -> Either String a
runGetStrict Get JpgJFIFApp0
forall t. Binary t => Get t
get ByteString
str of
    Left String
_err -> [JpgFrame]
lst
    Right JpgJFIFApp0
jfif -> JpgJFIFApp0 -> JpgFrame
JpgJFIF JpgJFIFApp0
jfif JpgFrame -> [JpgFrame] -> [JpgFrame]
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 Get (TiffHeader, [[ImageFileDirectory]])
-> ByteString -> Either String (TiffHeader, [[ImageFileDirectory]])
forall a. Get a -> ByteString -> Either String a
runGetStrict (ByteString -> Get (TiffHeader, [[ImageFileDirectory]])
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 JpgFrame -> [JpgFrame] -> [JpgFrame]
forall a. a -> [a] -> [a]
: [JpgFrame]
lst

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

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

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

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

    case JpgFrameKind
kind of
        JpgFrameKind
JpgEndOfImage -> [JpgFrame] -> Get [JpgFrame]
forall (m :: * -> *) a. Monad m => a -> m a
return []
        JpgAppSegment Word8
0 ->
            ByteString -> [JpgFrame] -> [JpgFrame]
parseJF__ (ByteString -> [JpgFrame] -> [JpgFrame])
-> Get ByteString -> Get ([JpgFrame] -> [JpgFrame])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get ByteString
takeCurrentFrame Get ([JpgFrame] -> [JpgFrame]) -> Get [JpgFrame] -> Get [JpgFrame]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get [JpgFrame]
parseNextFrame
        JpgAppSegment Word8
1 ->
            ByteString -> [JpgFrame] -> [JpgFrame]
parseExif (ByteString -> [JpgFrame] -> [JpgFrame])
-> Get ByteString -> Get ([JpgFrame] -> [JpgFrame])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get ByteString
takeCurrentFrame Get ([JpgFrame] -> [JpgFrame]) -> Get [JpgFrame] -> Get [JpgFrame]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get [JpgFrame]
parseNextFrame
        JpgAppSegment Word8
14 ->
            ByteString -> [JpgFrame] -> [JpgFrame]
parseAdobe14 (ByteString -> [JpgFrame] -> [JpgFrame])
-> Get ByteString -> Get ([JpgFrame] -> [JpgFrame])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get ByteString
takeCurrentFrame Get ([JpgFrame] -> [JpgFrame]) -> Get [JpgFrame] -> Get [JpgFrame]
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 JpgFrame -> [JpgFrame] -> [JpgFrame]
forall a. a -> [a] -> [a]
: [JpgFrame]
lst) (ByteString -> [JpgFrame] -> [JpgFrame])
-> Get ByteString -> Get ([JpgFrame] -> [JpgFrame])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get ByteString
takeCurrentFrame Get ([JpgFrame] -> [JpgFrame]) -> Get [JpgFrame] -> Get [JpgFrame]
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 JpgFrame -> [JpgFrame] -> [JpgFrame]
forall a. a -> [a] -> [a]
: [JpgFrame]
lst) (ByteString -> [JpgFrame] -> [JpgFrame])
-> Get ByteString -> Get ([JpgFrame] -> [JpgFrame])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get ByteString
takeCurrentFrame Get ([JpgFrame] -> [JpgFrame]) -> Get [JpgFrame] -> Get [JpgFrame]
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 JpgFrame -> [JpgFrame] -> [JpgFrame]
forall a. a -> [a] -> [a]
: [JpgFrame]
lst) (TableList JpgQuantTableSpec -> [JpgFrame] -> [JpgFrame])
-> Get (TableList JpgQuantTableSpec)
-> Get ([JpgFrame] -> [JpgFrame])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get (TableList JpgQuantTableSpec)
forall t. Binary t => Get t
get Get ([JpgFrame] -> [JpgFrame]) -> Get [JpgFrame] -> Get [JpgFrame]
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 JpgFrame -> [JpgFrame] -> [JpgFrame]
forall a. a -> [a] -> [a]
: [JpgFrame]
lst) (RestartInterval -> [JpgFrame] -> [JpgFrame])
-> Get RestartInterval -> Get ([JpgFrame] -> [JpgFrame])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get RestartInterval
forall t. Binary t => Get t
get Get ([JpgFrame] -> [JpgFrame]) -> Get [JpgFrame] -> Get [JpgFrame]
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 (HuffmanTree -> HuffmanPackedTree)
-> (Vector (Vector Word8) -> HuffmanTree)
-> Vector (Vector Word8)
-> HuffmanPackedTree
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector (Vector Word8) -> HuffmanTree
buildPackedHuffmanTree (Vector (Vector Word8) -> HuffmanPackedTree)
-> Vector (Vector Word8) -> HuffmanPackedTree
forall a b. (a -> b) -> a -> b
$ JpgHuffmanTableSpec -> Vector (Vector Word8)
huffCodes JpgHuffmanTableSpec
t) | JpgHuffmanTableSpec
t <- [JpgHuffmanTableSpec]
huffTables] JpgFrame -> [JpgFrame] -> [JpgFrame]
forall a. a -> [a] -> [a]
: [JpgFrame]
lst)
                    (TableList JpgHuffmanTableSpec -> [JpgFrame] -> [JpgFrame])
-> Get (TableList JpgHuffmanTableSpec)
-> Get ([JpgFrame] -> [JpgFrame])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get (TableList JpgHuffmanTableSpec)
forall t. Binary t => Get t
get Get ([JpgFrame] -> [JpgFrame]) -> Get [JpgFrame] -> Get [JpgFrame]
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 Get [JpgFrame] -> ByteString -> Either String [JpgFrame]
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 JpgFrame -> [JpgFrame] -> [JpgFrame]
forall a. a -> [a] -> [a]
: [JpgFrame]
lst
            ) (JpgScanHeader -> ByteString -> [JpgFrame])
-> Get JpgScanHeader -> Get (ByteString -> [JpgFrame])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get JpgScanHeader
forall t. Binary t => Get t
get Get (ByteString -> [JpgFrame]) -> Get ByteString -> Get [JpgFrame]
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 JpgFrame -> [JpgFrame] -> [JpgFrame]
forall a. a -> [a] -> [a]
: [JpgFrame]
lst) (JpgFrameHeader -> [JpgFrame] -> [JpgFrame])
-> Get JpgFrameHeader -> Get ([JpgFrame] -> [JpgFrame])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get JpgFrameHeader
forall t. Binary t => Get t
get Get ([JpgFrame] -> [JpgFrame]) -> Get [JpgFrame] -> Get [JpgFrame]
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 ([[Word8]] -> HuffmanTree)
-> (Vector (Vector Word8) -> [[Word8]])
-> Vector (Vector Word8)
-> HuffmanTree
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Vector Word8 -> [Word8]) -> [Vector Word8] -> [[Word8]]
forall a b. (a -> b) -> [a] -> [b]
map Vector Word8 -> [Word8]
forall a. Unbox a => Vector a -> [a]
VU.toList ([Vector Word8] -> [[Word8]])
-> (Vector (Vector Word8) -> [Vector Word8])
-> Vector (Vector Word8)
-> [[Word8]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector (Vector Word8) -> [Vector Word8]
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 Word8 -> Word8 -> Word8
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 Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Word8 -> Put
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
        case Word8
word2 of
            Word8
0xC0 -> JpgFrameKind -> Get JpgFrameKind
forall (m :: * -> *) a. Monad m => a -> m a
return JpgFrameKind
JpgBaselineDCTHuffman
            Word8
0xC1 -> JpgFrameKind -> Get JpgFrameKind
forall (m :: * -> *) a. Monad m => a -> m a
return JpgFrameKind
JpgExtendedSequentialDCTHuffman
            Word8
0xC2 -> JpgFrameKind -> Get JpgFrameKind
forall (m :: * -> *) a. Monad m => a -> m a
return JpgFrameKind
JpgProgressiveDCTHuffman
            Word8
0xC3 -> JpgFrameKind -> Get JpgFrameKind
forall (m :: * -> *) a. Monad m => a -> m a
return JpgFrameKind
JpgLosslessHuffman
            Word8
0xC4 -> JpgFrameKind -> Get JpgFrameKind
forall (m :: * -> *) a. Monad m => a -> m a
return JpgFrameKind
JpgHuffmanTableMarker
            Word8
0xC5 -> JpgFrameKind -> Get JpgFrameKind
forall (m :: * -> *) a. Monad m => a -> m a
return JpgFrameKind
JpgDifferentialSequentialDCTHuffman
            Word8
0xC6 -> JpgFrameKind -> Get JpgFrameKind
forall (m :: * -> *) a. Monad m => a -> m a
return JpgFrameKind
JpgDifferentialProgressiveDCTHuffman
            Word8
0xC7 -> JpgFrameKind -> Get JpgFrameKind
forall (m :: * -> *) a. Monad m => a -> m a
return JpgFrameKind
JpgDifferentialLosslessHuffman
            Word8
0xC9 -> JpgFrameKind -> Get JpgFrameKind
forall (m :: * -> *) a. Monad m => a -> m a
return JpgFrameKind
JpgExtendedSequentialArithmetic
            Word8
0xCA -> JpgFrameKind -> Get JpgFrameKind
forall (m :: * -> *) a. Monad m => a -> m a
return JpgFrameKind
JpgProgressiveDCTArithmetic
            Word8
0xCB -> JpgFrameKind -> Get JpgFrameKind
forall (m :: * -> *) a. Monad m => a -> m a
return JpgFrameKind
JpgLosslessArithmetic
            Word8
0xCD -> JpgFrameKind -> Get JpgFrameKind
forall (m :: * -> *) a. Monad m => a -> m a
return JpgFrameKind
JpgDifferentialSequentialDCTArithmetic
            Word8
0xCE -> JpgFrameKind -> Get JpgFrameKind
forall (m :: * -> *) a. Monad m => a -> m a
return JpgFrameKind
JpgDifferentialProgressiveDCTArithmetic
            Word8
0xCF -> JpgFrameKind -> Get JpgFrameKind
forall (m :: * -> *) a. Monad m => a -> m a
return JpgFrameKind
JpgDifferentialLosslessArithmetic
            Word8
0xD9 -> JpgFrameKind -> Get JpgFrameKind
forall (m :: * -> *) a. Monad m => a -> m a
return JpgFrameKind
JpgEndOfImage
            Word8
0xDA -> JpgFrameKind -> Get JpgFrameKind
forall (m :: * -> *) a. Monad m => a -> m a
return JpgFrameKind
JpgStartOfScan
            Word8
0xDB -> JpgFrameKind -> Get JpgFrameKind
forall (m :: * -> *) a. Monad m => a -> m a
return JpgFrameKind
JpgQuantizationTable
            Word8
0xDD -> JpgFrameKind -> Get JpgFrameKind
forall (m :: * -> *) a. Monad m => a -> m a
return JpgFrameKind
JpgRestartInterval
            Word8
a | Word8
a Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word8
0xF0 -> JpgFrameKind -> Get JpgFrameKind
forall (m :: * -> *) a. Monad m => a -> m a
return (JpgFrameKind -> Get JpgFrameKind)
-> JpgFrameKind -> Get JpgFrameKind
forall a b. (a -> b) -> a -> b
$! Word8 -> JpgFrameKind
JpgExtensionSegment Word8
a
              | Word8
a Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word8
0xE0 -> JpgFrameKind -> Get JpgFrameKind
forall (m :: * -> *) a. Monad m => a -> m a
return (JpgFrameKind -> Get JpgFrameKind)
-> JpgFrameKind -> Get JpgFrameKind
forall a b. (a -> b) -> a -> b
$! Word8 -> JpgFrameKind
JpgAppSegment (Word8
a Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
- Word8
0xE0)
              | Word8
a Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word8
0xD0 Bool -> Bool -> Bool
&& Word8
a Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8
0xD7 -> JpgFrameKind -> Get JpgFrameKind
forall (m :: * -> *) a. Monad m => a -> m a
return (JpgFrameKind -> Get JpgFrameKind)
-> JpgFrameKind -> Get JpgFrameKind
forall a b. (a -> b) -> a -> b
$! Word8 -> JpgFrameKind
JpgRestartIntervalEnd Word8
a
              | Bool
otherwise -> String -> Get JpgFrameKind
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"Invalid frame marker (" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Word8 -> String
forall a. Show a => a -> String
show Word8
a String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")")

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

get4BitOfEach :: Get (Word8, Word8)
get4BitOfEach :: Get (Word8, Word8)
get4BitOfEach = do
    Word8
val <- Get Word8
forall t. Binary t => Get t
get
    (Word8, Word8) -> Get (Word8, Word8)
forall (m :: * -> *) a. Monad m => a -> m a
return ((Word8
val Word8 -> Int -> Word8
forall a. Bits a => a -> Int -> a
`unsafeShiftR` Int
4) Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. Word8
0xF, Word8
val Word8 -> Word8 -> Word8
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 Put -> Put -> Put
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
        Bool -> Get () -> Get ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Word16
size Word16 -> Word16 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word16
4) (String -> Get ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Invalid jpeg restart interval size")
        Word16 -> RestartInterval
RestartInterval (Word16 -> RestartInterval) -> Get Word16 -> Get 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
        JpgComponent -> Get JpgComponent
forall (m :: * -> *) a. Monad m => a -> m a
return JpgComponent :: Word8 -> Word8 -> Word8 -> Word8 -> JpgComponent
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
        Word8 -> Put
forall t. Binary t => t -> Put
put (Word8 -> Put) -> Word8 -> Put
forall a b. (a -> b) -> a -> b
$ JpgComponent -> Word8
componentIdentifier JpgComponent
v
        Word8 -> Word8 -> Put
put4BitsOfEach (JpgComponent -> Word8
horizontalSamplingFactor JpgComponent
v) (Word8 -> Put) -> Word8 -> Put
forall a b. (a -> b) -> a -> b
$ JpgComponent -> Word8
verticalSamplingFactor JpgComponent
v
        Word8 -> Put
forall t. Binary t => t -> Put
put (Word8 -> Put) -> Word8 -> Put
forall a b. (a -> b) -> a -> b
$ JpgComponent -> Word8
quantizationTableDest JpgComponent
v

instance Binary JpgFrameHeader where
    get :: Get JpgFrameHeader
get = do
        Int
beginOffset <- Int64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> Int) -> Get Int64 -> Get Int
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 <- Int -> Get JpgComponent -> Get [JpgComponent]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
compCount) Get JpgComponent
forall t. Binary t => Get t
get
        Int
endOffset <- Int64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> Int) -> Get Int64 -> Get Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Int64
bytesRead
        Bool -> Get () -> Get ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
beginOffset Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
endOffset Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
frmHLength)
             (Int -> Get ()
skip (Int -> Get ()) -> Int -> Get ()
forall a b. (a -> b) -> a -> b
$ Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
frmHLength Int -> Int -> Int
forall a. Num a => a -> a -> a
- (Int
endOffset Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
beginOffset))
        JpgFrameHeader -> Get JpgFrameHeader
forall (m :: * -> *) a. Monad m => a -> m a
return JpgFrameHeader :: Word16
-> Word8
-> Word16
-> Word16
-> Word8
-> [JpgComponent]
-> JpgFrameHeader
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 (Word16 -> Put) -> Word16 -> Put
forall a b. (a -> b) -> a -> b
$ JpgFrameHeader -> Word16
jpgFrameHeaderLength JpgFrameHeader
v
        Word8 -> Put
putWord8    (Word8 -> Put) -> Word8 -> Put
forall a b. (a -> b) -> a -> b
$ JpgFrameHeader -> Word8
jpgSamplePrecision JpgFrameHeader
v
        Word16 -> Put
putWord16be (Word16 -> Put) -> Word16 -> Put
forall a b. (a -> b) -> a -> b
$ JpgFrameHeader -> Word16
jpgHeight JpgFrameHeader
v
        Word16 -> Put
putWord16be (Word16 -> Put) -> Word16 -> Put
forall a b. (a -> b) -> a -> b
$ JpgFrameHeader -> Word16
jpgWidth JpgFrameHeader
v
        Word8 -> Put
putWord8    (Word8 -> Put) -> Word8 -> Put
forall a b. (a -> b) -> a -> b
$ JpgFrameHeader -> Word8
jpgImageComponentCount JpgFrameHeader
v
        (JpgComponent -> Put) -> [JpgComponent] -> Put
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ JpgComponent -> Put
forall t. Binary t => t -> Put
put   ([JpgComponent] -> Put) -> [JpgComponent] -> Put
forall a b. (a -> b) -> a -> b
$ JpgFrameHeader -> [JpgComponent]
jpgComponents JpgFrameHeader
v

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

    get :: Get JpgScanSpecification
get = do
        Word8
compSel <- Get Word8
forall t. Binary t => Get t
get
        (Word8
dc, Word8
ac) <- Get (Word8, Word8)
get4BitOfEach
        JpgScanSpecification -> Get JpgScanSpecification
forall (m :: * -> *) a. Monad m => a -> m a
return JpgScanSpecification :: Word8 -> Word8 -> Word8 -> JpgScanSpecification
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 <- Int -> Get JpgScanSpecification -> Get [JpgScanSpecification]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
compCount) Get JpgScanSpecification
forall t. Binary t => Get t
get
        Word8
specBeg <- Get Word8
forall t. Binary t => Get t
get
        Word8
specEnd <- Get Word8
forall t. Binary t => Get t
get
        (Word8
approxHigh, Word8
approxLow) <- Get (Word8, Word8)
get4BitOfEach

        JpgScanHeader -> Get JpgScanHeader
forall (m :: * -> *) a. Monad m => a -> m a
return JpgScanHeader :: Word16
-> Word8
-> [JpgScanSpecification]
-> (Word8, Word8)
-> Word8
-> Word8
-> JpgScanHeader
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 (Word16 -> Put) -> Word16 -> Put
forall a b. (a -> b) -> a -> b
$ JpgScanHeader -> Word16
scanLength JpgScanHeader
v
        Word8 -> Put
putWord8 (Word8 -> Put) -> Word8 -> Put
forall a b. (a -> b) -> a -> b
$ JpgScanHeader -> Word8
scanComponentCount JpgScanHeader
v
        (JpgScanSpecification -> Put) -> [JpgScanSpecification] -> Put
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ JpgScanSpecification -> Put
forall t. Binary t => t -> Put
put ([JpgScanSpecification] -> Put) -> [JpgScanSpecification] -> Put
forall a b. (a -> b) -> a -> b
$ JpgScanHeader -> [JpgScanSpecification]
scans JpgScanHeader
v
        Word8 -> Put
putWord8 (Word8 -> Put)
-> ((Word8, Word8) -> Word8) -> (Word8, Word8) -> Put
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word8, Word8) -> Word8
forall a b. (a, b) -> a
fst ((Word8, Word8) -> Put) -> (Word8, Word8) -> Put
forall a b. (a -> b) -> a -> b
$ JpgScanHeader -> (Word8, Word8)
spectralSelection JpgScanHeader
v
        Word8 -> Put
putWord8 (Word8 -> Put)
-> ((Word8, Word8) -> Word8) -> (Word8, Word8) -> Put
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word8, Word8) -> Word8
forall a b. (a, b) -> b
snd ((Word8, Word8) -> Put) -> (Word8, Word8) -> Put
forall a b. (a -> b) -> a -> b
$ JpgScanHeader -> (Word8, Word8)
spectralSelection JpgScanHeader
v
        Word8 -> Word8 -> Put
put4BitsOfEach (JpgScanHeader -> Word8
successiveApproxHigh JpgScanHeader
v) (Word8 -> Put) -> Word8 -> Put
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 :: ST s (MutableMacroBlock s a)
createEmptyMutableMacroBlock = Int -> a -> ST s (MVector (PrimState (ST s)) a)
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 :: 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 = String -> ST s String
forall (m :: * -> *) a. Monad m => a -> m a
return String
"===============================\n"
          pLn Int
i = do
              a
v <- MutableMacroBlock s a
MVector (PrimState (ST s)) a
block MVector (PrimState (ST s)) a -> Int -> ST s a
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
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
              String -> ST s String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> ST s String) -> String -> ST s String
forall a b. (a -> b) -> a -> b
$ String -> a -> String
forall r. PrintfType r => String -> r
printf (if Int
i Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
8 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then String
"\n%5d " else String
"%5d ") a
v String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
vn

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


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