{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE CPP #-}

-- | A good explanation of the JPEG format, including diagrams, is given at:

-- <https://github.com/corkami/formats/blob/master/image/jpeg.md>

--

-- The full spec (excluding EXIF): https://www.w3.org/Graphics/JPEG/itu-t81.pdf

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( .. )
                              , TableList( .. )
                              , RestartInterval( .. )
                              , getJpgImage
                              , calculateSize
                              , dctBlockSize
                              , parseECS
                              , parseECS_simple
                              , skipUntilFrames
                              , skipFrameMarker
                              , parseFrameOfKind
                              , parseFrames
                              , parseFrameKinds
                              , parseToFirstFrameHeader
                              ) where


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

import Control.DeepSeq( NFData(..) )
import Control.Monad( when, replicateM, forM, forM_, unless )
import Control.Monad.ST( ST )
import Data.Bits( (.|.), (.&.), unsafeShiftL, unsafeShiftR )
import Data.List( partition )
import Data.Maybe( maybeToList )
import GHC.Generics( Generic )

#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 qualified Data.ByteString.Unsafe as BU

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

import Data.Binary.Get( Get
                      , getWord8
                      , getWord16be
                      , getByteString
                      , skip
                      , bytesRead
                      , lookAhead
                      , ByteOffset
                      , getLazyByteString
                      )
import qualified Data.Binary.Get.Internal as GetInternal

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 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
$c== :: JpgFrameKind -> JpgFrameKind -> Bool
== :: JpgFrameKind -> JpgFrameKind -> Bool
$c/= :: JpgFrameKind -> JpgFrameKind -> Bool
/= :: 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
$cshowsPrec :: Int -> JpgFrameKind -> ShowS
showsPrec :: Int -> JpgFrameKind -> ShowS
$cshow :: JpgFrameKind -> String
show :: JpgFrameKind -> String
$cshowList :: [JpgFrameKind] -> ShowS
showList :: [JpgFrameKind] -> ShowS
Show, (forall x. JpgFrameKind -> Rep JpgFrameKind x)
-> (forall x. Rep JpgFrameKind x -> JpgFrameKind)
-> Generic JpgFrameKind
forall x. Rep JpgFrameKind x -> JpgFrameKind
forall x. JpgFrameKind -> Rep JpgFrameKind x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. JpgFrameKind -> Rep JpgFrameKind x
from :: forall x. JpgFrameKind -> Rep JpgFrameKind x
$cto :: forall x. Rep JpgFrameKind x -> JpgFrameKind
to :: forall x. Rep JpgFrameKind x -> JpgFrameKind
Generic)
instance NFData JpgFrameKind

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 -- ^ The @ByteString@ is the ECS (Entropy-Coded Segment), typically the largest part of compressed image data.

    | JpgScans           !JpgFrameKind !JpgFrameHeader
    | JpgIntervalRestart !Word16
    deriving (JpgFrame -> JpgFrame -> Bool
(JpgFrame -> JpgFrame -> Bool)
-> (JpgFrame -> JpgFrame -> Bool) -> Eq JpgFrame
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: JpgFrame -> JpgFrame -> Bool
== :: JpgFrame -> JpgFrame -> Bool
$c/= :: JpgFrame -> JpgFrame -> Bool
/= :: JpgFrame -> JpgFrame -> Bool
Eq, 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
$cshowsPrec :: Int -> JpgFrame -> ShowS
showsPrec :: Int -> JpgFrame -> ShowS
$cshow :: JpgFrame -> String
show :: JpgFrame -> String
$cshowList :: [JpgFrame] -> ShowS
showList :: [JpgFrame] -> ShowS
Show, (forall x. JpgFrame -> Rep JpgFrame x)
-> (forall x. Rep JpgFrame x -> JpgFrame) -> Generic JpgFrame
forall x. Rep JpgFrame x -> JpgFrame
forall x. JpgFrame -> Rep JpgFrame x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. JpgFrame -> Rep JpgFrame x
from :: forall x. JpgFrame -> Rep JpgFrame x
$cto :: forall x. Rep JpgFrame x -> JpgFrame
to :: forall x. Rep JpgFrame x -> JpgFrame
Generic)
instance NFData JpgFrame

data JpgColorSpace
  = JpgColorSpaceYCbCr
  | JpgColorSpaceYCC
  | JpgColorSpaceY
  | JpgColorSpaceYA
  | JpgColorSpaceYCCA
  | JpgColorSpaceYCCK
  | JpgColorSpaceCMYK
  | JpgColorSpaceRGB
  | JpgColorSpaceRGBA
  deriving (JpgColorSpace -> JpgColorSpace -> Bool
(JpgColorSpace -> JpgColorSpace -> Bool)
-> (JpgColorSpace -> JpgColorSpace -> Bool) -> Eq JpgColorSpace
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: JpgColorSpace -> JpgColorSpace -> Bool
== :: JpgColorSpace -> JpgColorSpace -> Bool
$c/= :: JpgColorSpace -> JpgColorSpace -> Bool
/= :: JpgColorSpace -> JpgColorSpace -> Bool
Eq, 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
$cshowsPrec :: Int -> JpgColorSpace -> ShowS
showsPrec :: Int -> JpgColorSpace -> ShowS
$cshow :: JpgColorSpace -> String
show :: JpgColorSpace -> String
$cshowList :: [JpgColorSpace] -> ShowS
showList :: [JpgColorSpace] -> ShowS
Show, (forall x. JpgColorSpace -> Rep JpgColorSpace x)
-> (forall x. Rep JpgColorSpace x -> JpgColorSpace)
-> Generic JpgColorSpace
forall x. Rep JpgColorSpace x -> JpgColorSpace
forall x. JpgColorSpace -> Rep JpgColorSpace x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. JpgColorSpace -> Rep JpgColorSpace x
from :: forall x. JpgColorSpace -> Rep JpgColorSpace x
$cto :: forall x. Rep JpgColorSpace x -> JpgColorSpace
to :: forall x. Rep JpgColorSpace x -> JpgColorSpace
Generic)
instance NFData JpgColorSpace

data AdobeTransform
  = AdobeUnknown    -- ^ Value 0

  | AdobeYCbCr      -- ^ value 1

  | AdobeYCck       -- ^ value 2

  deriving (AdobeTransform -> AdobeTransform -> Bool
(AdobeTransform -> AdobeTransform -> Bool)
-> (AdobeTransform -> AdobeTransform -> Bool) -> Eq AdobeTransform
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: AdobeTransform -> AdobeTransform -> Bool
== :: AdobeTransform -> AdobeTransform -> Bool
$c/= :: AdobeTransform -> AdobeTransform -> Bool
/= :: AdobeTransform -> AdobeTransform -> Bool
Eq, 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
$cshowsPrec :: Int -> AdobeTransform -> ShowS
showsPrec :: Int -> AdobeTransform -> ShowS
$cshow :: AdobeTransform -> String
show :: AdobeTransform -> String
$cshowList :: [AdobeTransform] -> ShowS
showList :: [AdobeTransform] -> ShowS
Show, (forall x. AdobeTransform -> Rep AdobeTransform x)
-> (forall x. Rep AdobeTransform x -> AdobeTransform)
-> Generic AdobeTransform
forall x. Rep AdobeTransform x -> AdobeTransform
forall x. AdobeTransform -> Rep AdobeTransform x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. AdobeTransform -> Rep AdobeTransform x
from :: forall x. AdobeTransform -> Rep AdobeTransform x
$cto :: forall x. Rep AdobeTransform x -> AdobeTransform
to :: forall x. Rep AdobeTransform x -> AdobeTransform
Generic)
instance NFData AdobeTransform

