friday-devil (empty) → 0.1.0.1
raw patch · 5 files changed
+1056/−0 lines, 5 filesdep +basedep +bytestringdep +convertiblesetup-changed
Dependencies added: base, bytestring, convertible, deepseq, friday, transformers, vector
Files
- LICENSE +165/−0
- Setup.hs +2/−0
- friday-devil.cabal +49/−0
- src/Vision/Image/Storage/DevIL.hsc +568/−0
- src/Vision/Image/Storage/DevIL/ImageType.hsc +272/−0
+ LICENSE view
@@ -0,0 +1,165 @@+ GNU LESSER GENERAL PUBLIC LICENSE+ Version 3, 29 June 2007++ Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/>+ 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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ friday-devil.cabal view
@@ -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 <raphaeljavaux[at]gmail.com>+maintainer: Raphael Javaux <raphaeljavaux[at]gmail.com>++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+ <https://github.com/RaphaelJ/friday-devil/blob/master/README.md README>+ 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
+ src/Vision/Image/Storage/DevIL.hsc view
@@ -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+-- <https://github.com/RaphaelJ/friday-devil/blob/master/README.md README> 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
+ src/Vision/Image/Storage/DevIL/ImageType.hsc view
@@ -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)