diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,165 @@ + GNU LESSER GENERAL PUBLIC LICENSE + Version 3, 29 June 2007 + + Copyright (C) 2007 Free Software Foundation, Inc. + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + + This version of the GNU Lesser General Public License incorporates +the terms and conditions of version 3 of the GNU General Public +License, supplemented by the additional permissions listed below. + + 0. Additional Definitions. + + As used herein, "this License" refers to version 3 of the GNU Lesser +General Public License, and the "GNU GPL" refers to version 3 of the GNU +General Public License. + + "The Library" refers to a covered work governed by this License, +other than an Application or a Combined Work as defined below. + + An "Application" is any work that makes use of an interface provided +by the Library, but which is not otherwise based on the Library. +Defining a subclass of a class defined by the Library is deemed a mode +of using an interface provided by the Library. + + A "Combined Work" is a work produced by combining or linking an +Application with the Library. The particular version of the Library +with which the Combined Work was made is also called the "Linked +Version". + + The "Minimal Corresponding Source" for a Combined Work means the +Corresponding Source for the Combined Work, excluding any source code +for portions of the Combined Work that, considered in isolation, are +based on the Application, and not on the Linked Version. + + The "Corresponding Application Code" for a Combined Work means the +object code and/or source code for the Application, including any data +and utility programs needed for reproducing the Combined Work from the +Application, but excluding the System Libraries of the Combined Work. + + 1. Exception to Section 3 of the GNU GPL. + + You may convey a covered work under sections 3 and 4 of this License +without being bound by section 3 of the GNU GPL. + + 2. Conveying Modified Versions. + + If you modify a copy of the Library, and, in your modifications, a +facility refers to a function or data to be supplied by an Application +that uses the facility (other than as an argument passed when the +facility is invoked), then you may convey a copy of the modified +version: + + a) under this License, provided that you make a good faith effort to + ensure that, in the event an Application does not supply the + function or data, the facility still operates, and performs + whatever part of its purpose remains meaningful, or + + b) under the GNU GPL, with none of the additional permissions of + this License applicable to that copy. + + 3. Object Code Incorporating Material from Library Header Files. + + The object code form of an Application may incorporate material from +a header file that is part of the Library. You may convey such object +code under terms of your choice, provided that, if the incorporated +material is not limited to numerical parameters, data structure +layouts and accessors, or small macros, inline functions and templates +(ten or fewer lines in length), you do both of the following: + + a) Give prominent notice with each copy of the object code that the + Library is used in it and that the Library and its use are + covered by this License. + + b) Accompany the object code with a copy of the GNU GPL and this license + document. + + 4. Combined Works. + + You may convey a Combined Work under terms of your choice that, +taken together, effectively do not restrict modification of the +portions of the Library contained in the Combined Work and reverse +engineering for debugging such modifications, if you also do each of +the following: + + a) Give prominent notice with each copy of the Combined Work that + the Library is used in it and that the Library and its use are + covered by this License. + + b) Accompany the Combined Work with a copy of the GNU GPL and this license + document. + + c) For a Combined Work that displays copyright notices during + execution, include the copyright notice for the Library among + these notices, as well as a reference directing the user to the + copies of the GNU GPL and this license document. + + d) Do one of the following: + + 0) Convey the Minimal Corresponding Source under the terms of this + License, and the Corresponding Application Code in a form + suitable for, and under terms that permit, the user to + recombine or relink the Application with a modified version of + the Linked Version to produce a modified Combined Work, in the + manner specified by section 6 of the GNU GPL for conveying + Corresponding Source. + + 1) Use a suitable shared library mechanism for linking with the + Library. A suitable mechanism is one that (a) uses at run time + a copy of the Library already present on the user's computer + system, and (b) will operate properly with a modified version + of the Library that is interface-compatible with the Linked + Version. + + e) Provide Installation Information, but only if you would otherwise + be required to provide such information under section 6 of the + GNU GPL, and only to the extent that such information is + necessary to install and execute a modified version of the + Combined Work produced by recombining or relinking the + Application with a modified version of the Linked Version. (If + you use option 4d0, the Installation Information must accompany + the Minimal Corresponding Source and Corresponding Application + Code. If you use option 4d1, you must provide the Installation + Information in the manner specified by section 6 of the GNU GPL + for conveying Corresponding Source.) + + 5. Combined Libraries. + + You may place library facilities that are a work based on the +Library side by side in a single library together with other library +facilities that are not Applications and are not covered by this +License, and convey such a combined library under terms of your +choice, if you do both of the following: + + a) Accompany the combined library with a copy of the same work based + on the Library, uncombined with any other library facilities, + conveyed under the terms of this License. + + b) Give prominent notice with the combined library that part of it + is a work based on the Library, and explaining where to find the + accompanying uncombined form of the same work. + + 6. Revised Versions of the GNU Lesser General Public License. + + The Free Software Foundation may publish revised and/or new versions +of the GNU Lesser General Public License from time to time. Such new +versions will be similar in spirit to the present version, but may +differ in detail to address new problems or concerns. + + Each version is given a distinguishing version number. If the +Library as you received it specifies that a certain numbered version +of the GNU Lesser General Public License "or any later version" +applies to it, you have the option of following the terms and +conditions either of that published version or of any later version +published by the Free Software Foundation. If the Library as you +received it does not specify a version number of the GNU Lesser +General Public License, you may choose any version of the GNU Lesser +General Public License ever published by the Free Software Foundation. + + If the Library as you received it specifies that a proxy can decide +whether future versions of the GNU Lesser General Public License shall +apply, that proxy's public statement of acceptance of any version is +permanent authorization for you to choose that version for the +Library. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/friday-devil.cabal b/friday-devil.cabal new file mode 100644 --- /dev/null +++ b/friday-devil.cabal @@ -0,0 +1,49 @@ +name: friday-devil +-- +-+------- breaking API changes +-- | | +----- non-breaking API additions +-- | | | +--- code changes with no API change +version: 0.1.0.1 +synopsis: Uses the DevIL C library to read and write images from + and to files and memory buffers. +homepage: https://github.com/RaphaelJ/friday-devil +license: LGPL-3 +license-file: LICENSE +author: Raphael Javaux +maintainer: Raphael Javaux + +description: The library uses FFI calls to the DevIL image library to + read images from a wide variety of formats, including + BMP, JPG, PNG, GIF, ICO and PSD. + . + Please read our + + to get a detailed usage and some examples. + +category: Graphics +stability: Experimental +build-type: Simple +cabal-version: >= 1.10 + +source-repository head + type: git + location: https://github.com/RaphaelJ/friday-devil + +library + exposed-modules: Vision.Image.Storage.DevIL + Vision.Image.Storage.DevIL.ImageType + + ghc-options: -Wall -O2 + hs-source-dirs: src/ + default-language: Haskell2010 + + build-depends: base >= 4 && < 5 + , bytestring >= 0.10 && < 1 + , convertible >= 1 && < 2 + , deepseq >= 1.3 && < 2 + , friday >= 0.2 && < 0.3 + , transformers >= 0.3 && < 0.5 + , vector >= 0.10.0.1 && < 1 + + Build-tools: hsc2hs + + Extra-Libraries: IL diff --git a/src/Vision/Image/Storage/DevIL.hsc b/src/Vision/Image/Storage/DevIL.hsc new file mode 100644 --- /dev/null +++ b/src/Vision/Image/Storage/DevIL.hsc @@ -0,0 +1,568 @@ +{-# LANGUAGE BangPatterns, FlexibleContexts, FlexibleInstances + , ForeignFunctionInterface, LambdaCase, MultiParamTypeClasses #-} + +-- | Uses the DevIL C library to read and write images from and to files and +-- memory buffers. +-- +-- Please read our +-- to +-- to get a detailed usage and some examples. +-- +-- /Note:/ As the underlying 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. +-- The Haskell interface should be thread-safe but will not be able to benefit +-- from multiple processing cores. +module Vision.Image.Storage.DevIL ( + -- * Types & classes + StorageImage (..), StorageError (..) + , ImageType, LoadImageType, SaveImageType, SaveBSImageType + -- * Functions + , load, loadBS, save, saveBS + -- * Images types + , 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.Class (nChannels) +import Vision.Image.Grey (Grey, GreyDelayed) +import Vision.Image.RGBA (RGBA, RGBADelayed) +import Vision.Image.RGB (RGB, RGBDelayed) +import Vision.Image.Type (Manifest (..), delay) +import Vision.Primitive (Z (..), (:.) (..), ix2) + +import Vision.Image.Storage.DevIL.ImageType + +#include "IL/il.h" + +data StorageImage = GreyStorage Grey | RGBAStorage RGBA | RGBStorage RGB + deriving Show + +data StorageError = FailedToInit -- ^ Failed to initialise the library. + | FailedToOpenFile -- ^ Failed to open the given file. + | 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 -- ^ Failed to save the image. + | FileAlreadyExists -- ^ The file already exists. + | InvalidFile -- ^ The file could not be loaded + -- because of an invalid value. + | OutOfMemory -- ^ Could not allocate memory for the new + -- image data. + | UnknownFileType -- ^ The file content or extension does + -- not match any known image type. + | UnknownError (Maybe String) + deriving (Eq) + +-- Instances ------------------------------------------------------------------- + +instance Convertible StorageImage StorageImage where + safeConvert = Right + +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 StorageImage Grey where + safeConvert (GreyStorage img) = Right img + safeConvert (RGBAStorage img) = Right $ convert img + safeConvert (RGBStorage img) = Right $ convert img + +instance Convertible StorageImage RGBA where + safeConvert (GreyStorage img) = Right $ convert img + safeConvert (RGBAStorage img) = Right img + safeConvert (RGBStorage img) = Right $ convert img + +instance Convertible StorageImage RGB where + safeConvert (GreyStorage img) = Right $ convert img + safeConvert (RGBAStorage img) = Right $ convert img + safeConvert (RGBStorage img) = Right img + +instance Convertible StorageImage GreyDelayed where + safeConvert (GreyStorage img) = Right $ delay img + safeConvert (RGBAStorage img) = Right $ convert img + safeConvert (RGBStorage img) = Right $ convert img + +instance Convertible StorageImage RGBADelayed where + safeConvert (GreyStorage img) = Right $ convert img + safeConvert (RGBAStorage img) = Right $ delay img + safeConvert (RGBStorage img) = Right $ convert img + +instance Convertible StorageImage RGBDelayed where + safeConvert (GreyStorage img) = Right $ convert img + safeConvert (RGBAStorage img) = Right $ convert img + safeConvert (RGBStorage img) = Right $ delay 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." + +-- Functions ------------------------------------------------------------------- + +-- | Image types which can be loaded using 'load' and 'loadBS'. +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 + +-- | Reads an image from a file. +-- +-- If the 'Autodetect' image type is given, type will be determined +-- automatically with the file extension and the file headers. +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 + ) + +-- | Reads an image from a strict 'ByteString'. +-- +-- If the 'Autodetect' image type is given, type will be determined +-- automatically with the file headers. +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 + ) + +-- | Image types which can be loaded using 'save'. +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 + +-- | Saves the image to the given file. +-- +-- If the 'Autodetect' image type is given, type will be determined +-- automatically with the file extension. +-- +-- /Note:/ will fail if the file already exists. +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 + +-- | Image types which can be loaded using 'saveBS'. +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 + +-- | Saves the image into a manifest vector from a strict 'ByteString'. +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 + +-- C wrappers and helpers ------------------------------------------------------ + +type StorageMonad = ErrorT StorageError IO + +devilLock :: MVar () +devilLock = unsafePerformIO $ newMVar () +{-# NOINLINE devilLock #-} + +-- | Uses a global lock ('devilLock') to prevent two threads to call the +-- library at the same time. +-- Make sure that action will not trigger another call to lockDevil due to lazy +-- evaluation. +lockDevil :: IO a -> IO a +lockDevil action = do + takeMVar devilLock + ret <- action + putMVar devilLock () + return ret + +-- | Locks the DevIL library, allocates a new image name and executes the given +-- action. +lockAndBind :: (ImageName -> StorageMonad a) -> IO (Either StorageError a) +lockAndBind action = + lockDevil $ + runErrorT $ do + ilInit + name <- ilGenImageName + ilBindImage name + + action name + +type ILuint = #type ILuint +type ILsizei = #type ILsizei +type ILboolean = #type ILboolean +type ILenum = #type ILenum +type ILint = #type ILint +type ILubyte = #type ILubyte + +-- 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 = (#const IL_RGB) +il_RGBA = (#const IL_RGBA) +il_LUMINANCE = (#const IL_LUMINANCE) + +il_IMAGE_HEIGHT, il_IMAGE_WIDTH :: ILenum +il_IMAGE_FORMAT, il_IMAGE_TYPE :: ILenum +il_IMAGE_HEIGHT = (#const IL_IMAGE_HEIGHT) +il_IMAGE_WIDTH = (#const IL_IMAGE_WIDTH) +il_IMAGE_FORMAT = (#const IL_IMAGE_FORMAT) +il_IMAGE_TYPE = (#const IL_IMAGE_TYPE) + +il_UNSIGNED_BYTE :: ILenum +il_UNSIGNED_BYTE = (#const IL_UNSIGNED_BYTE) + +origin :: ILenum +origin = (#const IL_ORIGIN_UPPER_LEFT) + +-- | Initialize the library. +ilInit :: StorageMonad () +ilInit = do + lift ilInitC + + -- By default, origin is undefined and depends on the image type + _ <- ilOriginFuncC origin FailedToInit + _ <- ilEnableC (#const IL_ORIGIN_SET) FailedToInit + return () + +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 + +ilLoad :: LoadImageType t => t -> FilePath -> StorageMonad () +ilLoad t path = do + _ <- withCString path (ilLoadC (toIlType t)) + (\case (#const IL_COULD_NOT_OPEN_FILE) -> FailedToOpenFile + (#const IL_ILLEGAL_FILE_VALUE) -> InvalidFile + (#const IL_INVALID_FILE_HEADER) -> InvalidFile + (#const IL_INVALID_VALUE) -> InvalidFile + (#const IL_OUT_OF_MEMORY) -> OutOfMemory + (#const IL_INVALID_EXTENSION) -> 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 (#const IL_COULD_NOT_OPEN_FILE) -> FailedToOpenFile + (#const IL_ILLEGAL_FILE_VALUE) -> InvalidFile + (#const IL_INVALID_FILE_HEADER) -> InvalidFile + (#const IL_INVALID_VALUE) -> InvalidFile + (#const IL_OUT_OF_MEMORY) -> OutOfMemory + (#const IL_TYPE_UNKNOWN) -> 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 () + +-- | 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. ilDeleteImages will be called when the image + -- will be garbage collected. + 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 () + +-- | Removes the image and any allocated memory. +ilDeleteImage :: ImageName -> StorageMonad () +ilDeleteImage (ImageName name) = lift $ with name (ilDeleteImagesC 1) + +foreign import ccall unsafe "ilRegisterOrigin" ilRegisterOriginC + :: ILenum -- Origin + -> IO () + +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 = 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 + +-- | Saves the current image to a file. +ilSave :: SaveImageType t => t -> FilePath -> StorageMonad () +ilSave t path = do + _ <- withCString path (ilSaveC (toIlType t)) + (\case (#const IL_COULD_NOT_OPEN_FILE) -> FailedToOpenFile + (#const IL_INVALID_EXTENSION) -> UnknownFileType + (#const IL_FILE_ALREADY_EXISTS) -> FileAlreadyExists + _ -> FailedToSave) + return () + +foreign import ccall unsafe "ilSaveL" ilSaveLC + :: ILenum -> Ptr () -> ILuint -> IO ILuint + +-- | Saves the current image to a memory area. +ilSaveL :: SaveBSImageType t => t -> StorageMonad BS.ByteString +ilSaveL t = do + -- ilSaveLC returns the number of bytes required to store the image when + -- called with a NULL pointer and a size of 0. + size <- ilSaveLC (toIlType t) nullPtr 0 FailedToSave + ptr <- lift $ mallocBytes (fromIntegral size) + + _ <- ilSaveLC (toIlType t) ptr size + (\case (#const IL_OUT_OF_MEMORY) -> OutOfMemory + _ -> FailedToSave) + + lift $ BS.unsafePackMallocCStringLen (castPtr ptr, fromIntegral size) + +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. +() :: Integral a => IO a -> StorageError -> StorageMonad a +action err = action (const err) + +infix 0 +-- | Wraps a breakable DevIL action (which returns 0 on failure) in the +-- 'StorageMonad'. On failure, throws the error given by the function when +-- called with the 'ilGetErrorC' error code. +() :: 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 diff --git a/src/Vision/Image/Storage/DevIL/ImageType.hsc b/src/Vision/Image/Storage/DevIL/ImageType.hsc new file mode 100644 --- /dev/null +++ b/src/Vision/Image/Storage/DevIL/ImageType.hsc @@ -0,0 +1,272 @@ +-- | Defines image types which can be used with the DevIL API. +module Vision.Image.Storage.DevIL.ImageType where + +import Data.Word + +#include "IL/il.h" + +class ImageType t where + -- | Returns the DevIL constant associated with the image type. + toIlType :: t -> #type ILenum + +-- | Tries to determine automatically the image type with the header and/or the +-- file extension. +-- +-- Raises an 'UnknownFileType' error if the detection failed. +data Autodetect = Autodetect deriving (Eq, Show) + +data BLP = BLP deriving (Eq, Show) + +data BMP = BMP deriving (Eq, Show) + +data CHEAD = CHEAD deriving (Eq, Show) + +data CUT = CUT deriving (Eq, Show) + +data DCX = DCX deriving (Eq, Show) + +-- | DirectDraw Surface (.dds). +data DDS = DDS deriving (Eq, Show) + +data DICOM = DICOM deriving (Eq, Show) + +-- | Doom texture. +data Doom = Doom deriving (Eq, Show) + +-- | Doom flat texture (floor). +data DoomFlat = DoomFlat deriving (Eq, Show) + +data DPX = DPX deriving (Eq, Show) + +data EXR = EXR deriving (Eq, Show) + +data FITS = FITS deriving (Eq, Show) + +data FTX = FTX deriving (Eq, Show) + +data GIF = GIF deriving (Eq, Show) + +data HDR = HDR deriving (Eq, Show) + +data ICO = ICO deriving (Eq, Show) + +data ICNS = ICNS deriving (Eq, Show) + +data IFF = IFF deriving (Eq, Show) + +data IWI = IWI deriving (Eq, Show) + +-- | Paint Shop Pro (Jasc) palette. +data JASCPAL = JASCPAL deriving (Eq, Show) + +-- | JPEG 2000. +data JP2 = JP2 deriving (Eq, Show) + +data JPG = JPG deriving (Eq, Show) + +-- | Homeworld (.lif). +data LIF = LIF deriving (Eq, Show) + +data MDL = MDL deriving (Eq, Show) + +data MNG = MNG deriving (Eq, Show) + +data MP3 = MP3 deriving (Eq, Show) + +data PCD = PCD deriving (Eq, Show) + +data PCX = PCX deriving (Eq, Show) + +data PIC = PIC deriving (Eq, Show) + +data PIX = PIX deriving (Eq, Show) + +data PNG = PNG deriving (Eq, Show) + +-- | Portable AnyMap (.pbm, .pgm or .ppm). +data PNM = PNM deriving (Eq, Show) + +-- | Photoshop Document. +data PSD = PSD deriving (Eq, Show) + +-- | Paint Shop Pro image. +data PSP = PSP deriving (Eq, Show) + +data PXR = PXR deriving (Eq, Show) + +-- | Raw data with a 13-byte header. +data RAW = RAW deriving (Eq, Show) + +data ROT = ROT deriving (Eq, Show) + +data SGI = SGI deriving (Eq, Show) + +data SUN = SUN deriving (Eq, Show) + +-- | Medieval II: Total War Texture (.texture) file. +data Texture = Texture deriving (Eq, Show) + +data TGA = TGA deriving (Eq, Show) + +data TIFF = TIFF deriving (Eq, Show) + +data TPL = TPL deriving (Eq, Show) + +data UTX = UTX deriving (Eq, Show) + +data VTF = VTF deriving (Eq, Show) + +data WAL = WAL deriving (Eq, Show) + +data WBMP = WBMP deriving (Eq, Show) + +data XPM = XPM deriving (Eq, Show) + +-- Instances ------------------------------------------------------------------- + +instance ImageType Autodetect where + toIlType Autodetect = (#const IL_TYPE_UNKNOWN) + +instance ImageType BLP where + toIlType BLP = (#const IL_BLP) + +instance ImageType BMP where + toIlType BMP = (#const IL_BMP) + +instance ImageType CHEAD where + toIlType CHEAD = (#const IL_CHEAD) + +instance ImageType CUT where + toIlType CUT = (#const IL_CUT) + +instance ImageType DCX where + toIlType DCX = (#const IL_DCX) + +instance ImageType DDS where + toIlType DDS = (#const IL_DDS) + +instance ImageType DICOM where + toIlType DICOM = (#const IL_DICOM) + +instance ImageType Doom where + toIlType Doom = (#const IL_DOOM) + +instance ImageType DoomFlat where + toIlType DoomFlat = (#const IL_DOOM_FLAT) + +instance ImageType DPX where + toIlType DPX = (#const IL_DPX) + +instance ImageType EXR where + toIlType EXR = (#const IL_EXR) + +instance ImageType FITS where + toIlType FITS = (#const IL_FITS) + +instance ImageType FTX where + toIlType FTX = (#const IL_FTX) + +instance ImageType GIF where + toIlType GIF = (#const IL_GIF) + +instance ImageType HDR where + toIlType HDR = (#const IL_HDR) + +instance ImageType ICO where + toIlType ICO = (#const IL_ICO) + +instance ImageType ICNS where + toIlType ICNS = (#const IL_ICNS) + +instance ImageType IFF where + toIlType IFF = (#const IL_IFF) + +instance ImageType IWI where + toIlType IWI = (#const IL_IWI) + +instance ImageType JASCPAL where + toIlType JASCPAL = (#const IL_JASC_PAL) + +instance ImageType JP2 where + toIlType JP2 = (#const IL_JP2) + +instance ImageType JPG where + toIlType JPG = (#const IL_JPG) + +instance ImageType LIF where + toIlType LIF = (#const IL_LIF) + +instance ImageType MDL where + toIlType MDL = (#const IL_MDL) + +instance ImageType MNG where + toIlType MNG = (#const IL_MNG) + +instance ImageType MP3 where + toIlType MP3 = (#const IL_MP3) + +instance ImageType PCD where + toIlType PCD = (#const IL_PCD) + +instance ImageType PCX where + toIlType PCX = (#const IL_PCX) + +instance ImageType PIC where + toIlType PIC = (#const IL_PIC) + +instance ImageType PIX where + toIlType PIX = (#const IL_PIX) + +instance ImageType PNG where + toIlType PNG = (#const IL_PNG) + +instance ImageType PNM where + toIlType PNM = (#const IL_PNM) + +instance ImageType PSD where + toIlType PSD = (#const IL_PSD) + +instance ImageType PSP where + toIlType PSP = (#const IL_PSP) + +instance ImageType PXR where + toIlType PXR = (#const IL_PXR) + +instance ImageType RAW where + toIlType RAW = (#const IL_RAW) + +instance ImageType ROT where + toIlType ROT = (#const IL_ROT) + +instance ImageType SGI where + toIlType SGI = (#const IL_SGI) + +instance ImageType SUN where + toIlType SUN = (#const IL_SUN) + +instance ImageType Texture where + toIlType Texture = (#const IL_TEXTURE) + +instance ImageType TGA where + toIlType TGA = (#const IL_TGA) + +instance ImageType TIFF where + toIlType TIFF = (#const IL_TIF) + +instance ImageType TPL where + toIlType TPL = (#const IL_TPL) + +instance ImageType UTX where + toIlType UTX = (#const IL_UTX) + +instance ImageType VTF where + toIlType VTF = (#const IL_VTF) + +instance ImageType WAL where + toIlType WAL = (#const IL_WAL) + +instance ImageType WBMP where + toIlType WBMP = (#const IL_WBMP) + +instance ImageType XPM where + toIlType XPM = (#const IL_XPM)