data JpgAdobeApp14 = JpgAdobeApp14
  { JpgAdobeApp14 -> Word16
_adobeDctVersion :: !Word16
  , JpgAdobeApp14 -> Word16
_adobeFlag0      :: !Word16
  , JpgAdobeApp14 -> Word16
_adobeFlag1      :: !Word16
  , JpgAdobeApp14 -> AdobeTransform
_adobeTransform  :: !AdobeTransform
  }
  deriving (JpgAdobeApp14 -> JpgAdobeApp14 -> Bool
(JpgAdobeApp14 -> JpgAdobeApp14 -> Bool)
-> (JpgAdobeApp14 -> JpgAdobeApp14 -> Bool) -> Eq JpgAdobeApp14
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: JpgAdobeApp14 -> JpgAdobeApp14 -> Bool
== :: JpgAdobeApp14 -> JpgAdobeApp14 -> Bool
$c/= :: JpgAdobeApp14 -> JpgAdobeApp14 -> Bool
/= :: JpgAdobeApp14 -> JpgAdobeApp14 -> Bool
Eq, 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
$cshowsPrec :: Int -> JpgAdobeApp14 -> ShowS
showsPrec :: Int -> JpgAdobeApp14 -> ShowS
$cshow :: JpgAdobeApp14 -> String
show :: JpgAdobeApp14 -> String
$cshowList :: [JpgAdobeApp14] -> ShowS
showList :: [JpgAdobeApp14] -> ShowS
Show, (forall x. JpgAdobeApp14 -> Rep JpgAdobeApp14 x)
-> (forall x. Rep JpgAdobeApp14 x -> JpgAdobeApp14)
-> Generic JpgAdobeApp14
forall x. Rep JpgAdobeApp14 x -> JpgAdobeApp14
forall x. JpgAdobeApp14 -> Rep JpgAdobeApp14 x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. JpgAdobeApp14 -> Rep JpgAdobeApp14 x
from :: forall x. JpgAdobeApp14 -> Rep JpgAdobeApp14 x
$cto :: forall x. Rep JpgAdobeApp14 x -> JpgAdobeApp14
to :: forall x. Rep JpgAdobeApp14 x -> JpgAdobeApp14
Generic)
instance NFData JpgAdobeApp14

-- | Size: 1

data JFifUnit
  = JFifUnitUnknown   -- ^ 0

  | JFifPixelsPerInch -- ^ 1

  | JFifPixelsPerCentimeter -- ^ 2

  deriving (JFifUnit -> JFifUnit -> Bool
(JFifUnit -> JFifUnit -> Bool)
-> (JFifUnit -> JFifUnit -> Bool) -> Eq JFifUnit
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: JFifUnit -> JFifUnit -> Bool
== :: JFifUnit -> JFifUnit -> Bool
$c/= :: JFifUnit -> JFifUnit -> Bool
/= :: JFifUnit -> JFifUnit -> Bool
Eq, 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
$cshowsPrec :: Int -> JFifUnit -> ShowS
showsPrec :: Int -> JFifUnit -> ShowS
$cshow :: JFifUnit -> String
show :: JFifUnit -> String
$cshowList :: [JFifUnit] -> ShowS
showList :: [JFifUnit] -> ShowS
Show, (forall x. JFifUnit -> Rep JFifUnit x)
-> (forall x. Rep JFifUnit x -> JFifUnit) -> Generic JFifUnit
forall x. Rep JFifUnit x -> JFifUnit
forall x. JFifUnit -> Rep JFifUnit x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. JFifUnit -> Rep JFifUnit x
from :: forall x. JFifUnit -> Rep JFifUnit x
$cto :: forall x. Rep JFifUnit x -> JFifUnit
to :: forall x. Rep JFifUnit x -> JFifUnit
Generic)
instance NFData JFifUnit

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 a. a -> Get a
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 (JpgJFIFApp0 -> JpgJFIFApp0 -> Bool
(JpgJFIFApp0 -> JpgJFIFApp0 -> Bool)
-> (JpgJFIFApp0 -> JpgJFIFApp0 -> Bool) -> Eq JpgJFIFApp0
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: JpgJFIFApp0 -> JpgJFIFApp0 -> Bool
== :: JpgJFIFApp0 -> JpgJFIFApp0 -> Bool
$c/= :: JpgJFIFApp0 -> JpgJFIFApp0 -> Bool
/= :: JpgJFIFApp0 -> JpgJFIFApp0 -> Bool
Eq, 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
$cshowsPrec :: Int -> JpgJFIFApp0 -> ShowS
showsPrec :: Int -> JpgJFIFApp0 -> ShowS
$cshow :: JpgJFIFApp0 -> String
show :: JpgJFIFApp0 -> String
$cshowList :: [JpgJFIFApp0] -> ShowS
showList :: [JpgJFIFApp0] -> ShowS
Show, (forall x. JpgJFIFApp0 -> Rep JpgJFIFApp0 x)
-> (forall x. Rep JpgJFIFApp0 x -> JpgJFIFApp0)
-> Generic JpgJFIFApp0
forall x. Rep JpgJFIFApp0 x -> JpgJFIFApp0
forall x. JpgJFIFApp0 -> Rep JpgJFIFApp0 x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. JpgJFIFApp0 -> Rep JpgJFIFApp0 x
from :: forall x. JpgJFIFApp0 -> Rep JpgJFIFApp0 x
$cto :: forall x. Rep JpgJFIFApp0 x -> JpgJFIFApp0
to :: forall x. Rep JpgJFIFApp0 x -> JpgJFIFApp0
Generic)
instance NFData JpgJFIFApp0

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 a. String -> Get a
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 a. String -> Get a
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 a. a -> Get a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Int
forall a. Maybe a
Nothing
      Word8
_ -> Maybe Int -> Get (Maybe Int)
forall a. a -> Get a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Int
forall a. Maybe a
Nothing
    JpgJFIFApp0 -> Get JpgJFIFApp0
