{-# LANGUAGE GeneralisedNewtypeDeriving #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Hakyll.Images.CompressJpg
( JpgQuality,
compressJpgCompiler,
compressJpg,
)
where
import Codec.Picture.Types (DynamicImage(..), dropTransparency, pixelMap)
import qualified Codec.Picture.Types as Picture
import Codec.Picture.Metadata (Metadatas, SourceFormat(SourceJpeg), basicMetadata)
import qualified Codec.Picture.Metadata as Meta
import Codec.Picture.Metadata.Exif (ExifTag(TagOrientation))
import Codec.Picture.Jpg (JpgEncodable, decodeJpegWithMetadata, encodeDirectJpegAtQualityWithMetadata)
import Data.ByteString.Lazy (toStrict)
import Data.ByteString (ByteString)
import Hakyll.Core.Compiler (Compiler)
import Hakyll.Core.Item (Item (..))
import Hakyll.Images.Common
( Image (..),
ImageFormat (..),
format,
image,
)
import Numeric.Natural (Natural)
newtype JpgQuality = JpgQuality Natural
deriving (Integer -> JpgQuality
JpgQuality -> JpgQuality
JpgQuality -> JpgQuality -> JpgQuality
(JpgQuality -> JpgQuality -> JpgQuality)
-> (JpgQuality -> JpgQuality -> JpgQuality)
-> (JpgQuality -> JpgQuality -> JpgQuality)
-> (JpgQuality -> JpgQuality)
-> (JpgQuality -> JpgQuality)
-> (JpgQuality -> JpgQuality)
-> (Integer -> JpgQuality)
-> Num JpgQuality
forall a.
(a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a)
-> (a -> a)
-> (a -> a)
-> (Integer -> a)
-> Num a
$c+ :: JpgQuality -> JpgQuality -> JpgQuality
+ :: JpgQuality -> JpgQuality -> JpgQuality
$c- :: JpgQuality -> JpgQuality -> JpgQuality
- :: JpgQuality -> JpgQuality -> JpgQuality
$c* :: JpgQuality -> JpgQuality -> JpgQuality
* :: JpgQuality -> JpgQuality -> JpgQuality
$cnegate :: JpgQuality -> JpgQuality
negate :: JpgQuality -> JpgQuality
$cabs :: JpgQuality -> JpgQuality
abs :: JpgQuality -> JpgQuality
$csignum :: JpgQuality -> JpgQuality
signum :: JpgQuality -> JpgQuality
$cfromInteger :: Integer -> JpgQuality
fromInteger :: Integer -> JpgQuality
Num, JpgQuality -> JpgQuality -> Bool
(JpgQuality -> JpgQuality -> Bool)
-> (JpgQuality -> JpgQuality -> Bool) -> Eq JpgQuality
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: JpgQuality -> JpgQuality -> Bool
== :: JpgQuality -> JpgQuality -> Bool
$c/= :: JpgQuality -> JpgQuality -> Bool
/= :: JpgQuality -> JpgQuality -> Bool
Eq, Int -> JpgQuality
JpgQuality -> Int
JpgQuality -> [JpgQuality]
JpgQuality -> JpgQuality
JpgQuality -> JpgQuality -> [JpgQuality]
JpgQuality -> JpgQuality -> JpgQuality -> [JpgQuality]
(JpgQuality -> JpgQuality)
-> (JpgQuality -> JpgQuality)
-> (Int -> JpgQuality)
-> (JpgQuality -> Int)
-> (JpgQuality -> [JpgQuality])
-> (JpgQuality -> JpgQuality -> [JpgQuality])
-> (JpgQuality -> JpgQuality -> [JpgQuality])
-> (JpgQuality -> JpgQuality -> JpgQuality -> [JpgQuality])
-> Enum JpgQuality
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: JpgQuality -> JpgQuality
succ :: JpgQuality -> JpgQuality
$cpred :: JpgQuality -> JpgQuality
pred :: JpgQuality -> JpgQuality
$ctoEnum :: Int -> JpgQuality
toEnum :: Int -> JpgQuality
$cfromEnum :: JpgQuality -> Int
fromEnum :: JpgQuality -> Int
$cenumFrom :: JpgQuality -> [JpgQuality]
enumFrom :: JpgQuality -> [JpgQuality]
$cenumFromThen :: JpgQuality -> JpgQuality -> [JpgQuality]
enumFromThen :: JpgQuality -> JpgQuality -> [JpgQuality]
$cenumFromTo :: JpgQuality -> JpgQuality -> [JpgQuality]
enumFromTo :: JpgQuality -> JpgQuality -> [JpgQuality]
$cenumFromThenTo :: JpgQuality -> JpgQuality -> JpgQuality -> [JpgQuality]
enumFromThenTo :: JpgQuality -> JpgQuality -> JpgQuality -> [JpgQuality]
Enum, Eq JpgQuality
Eq JpgQuality =>
(JpgQuality -> JpgQuality -> Ordering)
-> (JpgQuality -> JpgQuality -> Bool)
-> (JpgQuality -> JpgQuality -> Bool)
-> (JpgQuality -> JpgQuality -> Bool)
-> (JpgQuality -> JpgQuality -> Bool)
-> (JpgQuality -> JpgQuality -> JpgQuality)
-> (JpgQuality -> JpgQuality -> JpgQuality)
-> Ord JpgQuality
JpgQuality -> JpgQuality -> Bool
JpgQuality -> JpgQuality -> Ordering
JpgQuality -> JpgQuality -> JpgQuality
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: JpgQuality -> JpgQuality -> Ordering
compare :: JpgQuality -> JpgQuality -> Ordering
$c< :: JpgQuality -> JpgQuality -> Bool
< :: JpgQuality -> JpgQuality -> Bool
$c<= :: JpgQuality -> JpgQuality -> Bool
<= :: JpgQuality -> JpgQuality -> Bool
$c> :: JpgQuality -> JpgQuality -> Bool
> :: JpgQuality -> JpgQuality -> Bool
$c>= :: JpgQuality -> JpgQuality -> Bool
>= :: JpgQuality -> JpgQuality -> Bool
$cmax :: JpgQuality -> JpgQuality -> JpgQuality
max :: JpgQuality -> JpgQuality -> JpgQuality
$cmin :: JpgQuality -> JpgQuality -> JpgQuality
min :: JpgQuality -> JpgQuality -> JpgQuality
Ord, Num JpgQuality
Ord JpgQuality
(Num JpgQuality, Ord JpgQuality) =>
(JpgQuality -> Rational) -> Real JpgQuality
JpgQuality -> Rational
forall a. (Num a, Ord a) => (a -> Rational) -> Real a
$ctoRational :: JpgQuality -> Rational
toRational :: JpgQuality -> Rational
Real, Enum JpgQuality
Real JpgQuality
(Real JpgQuality, Enum JpgQuality) =>
(JpgQuality -> JpgQuality -> JpgQuality)
-> (JpgQuality -> JpgQuality -> JpgQuality)
-> (JpgQuality -> JpgQuality -> JpgQuality)
-> (JpgQuality -> JpgQuality -> JpgQuality)
-> (JpgQuality -> JpgQuality -> (JpgQuality, JpgQuality))
-> (JpgQuality -> JpgQuality -> (JpgQuality, JpgQuality))
-> (JpgQuality -> Integer)
-> Integral JpgQuality
JpgQuality -> Integer
JpgQuality -> JpgQuality -> (JpgQuality, JpgQuality)
JpgQuality -> JpgQuality -> JpgQuality
forall a.
(Real a, Enum a) =>
(a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> (a, a))
-> (a -> a -> (a, a))
-> (a -> Integer)
-> Integral a
$cquot :: JpgQuality -> JpgQuality -> JpgQuality
quot :: JpgQuality -> JpgQuality -> JpgQuality
$crem :: JpgQuality -> JpgQuality -> JpgQuality
rem :: JpgQuality -> JpgQuality -> JpgQuality
$cdiv :: JpgQuality -> JpgQuality -> JpgQuality
div :: JpgQuality -> JpgQuality -> JpgQuality
$cmod :: JpgQuality -> JpgQuality -> JpgQuality
mod :: JpgQuality -> JpgQuality -> JpgQuality
$cquotRem :: JpgQuality -> JpgQuality -> (JpgQuality, JpgQuality)
quotRem :: JpgQuality -> JpgQuality -> (JpgQuality, JpgQuality)
$cdivMod :: JpgQuality -> JpgQuality -> (JpgQuality, JpgQuality)
divMod :: JpgQuality -> JpgQuality -> (JpgQuality, JpgQuality)
$ctoInteger :: JpgQuality -> Integer
toInteger :: JpgQuality -> Integer
Integral)
mkJpgQuality :: Integral a => a -> JpgQuality
mkJpgQuality :: forall a. Integral a => a -> JpgQuality
mkJpgQuality a
q | a
q a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
0 = Natural -> JpgQuality
JpgQuality Natural
0
| a
q a -> a -> Bool
forall a. Ord a => a -> a -> Bool
> a
100 = Natural -> JpgQuality
JpgQuality Natural
100
| Bool
otherwise = Natural -> JpgQuality
JpgQuality (a -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
q)
compressJpg :: Integral a => a -> Image -> Image
compressJpg :: forall a. Integral a => a -> Image -> Image
compressJpg a
quality' Image
src =
if Image -> ImageFormat
format Image
src ImageFormat -> ImageFormat -> Bool
forall a. Eq a => a -> a -> Bool
/= ImageFormat
Jpeg
then [Char] -> Image
forall a. HasCallStack => [Char] -> a
error [Char]
"Image is not a JPEG."
else case ByteString -> Either [Char] (DynamicImage, Metadatas)
decodeJpegWithMetadata (ByteString -> Either [Char] (DynamicImage, Metadatas))
-> ByteString -> Either [Char] (DynamicImage, Metadatas)
forall a b. (a -> b) -> a -> b
$ Image -> ByteString
image Image
src of
Left [Char]
msg -> [Char] -> Image
forall a. HasCallStack => [Char] -> a
error ([Char] -> Image) -> [Char] -> Image
forall a b. (a -> b) -> a -> b
$ [Char]
"Loading the image failed for the following reason: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
msg
Right (DynamicImage
dynImage, Metadatas
meta) ->
ImageFormat -> ByteString -> Image
Image ImageFormat
Jpeg (ByteString -> Image) -> ByteString -> Image
forall a b. (a -> b) -> a -> b
$ case DynamicImage
dynImage of
(ImageY8 Image Pixel8
img) -> (JpgQuality -> Metadatas -> Image Pixel8 -> ByteString
forall q px.
(Integral q, JpgEncodable px) =>
q -> Metadatas -> Image px -> ByteString
encodeJpeg JpgQuality
quality Metadatas
meta Image Pixel8
img)
(ImageCMYK8 Image PixelCMYK8
img) -> (JpgQuality -> Metadatas -> Image PixelCMYK8 -> ByteString
forall q px.
(Integral q, JpgEncodable px) =>
q -> Metadatas -> Image px -> ByteString
encodeJpeg JpgQuality
quality Metadatas
meta Image PixelCMYK8
img)
(ImageRGB8 Image PixelRGB8
img) -> (JpgQuality -> Metadatas -> Image PixelRGB8 -> ByteString
forall q px.
(Integral q, JpgEncodable px) =>
q -> Metadatas -> Image px -> ByteString
encodeJpeg JpgQuality
quality Metadatas
meta Image PixelRGB8
img)
(ImageYCbCr8 Image PixelYCbCr8
img) -> (JpgQuality -> Metadatas -> Image PixelYCbCr8 -> ByteString
forall q px.
(Integral q, JpgEncodable px) =>
q -> Metadatas -> Image px -> ByteString
encodeJpeg JpgQuality
quality Metadatas
meta Image PixelYCbCr8
img)
(ImageYA8 Image PixelYA8
img) -> (JpgQuality -> Metadatas -> Image Pixel8 -> ByteString
forall q px.
(Integral q, JpgEncodable px) =>
q -> Metadatas -> Image px -> ByteString
encodeJpeg JpgQuality
quality Metadatas
meta ((PixelYA8 -> Pixel8) -> Image PixelYA8 -> Image Pixel8
forall a b. (Pixel a, Pixel b) => (a -> b) -> Image a -> Image b
pixelMap PixelYA8 -> Pixel8
forall a b. TransparentPixel a b => a -> b
dropTransparency Image PixelYA8
img))
DynamicImage
_ -> [Char] -> ByteString
forall a. HasCallStack => [Char] -> a
error [Char]
"Loading the image failed because the color space is unknown."
where
quality :: JpgQuality
quality = a -> JpgQuality
forall a. Integral a => a -> JpgQuality
mkJpgQuality a
quality'
encodeJpeg :: (Integral q, JpgEncodable px)
=> q
-> Metadatas
-> Picture.Image px
-> ByteString
encodeJpeg :: forall q px.
(Integral q, JpgEncodable px) =>
q -> Metadatas -> Image px -> ByteString
encodeJpeg q
qual Metadatas
meta img :: Image px
img@Picture.Image{Int
Vector (PixelBaseComponent px)
imageWidth :: Int
imageHeight :: Int
imageData :: Vector (PixelBaseComponent px)
imageWidth :: forall a. Image a -> Int
imageHeight :: forall a. Image a -> Int
imageData :: forall a. Image a -> Vector (PixelBaseComponent a)
..}
= ByteString -> ByteString
toStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Pixel8 -> Metadatas -> Image px -> ByteString
forall px.
JpgEncodable px =>
Pixel8 -> Metadatas -> Image px -> ByteString
encodeDirectJpegAtQualityWithMetadata (q -> Pixel8
forall a b. (Integral a, Num b) => a -> b
fromIntegral q
qual) Metadatas
newmeta Image px
img
where
exifOrientationMeta :: Metadatas
exifOrientationMeta = ((ExifTag, ExifData) -> Metadatas)
-> [(ExifTag, ExifData)] -> Metadatas
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (\(ExifTag
k, ExifData
v) -> Keys ExifData -> ExifData -> Metadatas
forall a. (Show a, NFData a) => Keys a -> a -> Metadatas
Meta.singleton (ExifTag -> Keys ExifData
Meta.Exif ExifTag
k) ExifData
v)
([(ExifTag, ExifData)] -> Metadatas)
-> [(ExifTag, ExifData)] -> Metadatas
forall a b. (a -> b) -> a -> b
$ ((ExifTag, ExifData) -> Bool)
-> [(ExifTag, ExifData)] -> [(ExifTag, ExifData)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(ExifTag
k, ExifData
_) -> ExifTag
k ExifTag -> ExifTag -> Bool
forall a. Eq a => a -> a -> Bool
== ExifTag
TagOrientation)
([(ExifTag, ExifData)] -> [(ExifTag, ExifData)])
-> [(ExifTag, ExifData)] -> [(ExifTag, ExifData)]
forall a b. (a -> b) -> a -> b
$ Metadatas -> [(ExifTag, ExifData)]
Meta.extractExifMetas Metadatas
meta
newmeta :: Metadatas
newmeta = Metadatas
exifOrientationMeta Metadatas -> Metadatas -> Metadatas
forall a. Semigroup a => a -> a -> a
<> SourceFormat -> Int -> Int -> Metadatas
forall nSize.
Integral nSize =>
SourceFormat -> nSize -> nSize -> Metadatas
basicMetadata SourceFormat
SourceJpeg Int
imageWidth Int
imageHeight
compressJpgCompiler :: Integral a => a -> Item Image -> Compiler (Item Image)
compressJpgCompiler :: forall a. Integral a => a -> Item Image -> Compiler (Item Image)
compressJpgCompiler a
quality = Item Image -> Compiler (Item Image)
forall a. a -> Compiler a
forall (m :: * -> *) a. Monad m => a -> m a
return (Item Image -> Compiler (Item Image))
-> (Item Image -> Item Image)
-> Item Image
-> Compiler (Item Image)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Image -> Image) -> Item Image -> Item Image
forall a b. (a -> b) -> Item a -> Item b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a -> Image -> Image
forall a. Integral a => a -> Image -> Image
compressJpg a
quality)