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
| Doom
| DoomFlat
| GIF | ICO | JPG
| LIF
| MNG | PCD | PCX | PIC | PNG
| PNM
| PSD | PSP | SGI | TGA | TIFF
| RAW
deriving (Eq, Show)
data StorageError = FailedToInit
| FailedToOpenFile
| InvalidType
| OutOfMemory
| FailedToLoad
| FailedToHaskell
| FailedToDevil
| FailedToSave
| 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."
load :: Maybe ImageType -> FilePath -> IO (Either StorageError StorageImage)
load mType path =
lockDevil $
bindAndLoad $
withCString path $ \cPath ->
ilLoadC (toIlType mType) cPath
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)
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
devilLock :: MVar ()
devilLock = unsafePerformIO $ newMVar ()
lockDevil :: IO a -> IO a
lockDevil action = do
takeMVar devilLock
ret <- action
putMVar devilLock ()
return ret
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
(1291) -> InvalidType
(1288) -> InvalidType
(1282) -> OutOfMemory
_ -> FailedToLoad
fromDevil name
toIlType :: Maybe ImageType -> ILenum
toIlType (Just BMP) = (1056)
toIlType (Just CUT) = (1057)
toIlType (Just DDS) = (1079)
toIlType (Just Doom) = (1058)
toIlType (Just DoomFlat) = (1059)
toIlType (Just GIF) = (1078)
toIlType (Just ICO) = (1060)
toIlType (Just JPG) = (1061)
toIlType (Just LIF) = (1076)
toIlType (Just MNG) = (1077)
toIlType (Just PCD) = (1063)
toIlType (Just PCX) = (1064)
toIlType (Just PIC) = (1065)
toIlType (Just PNG) = (1066)
toIlType (Just PNM) = (1067)
toIlType (Just PSD) = (1081)
toIlType (Just PSP) = (1083)
toIlType (Just SGI) = (1068)
toIlType (Just TGA) = (1069)
toIlType (Just TIFF) = (1070)
toIlType (Just RAW) = (1072)
toIlType Nothing = (0)
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)
ilInit :: StorageMonad ()
ilInit = do
lift ilInitC
ilOriginFuncC (1537) <?> FailedToInit
ilEnableC (1536) <?> FailedToInit
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
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
ilDeleteImage :: ImageName -> StorageMonad ()
ilDeleteImage (ImageName name) = lift $ with name (ilDeleteImagesC 1)
foreign import ccall unsafe "ilTexImage" ilTexImageC
:: ILuint -> ILuint -> ILuint
-> ILubyte -> ILenum -> ILenum
-> Ptr ()
-> IO ILboolean
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
ilSaveImage :: FilePath -> StorageMonad ()
ilSaveImage file = withCString file ilSaveImageC <?> FailedToSave
infix 0 <?>
(<?>) :: IO ILboolean -> StorageError -> StorageMonad ()
action <?> err = do
res <- lift action
when (res == 0) $
throwError err