forall a. a -> Get a
forall (m :: * -> *) a. Monad m => a -> m a
return (JpgJFIFApp0 -> Get JpgJFIFApp0) -> JpgJFIFApp0 -> Get JpgJFIFApp0
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 (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 a. a -> Get a
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 a. String -> Get a
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 a. String -> Get a
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 a b. Get (a -> b) -> Get a -> Get b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get Word16
getWord16be Get (AdobeTransform -> JpgAdobeApp14)
-> Get AdobeTransform -> Get JpgAdobeApp14
forall a b. Get (a -> b) -> Get a -> Get b
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 (JpgFrameHeader -> JpgFrameHeader -> Bool
(JpgFrameHeader -> JpgFrameHeader -> Bool)
-> (JpgFrameHeader -> JpgFrameHeader -> Bool) -> Eq JpgFrameHeader
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: JpgFrameHeader -> JpgFrameHeader -> Bool
== :: JpgFrameHeader -> JpgFrameHeader -> Bool
$c/= :: JpgFrameHeader -> JpgFrameHeader -> Bool
/= :: JpgFrameHeader -> JpgFrameHeader -> Bool
Eq, 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
$cshowsPrec :: Int -> JpgFrameHeader -> ShowS
showsPrec :: Int -> JpgFrameHeader -> ShowS
$cshow :: JpgFrameHeader -> String
show :: JpgFrameHeader -> String
$cshowList :: [JpgFrameHeader] -> ShowS
showList :: [JpgFrameHeader] -> ShowS
Show, (forall x. JpgFrameHeader -> Rep JpgFrameHeader x)
-> (forall x. Rep JpgFrameHeader x -> JpgFrameHeader)
-> Generic JpgFrameHeader
forall x. Rep JpgFrameHeader x -> JpgFrameHeader
forall x. JpgFrameHeader -> Rep JpgFrameHeader x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. JpgFrameHeader -> Rep JpgFrameHeader x
from :: forall x. JpgFrameHeader -> Rep JpgFrameHeader x
$cto :: forall x. Rep JpgFrameHeader x -> JpgFrameHeader
to :: forall x. Rep JpgFrameHeader x -> JpgFrameHeader
Generic)
instance NFData JpgFrameHeader


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 a. Num a => [a] -> a
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 (JpgComponent -> JpgComponent -> Bool
(JpgComponent -> JpgComponent -> Bool)
-> (JpgComponent -> JpgComponent -> Bool) -> Eq JpgComponent
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: JpgComponent -> JpgComponent -> Bool
== :: JpgComponent -> JpgComponent -> Bool
$c/= :: JpgComponent -> JpgComponent -> Bool
/= :: JpgComponent -> JpgComponent -> Bool
Eq, 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
$cshowsPrec :: Int -> JpgComponent -> ShowS
showsPrec :: Int -> JpgComponent -> ShowS
$cshow :: JpgComponent -> String
show :: JpgComponent -> String
$cshowList :: [JpgComponent] -> ShowS
showList :: [JpgComponent] -> ShowS
Show, (forall x. JpgComponent -> Rep JpgComponent x)
-> (forall x. Rep JpgComponent x -> JpgComponent)
-> Generic JpgComponent
forall x. Rep JpgComponent x -> JpgComponent
forall x. JpgComponent -> Rep JpgComponent x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. JpgComponent -> Rep JpgComponent x
from :: forall x. JpgComponent -> Rep JpgComponent x
$cto :: forall x. Rep JpgComponent x -> JpgComponent
to :: forall x. Rep JpgComponent x -> JpgComponent
Generic)
instance NFData JpgComponent

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

data JpgImage = JpgImage { JpgImage -> [JpgFrame]
jpgFrame :: [JpgFrame] }
    deriving (JpgImage -> JpgImage -> Bool
(JpgImage -> JpgImage -> Bool)
-> (JpgImage -> JpgImage -> Bool) -> Eq JpgImage
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: JpgImage -> JpgImage -> Bool
== :: JpgImage -> JpgImage -> Bool
$c/= :: JpgImage -> JpgImage -> Bool
/= :: JpgImage -> JpgImage -> Bool
Eq, 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
$cshowsPrec :: Int -> JpgImage -> ShowS
showsPrec :: Int -> JpgImage -> ShowS
$cshow :: JpgImage -> String
show :: JpgImage -> String
$cshowList :: [JpgImage] -> ShowS
showList :: [JpgImage] -> ShowS
Show, (forall x. JpgImage -> Rep JpgImage x)
-> (forall x. Rep JpgImage x -> JpgImage) -> Generic JpgImage
forall x. Rep JpgImage x -> JpgImage
forall x. JpgImage -> Rep JpgImage x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. JpgImage -> Rep JpgImage x
from :: forall x. JpgImage -> Rep JpgImage x
$cto :: forall x. Rep JpgImage x -> JpgImage
to :: forall x. Rep JpgImage x -> JpgImage
Generic)
instance NFData JpgImage

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

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

    , JpgScanSpecification -> Word8
acEntropyCodingTable :: !Word8

    }
    deriving (JpgScanSpecification -> JpgScanSpecification -> Bool
(JpgScanSpecification -> JpgScanSpecification -> Bool)
-> (JpgScanSpecification -> JpgScanSpecification -> Bool)
-> Eq JpgScanSpecification
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: JpgScanSpecification -> JpgScanSpecification -> Bool
== :: JpgScanSpecification -> JpgScanSpecification -> Bool
$c/= :: JpgScanSpecification -> JpgScanSpecification -> Bool
/= :: JpgScanSpecification -> JpgScanSpecification -> Bool
Eq, 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
$cshowsPrec :: Int -> JpgScanSpecification -> ShowS
showsPrec :: Int -> JpgScanSpecification -> ShowS
$cshow :: JpgScanSpecification -> String
show :: JpgScanSpecification -> String
$cshowList :: [JpgScanSpecification] -> ShowS
showList :: [JpgScanSpecification] -> ShowS
Show, (forall x. JpgScanSpecification -> Rep JpgScanSpecification x)
-> (forall x. Rep JpgScanSpecification x -> JpgScanSpecification)
-> Generic JpgScanSpecification
forall x. Rep JpgScanSpecification x -> JpgScanSpecification
forall x. JpgScanSpecification -> Rep JpgScanSpecification x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. JpgScanSpecification -> Rep JpgScanSpecification x
from :: forall x. JpgScanSpecification -> Rep JpgScanSpecification x
$cto :: forall x. Rep JpgScanSpecification x -> JpgScanSpecification
to :: forall x. Rep JpgScanSpecification x -> JpgScanSpecification
Generic)
instance NFData JpgScanSpecification

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 (JpgScanHeader -> JpgScanHeader -> Bool
(JpgScanHeader -> JpgScanHeader -> Bool)
-> (JpgScanHeader -> JpgScanHeader -> Bool) -> Eq JpgScanHeader
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: JpgScanHeader -> JpgScanHeader -> Bool
== :: JpgScanHeader -> JpgScanHeader -> Bool
$c/= :: JpgScanHeader -> JpgScanHeader -> Bool
/= :: JpgScanHeader -> JpgScanHeader -> Bool
Eq, 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
$cshowsPrec :: Int -> JpgScanHeader -> ShowS
showsPrec :: Int -> JpgScanHeader -> ShowS
$cshow :: JpgScanHeader -> String
show :: JpgScanHeader -> String
$cshowList :: [JpgScanHeader] -> ShowS
showList :: [JpgScanHeader] -> ShowS
Show, (forall x. JpgScanHeader -> Rep JpgScanHeader x)
-> (forall x. Rep JpgScanHeader x -> JpgScanHeader)
-> Generic JpgScanHeader
forall x. Rep JpgScanHeader x -> JpgScanHeader
forall x. JpgScanHeader -> Rep JpgScanHeader x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. JpgScanHeader -> Rep JpgScanHeader x
from :: forall x. JpgScanHeader -> Rep JpgScanHeader x
$cto :: forall x. Rep JpgScanHeader x -> JpgScanHeader
to :: forall x. Rep JpgScanHeader x -> JpgScanHeader
Generic)
instance NFData JpgScanHeader

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 a. Num a => [a] -> a
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 (JpgQuantTableSpec -> JpgQuantTableSpec -> Bool
(JpgQuantTableSpec -> JpgQuantTableSpec -> Bool)
-> (JpgQuantTableSpec -> JpgQuantTableSpec -> Bool)
-> Eq JpgQuantTableSpec
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: JpgQuantTableSpec -> JpgQuantTableSpec -> Bool
== :: JpgQuantTableSpec -> JpgQuantTableSpec -> Bool
$c/= :: JpgQuantTableSpec -> JpgQuantTableSpec -> Bool
/= :: JpgQuantTableSpec -> JpgQuantTableSpec -> Bool
Eq, 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
$cshowsPrec :: Int -> JpgQuantTableSpec -> ShowS
showsPrec :: Int -> JpgQuantTableSpec -> ShowS
$cshow :: JpgQuantTableSpec -> String
show :: JpgQuantTableSpec -> String
$cshowList :: [JpgQuantTableSpec] -> ShowS
showList :: [JpgQuantTableSpec] -> ShowS
Show, (forall x. JpgQuantTableSpec -> Rep JpgQuantTableSpec x)
-> (forall x. Rep JpgQuantTableSpec x -> JpgQuantTableSpec)
-> Generic JpgQuantTableSpec
forall x. Rep JpgQuantTableSpec x -> JpgQuantTableSpec
forall x. JpgQuantTableSpec -> Rep JpgQuantTableSpec x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. JpgQuantTableSpec -> Rep JpgQuantTableSpec x
from :: forall x. JpgQuantTableSpec -> Rep JpgQuantTableSpec x
$cto :: forall x. Rep JpgQuantTableSpec x -> JpgQuantTableSpec
to :: forall x. Rep JpgQuantTableSpec x -> JpgQuantTableSpec
Generic)
instance NFData JpgQuantTableSpec

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 a. Num a => [a] -> a
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 a b. Get a -> (a -> Get b) -> Get b
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 a. 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 a. a -> Get a
forall (m :: * -> *) a. Monad m => a -> m a
return 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 (JpgHuffmanTableSpec -> JpgHuffmanTableSpec -> Bool
(JpgHuffmanTableSpec -> JpgHuffmanTableSpec -> Bool)
-> (JpgHuffmanTableSpec -> JpgHuffmanTableSpec -> Bool)
-> Eq JpgHuffmanTableSpec
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: JpgHuffmanTableSpec -> JpgHuffmanTableSpec -> Bool
== :: JpgHuffmanTableSpec -> JpgHuffmanTableSpec -> Bool
$c/= :: JpgHuffmanTableSpec -> JpgHuffmanTableSpec -> Bool
/= :: JpgHuffmanTableSpec -> JpgHuffmanTableSpec -> Bool
Eq, 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
$cshowsPrec :: Int -> JpgHuffmanTableSpec -> ShowS
showsPrec :: Int -> JpgHuffmanTableSpec -> ShowS
$cshow :: JpgHuffmanTableSpec -> String
show :: JpgHuffmanTableSpec -> String
$cshowList :: [JpgHuffmanTableSpec] -> ShowS
showList :: [JpgHuffmanTableSpec] -> ShowS
Show, (forall x. JpgHuffmanTableSpec -> Rep JpgHuffmanTableSpec x)
-> (forall x. Rep JpgHuffmanTableSpec x -> JpgHuffmanTableSpec)
-> Generic JpgHuffmanTableSpec
forall x. Rep JpgHuffmanTableSpec x -> JpgHuffmanTableSpec
forall x. JpgHuffmanTableSpec -> Rep JpgHuffmanTableSpec x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. JpgHuffmanTableSpec -> Rep JpgHuffmanTableSpec x
from :: forall x. JpgHuffmanTableSpec -> Rep JpgHuffmanTableSpec x
$cto :: forall x. Rep JpgHuffmanTableSpec x -> JpgHuffmanTableSpec
to :: forall x. Rep JpgHuffmanTableSpec x -> JpgHuffmanTableSpec
Generic)
instance NFData JpgHuffmanTableSpec

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 a. Num a => [a] -> a
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 a. a -> Get a
forall (m :: * -> *) a. Monad m => a -> m a
return 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 a b. PutM a -> PutM b -> PutM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Word8 -> Put
putWord8 Word8
0xD8 Put -> Put -> Put
forall a b. PutM a -> PutM b -> PutM b
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 a b. PutM a -> PutM b -> PutM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Word8 -> Put
putWord8 Word8
0xFF Put -> Put -> Put
forall a b. PutM a -> PutM b -> PutM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Word8 -> Put
putWord8 Word8
0xD9

    -- | Consider using `getJpgImage` instead for a non-semi-lazy implementation.

    get :: Get JpgImage
