module Vision.Image.Storage.DevIL (
StorageImage (..), StorageError (..)
, ImageType, LoadImageType, SaveImageType, SaveBSImageType
, load, loadBS, save, saveBS
, Autodetect (..), BLP (..), BMP (..), CUT (..), DCX (..), DDS (..)
, DICOM (..), Doom (..), DoomFlat (..), DPX (..), EXR (..), FITS (..)
, FTX (..), GIF (..), HDR (..), ICO (..), ICNS (..), IFF (..), IWI (..)
, JASCPAL (..), JP2 (..), JPG (..), LIF (..), MDL (..), MNG (..), MP3 (..)
, PCD (..), PCX (..), PIC (..), PIX (..), PNG (..), PNM (..), PSD (..)
, PSP (..), PXR (..), RAW (..), ROT (..), SGI (..), SUN (..), Texture (..)
, TGA (..), TIFF (..), TPL (..), UTX (..), VTF (..), WAL (..), WBMP (..)
, XPM (..)
) where
import Control.Applicative ((<$>), (<*))
import Control.Concurrent.MVar (MVar, newMVar, takeMVar, putMVar)
import Control.DeepSeq (NFData (..), deepseq)
import Control.Monad (when)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Error (
Error (..), ErrorT (..), runErrorT, throwError
)
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, mallocBytes)
import Foreign.Marshal.Utils (with)
import Foreign.Ptr (Ptr, castPtr, nullPtr)
import Foreign.Storable (peek)
import System.IO.Unsafe (unsafePerformIO)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Unsafe as BS
import Vision.Image (Manifest (..), Grey, RGB, RGBA, nChannels)
import Vision.Primitive (Z (..), (:.) (..), ix2)
import Vision.Image.Storage.DevIL.ImageType
data StorageImage = GreyStorage Grey | RGBAStorage RGBA | RGBStorage RGB
deriving Show
data StorageError = FailedToInit
| FailedToOpenFile
| FailedToLoad
| FailedToHaskell
| FailedToDevil
| FailedToSave
| FileAlreadyExists
| InvalidFile
| OutOfMemory
| UnknownFileType
| UnknownError (Maybe String)
deriving (Eq)
instance Convertible Grey StorageImage where
safeConvert = Right . GreyStorage
instance Convertible RGBA StorageImage where
safeConvert = Right . RGBAStorage
instance Convertible RGB StorageImage where
safeConvert = Right . RGBStorage
instance (Convertible Grey i, Convertible RGB i, Convertible RGBA i)
=> Convertible StorageImage i where
safeConvert (GreyStorage img) = Right $ convert img
safeConvert (RGBAStorage img) = Right $ convert img
safeConvert (RGBStorage img) = Right $ convert img
instance NFData StorageImage where
rnf !(GreyStorage img) = rnf img
rnf !(RGBAStorage img) = rnf img
rnf !(RGBStorage img) = rnf 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 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 = "Failed to save the image."
show FileAlreadyExists = "The file already exists."
show InvalidFile =
"The file could not be loaded because of an invalid value."
show OutOfMemory = "Could not allocate memory for the new image data."
show UnknownFileType =
"The file content or extension does not match any known image type."
show (UnknownError (Just msg)) = msg
show (UnknownError Nothing ) = "Unknown error."
class ImageType t => LoadImageType t
instance LoadImageType Autodetect
instance LoadImageType BLP
instance LoadImageType BMP
instance LoadImageType CUT
instance LoadImageType DCX
instance LoadImageType DDS
instance LoadImageType DICOM
instance LoadImageType Doom
instance LoadImageType DoomFlat
instance LoadImageType DPX
instance LoadImageType EXR
instance LoadImageType FITS
instance LoadImageType FTX
instance LoadImageType GIF
instance LoadImageType HDR
instance LoadImageType ICO
instance LoadImageType ICNS
instance LoadImageType IFF
instance LoadImageType IWI
instance LoadImageType JASCPAL
instance LoadImageType JP2
instance LoadImageType JPG
instance LoadImageType LIF
instance LoadImageType MDL
instance LoadImageType MNG
instance LoadImageType MP3
instance LoadImageType PCD
instance LoadImageType PCX
instance LoadImageType PIC
instance LoadImageType PIX
instance LoadImageType PNG
instance LoadImageType PNM
instance LoadImageType PSD
instance LoadImageType PSP
instance LoadImageType PXR
instance LoadImageType RAW
instance LoadImageType ROT
instance LoadImageType SGI
instance LoadImageType SUN
instance LoadImageType Texture
instance LoadImageType TGA
instance LoadImageType TIFF
instance LoadImageType TPL
instance LoadImageType UTX
instance LoadImageType VTF
instance LoadImageType WAL
instance LoadImageType WBMP
instance LoadImageType XPM
load :: (LoadImageType t, Convertible StorageImage i)
=> t -> FilePath -> IO (Either StorageError i)
load !t path =
path `deepseq` (
lockAndBind $ \name -> do
ilLoad t path
convert <$> fromDevil name
)
loadBS :: (LoadImageType t, Convertible StorageImage i)
=> t -> BS.ByteString -> Either StorageError i
loadBS !t bs =
bs `deepseq` (
unsafePerformIO $
lockAndBind $ \name -> do
ilLoadL t bs
convert <$> fromDevil name
)
class ImageType t => SaveImageType t
instance SaveImageType Autodetect
instance SaveImageType BMP
instance SaveImageType CHEAD
instance SaveImageType DDS
instance SaveImageType EXR
instance SaveImageType HDR
instance SaveImageType JASCPAL
instance SaveImageType JP2
instance SaveImageType JPG
instance SaveImageType PNG
instance SaveImageType PNM
instance SaveImageType PSD
instance SaveImageType RAW
instance SaveImageType SGI
instance SaveImageType TGA
instance SaveImageType TIFF
instance SaveImageType VTF
instance SaveImageType WBMP
instance SaveImageType XPM
save :: (SaveImageType t, Convertible i StorageImage)
=> t -> FilePath -> i -> IO (Maybe StorageError)
save !t path img =
path `deepseq` storImg `deepseq` (do
res <- lockAndBind $ \name -> do
toDevil storImg
ilSave t path
ilDeleteImage name
return $ case res of Right () -> Nothing
Left err -> Just err
)
where
storImg = convert img
class ImageType t => SaveBSImageType t
instance SaveBSImageType BMP
instance SaveBSImageType CHEAD
instance SaveBSImageType DDS
instance SaveBSImageType EXR
instance SaveBSImageType HDR
instance SaveBSImageType JASCPAL
instance SaveBSImageType JP2
instance SaveBSImageType JPG
instance SaveBSImageType PNG
instance SaveBSImageType PNM
instance SaveBSImageType PSD
instance SaveBSImageType RAW
instance SaveBSImageType SGI
instance SaveBSImageType TGA
instance SaveBSImageType TIFF
instance SaveBSImageType VTF
instance SaveBSImageType WBMP
instance SaveBSImageType XPM
saveBS :: (SaveBSImageType t, Convertible i StorageImage)
=> t -> i -> Either StorageError BS.ByteString
saveBS !t img =
storImg `deepseq` (
unsafePerformIO $
lockAndBind $ \name -> do
toDevil storImg
ilSaveL t <* ilDeleteImage name
)
where
storImg = convert img
type StorageMonad = ErrorT StorageError IO
devilLock :: MVar ()
devilLock = unsafePerformIO $ newMVar ()
lockDevil :: IO a -> IO a
lockDevil action = do
takeMVar devilLock
ret <- action
putMVar devilLock ()
return ret
lockAndBind :: (ImageName -> StorageMonad a) -> IO (Either StorageError a)
lockAndBind action =
lockDevil $
runErrorT $ do
ilInit
name <- ilGenImageName
ilBindImage name
action name
type ILuint = Word32
type ILsizei = Word64
type ILboolean = Word8
type ILenum = Word32
type ILint = Int32
type ILubyte = Word8
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)
il_RGBA = (6408)
il_LUMINANCE = (6409)
il_IMAGE_HEIGHT, il_IMAGE_WIDTH :: ILenum
il_IMAGE_FORMAT, il_IMAGE_TYPE :: ILenum
il_IMAGE_HEIGHT = (3557)
il_IMAGE_WIDTH = (3556)
il_IMAGE_FORMAT = (3562)
il_IMAGE_TYPE = (3563)
il_UNSIGNED_BYTE :: ILenum
il_UNSIGNED_BYTE = (5121)
origin :: ILenum
origin = (1538)
ilInit :: StorageMonad ()
ilInit = do
lift ilInitC
_ <- ilOriginFuncC origin <?> FailedToInit
_ <- ilEnableC (1536) <?> FailedToInit
return ()
foreign import ccall unsafe "ilGenImages" ilGenImagesC
:: ILsizei -> Ptr ILuint -> IO ()
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 ()
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
ilLoad :: LoadImageType t => t -> FilePath -> StorageMonad ()
ilLoad t path = do
_ <- withCString path (ilLoadC (toIlType t))
<??> (\case (1290) -> FailedToOpenFile
(1287) -> InvalidFile
(1288) -> InvalidFile
(1285) -> InvalidFile
(1282) -> OutOfMemory
(1291) -> UnknownFileType
_ -> FailedToLoad)
return ()
ilLoadL :: LoadImageType t => t -> BS.ByteString -> StorageMonad ()
ilLoadL t bs = do
_ <- BS.unsafeUseAsCStringLen bs (\(ptr, len) ->
ilLoadLC (toIlType t) ptr
(fromIntegral len))
<??> (\case (1290) -> FailedToOpenFile
(1287) -> InvalidFile
(1288) -> InvalidFile
(1285) -> InvalidFile
(1282) -> OutOfMemory
(0) -> UnknownFileType
_ -> FailedToLoad)
return ()
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 ()
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
ilConvertImage il_RGBA il_UNSIGNED_BYTE
RGBAStorage <$> toManifest size
where
convertChannels destFormat = do
pixelType <- ilGetInteger il_IMAGE_TYPE
when (pixelType /= il_UNSIGNED_BYTE) $
ilConvertImage destFormat il_UNSIGNED_BYTE
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
return ()
ilDeleteImage :: ImageName -> StorageMonad ()
ilDeleteImage (ImageName name) = lift $ with name (ilDeleteImagesC 1)
foreign import ccall unsafe "ilRegisterOrigin" ilRegisterOriginC
:: ILenum
-> IO ()
foreign import ccall unsafe "ilTexImage" ilTexImageC
:: ILuint -> ILuint -> ILuint
-> ILubyte -> ILenum -> ILenum
-> Ptr ()
-> IO ILboolean
toDevil :: StorageImage -> StorageMonad ()
toDevil storImg = do
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 = do
_ <- (unsafeWith vec $ \p ->
ilTexImageC (fromIntegral w) (fromIntegral h) 1
(fromIntegral $ nChannels img)
format il_UNSIGNED_BYTE (castPtr p))
<?> OutOfMemory
lift $ ilRegisterOriginC origin
foreign import ccall unsafe "ilSave" ilSaveC
:: ILenum -> CString -> IO ILboolean
ilSave :: SaveImageType t => t -> FilePath -> StorageMonad ()
ilSave t path = do
_ <- withCString path (ilSaveC (toIlType t))
<??> (\case (1290) -> FailedToOpenFile
(1291) -> UnknownFileType
(1292) -> FileAlreadyExists
_ -> FailedToSave)
return ()
foreign import ccall unsafe "ilSaveL" ilSaveLC
:: ILenum -> Ptr () -> ILuint -> IO ILuint
ilSaveL :: SaveBSImageType t => t -> StorageMonad BS.ByteString
ilSaveL t = do
size <- ilSaveLC (toIlType t) nullPtr 0 <?> FailedToSave
ptr <- lift $ mallocBytes (fromIntegral size)
_ <- ilSaveLC (toIlType t) ptr size
<??> (\case (1282) -> OutOfMemory
_ -> FailedToSave)
lift $ BS.unsafePackMallocCStringLen (castPtr ptr, fromIntegral size)
infix 0 <?>
(<?>) :: Integral a => IO a -> StorageError -> StorageMonad a
action <?> err = action <??> (const err)
infix 0 <??>
(<??>) :: Integral a => IO a -> (ILenum -> StorageError) -> StorageMonad a
action <??> f = do
res <- lift action
when (res == 0) $ do
err <- lift ilGetErrorC
throwError (f err)
return res