{-# LINE 1 "src/Vision/Image/Storage.hsc" #-}
{-# LANGUAGE BangPatterns, FlexibleContexts, FlexibleInstances
{-# LINE 2 "src/Vision/Image/Storage.hsc" #-}
           , ForeignFunctionInterface, MultiParamTypeClasses #-}

-- | Uses the DevIL C library to read and write images from and to files.
--
-- /Note:/ As the underlier DevIL library is *not* tread-safe, there is a global
-- lock which will prevent two load/save calls to be performed at the same time.
module Vision.Image.Storage (
      ImageType (..), StorageImage (..), StorageError (..), load, loadBS, save
    ) where

import Control.Applicative ((<$>))
import Control.Concurrent.MVar (MVar, newMVar, takeMVar, putMVar)
import Control.Monad (when)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Error (Error (..), ErrorT, runErrorT, throwError)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Unsafe as BS
import Data.Convertible (Convertible (..), convert)
import Data.Int
import Data.Vector.Storable (unsafeFromForeignPtr0, unsafeWith)
import Data.Word
import Foreign.C.String (CString, withCString)
import Foreign.Concurrent (newForeignPtr)
import Foreign.Marshal.Alloc (alloca)
import Foreign.Marshal.Utils (with)
import Foreign.Ptr (Ptr, castPtr)
import Foreign.Storable (peek)
import System.IO.Unsafe (unsafePerformIO)

import Vision.Image.Grey (Grey, GreyPixel)
import Vision.Image.RGBA (RGBA, RGBAPixel)
import Vision.Image.RGB (RGB, RGBPixel)
import Vision.Image.Type (Manifest (..), Delayed (..), delay, nChannels)
import Vision.Primitive (Z (..), (:.) (..), ix2)

data StorageImage = GreyStorage Grey | RGBAStorage RGBA | RGBStorage RGB

data ImageType = BMP | CUT
               | DDS         -- ^ DirectDraw Surface (.dds).
               | Doom        -- ^ Doom texture.
               | DoomFlat    -- ^ Doom flat texture (floor).
               | GIF | ICO | JPG
               | LIF         -- ^ Homeworld (.lif).
               | MNG | PCD | PCX | PIC | PNG
               | PNM         -- ^ Portable AnyMap (.pbm, .pgm or .ppm).
               | PSD | PSP | SGI | TGA | TIFF
               | RAW         -- Raw data with a 13-byte header.
    deriving (Eq, Show)

data StorageError = FailedToInit     -- ^ Failed to initialise the library.
                  | FailedToOpenFile -- ^ Failed to open the given file.
                  | InvalidType      -- ^ The file could not be loaded based
                                     -- on extension or header.
                  | OutOfMemory      -- ^ Could not allocate memory for the new
                                     -- image data.
                  | FailedToLoad     -- ^ Failed to load the image, invalid
                                     -- format.
                  | FailedToHaskell  -- ^ Failed to convert the loaded image to
                                     -- its Haskell representation.
                  | FailedToDevil    -- ^ Failed to write the image content
                                     -- through the inner DevIL library.
                  | FailedToSave     -- ^ Could not open the file for writing.
                  | UnknownError (Maybe String)
    deriving (Eq)

type StorageMonad = ErrorT StorageError IO

instance Convertible StorageImage StorageImage where
    safeConvert = Right

instance Convertible (Manifest GreyPixel) StorageImage where
    safeConvert = Right . GreyStorage

instance Convertible (Manifest RGBAPixel) StorageImage where
    safeConvert = Right . RGBAStorage

instance Convertible (Manifest RGBPixel) StorageImage where
    safeConvert = Right . RGBStorage

instance Convertible StorageImage (Manifest GreyPixel) where
    safeConvert (GreyStorage img) = Right img
    safeConvert (RGBAStorage img) = Right $ convert img
    safeConvert (RGBStorage img)  = Right $ convert img

instance Convertible StorageImage (Manifest RGBAPixel) where
    safeConvert (GreyStorage img) = Right $ convert img
    safeConvert (RGBAStorage img) = Right img
    safeConvert (RGBStorage img)  = Right $ convert img

instance Convertible StorageImage (Manifest RGBPixel) where
    safeConvert (GreyStorage img) = Right $ convert img
    safeConvert (RGBAStorage img) = Right $ convert img
    safeConvert (RGBStorage img)  = Right img

instance Convertible StorageImage (Delayed GreyPixel) where
    safeConvert (GreyStorage img) = Right $ delay img
    safeConvert (RGBAStorage img) = Right $ convert img
    safeConvert (RGBStorage img)  = Right $ convert img

instance Convertible StorageImage (Delayed RGBAPixel) where
    safeConvert (GreyStorage img) = Right $ convert img
    safeConvert (RGBAStorage img) = Right $ delay img
    safeConvert (RGBStorage img)  = Right $ convert img

instance Convertible StorageImage (Delayed RGBPixel) where
    safeConvert (GreyStorage img) = Right $ convert img
    safeConvert (RGBAStorage img) = Right $ convert img
    safeConvert (RGBStorage img)  = Right $ delay img

instance Error StorageError where
    noMsg  = UnknownError Nothing
    strMsg = UnknownError . Just

instance Show StorageError where
    show FailedToInit     = "Failed to initialise the DevIL library."
    show FailedToOpenFile = "Failed to open the given file."
    show InvalidType      =
        "The file could not be loaded based on extension or header."
    show OutOfMemory      = "Could not allocate memory for the new image data."
    show FailedToLoad     = "Failed to load the image."
    show FailedToHaskell  =
        "Failed to convert the loaded image to its Haskell representation."
    show FailedToDevil    =
        "Failed to write the image content through the inner DevIL library."
    show FailedToSave     = "Could not open the file for writing."
    show (UnknownError (Just msg)) = msg
    show (UnknownError Nothing   ) = "Unknown error."

-- | Reads an image into a manifest vector from a file.
--
-- If no image type is given, type will be determined automatically.
load :: Maybe ImageType -> FilePath -> IO (Either StorageError StorageImage)
load mType path =
    lockDevil $
        bindAndLoad $
            withCString path $ \cPath ->
                ilLoadC (toIlType mType) cPath

-- | Reads an image into a manifest vector from a strict 'ByteString'.
--
-- If no image type is given, type will be determined automatically.
-- TIFF images are not supported.
loadBS :: Maybe ImageType -> BS.ByteString
       -> IO (Either StorageError StorageImage)
loadBS (Just TIFF) _  = return $ Left FailedToLoad
loadBS mType       bs =
    lockDevil $
        bindAndLoad $
            BS.unsafeUseAsCStringLen bs $ \(ptr, len) ->
                ilLoadLC (toIlType mType) ptr (fromIntegral len)

-- | Saves the image to the given file.
--
-- /Note:/ The image type is determined by the filename extension.
-- Will fail if the file already exists.
save :: (Convertible i StorageImage) => FilePath -> i -> IO (Maybe StorageError)
save path img = lockDevil $ do
    res <- runErrorT $ do
        ilInit
        name <- ilGenImageName
        ilBindImage name

        toDevil $ convert img
        ilSaveImage path

        ilDeleteImage name

    return $ case res of Right () -> Nothing
                         Left err -> Just err

-- C wrappers and helpers ------------------------------------------------------

devilLock :: MVar ()
devilLock = unsafePerformIO $ newMVar ()
{-# NOINLINE devilLock #-}

-- | Uses a global lock ('devilLock') to prevent two threads to call the
-- library at the same time.
lockDevil :: IO a -> IO a
lockDevil action = do
    takeMVar devilLock
    ret <- action
    putMVar devilLock ()
    return ret

-- | Allocates a new image name, executes the given action to load the image
-- and then converts it into its Haskell representation.
bindAndLoad :: IO ILboolean ->  IO (Either StorageError StorageImage)
bindAndLoad action = runErrorT $ do
    ilInit
    name <- ilGenImageName
    ilBindImage name

    res <- lift action
    when (res == 0) $ do
        err <- lift ilGetErrorC
        throwError $ case err of
            (1290) -> FailedToOpenFile
{-# LINE 200 "src/Vision/Image/Storage.hsc" #-}
            (1291)   -> InvalidType
{-# LINE 201 "src/Vision/Image/Storage.hsc" #-}
            (1288) -> InvalidType
{-# LINE 202 "src/Vision/Image/Storage.hsc" #-}
            (1282)       -> OutOfMemory
{-# LINE 203 "src/Vision/Image/Storage.hsc" #-}
            _                               -> FailedToLoad

    fromDevil name

toIlType :: Maybe ImageType -> ILenum
toIlType (Just BMP)      = (1056)
{-# LINE 209 "src/Vision/Image/Storage.hsc" #-}
toIlType (Just CUT)      = (1057)
{-# LINE 210 "src/Vision/Image/Storage.hsc" #-}
toIlType (Just DDS)      = (1079)
{-# LINE 211 "src/Vision/Image/Storage.hsc" #-}
toIlType (Just Doom)     = (1058)
{-# LINE 212 "src/Vision/Image/Storage.hsc" #-}
toIlType (Just DoomFlat) = (1059)
{-# LINE 213 "src/Vision/Image/Storage.hsc" #-}
toIlType (Just GIF)      = (1078)
{-# LINE 214 "src/Vision/Image/Storage.hsc" #-}
toIlType (Just ICO)      = (1060)
{-# LINE 215 "src/Vision/Image/Storage.hsc" #-}
toIlType (Just JPG)      = (1061)
{-# LINE 216 "src/Vision/Image/Storage.hsc" #-}
toIlType (Just LIF)      = (1076)
{-# LINE 217 "src/Vision/Image/Storage.hsc" #-}
toIlType (Just MNG)      = (1077)
{-# LINE 218 "src/Vision/Image/Storage.hsc" #-}
toIlType (Just PCD)      = (1063)
{-# LINE 219 "src/Vision/Image/Storage.hsc" #-}
toIlType (Just PCX)      = (1064)
{-# LINE 220 "src/Vision/Image/Storage.hsc" #-}
toIlType (Just PIC)      = (1065)
{-# LINE 221 "src/Vision/Image/Storage.hsc" #-}
toIlType (Just PNG)      = (1066)
{-# LINE 222 "src/Vision/Image/Storage.hsc" #-}
toIlType (Just PNM)      = (1067)
{-# LINE 223 "src/Vision/Image/Storage.hsc" #-}
toIlType (Just PSD)      = (1081)
{-# LINE 224 "src/Vision/Image/Storage.hsc" #-}
toIlType (Just PSP)      = (1083)
{-# LINE 225 "src/Vision/Image/Storage.hsc" #-}
toIlType (Just SGI)      = (1068)
{-# LINE 226 "src/Vision/Image/Storage.hsc" #-}
toIlType (Just TGA)      = (1069)
{-# LINE 227 "src/Vision/Image/Storage.hsc" #-}
toIlType (Just TIFF)     = (1070)
{-# LINE 228 "src/Vision/Image/Storage.hsc" #-}
toIlType (Just RAW)      = (1072)
{-# LINE 229 "src/Vision/Image/Storage.hsc" #-}
toIlType Nothing         = (0)
{-# LINE 230 "src/Vision/Image/Storage.hsc" #-}


{-# LINE 232 "src/Vision/Image/Storage.hsc" #-}

type ILuint    = Word32
{-# LINE 234 "src/Vision/Image/Storage.hsc" #-}
type ILsizei   = Word64
{-# LINE 235 "src/Vision/Image/Storage.hsc" #-}
type ILboolean = Word8
{-# LINE 236 "src/Vision/Image/Storage.hsc" #-}
type ILenum    = Word32
{-# LINE 237 "src/Vision/Image/Storage.hsc" #-}
type ILint     = Int32
{-# LINE 238 "src/Vision/Image/Storage.hsc" #-}
type ILubyte   = Word8
{-# LINE 239 "src/Vision/Image/Storage.hsc" #-}

-- DevIL uses unsigned integers as names for each image in processing.
newtype ImageName = ImageName ILuint
    deriving (Show)

foreign import ccall unsafe "ilInit" ilInitC :: IO ()
foreign import ccall unsafe "ilGetError" ilGetErrorC :: IO ILenum
foreign import ccall unsafe "ilOriginFunc" ilOriginFuncC
    :: ILenum -> IO ILboolean
foreign import ccall unsafe "ilEnable" ilEnableC :: ILenum -> IO ILboolean

il_RGB, il_RGBA, il_LUMINANCE :: ILenum
il_RGB = (6407)
{-# LINE 252 "src/Vision/Image/Storage.hsc" #-}
il_RGBA = (6408)
{-# LINE 253 "src/Vision/Image/Storage.hsc" #-}
il_LUMINANCE = (6409)
{-# LINE 254 "src/Vision/Image/Storage.hsc" #-}

il_IMAGE_HEIGHT, il_IMAGE_WIDTH :: ILenum
il_IMAGE_FORMAT, il_IMAGE_TYPE :: ILenum
il_IMAGE_HEIGHT = (3557)
{-# LINE 258 "src/Vision/Image/Storage.hsc" #-}
il_IMAGE_WIDTH  = (3556)
{-# LINE 259 "src/Vision/Image/Storage.hsc" #-}
il_IMAGE_FORMAT = (3562)
{-# LINE 260 "src/Vision/Image/Storage.hsc" #-}
il_IMAGE_TYPE   = (3563)
{-# LINE 261 "src/Vision/Image/Storage.hsc" #-}

il_UNSIGNED_BYTE :: ILenum
il_UNSIGNED_BYTE = (5121)
{-# LINE 264 "src/Vision/Image/Storage.hsc" #-}

-- | Initialize the library.
ilInit :: StorageMonad ()
ilInit = do
    lift ilInitC

    -- By default, origin is undefined and depends on the image type
    ilOriginFuncC (1537) <?> FailedToInit
{-# LINE 272 "src/Vision/Image/Storage.hsc" #-}
    ilEnableC (1536)            <?> FailedToInit
{-# LINE 273 "src/Vision/Image/Storage.hsc" #-}

foreign import ccall unsafe "ilGenImages" ilGenImagesC
  :: ILsizei -> Ptr ILuint -> IO ()

-- | Allocates a new image name.
ilGenImageName :: StorageMonad ImageName
ilGenImageName = lift $ do
    alloca $ \pName -> do
        ilGenImagesC 1 pName
        name <- peek pName
        return $! ImageName name

foreign import ccall unsafe "ilBindImage" ilBindImageC :: ILuint -> IO ()

-- | Sets the image name as the current image for processing.
ilBindImage :: ImageName -> StorageMonad ()
ilBindImage (ImageName name) = lift $ ilBindImageC name

foreign import ccall unsafe "ilLoad" ilLoadC :: ILenum -> CString
                                             -> IO ILboolean
foreign import ccall unsafe "ilLoadL" ilLoadLC :: ILenum -> CString -> ILuint
                                               -> IO ILboolean

foreign import ccall unsafe "ilGetInteger" ilGetIntegerC :: ILenum -> IO ILint
foreign import ccall unsafe "ilConvertImage" ilConvertImageC
    :: ILenum -> ILenum -> IO ILboolean
foreign import ccall unsafe "ilGetData" ilGetDataC :: IO (Ptr ILubyte)
foreign import ccall unsafe "ilDeleteImages" ilDeleteImagesC
    :: ILsizei -> Ptr ILuint -> IO ()

-- | Puts the current image inside a 'Vector'.
fromDevil :: ImageName -> StorageMonad StorageImage
fromDevil (ImageName name) = do
    format <- ilGetInteger il_IMAGE_FORMAT
    w      <- ilGetInteger il_IMAGE_WIDTH
    h      <- ilGetInteger il_IMAGE_HEIGHT
    let !size = ix2 h w

    case format of
        _ | format == il_RGB -> do
            convertChannels il_RGB
            RGBStorage <$> toManifest size
          | format == il_RGBA -> do
            convertChannels il_RGBA
            RGBAStorage <$> toManifest size
          | format == il_RGBA -> do
            convertChannels il_LUMINANCE
            GreyStorage <$> toManifest size
          | otherwise -> do -- Unsupported formats are converted to RGBA.
            ilConvertImage il_RGBA il_UNSIGNED_BYTE
            RGBAStorage <$> toManifest size
  where
    -- Converts the image to the given format if the pixel type isn't Word8.
    convertChannels destFormat = do
        pixelType <- ilGetInteger il_IMAGE_TYPE
        when (pixelType /= il_UNSIGNED_BYTE) $
            ilConvertImage destFormat il_UNSIGNED_BYTE

    -- Converts the C vector of unsigned bytes to a garbage collected 'Vector'
    -- inside a 'Manifest' image.
    toManifest size@(Z :. h :. w) = lift $ do
        pixels        <- castPtr <$> ilGetDataC
        managedPixels <- newForeignPtr pixels (with name (ilDeleteImagesC 1))
        return $! Manifest size (unsafeFromForeignPtr0 managedPixels (w * h))

    ilGetInteger mode = lift $ fromIntegral <$> ilGetIntegerC mode

    ilConvertImage format pixelType = do
        ilConvertImageC format pixelType <?> FailedToHaskell

-- | Removes the image and any allocated memory.
ilDeleteImage :: ImageName -> StorageMonad ()
ilDeleteImage (ImageName name) = lift $ with name (ilDeleteImagesC 1)

foreign import ccall unsafe "ilTexImage" ilTexImageC
    :: ILuint -> ILuint -> ILuint   -- w h depth
    -> ILubyte -> ILenum -> ILenum  -- numberOfChannels format type
    -> Ptr ()                       -- data (copy from this pointer)
    -> IO ILboolean

-- | Sets the current DevIL image to the vector's internal array.
toDevil :: StorageImage -> StorageMonad ()
toDevil storImg =
    case storImg of GreyStorage img -> writeManifest img il_LUMINANCE
                    RGBAStorage img -> writeManifest img il_RGBA
                    RGBStorage  img -> writeManifest img il_RGB
  where
    writeManifest img@(Manifest (Z :. h :. w) vec) format =
        (unsafeWith vec $ \p ->
            ilTexImageC (fromIntegral w) (fromIntegral h) 1
                        (fromIntegral $ nChannels img)
                        format il_UNSIGNED_BYTE (castPtr p)
        ) <?> FailedToDevil

foreign import ccall unsafe "ilSaveImage" ilSaveImageC
    :: CString -> IO ILboolean

-- | Saves the current image.
ilSaveImage :: FilePath -> StorageMonad ()
ilSaveImage file = withCString file ilSaveImageC <?> FailedToSave

infix 0 <?>
-- | Wraps a breakable DevIL action (which returns 0 on failure) in the
-- 'StorageMonad'. Throws the given error in the monad if the action fails.
(<?>) :: IO ILboolean -> StorageError -> StorageMonad ()
action <?> err = do
    res <- lift action
    when (res == 0) $
        throwError err