get = do
        Get ()
skipUntilFrames
        [JpgFrame]
frames <- Get [JpgFrame]
parseFramesSemiLazy
        -- let endOfImageMarker = 0xD9

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

-- | Like `get` from `instance Binary JpgImage`, but without the legacy

-- semi-lazy implementation.

getJpgImage :: Get JpgImage
getJpgImage :: Get JpgImage
getJpgImage = do
    Get ()
skipUntilFrames
    [JpgFrame]
frames <- Get [JpgFrame]
parseFrames
    JpgImage -> Get JpgImage
forall a. a -> Get a
forall (m :: * -> *) a. Monad m => a -> m a
return JpgImage { jpgFrame :: [JpgFrame]
jpgFrame = [JpgFrame]
frames }

skipUntilFrames :: Get ()
skipUntilFrames :: Get ()
skipUntilFrames = do
    let startOfImageMarker :: Word8
startOfImageMarker = Word8
0xD8
    Word8 -> Word8 -> Get ()
checkMarker Word8
commonMarkerFirstByte Word8
startOfImageMarker
    Get ()
eatUntilCode

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 a b. PutM a -> PutM b -> PutM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Word16 -> Put
putWord16be Word16
14 Put -> Put -> Put
forall a b. PutM a -> PutM b -> PutM b
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 a b. PutM a -> PutM b -> PutM b
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 a b. PutM a -> PutM b -> PutM b
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 a b. PutM a -> PutM b -> PutM b
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 a b. PutM a -> PutM b -> PutM b
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 a b. PutM a -> PutM b -> PutM b
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 a b. PutM a -> PutM b -> PutM b
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 a b. PutM a -> PutM b -> PutM b
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 a b. PutM a -> PutM b -> PutM b
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 a b. PutM a -> PutM b -> PutM b
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 a b. PutM a -> PutM b -> PutM b
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 a b. PutM a -> PutM b -> PutM b
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 a b. PutM a -> PutM b -> PutM b
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 a. String -> Get a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Invalid marker used")

-- | Simpler implementation of `parseECS` to allow an easier understanding

-- of the logic, and to provide a comparison for correctness.

parseECS_simple :: Get L.ByteString
parseECS_simple :: Get ByteString
parseECS_simple = do
    -- There's no efficient way in `binary` to parse byte-by-byte while assembling a

    -- resulting ByteString (without using `.Internal` modules, which is what

    --  `parseECS` does), so instead first compute the length of the content

    -- byte-by-byte inside a `lookAhead` (not advancing the parser offset), and

    -- then efficiently take that long a ByteString (advancing the parser offset).

    --

    -- This is still slow compared to `parseECS` because parser functions

    -- (`getWord8`) are used repeatedly, instead of plain loops over ByteString contents.

    -- The slowdown is ~2x on GHC 8.10.7 on an Intel Core i7-7500U.

    Int64
n <- Get Int64 -> Get Int64
forall a. Get a -> Get a
lookAhead Get Int64
getContentLength
    Int64 -> Get ByteString
getLazyByteString Int64
n
  where
    getContentLength :: Get ByteOffset
    getContentLength :: Get Int64
getContentLength = do
        Int64
bytesReadBeforeContent <- Get Int64
bytesRead
        let loop :: Word8 -> Get ByteOffset
            loop :: Word8 -> Get Int64
loop !Word8
v = do
                Word8
vNext <- Get Word8
getWord8
                let 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
                let vIsSegmentMarker :: Bool
vIsSegmentMarker = 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
                if Bool -> Bool
not Bool
vIsSegmentMarker
                    then Word8 -> Get Int64
loop Word8
vNext
                    else do
                        Int64
bytesReadAfterContentPlus2 <- Get Int64
bytesRead -- "plus 2" because we've also read the segment marker (0xFF and `vNext`)

                        let !contentLength :: Int64
contentLength = (Int64
bytesReadAfterContentPlus2 Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
- Int64
2) Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
- Int64
bytesReadBeforeContent
                        Int64 -> Get Int64
forall a. a -> Get a
forall (m :: * -> *) a. Monad m => a -> m a
return Int64
contentLength

        Word8
v_first <- Get Word8
getWord8
        Word8 -> Get Int64
loop Word8
v_first

-- Replace by `Data.ByteString.dropEnd` once we require `bytestring >= 0.11.1.0`.

bsDropEnd :: Int -> B.ByteString -> B.ByteString
bsDropEnd :: Int -> ByteString -> ByteString
bsDropEnd Int
n ByteString
bs
    | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0    = ByteString
bs
    | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
len  = ByteString
B.empty
    | Bool
otherwise = Int -> ByteString -> ByteString
B.take (Int
len Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) ByteString
bs
  where
    len :: Int
