Image.hs

{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -Wall #-}

{- | Commands that operate on images, with ImageMagick (@identify@ and
@convert@).
-}
module Document.Build.Image (
  -- * Information
  ImageInfo (..),
  imageFormat,
  imageWidth,
  imageHeight,
  imageResolutionX,
  imageResolutionY,
  imageResolutionUnits,
  imageColourspace,
  imageDepth,
  imageFrames,
  imageInfo,
  parseImageInfo,
  GetImageInfo (..),
  HasImageInfo (..),
  ReviewImageInfo (..),
  AsImageInfo (..),

  -- * Conversion
  imageConvert,
  imageConvertWith,
  imageConvertFirstFrame,
  imageResize,
  imageAppend,
) where

import Control.DeepSeq (NFData)
import Control.Lens (Field1, Field2, Field3, Field4, Field5, Field6, Field7, Field8, Field9, Getter, Lens', Prism', Review, lens, prism', review, unto, view, _1, _2, _3, _4, _5, _6, _7, _8, _9, _Wrapped)
import Control.Monad.Trans.Class (lift)
import Data.Aeson (FromJSON (..), ToJSON (..), object, withObject, (.:), (.=))
import Data.Data (Data)
import Document.Build.Build (Command, createParentDirectory, expectOutput, failBuild, process, requireDirectory, requireInput)
import Document.Build.Error (BuildError (..), CommandLine (..), ReviewBuildError)
import GHC.Generics (Generic)
import System.FilePath ((</>))
import Text.Read (readMaybe)

{- $setup
>>> import Control.Lens ((^.))
-}

{- | Information about an image: its format (such as @"PNG"@), width and
height in pixels, horizontal and vertical resolution, the units of the
resolution (such as @"PixelsPerInch"@ or @"Undefined"@), colourspace (such as
@"sRGB"@), bit depth, and number of frames.

@since 0.1.0.0
-}
data ImageInfo
  = ImageInfo String Int Int Double Double String String Int Int
  deriving stock (Eq, Ord, Show, Generic, Data)
  deriving anyclass (NFData)

-- | @since 0.1.0.0
instance ToJSON ImageInfo where
  toJSON (ImageInfo m w h x y u c z n) =
    object
      [ "format" .= m
      , "width" .= w
      , "height" .= h
      , "resolutionX" .= x
      , "resolutionY" .= y
      , "resolutionUnits" .= u
      , "colourspace" .= c
      , "depth" .= z
      , "frames" .= n
      ]

-- | @since 0.1.0.0
instance FromJSON ImageInfo where
  parseJSON =
    withObject "ImageInfo" $ \o ->
      ImageInfo
        <$> o .: "format"
        <*> o .: "width"
        <*> o .: "height"
        <*> o .: "resolutionX"
        <*> o .: "resolutionY"
        <*> o .: "resolutionUnits"
        <*> o .: "colourspace"
        <*> o .: "depth"
        <*> o .: "frames"

-- | @since 0.1.0.0
instance Field1 ImageInfo ImageInfo String String

-- | @since 0.1.0.0
instance Field2 ImageInfo ImageInfo Int Int

-- | @since 0.1.0.0
instance Field3 ImageInfo ImageInfo Int Int

-- | @since 0.1.0.0
instance Field4 ImageInfo ImageInfo Double Double

-- | @since 0.1.0.0
instance Field5 ImageInfo ImageInfo Double Double

-- | @since 0.1.0.0
instance Field6 ImageInfo ImageInfo String String

-- | @since 0.1.0.0
instance Field7 ImageInfo ImageInfo String String

-- | @since 0.1.0.0
instance Field8 ImageInfo ImageInfo Int Int

-- | @since 0.1.0.0
instance Field9 ImageInfo ImageInfo Int Int

-- | @since 0.1.0.0
imageFormat :: Lens' ImageInfo String
imageFormat =
  _1
{-# INLINE imageFormat #-}

-- | @since 0.1.0.0
imageWidth :: Lens' ImageInfo Int
imageWidth =
  _2
{-# INLINE imageWidth #-}

-- | @since 0.1.0.0
imageHeight :: Lens' ImageInfo Int
imageHeight =
  _3
{-# INLINE imageHeight #-}

-- | @since 0.1.0.0
imageResolutionX :: Lens' ImageInfo Double
imageResolutionX =
  _4
{-# INLINE imageResolutionX #-}

-- | @since 0.1.0.0
imageResolutionY :: Lens' ImageInfo Double
imageResolutionY =
  _5
{-# INLINE imageResolutionY #-}

-- | @since 0.1.0.0
imageResolutionUnits :: Lens' ImageInfo String
imageResolutionUnits =
  _6
{-# INLINE imageResolutionUnits #-}

-- | @since 0.1.0.0
imageColourspace :: Lens' ImageInfo String
imageColourspace =
  _7
{-# INLINE imageColourspace #-}

-- | @since 0.1.0.0
imageDepth :: Lens' ImageInfo Int
imageDepth =
  _8
{-# INLINE imageDepth #-}

-- | @since 0.1.0.0
imageFrames :: Lens' ImageInfo Int
imageFrames =
  _9
{-# INLINE imageFrames #-}

-- | The @identify@ format that 'parseImageInfo' reads.
identifyFormat :: String
identifyFormat =
  "%m\\n%w\\n%h\\n%x\\n%y\\n%U\\n%[colorspace]\\n%z\\n%n\\n"

{- | Information about the image being operated on, from its first frame,
using @identify@.

@since 0.1.0.0
-}
imageInfo :: (ReviewBuildError e) => Command e ImageInfo
imageInfo =
  do
    i <- requireInput
    let c = CommandLine "identify" ["-format", identifyFormat, i <> "[0]"]
    o <- lift (process c)
    maybe
      (lift (failBuild (ProcessOutputUnrecognised c "image format, width, height, resolution, units, colourspace, depth and frames")))
      pure
      (parseImageInfo o)

{- | Parse the output of @identify@ with the format
@%m\\n%w\\n%h\\n%x\\n%y\\n%U\\n%[colorspace]\\n%z\\n%n\\n@. A resolution may
be followed by its units, which are ignored.

>>> fmap (^. imageWidth) (parseImageInfo "PNG\n3384\n262\n72\n72\nUndefined\nsRGB\n8\n1\n")
Just 3384

>>> parseImageInfo "PNG\n3384\n262\n72 PixelsPerInch\n72 PixelsPerInch\nPixelsPerInch\nsRGB\n8\n1\n"
Just (ImageInfo "PNG" 3384 262 72.0 72.0 "PixelsPerInch" "sRGB" 8 1)

>>> parseImageInfo "PNG\n"
Nothing

@since 0.1.0.0
-}
parseImageInfo :: String -> Maybe ImageInfo
parseImageInfo s =
  let number :: (Read a) => String -> Maybe a
      number x =
        case words x of
          (n : _) -> readMaybe n
          [] -> Nothing
   in case lines s of
        (m : w : h : x : y : u : c : z : n : _) ->
          ImageInfo m <$> number w <*> number h <*> number x <*> number y <*> pure u <*> pure c <*> number z <*> number n
        _ -> Nothing

-- | @since 0.1.0.0
class GetImageInfo s where
  getImageInfo :: Getter s ImageInfo

-- | @since 0.1.0.0
instance GetImageInfo ImageInfo where
  getImageInfo =
    id
  {-# INLINE getImageInfo #-}

-- | @since 0.1.0.0
class (GetImageInfo s) => HasImageInfo s where
  {-# MINIMAL setImageInfo #-}
  setImageInfo :: ImageInfo -> s -> s

  imageInfoLens :: Lens' s ImageInfo
  imageInfoLens =
    lens (view getImageInfo) (flip setImageInfo)
  {-# INLINE imageInfoLens #-}

-- | @since 0.1.0.0
instance HasImageInfo ImageInfo where
  setImageInfo =
    const
  {-# INLINE setImageInfo #-}

-- | @since 0.1.0.0
class ReviewImageInfo t where
  reviewImageInfo :: Review t ImageInfo

-- | @since 0.1.0.0
instance ReviewImageInfo ImageInfo where
  reviewImageInfo =
    unto id
  {-# INLINE reviewImageInfo #-}

-- | @since 0.1.0.0
class (ReviewImageInfo t) => AsImageInfo t where
  {-# MINIMAL matchImageInfo #-}
  matchImageInfo :: t -> Maybe ImageInfo

  _ImageInfo :: Prism' t ImageInfo
  _ImageInfo =
    prism' (review reviewImageInfo) matchImageInfo
  {-# INLINE _ImageInfo #-}

-- | @since 0.1.0.0
instance AsImageInfo ImageInfo where
  matchImageInfo =
    Just
  {-# INLINE matchImageInfo #-}

{- | Convert the image being operated on to a file path, with the format given
by its extension, and return the file path.

@since 0.1.0.0
-}
imageConvert :: (ReviewBuildError e) => FilePath -> Command e FilePath
imageConvert =
  imageConvertWith []
{-# INLINE imageConvert #-}

{- | Convert the image being operated on with @convert@ and options that
follow the input file, writing to a file path, and return the file path.

@since 0.1.0.0
-}
imageConvertWith :: (ReviewBuildError e) => [String] -> FilePath -> Command e FilePath
imageConvertWith opts o =
  do
    i <- requireInput
    let c = CommandLine "convert" ([i] <> opts <> [o])
    lift (createParentDirectory o *> process c *> expectOutput c o)

{- | Convert the first frame of the image being operated on with @convert@
and options that follow the input file, writing to a file path, and return
the file path. Unlike 'imageConvertWith', an image with more than one frame,
such as an animated GIF, produces one file.

@since 0.1.0.0
-}
imageConvertFirstFrame :: (ReviewBuildError e) => [String] -> FilePath -> Command e FilePath
imageConvertFirstFrame opts o =
  do
    i <- requireInput
    let c = CommandLine "convert" ([i <> "[0]"] <> opts <> [o])
    lift (createParentDirectory o *> process c *> expectOutput c o)

{- | Resize the image being operated on to fit within a square of a number of
pixels, keeping its aspect ratio, writing to a file path, and return the file
path.

@since 0.1.0.0
-}
imageResize :: (ReviewBuildError e) => Int -> FilePath -> Command e FilePath
imageResize n =
  imageConvertWith ["-resize", show n <> "x" <> show n]
{-# INLINE imageResize #-}

{- | Join images in the directory being operated on, given by their paths
relative to it, side by side, from left to right, into a file path, and
return the file path.

@since 0.1.0.0
-}
imageAppend :: (ReviewBuildError e) => [FilePath] -> FilePath -> Command e FilePath
imageAppend fs o =
  do
    d <- requireDirectory
    let is = fmap (d </>) fs
        c = CommandLine "convert" (is <> ["+append", o])
    _ <- lift (traverse (view _Wrapped requireInput) is)
    lift (createParentDirectory o *> process c *> expectOutput c o)