len = ByteString -> Int
B.length ByteString
bs
{-# INLINE bsDropEnd #-}

-- | Parses a Scan's ECS (Entropy-Coded Segment, the largest part of compressed image data)

-- from the `Get` stream.

--

-- When this function is called, the parser's offset should be

-- immediately behind the SOS tag.

--

-- As described on e.g. https://www.ccoderun.ca/programming/2017-01-31_jpeg/,

--

-- > To find the next segment after the SOS, you must keep reading until you

-- > find a 0xFF bytes which is not immediately followed by 0x00 (see "byte stuffing")

-- > [or a reset marker's byte: 0xD0 through 0xD7].

-- > Normally, this will be the EOI segment that comes at the end of the file.

--

-- where the 0xFF is the next segment's marker.

-- See https://github.com/corkami/formats/blob/master/image/jpeg.md#entropy-coded-segment

-- for more details.

--

-- This function returns the ECS, not including the next segment's

-- marker on its trailing end.

parseECS :: Get L.ByteString
parseECS :: Get ByteString
parseECS = do
    -- For a simpler but slower implementation of this function, see

    -- `parseECS_simple`.


    Word8
v_first <- Get Word8
getWord8
    -- TODO: Compare with what `scan` from `binary-parsers` does.

    --       Probably we cannot use it because it does not allow us to set the parser state

    --       to be _before_ the segment marker which would be convenient to not have to

    --       make a special case the function that calls this function.

    --       But `scan` works on pointers into the bytestring chunks. Why, for performance?

    --       I've asked on https://github.com/winterland1989/binary-parsers/issues/7

    --       If that is for performance, we may want to replicate the same thing here.

    --

    --       An orthogonal idea is to use `Data.ByteString.elemIndex` to fast-forward

    --       to the next 0xFF using `memchr`, but the `unsafe` call to `memchr` might

    --       have too much overhead, since 0xFF bytes appear statistically every 256 bytes.

    --       See https://stackoverflow.com/questions/14519905/how-much-does-it-cost-for-haskell-ffi-to-go-into-c-and-back


    -- `withInputChunks` allows us to work on chunks of ByteStrings,

    -- reducing the number of higher-overhead `Get` functions called.

    -- It also allows to easily assemble the ByteString to return,

    -- which may be cross-chunk.

    -- `withInputChunks` terminates when we return a

    --     Right (consumed :: ByteString, unconsumed :: ByteString)

    -- from `consumeChunk`, setting the `Get` parser's offset to just before `unconsumed`.

    -- Because the segment marker we seek may be the 2 bytes across chunk boundaries,

    -- we need to keep a reference to the previous chunk (initialised as `B.empty`),

    -- so that we can set `consumed` properly, because this function is supposed

    -- to not consume the start of the segment marker (see code dropping the last

    -- byte of the previous chunk below).

    (Word8, ByteString)
-> Consume (Word8, ByteString)
-> ([ByteString] -> ByteString)
-> ([ByteString] -> Get ByteString)
-> Get ByteString
forall s b.
s
-> Consume s
-> ([ByteString] -> b)
-> ([ByteString] -> Get b)
-> Get b
GetInternal.withInputChunks
        (Word8
v_first, ByteString
B.empty)
        Consume (Word8, ByteString)
consumeChunk
        (         [ByteString] -> ByteString
L.fromChunks ([ByteString] -> ByteString)
-> ([ByteString] -> [ByteString]) -> [ByteString] -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word8 -> ByteString
B.singleton Word8
v_first ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
:)) -- `v_first` also belongs to the returned BS

        (ByteString -> Get ByteString
forall a. a -> Get a
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> Get ByteString)
-> ([ByteString] -> ByteString) -> [ByteString] -> Get ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ByteString] -> ByteString
L.fromChunks ([ByteString] -> ByteString)
-> ([ByteString] -> [ByteString]) -> [ByteString] -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word8 -> ByteString
B.singleton Word8
v_first ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
:)) -- `v_first` also belongs to the returned BS

  where
    consumeChunk :: GetInternal.Consume (Word8, B.ByteString) -- which is: (Word8, B.ByteString) -> B.ByteString -> Either (Word8, B.ByteString) (B.ByteString, B.ByteString)

    consumeChunk :: Consume (Word8, ByteString)
consumeChunk (!Word8
v_chunk_start, !ByteString
prev_chunk) !ByteString
chunk
        -- If `withInputChunks` hands us an empty chunk (which `binary` probably

        -- won't do, but since that's not documented, handle it anyway) then skip over it,

        -- so that we always remember the last `prev_chunk` that actually has data in it,

        -- since we `bsDropEnd 1 prev_chunk` in the `case` below.

        | ByteString -> Bool
B.null ByteString
chunk = (Word8, ByteString)
-> Either (Word8, ByteString) (ByteString, ByteString)
forall a b. a -> Either a b
Left (Word8
v_chunk_start, ByteString
prev_chunk)
        | Bool
otherwise = Word8 -> Int -> Either (Word8, ByteString) (ByteString, ByteString)
loop Word8
v_chunk_start Int
0
          where
            loop :: Word8 -> Int -> Either (Word8, B.ByteString) (B.ByteString, B.ByteString)
            loop :: Word8 -> Int -> Either (Word8, ByteString) (ByteString, ByteString)
loop !Word8
v !Int
offset_in_chunk
                | Int
offset_in_chunk Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= ByteString -> Int
B.length ByteString
chunk = (Word8, ByteString)
-> Either (Word8, ByteString) (ByteString, ByteString)
forall a b. a -> Either a b
Left (Word8
v, ByteString
chunk)
                | Bool
otherwise =
                    let !vNext :: Word8
vNext = ByteString -> Int -> Word8
BU.unsafeIndex ByteString
chunk Int
offset_in_chunk -- bounds check is done above

                        !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
                        !vIsSegmentMarker :: Bool
vIsSegmentMarker = 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
                    in
                        if Bool -> Bool
not Bool
vIsSegmentMarker
                            then Word8 -> Int -> Either (Word8, ByteString) (ByteString, ByteString)
loop Word8
vNext (Int
offset_in_chunkInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
                            else
                                -- Set the parser state to _before_ the segment marker.

                                -- The first case, where the segment marker's 2 bytes are exactly

                                -- at the chunk boundary, requires us to allocate a new BS with

                                -- `B.cons`; luckily this case should be rare.

                                let (!ByteString
consumed, !ByteString
unconsumed) = case () of
                                     () | Int
offset_in_chunk Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 -> (Int -> ByteString -> ByteString
bsDropEnd Int
1 ByteString
prev_chunk, Word8
v Word8 -> ByteString -> ByteString
`B.cons` ByteString
chunk) -- segment marker starts at `v`, which is the last byte of the previous chunk

                                        | Int
offset_in_chunk Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 -> (ByteString
B.empty, ByteString
chunk) -- segment marker starts exactly at `chunk`

                                        | Bool
otherwise            -> Int -> ByteString -> (ByteString, ByteString)
B.splitAt (Int
offset_in_chunk Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) ByteString
chunk -- segment marker starts at `v`, which is 1 before `vNext` (which is at `offset_in_chunk`)

                                in (ByteString, ByteString)
-> Either (Word8, ByteString) (ByteString, ByteString)
forall a b. b -> Either a b
Right ((ByteString, ByteString)
 -> Either (Word8, ByteString) (ByteString, ByteString))
-> (ByteString, ByteString)
-> Either (Word8, ByteString) (ByteString, ByteString)
forall a b. (a -> b) -> a -> b
$! (ByteString
consumed, ByteString
unconsumed)



parseAdobe14 :: B.ByteString -> Maybe JpgFrame
parseAdobe14 :: ByteString -> Maybe JpgFrame
parseAdobe14 ByteString
str = 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 -> Maybe JpgFrame
forall a. Maybe a
Nothing
    Right JpgAdobeApp14
app14 -> JpgFrame -> Maybe JpgFrame
forall a. a -> Maybe a
Just (JpgFrame -> Maybe JpgFrame) -> JpgFrame -> Maybe JpgFrame
forall a b. (a -> b) -> a -> b
$! JpgAdobeApp14 -> JpgFrame
JpgAdobeAPP14 JpgAdobeApp14
app14

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

parseJF__ :: B.ByteString -> Maybe JpgFrame
parseJF__ :: ByteString -> Maybe JpgFrame
parseJF__ ByteString
str = 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 -> Maybe JpgFrame
forall a. Maybe a
Nothing
    Right JpgJFIFApp0
jfif -> JpgFrame -> Maybe JpgFrame
forall a. a -> Maybe a
Just (JpgFrame -> Maybe JpgFrame) -> JpgFrame -> Maybe JpgFrame
forall a b. (a -> b) -> a -> b
$! JpgJFIFApp0 -> JpgFrame
JpgJFIF JpgJFIFApp0
jfif

parseExif :: B.ByteString -> Maybe JpgFrame
parseExif :: ByteString -> Maybe JpgFrame
parseExif ByteString
str
  | ByteString
exifHeader ByteString -> ByteString -> Bool
`B.isPrefixOf` ByteString
str =
      let
        tiff :: ByteString
tiff = Int -> ByteString -> ByteString
B.drop (ByteString -> Int
B.length ByteString
exifHeader) ByteString
str
      in
        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 -> Maybe JpgFrame
forall a. Maybe a
Nothing
            Right (TiffHeader
_hdr :: TiffHeader, []) -> Maybe JpgFrame
forall a. Maybe a
Nothing
            Right (TiffHeader
_hdr :: TiffHeader, [ImageFileDirectory]
ifds : [[ImageFileDirectory]]
_) -> JpgFrame -> Maybe JpgFrame
forall a. a -> Maybe a
Just (JpgFrame -> Maybe JpgFrame) -> JpgFrame -> Maybe JpgFrame
forall a b. (a -> b) -> a -> b
$! [ImageFileDirectory] -> JpgFrame
JpgExif [ImageFileDirectory]
ifds
  | Bool
otherwise = Maybe JpgFrame
forall a. Maybe a
Nothing
  where
    exifHeader :: ByteString
exifHeader = String -> ByteString
BC.pack String
"Exif\0\0"

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 (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 a. a -> [a]
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

skipFrameMarker :: Get ()
skipFrameMarker :: Get ()
skipFrameMarker = 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 a. String -> Get a
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
")"

-- | Parses a single frame.

--

-- Returns `Nothing` when we encounter a frame we want to skip.

parseFrameOfKind :: JpgFrameKind -> Get (Maybe JpgFrame)
parseFrameOfKind :: JpgFrameKind -> Get (Maybe JpgFrame)
parseFrameOfKind JpgFrameKind
kind = do
    case JpgFrameKind
kind of
        JpgFrameKind
JpgEndOfImage -> Maybe JpgFrame -> Get (Maybe JpgFrame)
forall a. a -> Get a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe JpgFrame
forall a. Maybe a
Nothing
        JpgAppSegment Word8
0 -> ByteString -> Maybe JpgFrame
parseJF__ (ByteString -> Maybe JpgFrame)
-> Get ByteString -> Get (Maybe JpgFrame)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get ByteString
takeCurrentFrame
        JpgAppSegment Word8
1 -> ByteString -> Maybe JpgFrame
parseExif (ByteString -> Maybe JpgFrame)
-> Get ByteString -> Get (Maybe JpgFrame)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get ByteString
takeCurrentFrame
        JpgAppSegment Word8
14 -> ByteString -> Maybe JpgFrame
parseAdobe14 (ByteString -> Maybe JpgFrame)
-> Get ByteString -> Get (Maybe JpgFrame)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get ByteString
takeCurrentFrame
        JpgAppSegment Word8
c -> JpgFrame -> Maybe JpgFrame
forall a. a -> Maybe a
Just (JpgFrame -> Maybe JpgFrame)
-> (ByteString -> JpgFrame) -> ByteString -> Maybe JpgFrame
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> ByteString -> JpgFrame
JpgAppFrame Word8
c (ByteString -> Maybe JpgFrame)
-> Get ByteString -> Get (Maybe JpgFrame)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get ByteString
takeCurrentFrame
        JpgExtensionSegment Word8
c -> JpgFrame -> Maybe JpgFrame
forall a. a -> Maybe a
Just (JpgFrame -> Maybe JpgFrame)
-> (ByteString -> JpgFrame) -> ByteString -> Maybe JpgFrame
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> ByteString -> JpgFrame
JpgExtension Word8
c (ByteString -> Maybe JpgFrame)
-> Get ByteString -> Get (Maybe JpgFrame)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get ByteString
takeCurrentFrame
        JpgFrameKind
JpgQuantizationTable ->
            (\(TableList [JpgQuantTableSpec]
quants) -> JpgFrame -> Maybe JpgFrame
forall a. a -> Maybe a
Just (JpgFrame -> Maybe JpgFrame) -> JpgFrame -> Maybe JpgFrame
forall a b. (a -> b) -> a -> b
$! [JpgQuantTableSpec] -> JpgFrame
JpgQuantTable [JpgQuantTableSpec]
quants) (TableList JpgQuantTableSpec -> Maybe JpgFrame)
-> Get (TableList JpgQuantTableSpec) -> Get (Maybe JpgFrame)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get (TableList JpgQuantTableSpec)
forall t. Binary t => Get t
get
        JpgFrameKind
JpgRestartInterval ->
            (\(RestartInterval Word16
i) -> JpgFrame -> Maybe JpgFrame
forall a. a -> Maybe a
Just (JpgFrame -> Maybe JpgFrame) -> JpgFrame -> Maybe JpgFrame
forall a b. (a -> b) -> a -> b
$! Word16 -> JpgFrame
JpgIntervalRestart Word16
i) (RestartInterval -> Maybe JpgFrame)
-> Get RestartInterval -> Get (Maybe JpgFrame)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get RestartInterval
forall t. Binary t => Get t
get
        JpgFrameKind
JpgHuffmanTableMarker ->
            (\(TableList [JpgHuffmanTableSpec]
huffTables) -> JpgFrame -> Maybe JpgFrame
forall a. a -> Maybe a
Just (JpgFrame -> Maybe JpgFrame) -> JpgFrame -> Maybe JpgFrame
forall a b. (a -> b) -> a -> b
$!
                    [(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])
                    (TableList JpgHuffmanTableSpec -> Maybe JpgFrame)
-> Get (TableList JpgHuffmanTableSpec) -> Get (Maybe JpgFrame)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get (TableList JpgHuffmanTableSpec)
forall t. Binary t => Get t
get
        JpgFrameKind
JpgStartOfScan -> do
            JpgScanHeader
scanHeader <- Get JpgScanHeader
forall t. Binary t => Get t
get
            ByteString
ecs <- Get ByteString
parseECS
            Maybe JpgFrame -> Get (Maybe JpgFrame)
forall a. a -> Get a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe JpgFrame -> Get (Maybe JpgFrame))
-> Maybe JpgFrame -> Get (Maybe JpgFrame)
forall a b. (a -> b) -> a -> b
$! JpgFrame -> Maybe JpgFrame
forall a. a -> Maybe a
Just (JpgFrame -> Maybe JpgFrame) -> JpgFrame -> Maybe JpgFrame
forall a b. (a -> b) -> a -> b
$! JpgScanHeader -> ByteString -> JpgFrame
JpgScanBlob JpgScanHeader
scanHeader ByteString
ecs
        JpgFrameKind
_ -> JpgFrame -> Maybe JpgFrame
forall a. a -> Maybe a
Just (JpgFrame -> Maybe JpgFrame)
-> (JpgFrameHeader -> JpgFrame) -> JpgFrameHeader -> Maybe JpgFrame
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JpgFrameKind -> JpgFrameHeader -> JpgFrame
JpgScans JpgFrameKind
kind (JpgFrameHeader -> Maybe JpgFrame)
-> Get JpgFrameHeader -> Get (Maybe JpgFrame)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get JpgFrameHeader
forall t. Binary t => Get t
get


-- | Parse a list of `JpgFrame`s.

--

-- This function has various quirks; consider the below with great caution

-- when using this function.

--

-- While @data JpgFrame = ... | JpgScanBlob !...` itself has strict fields,

--

-- This function is written in such a way that that it can construct

-- the @[JpgFrame]@ "lazily" such that the expensive byte-by-byte traversal

-- in `parseECS` to create a `JpgScanBlob` can be avoided if only

-- list elements before that `JpgScanBlob` are evaluated.

--

-- That means the user can write code such as

--

-- > let mbFirstScan =

-- >       case runGetOrFail (get @JPG.JpgImage) hugeImageByteString of -- (`get @JPG.JpgImage` uses `parseFramesSemiLazy`)

-- >         Right (_restBs, _offset, res) ->

-- >           find (\frame -> case frame of { JPG.JpgScans{} -> True; _ -> False }) (JPG.jpgFrame res)

--

-- with the guarantee that only the bytes before the ECS (large compressed image data)

-- will be inspected, assuming that indeed there is at least 1 `JpgScan` in front

-- of the `JpgScanBlob` that contains the ECS.

--

-- This guarantee can be useful to e.g. quickly read just the image

-- dimensions (width, height) without traversing the large data.

--

-- Also note that this `Get` parser does not correctly maintain the parser byte offset

-- (`Data.Binary.Get.bytesRead`), because as soon as a `JpgStartOfScan` is returned,

-- it uses `Data.Binary.Get.getRemainingLazyBytes` to provide:

--

-- 1. the laziness described above, and

-- 2. the ability to ignore any parser failure after the first successfully-parsed

--    `JpgScanBlob` (it is debatable whether this behaviour is a desirable behaviour of this

--    library, but it is historically so and existing exposed functions do not break

--    this for backwards compatibility with existing uses of this library).

--    This fact also means that even `parseNextFrameStrict` cannot maintain

--    correct parser byte offsets.

--

-- Further note that if you are reading a huge JPEG image from disk strictly,

-- this will already incur a full traversal (namely creation) of the `hugeImageByteString`.

-- Thus, `parseNextFrameLazy` only provides any benefit if you:

--

-- - read the image from disk using lazy IO (not recommended!) such as via

--   `Data.ByteString.Lazy.readFile`,

-- - or do something similar, such as creating the `hugeImageByteString` via @mmap()@

--

-- This function is called "semi lazy" because only the first `JpgScanBlob` returned

-- in the `[JpgFrame]` is returned lazily; frames of other types, or multiple

-- `JpgScanBlob`s, are confusingly not dealt with lazily.

--

-- If as a caller you do not want to deal with any of these quirks,

-- and use proper strict IO and/or via `Data.Binary.Get`'s incremental input interface:

--

-- - If you want the whole `[JpgFrame]`: use `parseFrames`.

-- - If you want parsing to terminate early as in the example shown above,

--   use in combination with just the right amount of `get :: Get JpgFrameKind`,

--   `parseFrameOfKind`, and `skipFrameMarker`.

parseFramesSemiLazy :: Get [JpgFrame]
parseFramesSemiLazy :: Get [JpgFrame]
parseFramesSemiLazy = do
    JpgFrameKind
kind <- Get JpgFrameKind
forall t. Binary t => Get t
get
    case JpgFrameKind
kind of
        -- The end-of-image case needs to be here because `_ ->` default case below

        -- unconditionally uses `skipFrameMarker` which does not exist after `JpgEndOfImage`.

        JpgFrameKind
JpgEndOfImage -> [JpgFrame] -> Get [JpgFrame]
forall a. a -> Get a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
        JpgFrameKind
JpgStartOfScan -> do
            JpgScanHeader
scanHeader <- Get JpgScanHeader
forall t. Binary t => Get t
get
            ByteString
remainingBytes <- Get ByteString
getRemainingLazyBytes
            -- It is after the above `getRemainingLazyBytes` that the `Get` parser lazily succeeds,

            -- allowing consumers of `parseFramesSemiLazy` evaluate all `[JpgFrame]` list elements

            -- until (excluding) the cons-cell around the `JpgScanBlob ...` we construct below.


            [JpgFrame] -> Get [JpgFrame]
forall a. a -> Get a
forall (m :: * -> *) a. Monad m => a -> m a
return ([JpgFrame] -> Get [JpgFrame]) -> [JpgFrame] -> Get [JpgFrame]
forall a b. (a -> b) -> a -> b
$ case Get ByteString -> ByteString -> Either String ByteString
forall a. Get a -> ByteString -> Either String a
runGet Get ByteString
parseECS ByteString
remainingBytes of
                Left String
_ ->
                    -- Construct invalid `JpgScanBlob` even when the compressed JPEG

                    -- data is truncated or otherwise invalid, because that's what JuicyPixels's

                    -- `parseFramesSemiLazy` function did in the past, for backwards compat.

                    [JpgScanHeader -> ByteString -> JpgFrame
JpgScanBlob JpgScanHeader
scanHeader ByteString
remainingBytes]
                Right ByteString
ecs ->
                    JpgScanHeader -> ByteString -> JpgFrame
JpgScanBlob JpgScanHeader
scanHeader ByteString
ecs
                    JpgFrame -> [JpgFrame] -> [JpgFrame]
forall a. a -> [a] -> [a]
:
                    -- TODO Why `drop 1` instead of `runGet (skipFrameMarker *> parseFramesSemiLazy) remainingBytes` that would check that the dropped 1 Byte is really a frame marker?

                    case Get [JpgFrame] -> ByteString -> Either String [JpgFrame]
forall a. Get a -> ByteString -> Either String a
runGet Get [JpgFrame]
parseFramesSemiLazy (Int64 -> ByteString -> ByteString
L.drop (ByteString -> Int64
L.length ByteString
ecs Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
1) ByteString
remainingBytes) of
                        -- After we've encountered the first scan blob containing encoded image data,

                        -- we accept anything else after to fail parsing, ignoring that failure,

                        -- end emitting no further frames.

                        -- TODO: Explain why JuicyPixel chose to use this logic, insteaed of failing.

                        Left String
_ -> []
                        Right [JpgFrame]
remainingFrames -> [JpgFrame]
remainingFrames
        JpgFrameKind
_ -> do
            Maybe JpgFrame
mbFrame <- JpgFrameKind -> Get (Maybe JpgFrame)
parseFrameOfKind JpgFrameKind
kind
            Get ()
skipFrameMarker
            [JpgFrame]
remainingFrames <- Get [JpgFrame]
parseFramesSemiLazy
            [JpgFrame] -> Get [JpgFrame]
forall a. a -> Get a
forall (m :: * -> *) a. Monad m => a -> m a
return ([JpgFrame] -> Get [JpgFrame]) -> [JpgFrame] -> Get [JpgFrame]
forall a b. (a -> b) -> a -> b
$ Maybe JpgFrame -> [JpgFrame]
forall a. Maybe a -> [a]
maybeToList Maybe JpgFrame
mbFrame [JpgFrame] -> [JpgFrame] -> [JpgFrame]
forall a. [a] -> [a] -> [a]
++ [JpgFrame]
remainingFrames

-- | Parse a list of `JpgFrame`s.

parseFrames :: Get [JpgFrame]
parseFrames :: Get [JpgFrame]
parseFrames = do
    JpgFrameKind
kind <- Get JpgFrameKind
forall t. Binary t => Get t
get
    case JpgFrameKind
kind of
        JpgFrameKind
JpgEndOfImage -> [JpgFrame] -> Get [JpgFrame]
forall a. a -> Get a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
        JpgFrameKind
_ -> do
            Maybe JpgFrame
mbFrame <- JpgFrameKind -> Get (Maybe JpgFrame)
parseFrameOfKind JpgFrameKind
kind
            Get ()
skipFrameMarker
            [JpgFrame]
remainingFrames <- Get [JpgFrame]
parseFrames
            [JpgFrame] -> Get [JpgFrame]
forall a. a -> Get a
forall (m :: * -> *) a. Monad m => a -> m a
return ([JpgFrame] -> Get [JpgFrame]) -> [JpgFrame] -> Get [JpgFrame]
forall a b. (a -> b) -> a -> b
$ Maybe JpgFrame -> [JpgFrame]
forall a. Maybe a -> [a]
maybeToList Maybe JpgFrame
mbFrame [JpgFrame] -> [JpgFrame] -> [JpgFrame]
forall a. [a] -> [a] -> [a]
++ [JpgFrame]
remainingFrames

-- | Parse a list of `JpgFrameKind`s with their corresponding offsets and lengths

-- (not counting the segment and frame markers into the lengths).

--

-- Useful for debugging.

parseFrameKinds :: Get [(JpgFrameKind, Int64, Int64)]
parseFrameKinds :: Get [(JpgFrameKind, Int64, Int64)]
parseFrameKinds = do
    Int64
kindMarkerOffset :: Int64 <- Get Int64
bytesRead
    JpgFrameKind
kind <- Get JpgFrameKind
forall t. Binary t => Get t
get
    case JpgFrameKind
kind of
        JpgFrameKind
JpgEndOfImage -> [(JpgFrameKind, Int64, Int64)]
-> Get [(JpgFrameKind, Int64, Int64)]
forall a. a -> Get a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [(JpgFrameKind
JpgEndOfImage, Int64
kindMarkerOffset, Int64
0)]
        JpgFrameKind
_ -> do
            Int64
parserOffsetBefore <- Get Int64
bytesRead
            Maybe JpgFrame
_ <- JpgFrameKind -> Get (Maybe JpgFrame)
parseFrameOfKind JpgFrameKind
kind
            Int64
parserOffsetAfter <- Get Int64
bytesRead
            let !segmentLengthWithoutMarker :: Int64
segmentLengthWithoutMarker = Int64
parserOffsetAfter Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
- Int64
parserOffsetBefore
            Get ()
skipFrameMarker
            [(JpgFrameKind, Int64, Int64)]
remainingKinds <- Get [(JpgFrameKind, Int64, Int64)]
parseFrameKinds
            [(JpgFrameKind, Int64, Int64)]
-> Get [(JpgFrameKind, Int64, Int64)]
forall a. a -> Get a
forall (m :: * -> *) a. Monad m => a -> m a
return ([(JpgFrameKind, Int64, Int64)]
 -> Get [(JpgFrameKind, Int64, Int64)])
-> [(JpgFrameKind, Int64, Int64)]
-> Get [(JpgFrameKind, Int64, Int64)]
forall a b. (a -> b) -> a -> b
$ (JpgFrameKind
kind, Int64
kindMarkerOffset, Int64
segmentLengthWithoutMarker)(JpgFrameKind, Int64, Int64)
-> [(JpgFrameKind, Int64, Int64)] -> [(JpgFrameKind, Int64, Int64)]
forall a. a -> [a] -> [a]
:[(JpgFrameKind, Int64, Int64)]
remainingKinds

-- | Parses forward, returning the first scan header encountered.

--

-- Should be used after `skipUntilFrames`.

--

-- Fails parsing when an SOS segment marker (`JpgStartOfScan`, resulting

-- in `JpgScanBlob`) is encountered before an SOF segment marker (that

-- results in `JpgScans` carrying the `JpgFrameHeader`).

parseToFirstFrameHeader :: Get (Maybe JpgFrameHeader)
parseToFirstFrameHeader :: Get (Maybe JpgFrameHeader)
parseToFirstFrameHeader = do
    JpgFrameKind
kind <- Get JpgFrameKind
forall t. Binary t => Get t
get
    case JpgFrameKind
kind of
        JpgFrameKind
JpgEndOfImage -> Maybe JpgFrameHeader -> Get (Maybe JpgFrameHeader)
forall a. a -> Get a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe JpgFrameHeader
forall a. Maybe a
Nothing
        JpgFrameKind
JpgStartOfScan -> String -> Get (Maybe JpgFrameHeader)
forall a. String -> Get a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"parseToFirstFrameHeader: Encountered SOS frame marker before frame header that tells its dimensions"
        JpgFrameKind
_ -> do
            Maybe JpgFrame
mbFrame <- JpgFrameKind -> Get (Maybe JpgFrame)
parseFrameOfKind JpgFrameKind
kind
            case Maybe JpgFrame
mbFrame of
                Maybe JpgFrame
Nothing -> Get (Maybe JpgFrameHeader)
continueSearching
                Just JpgFrame
frame -> case JpgFrame
frame of
                    JpgScans JpgFrameKind
_ JpgFrameHeader
frameHeader -> Maybe JpgFrameHeader -> Get (Maybe JpgFrameHeader)
forall a. a -> Get a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe JpgFrameHeader -> Get (Maybe JpgFrameHeader))
-> Maybe JpgFrameHeader -> Get (Maybe JpgFrameHeader)
forall a b. (a -> b) -> a -> b
$ JpgFrameHeader -> Maybe JpgFrameHeader
forall a. a -> Maybe a
Just (JpgFrameHeader -> Maybe JpgFrameHeader)
-> JpgFrameHeader -> Maybe JpgFrameHeader
forall a b. (a -> b) -> a -> b
$! JpgFrameHeader
frameHeader
                    JpgFrame
_ -> Get (Maybe JpgFrameHeader)
continueSearching
  where
    continueSearching :: Get (Maybe JpgFrameHeader)
continueSearching = do
        Get ()
skipFrameMarker
        Get (Maybe JpgFrameHeader)
parseToFirstFrameHeader

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 a b. PutM a -> PutM b -> PutM b
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 a. a -> Get a
forall (m :: * -> *) a. Monad m => a -> m a
return JpgFrameKind
JpgBaselineDCTHuffman
            Word8
0xC1 -> JpgFrameKind -> Get JpgFrameKind
forall a. a -> Get a
forall (m :: * -> *) a. Monad m => a -> m a
return JpgFrameKind
JpgExtendedSequentialDCTHuffman
            Word8
0xC2 -> JpgFrameKind -> Get JpgFrameKind
forall a. a -> Get a
forall (m :: * -> *) a. Monad m => a -> m a
return JpgFrameKind
JpgProgressiveDCTHuffman
            Word8
0xC3 -> JpgFrameKind -> Get JpgFrameKind
forall a. a -> Get a
forall (m :: * -> *) a. Monad m => a -> m a
return JpgFrameKind
JpgLosslessHuffman
            Word8
0xC4 -> JpgFrameKind -> Get JpgFrameKind
forall a. a -> Get a
forall (m :: * -> *) a. Monad m => a -> m a
return JpgFrameKind
JpgHuffmanTableMarker
            Word8
0xC5 -> JpgFrameKind -> Get JpgFrameKind
forall a. a -> Get a
forall (m :: * -> *) a. Monad m => a -> m a
return JpgFrameKind
JpgDifferentialSequentialDCTHuffman
            Word8
0xC6 -> JpgFrameKind -> Get JpgFrameKind
forall a. a -> Get a
forall (m :: * -> *) a. Monad m => a -> m a
return JpgFrameKind
JpgDifferentialProgressiveDCTHuffman
            Word8
0xC7 -> JpgFrameKind -> Get JpgFrameKind
forall a. a -> Get a
forall (m :: * -> *) a. Monad m => a -> m a
return JpgFrameKind
JpgDifferentialLosslessHuffman
            Word8
0xC9 -> JpgFrameKind -> Get JpgFrameKind
forall a. a -> Get a
forall (m :: * -> *) a. Monad m => a -> m a
return JpgFrameKind
JpgExtendedSequentialArithmetic
            Word8
0xCA -> JpgFrameKind -> Get JpgFrameKind
forall a. a -> Get a
forall (m :: * -> *) a. Monad m => a -> m a
return JpgFrameKind
JpgProgressiveDCTArithmetic
            Word8
0xCB -> JpgFrameKind -> Get JpgFrameKind
forall a. a -> Get a
forall (m :: * -> *) a. Monad m => a -> m a
return JpgFrameKind
JpgLosslessArithmetic
            Word8
0xCD -> JpgFrameKind -> Get JpgFrameKind
forall a. a -> Get a
forall (m :: * -> *) a. Monad m => a -> m a
return JpgFrameKind
JpgDifferentialSequentialDCTArithmetic
            Word8
0xCE -> JpgFrameKind -> Get JpgFrameKind
forall a. a -> Get a
forall (m :: * -> *) a. Monad m => a -> m a
return JpgFrameKind
JpgDifferentialProgressiveDCTArithmetic
            Word8
0xCF -> JpgFrameKind -> Get JpgFrameKind
forall a. a -> Get a
forall (m :: * -> *) a. Monad m => a -> m a
return JpgFrameKind
JpgDifferentialLosslessArithmetic
            Word8
0xD9 -> JpgFrameKind -> Get JpgFrameKind
forall a. a -> Get a
forall (m :: * -> *) a. Monad m => a -> m a
return JpgFrameKind
JpgEndOfImage
            Word8
0xDA -> JpgFrameKind -> Get JpgFrameKind
forall a. a -> Get a
forall (m :: * -> *) a. Monad m => a -> m a
return JpgFrameKind
JpgStartOfScan
            Word8
0xDB -> JpgFrameKind -> Get JpgFrameKind
forall a. a -> Get a
forall (m :: * -> *) a. Monad m => a -> m a
return JpgFrameKind
JpgQuantizationTable
            Word8
0xDD -> JpgFrameKind -> Get JpgFrameKind
forall a. a -> Get a
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 a. a -> Get a
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 a. a -> Get a
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 a. a -> Get a
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 a. String -> Get a
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 a. a -> Get a
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 a b. PutM a -> PutM b -> PutM b
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 a. String -> Get a
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 a. a -> Get a
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
        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 a. a -> Get a
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 (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 a. a -> Get a
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 <- 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 a. a -> Get a
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 (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 :: forall a s. (Storable a, Num a) => 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 :: 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 = String -> ST s String
forall a. a -> ST s a
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 a. a -> ST s a
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 :: 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 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 :: forall a. Num a => a
dctBlockSize = a
8