{-# OPTIONS -fno-warn-orphans #-} module Graphics.Transform.Magick.FFIHelpers(withExceptions, withExceptions_, setField, (-->), mkImage, setImage, applyImageFn, applyImageFn', applyImageFn1, applyImageFn1', setFilename, getFilename, setPage, doTransform, doTransformIO, doTransformIO_XY, doTransformIO_XY_real, sideEffectingOp, linkImagesTogether, mkNewExceptionInfo, nonFinalizedExceptionInfo, destroyExceptionInfo, withTmpExceptionInfo, mkNewImageInfo, mkFinalizedImageInfo, destroyImageInfo, withTmpImageInfo, toCEnum, hImageRows, hImageColumns, maybeToPtr, mkNewUnloadedImage) where #include import Graphics.Transform.Magick.Types import Graphics.Transform.Magick.Magick import Graphics.Transform.Magick.Errors import Graphics.Transform.Magick.Util import qualified Foreign.Concurrent as FC (newForeignPtr) import Control.Exception import Prelude hiding (maximum, minimum) import Control.Monad -- functions to help with doing FFI setImage :: HImage -> Ptr HImage_ -> HImage setImage hIm imPtr = unsafePerformIO $ do i <- newForeignPtr finalize_image imPtr return hIm{ image = i } mkImage :: Ptr HImage_ -> ImageNotLoaded -> HImage mkImage p info = unsafePerformIO $ do i <- newForeignPtr finalize_image p return $ HImage { image=i, otherInfo=info } -------------- Strings/char arrays -- This is really terrible. How to avoid these casts? pokeStringIntoCharArray :: Ptr CharArray -> String -> IO () pokeStringIntoCharArray ptr s = go (castPtr ptr) s where go :: Ptr CChar -> String -> IO () go p [] = poke p nullChar go p (c:cs) = do debug 3 $ "p = " ++ show p ++ " c = " ++ show c poke p (castCharToCChar c) go (p `plusPtr` charSize) cs peekStringFromCharArray :: Ptr CharArray -> IO String peekStringFromCharArray ptr = (debug 3 $ "peekStringFromCharArray: ptr = " ++ show ptr) >> go (castPtr ptr) "" where go :: Ptr CChar -> String -> IO String go p s = do debug 3 $ "p = " ++ show p c <- (liftM castCCharToChar) $ peek p debug 3 $ " c = " ++ show c if c == '\0' then return s else go (p `plusPtr` charSize) (s ++ [c]) charSize :: Int charSize = sizeOf (undefined::CChar) nullChar :: CChar nullChar = castCharToCChar '\0' -------- sets a field in something Storable -------- class PtrAccessors ptr where setField :: Storable a => (a -> a) -> ptr a -> IO () (-->) :: Storable a => ptr a -> (a -> b) -> b instance PtrAccessors Ptr where setField modify p = peek p >>= ((poke p).modify) p --> sel = unsafePerformIO $ peek p >>= (return.sel) instance PtrAccessors ForeignPtr where setField modify p = withForeignPtr p (setField modify) p --> sel = unsafePerformIO $ withForeignPtr p (\fp -> peek fp >>= (return.sel)) -- setField :: Storable a => (a -> a) -> Ptr a -> IO () -- setField modify p = peek p >>= ((poke p).modify) -- (-->) :: Storable a => Ptr a -> (a -> b) -> b -- (-->) p sel = unsafePerformIO $ peek p >>= (return.sel) --------------------------------- -- Function for handling exceptions from GraphicsMagick calls. -- Takes an IO action (that's presumably a call to a GraphicsMagick function), -- an error message to print if something goes wrong, and a function to -- determine whether the result of the call was erroneous, as well as a pointer -- to the exception info that the action will set. -- The checker function is assumed to return True if there was an error. withExceptions :: IO a -> String -> (a -> Bool) -> (ForeignPtr ExceptionInfo) -> IO a withExceptions action errMsg checker excPtr_ = withForeignPtr excPtr_ $ \excPtr -> do result <- action if (checker result) then do -- this prints out GraphicsMagick's message tellUser "hsMagick: caught a GraphicsMagick exception as follows: " catch_exception excPtr signalException errMsg else return result -- Same as withExceptions, but throws away the result withExceptions_ :: IO a -> String -> (a -> Bool) -> ForeignPtr ExceptionInfo -> IO () withExceptions_ action errMsg checker excPtr = withExceptions action errMsg checker excPtr >> return () -- Note: for a plain Image -> Exception -> Image function, we should -- call doTransform. For transformations that take extra arguments, -- we use doTransformIO. applyImageFn :: HImage -> (Ptr HImage_ -> a) -> (a -> IO b) -> IO b applyImageFn hImage fn run = withForeignPtr (getImage hImage) $ \i_ptr -> run $ fn i_ptr applyImageFn' :: HImage -> (Ptr HImage_ -> t) -> (t -> Ptr ExceptionInfo -> IO b) -> IO b applyImageFn' hImage fn run = withForeignPtr (getImage hImage) $ \i_ptr -> withForeignPtr (getExceptionInfo hImage) $ \e_ptr -> run (fn i_ptr) e_ptr applyImageFn1 :: HImage -> (Ptr HImage_ -> t -> IO b) -> t -> IO b applyImageFn1 hImage fn v = applyImageFn hImage fn $ \f -> f v applyImageFn1' :: HImage -> (Ptr HImage_ -> t -> Ptr ExceptionInfo -> IO b) -> t -> IO b applyImageFn1' hImage fn v = applyImageFn' hImage fn $ \f -> f v -- doTransform takes an image transformation that takes an -- image pointer and an exception pointer as arguments, and applies it -- to the given HImage. -- It's assumed that the transformer returns null if an error occurs, -- so this checks for null and looks at the exception field. doTransform :: (Ptr HImage_ -> Ptr ExceptionInfo -> IO (Ptr HImage_)) -> HImage -> HImage doTransform transform hImage = doTransformIO (applyImageFn hImage transform $ withForeignPtr excInfo) hImage where excInfo = getExceptionInfo hImage -- doTransformIO takes an arbitrary IO action that returns an HImage_ -- pointer, and returns a new HImage with the image field of the given -- HImage set to it, checking for exceptions. -- It's assumed that the IO action returns a null pointer to signal -- an exception. doTransformIO :: IO (Ptr HImage_) -> HImage -> HImage doTransformIO act hImage = setImage hImage (unsafePerformIO (withExceptions act -- TODO: better messages "error doing image transformation" (== nullPtr) excInfo)) where excInfo = getExceptionInfo hImage doTransformIO_XY :: (Integral a, Integral b) => (Ptr HImage_ -> a -> a -> Ptr ExceptionInfo -> IO (Ptr HImage_)) -> HImage -> b -> b -> HImage doTransformIO_XY transform hImage x_ y_ = doTransformIO (applyImageFn' hImage transform $ \f -> f (fromIntegral x_) (fromIntegral y_)) hImage -- Ugh. doTransformIO_XY_real :: (Real b, Fractional a) => (Ptr HImage_ -> a -> a -> Ptr ExceptionInfo -> IO (Ptr HImage_)) -> HImage -> b -> b -> HImage doTransformIO_XY_real transform hImage x_ y_ = doTransformIO (applyImageFn' hImage transform $ \f -> f (realToFrac x_) (realToFrac y_)) hImage ------------------ creating image sequences ----------- linkImagesTogether :: [HImage] -> IO () linkImagesTogether [] = signalException $ "internal error: linkImagesTogether:" ++ " empty list" linkImagesTogether (img:images) = do _ <- foldM (\ bigImage smallImage -> withForeignPtr (getImage bigImage) $ \bi -> withForeignPtr (getImage smallImage) $ \si -> do (#poke Image, next) bi si return smallImage) img images debug 3 $ "Checking assertion..." -- check that: all images but the last one have a non-null "next" -- ptr, and also, the last one has a null "next" ptr allGood <- allM nextImageNotNull (butLast images) lastNull <- (liftM not) (nextImageNotNull (last images)) assertM (allGood && lastNull) "flattenImage: internal error: couldn't create sequence" where nextImageNotNull hImage = do -- debug 3 $ "peeking: " ++ show (getImage hImage) nextIm <- withForeignPtr (getImage hImage) $ (#peek Image, next) debug 3 $ "peeked! " ++ show nextIm return $ nextIm /= nullPtr ------------------ instances -------------------------- --- (should this be in this module? Who knows?) instance Storable FilterTypes where sizeOf _ = sizeOf (undefined::CUInt) alignment _ = alignment (undefined::CUInt) peek ptr = do -- is this use of cast right? (theInt::CUInt) <- peek (castPtr ptr) return $ toEnum (fromIntegral theInt) poke ptr val = poke (castPtr ptr) (fromEnum val) -- TODO: -- could this be auto-generated? boilerplate sux... -- (fundeps? instance Enum a => Storable a...) instance Storable CompositeOp where sizeOf _ = sizeOf (undefined::CUInt) alignment _ = alignment (undefined::CUInt) peek ptr = do -- is this use of cast right? (theInt::CUInt) <- peek (castPtr ptr) return $ toEnum (fromIntegral theInt) poke ptr val = poke (castPtr ptr) (fromEnum val) instance Storable ImageCharacteristics where sizeOf _ = (sizeOf (undefined::CUInt)) * 5 alignment _ = alignment (undefined::CUInt) peek ptr = do cmyk' <- (#peek ImageCharacteristics, cmyk) ptr grayscale' <- (#peek ImageCharacteristics, grayscale) ptr mONOCHROME' <- (#peek ImageCharacteristics, monochrome) ptr opaque' <- (#peek ImageCharacteristics, opaque) ptr palette' <- (#peek ImageCharacteristics, palette) ptr return $ ImageC { cmyk=toEnum cmyk', grayscale=toEnum grayscale', mONOCHROME=toEnum mONOCHROME', opaque=toEnum opaque', palette=toEnum palette'} poke ptr i = do (#poke ImageCharacteristics, cmyk) ptr (fromEnum$ cmyk i) (#poke ImageCharacteristics, grayscale) ptr (fromEnum$ grayscale i) (#poke ImageCharacteristics, monochrome) ptr (fromEnum$ mONOCHROME i) (#poke ImageCharacteristics, opaque) ptr (fromEnum$ opaque i) (#poke ImageCharacteristics, palette) ptr (fromEnum$ palette i) instance Storable ImageStatistics where sizeOf _ = 4 * sizeOf (undefined::ImageChannelStatistics) alignment _ = alignment (undefined::ImageChannelStatistics) peek ptr = do red' <- (#peek ImageStatistics, red) ptr green' <- (#peek ImageStatistics, green) ptr blue' <- (#peek ImageStatistics, blue) ptr opacity' <- (#peek ImageStatistics, opacity) ptr return $ ImageS { red_=red', green_=green', blue_=blue', opacity_=opacity' } poke ptr i = do (#poke ImageStatistics, red) ptr (red_ i) (#poke ImageStatistics, green) ptr (green_ i) (#poke ImageStatistics, blue) ptr (blue_ i) (#poke ImageStatistics, opacity) ptr (opacity_ i) instance Storable ImageChannelStatistics where sizeOf _ = 5 * sizeOf (undefined::CDouble) alignment _ = alignment (undefined::CDouble) peek ptr = do (maximum'::CDouble) <- (#peek ImageChannelStatistics, maximum) ptr (minimum'::CDouble) <- (#peek ImageChannelStatistics, minimum) ptr (mean'::CDouble) <- (#peek ImageChannelStatistics, mean) ptr (standard_deviation'::CDouble) <- (#peek ImageChannelStatistics, standard_deviation) ptr (variance'::CDouble) <- (#peek ImageChannelStatistics, variance) ptr return $ ImageCS { maximum=realToFrac maximum', minimum=realToFrac minimum', mean=realToFrac mean', standard_deviation=realToFrac standard_deviation', variance=realToFrac variance' } poke ptr i = do (#poke ImageChannelStatistics, maximum) ptr (maximum i) (#poke ImageChannelStatistics, minimum) ptr (minimum i) (#poke ImageChannelStatistics, mean) ptr (mean i) (#poke ImageChannelStatistics, standard_deviation) ptr (standard_deviation i) (#poke ImageChannelStatistics, variance) ptr (variance i) instance Storable ExceptionInfo where sizeOf _ = 32 -- TODO alignment _ = alignment (undefined::CULong) peek ptr = do severity' <- (#peek ExceptionInfo, severity ) ptr reason' <- (#peek ExceptionInfo, reason ) ptr description' <- (#peek ExceptionInfo, description ) ptr error_number' <- (#peek ExceptionInfo, error_number ) ptr mODULE' <- (#peek ExceptionInfo, module ) ptr function' <- (#peek ExceptionInfo, function ) ptr line' <- (#peek ExceptionInfo, line ) ptr signature__' <- (#peek ExceptionInfo, signature ) ptr return $ ExceptionInfo { severity=severity', reason=reason', description=description', error_number=error_number', mODULE=mODULE', function=function', line=line', signature__=signature__'} poke ptr e = do (#poke ExceptionInfo, severity ) ptr (severity e ) (#poke ExceptionInfo, reason ) ptr (reason e ) (#poke ExceptionInfo, description ) ptr (description e ) (#poke ExceptionInfo, error_number ) ptr (error_number e) (#poke ExceptionInfo, module ) ptr (mODULE e ) (#poke ExceptionInfo, function ) ptr (function e ) (#poke ExceptionInfo, line ) ptr (signature__ e ) -- it's unfortunate that we have to write this twice -- (maybe there's some wackier type system feature that -- would let us not do so) instance Storable (PixelPacket Word8) where sizeOf _ = 4*(sizeOf(undefined::Word8)) alignment _ = alignment (undefined::Word8) peek ptr = do red' <- (#peek PixelPacket, red) ptr green' <- (#peek PixelPacket, green) ptr blue' <- (#peek PixelPacket, blue) ptr opacity' <- (#peek PixelPacket, opacity) ptr return $ PixelPacket{ red=red', green=green', blue=blue', opacity=opacity' } poke ptr p = do (#poke PixelPacket, red) ptr (red p) (#poke PixelPacket, blue) ptr (blue p) (#poke PixelPacket, green) ptr (green p) (#poke PixelPacket, opacity) ptr (opacity p) instance Storable CharArray where sizeOf _ = maxTextExtent alignment _ = 1 peek _ = error "CharArray: peek is not implemented" poke _ _ = error "CharArray: poke is not implemented" instance Storable HImageInfo where sizeOf _ = (#size ImageInfo) alignment _ = alignment (undefined::CULong) peek ptr = do -- again, ugh compression' <- (#peek ImageInfo, compression) ptr temporary' <- (#peek ImageInfo, temporary) ptr adjoin' <- (#peek ImageInfo, adjoin) ptr antialias' <- (#peek ImageInfo, antialias) ptr subimage' <- (#peek ImageInfo, subimage) ptr subrange' <- (#peek ImageInfo, subrange) ptr depth' <- (#peek ImageInfo, depth) ptr size' <- (#peek ImageInfo, size) ptr tile' <- (#peek ImageInfo, tile) ptr page' <- (#peek ImageInfo, page) ptr interlace' <- (#peek ImageInfo, interlace) ptr endian' <- (#peek ImageInfo, endian) ptr units' <- (#peek ImageInfo, units) ptr quality' <- (#peek ImageInfo, quality) ptr sampling_factor' <- (#peek ImageInfo, sampling_factor) ptr server_name' <- (#peek ImageInfo, server_name) ptr font' <- (#peek ImageInfo, font) ptr texture' <- (#peek ImageInfo, texture) ptr density' <- (#peek ImageInfo, density) ptr pointsize' <- (#peek ImageInfo, pointsize) ptr fuzz' <- (#peek ImageInfo, fuzz) ptr pen' <- (#peek ImageInfo, pen) ptr background_color' <- (#peek ImageInfo, background_color) ptr border_color' <- (#peek ImageInfo, border_color) ptr matte_color' <- (#peek ImageInfo, matte_color) ptr dither' <- (#peek ImageInfo, dither) ptr monochrome' <- (#peek ImageInfo, monochrome) ptr colorspace' <- (#peek ImageInfo, colorspace) ptr tYPE' <- (#peek ImageInfo, type) ptr group' <- (#peek ImageInfo, group) ptr verbose' <- (#peek ImageInfo, verbose) ptr view' <- (#peek ImageInfo, view) ptr progress' <- (#peek ImageInfo, progress) ptr authenticate' <- (#peek ImageInfo, authenticate) ptr client_data' <- (#peek ImageInfo, client_data) ptr file' <- (#peek ImageInfo, file) ptr magick' <- peekStringFromCharArray $ (#ptr ImageInfo, magick) ptr filename' <- peekStringFromCharArray $ (#ptr ImageInfo, filename) ptr cache' <- (#peek ImageInfo, cache) ptr definitions' <- (#peek ImageInfo, definitions) ptr attributes' <- (#peek ImageInfo, attributes) ptr ping' <- (#peek ImageInfo, ping) ptr preview_type' <- (#peek ImageInfo, preview_type) ptr affirm' <- (#peek ImageInfo, affirm) ptr blob' <- (#peek ImageInfo, blob) ptr lENGTH' <- (#peek ImageInfo, length) ptr unique' <- (#peek ImageInfo, unique) ptr zero' <- (#peek ImageInfo, zero) ptr signature' <- (#peek ImageInfo, signature) ptr return $ HImageInfo{compression=compression', temporary=temporary', adjoin=adjoin', antialias=antialias', subimage=subimage', subrange=subrange', depth=depth', size=size', tile=tile', page=page', interlace=interlace', endian=endian', units=units', quality=quality', sampling_factor=sampling_factor', server_name=server_name', font=font', texture=texture', density=density', pointsize=pointsize', fuzz=fuzz', pen=pen', background_color=background_color', border_color=border_color', matte_color=matte_color', dither=dither', monochrome=monochrome', colorspace=colorspace', tYPE=tYPE', group=group', verbose=verbose', view=view', progress=progress', authenticate=authenticate', client_data=client_data', file=file', magick=magick', filename=filename', cache=cache', definitions=definitions', attributes=attributes', ping=ping', preview_type=preview_type', affirm=affirm', blob=blob', lENGTH=lENGTH', unique=unique', zero=zero', signature=signature'} poke ptr hImageInfo = do -- ugh, boilerplate. is there a way to auto-generate this? (#poke ImageInfo, compression) ptr (compression hImageInfo) (#poke ImageInfo, temporary) ptr (temporary hImageInfo) (#poke ImageInfo, adjoin) ptr (adjoin hImageInfo) (#poke ImageInfo, antialias) ptr (antialias hImageInfo) (#poke ImageInfo, subimage) ptr (subimage hImageInfo) (#poke ImageInfo, subrange) ptr (subrange hImageInfo) (#poke ImageInfo, depth) ptr (depth hImageInfo) (#poke ImageInfo, size) ptr (size hImageInfo) (#poke ImageInfo, tile) ptr (tile hImageInfo) (#poke ImageInfo, page) ptr (page hImageInfo) (#poke ImageInfo, interlace) ptr (interlace hImageInfo) (#poke ImageInfo, endian ) ptr (endian hImageInfo) (#poke ImageInfo, units ) ptr (units hImageInfo) (#poke ImageInfo, quality ) ptr (quality hImageInfo ) (#poke ImageInfo, sampling_factor) ptr (sampling_factor hImageInfo) (#poke ImageInfo, server_name) ptr (server_name hImageInfo) (#poke ImageInfo, font ) ptr (font hImageInfo) (#poke ImageInfo, texture ) ptr (texture hImageInfo ) (#poke ImageInfo, density ) ptr (density hImageInfo ) (#poke ImageInfo, pointsize ) ptr (pointsize hImageInfo ) (#poke ImageInfo, fuzz ) ptr (fuzz hImageInfo ) (#poke ImageInfo, pen ) ptr (pen hImageInfo ) (#poke ImageInfo, background_color) ptr (background_color hImageInfo) (#poke ImageInfo, border_color) ptr (border_color hImageInfo) (#poke ImageInfo, matte_color) ptr (matte_color hImageInfo) (#poke ImageInfo, dither ) ptr (dither hImageInfo ) (#poke ImageInfo, monochrome ) ptr (monochrome hImageInfo ) (#poke ImageInfo, colorspace ) ptr (colorspace hImageInfo) (#poke ImageInfo, type ) ptr (tYPE hImageInfo ) (#poke ImageInfo, group ) ptr (group hImageInfo ) (#poke ImageInfo, verbose ) ptr (verbose hImageInfo ) (#poke ImageInfo, view ) ptr (view hImageInfo ) (#poke ImageInfo, authenticate) ptr (authenticate hImageInfo) (#poke ImageInfo, client_data) ptr (client_data hImageInfo) (#poke ImageInfo, file ) ptr (file hImageInfo ) -- the two char-array things: magick and filename pokeStringIntoCharArray ((#ptr ImageInfo, magick) ptr) (magick hImageInfo) pokeStringIntoCharArray ((#ptr ImageInfo, filename) ptr) (filename hImageInfo) -- (#poke ImageInfo, cache ) ptr (cache hImageInfo ) (#poke ImageInfo, definitions) ptr (definitions hImageInfo) (#poke ImageInfo, attributes ) ptr (attributes hImageInfo) (#poke ImageInfo, ping ) ptr (ping hImageInfo) (#poke ImageInfo, preview_type) ptr (preview_type hImageInfo) (#poke ImageInfo, affirm ) ptr (affirm hImageInfo) (#poke ImageInfo, blob ) ptr (blob hImageInfo) (#poke ImageInfo, length ) ptr (lENGTH hImageInfo) (#poke ImageInfo, unique ) ptr (unique hImageInfo) (#poke ImageInfo, zero ) ptr (zero hImageInfo) (#poke ImageInfo, signature ) ptr (signature hImageInfo) instance Storable HImage_ where sizeOf _ = (#size Image) alignment _ = alignment (undefined::CULong) peek ptr = do storage_class' <- (#peek Image, storage_class) ptr colorspace_' <- (#peek Image, colorspace) ptr compression_' <- (#peek Image, compression) ptr dither_' <- (#peek Image, dither) ptr matte' <- (#peek Image, matte) ptr columns' <- (#peek Image, columns) ptr rows' <- (#peek Image, rows) ptr colors' <- (#peek Image, colors) ptr depth_' <- (#peek Image, depth) ptr colormap' <- (#peek Image, colormap) ptr background_color_' <- (#peek Image, background_color) ptr border_color_' <- (#peek Image, border_color) ptr matte_color_' <- (#peek Image, matte_color) ptr gamma' <- (#peek Image, gamma) ptr chromaticity' <- (#peek Image, chromaticity) ptr orientation' <- (#peek Image, orientation) ptr rendering_intent' <- (#peek Image, rendering_intent) ptr units_' <- (#peek Image, units) ptr montage' <- (#peek Image, montage) ptr directory' <- (#peek Image, directory) ptr geometry' <- (#peek Image, geometry) ptr offset' <- (#peek Image, offset) ptr x_resolution' <- (#peek Image, x_resolution) ptr y_resolution' <- (#peek Image, y_resolution) ptr page_' <- (#peek Image, page) ptr tile_info' <- (#peek Image, tile_info) ptr blur' <- (#peek Image, blur) ptr fuzz_' <- (#peek Image, fuzz) ptr fILTER' <- (#peek Image, filter) ptr interlace_' <- (#peek Image, interlace) ptr endian_' <- (#peek Image, endian) ptr gravity' <- (#peek Image, gravity) ptr compose' <- (#peek Image, compose) ptr dispose' <- (#peek Image, dispose) ptr scene' <- (#peek Image, scene) ptr delay' <- (#peek Image, delay) ptr iterations' <- (#peek Image, iterations) ptr total_colors' <- (#peek Image, total_colors) ptr start_loop' <- (#peek Image, start_loop) ptr eRROR' <- (#peek Image, error) ptr timer' <- (#peek Image, timer) ptr client_data_' <- (#peek Image, client_data) ptr filename_' <- peekStringFromCharArray ((#ptr Image, filename) ptr) magick_filename' <- peekStringFromCharArray ((#ptr Image, magick_filename) ptr) magick_' <- peekStringFromCharArray ((#ptr Image, magick) ptr) magick_rows' <- (#peek Image, magick_rows) ptr exception' <- (#peek Image, exception) ptr previous' <- (#peek Image, previous) ptr next' <- (#peek Image, next) ptr profiles' <- (#peek Image, profiles) ptr is_monochrome' <- (#peek Image, is_monochrome) ptr is_grayscale' <- (#peek Image, is_grayscale) ptr taint' <- (#peek Image, taint) ptr clip_mask' <- (#peek Image, clip_mask) ptr cache_' <- (#peek Image, cache) ptr attributes_' <- (#peek Image, attributes) ptr ascii85' <- (#peek Image, ascii85) ptr blob_' <- (#peek Image, blob) ptr reference_count' <- (#peek Image, reference_count) ptr semaphore' <- (#peek Image, semaphore) ptr logging' <- (#peek Image, logging) ptr list' <- (#peek Image, list) ptr signature_' <- (#peek Image, signature) ptr return $ HImage_ { storage_class=storage_class', colorspace_=colorspace_', compression_=compression_', dither_=dither_', matte=matte', columns=columns', rows=rows', colors=colors', depth_=depth_', colormap=colormap', background_color_=background_color_', border_color_=border_color_', matte_color_=matte_color_', gamma=gamma', chromaticity=chromaticity', orientation=orientation', rendering_intent=rendering_intent', units_=units_', montage=montage', directory=directory', geometry=geometry', offset=offset', x_resolution=x_resolution', y_resolution=y_resolution', page_=page_', tile_info=tile_info', blur=blur', fuzz_=fuzz_', fILTER=fILTER', interlace_=interlace_', endian_=endian_', gravity=gravity', compose=compose', dispose=dispose', scene=scene', delay=delay', iterations=iterations', total_colors=total_colors', start_loop=start_loop', eRROR=eRROR', timer=timer', client_data_=client_data_', filename_=filename_', magick_filename=magick_filename', magick_=magick_', magick_rows=magick_rows', exception=exception', previous=previous', next=next', profiles=profiles', is_monochrome=is_monochrome', is_grayscale=is_grayscale', taint=taint', clip_mask=clip_mask', cache_=cache_', attributes_=attributes_', ascii85=ascii85', blob_=blob_', reference_count=reference_count', semaphore=semaphore', logging=logging', list=list', signature_=signature_' } poke ptr hImage = do (#poke Image, storage_class) ptr (storage_class hImage) (#poke Image, colorspace) ptr (colorspace_ hImage) (#poke Image, compression) ptr (compression_ hImage) (#poke Image, dither) ptr (dither_ hImage) (#poke Image, matte) ptr (matte hImage) (#poke Image, columns) ptr (columns hImage) (#poke Image, rows) ptr (rows hImage) (#poke Image, colors) ptr (colors hImage) (#poke Image, depth) ptr (depth_ hImage) (#poke Image, colormap) ptr (colormap hImage) (#poke Image, background_color) ptr (background_color_ hImage) (#poke Image, border_color) ptr (border_color_ hImage) (#poke Image, matte_color) ptr (matte_color_ hImage) (#poke Image, gamma) ptr (gamma hImage) (#poke Image, chromaticity) ptr (chromaticity hImage) (#poke Image, orientation) ptr (orientation hImage) (#poke Image, rendering_intent) ptr (rendering_intent hImage) (#poke Image, units) ptr (units_ hImage) (#poke Image, montage) ptr (montage hImage) (#poke Image, directory) ptr (directory hImage) (#poke Image, geometry) ptr (geometry hImage) (#poke Image, offset) ptr (offset hImage) (#poke Image, x_resolution) ptr (x_resolution hImage) (#poke Image, y_resolution) ptr (y_resolution hImage) (#poke Image, page) ptr (page_ hImage) (#poke Image, tile_info) ptr (tile_info hImage) (#poke Image, blur) ptr (blur hImage) (#poke Image, fuzz) ptr (fuzz_ hImage) (#poke Image, filter) ptr (fILTER hImage) (#poke Image, interlace) ptr (interlace_ hImage) (#poke Image, endian) ptr (endian_ hImage) (#poke Image, gravity) ptr (gravity hImage) (#poke Image, compose) ptr (compose hImage) (#poke Image, dispose) ptr (dispose hImage) (#poke Image, scene) ptr (scene hImage) (#poke Image, delay) ptr (delay hImage) (#poke Image, iterations) ptr (iterations hImage) (#poke Image, total_colors) ptr (total_colors hImage) (#poke Image, start_loop) ptr (start_loop hImage) (#poke Image, error) ptr (eRROR hImage) (#poke Image, timer) ptr (timer hImage) (#poke Image, client_data) ptr (client_data_ hImage) pokeStringIntoCharArray ((#ptr Image, filename) ptr) (filename_ hImage) pokeStringIntoCharArray ((#ptr Image, magick_filename) ptr) (magick_filename hImage) pokeStringIntoCharArray ((#ptr Image, magick) ptr) (magick_ hImage) (#poke Image, magick_rows) ptr (magick_rows hImage) (#poke Image, exception) ptr (exception hImage) (#poke Image, previous) ptr (previous hImage) (#poke Image, next) ptr (next hImage) (#poke Image, profiles) ptr (profiles hImage) (#poke Image, is_monochrome) ptr (is_monochrome hImage) (#poke Image, is_grayscale) ptr (is_grayscale hImage) (#poke Image, taint) ptr (taint hImage) (#poke Image, clip_mask) ptr (clip_mask hImage) (#poke Image, cache) ptr (cache_ hImage) (#poke Image, attributes) ptr (attributes_ hImage) (#poke Image, ascii85) ptr (ascii85 hImage) (#poke Image, blob) ptr (blob_ hImage) (#poke Image, reference_count) ptr (reference_count hImage) (#poke Image, semaphore) ptr (semaphore hImage) (#poke Image, logging) ptr (logging hImage) (#poke Image, list) ptr (list hImage) (#poke Image, signature) ptr (signature_ hImage) instance Storable Rectangle where sizeOf _ = (2*(sizeOf(undefined::CUInt))) + (2*(sizeOf(undefined::CInt))) alignment _ = alignment (undefined::CInt) peek ptr = do width' <- (#peek RectangleInfo, width) ptr height' <- (#peek RectangleInfo, height) ptr x' <- (#peek RectangleInfo, x) ptr y' <- (#peek RectangleInfo, y) ptr return $ Rectangle{ width=width', height=height', x=x', y=y'} poke ptr rect = do (#poke RectangleInfo, width) ptr (width rect) (#poke RectangleInfo, height) ptr (height rect) (#poke RectangleInfo, x) ptr (x rect) (#poke RectangleInfo, y) ptr (y rect) instance Storable AffineMatrix where sizeOf _ = (#size AffineMatrix) alignment _ = alignment (undefined::CDouble) peek ptr = do sx' <- (#peek AffineMatrix, sx) ptr rx' <- (#peek AffineMatrix, rx) ptr ry' <- (#peek AffineMatrix, ry) ptr sy' <- (#peek AffineMatrix, sy) ptr tx' <- (#peek AffineMatrix, tx) ptr ty' <- (#peek AffineMatrix, ty) ptr return $ AffineMatrix { sx=sx', rx=rx', ry=ry', sy=sy', tx=tx', ty=ty' } poke ptr mat = do (#poke AffineMatrix, sx) ptr (sx mat) (#poke AffineMatrix, rx) ptr (rx mat) (#poke AffineMatrix, ry) ptr (ry mat) (#poke AffineMatrix, sy) ptr (sy mat) (#poke AffineMatrix, tx) ptr (tx mat) (#poke AffineMatrix, ty) ptr (ty mat) -- shouldn't really have this magick number here maxTextExtent :: Int maxTextExtent = 2053 hImageRows, hImageColumns :: HImage -> Word hImageRows i = unsafePerformIO $ withForeignPtr (getImage i) $ return.fromIntegral.columns.unsafePerformIO.peek hImageColumns i = unsafePerformIO $ withForeignPtr (getImage i) $ return.fromIntegral.rows.unsafePerformIO.peek --------------- Filename handling class HasFilename a where setFilename :: a -> FilePath -> IO () getFilename :: a -> FilePath instance HasFilename ImageNotLoaded where getFilename (ImageNotLoaded{ imageInfo = iInfo}) = iInfo-->filename setFilename (ImageNotLoaded{ imageInfo = iInfo}) s = setField (\ info -> info{filename=s}) iInfo instance HasFilename HImage where getFilename(HImage{ image=p, otherInfo=other }) = let filename1 = p-->filename_ filename2 = getFilename other in assert (filename1 == filename2) filename1 setFilename(HImage{ image=p, otherInfo=other }) s = setFilename other s >> setField (\ im -> im{filename_=s}) p ------------- Page setting setPage :: HImage -> Rectangle -> IO () setPage hImage rect = applyImageFn hImage (#poke Image, page) $ \f -> f rect ------------- Dealing with side-effecting GraphicsMagick functions sideEffectingOp :: (HImage -> IO CUInt) -> HImage -> HImage sideEffectingOp impureFun = (\ hImage -> unsafePerformIO $ do newImage <- cloneImage hImage withExceptions_ (impureFun newImage) "hsMagick: Error doing transformation" (== 0) (getExceptionInfo newImage) return newImage) --------- Utils -- The type emphasizes that we're doing something wantonly -- non-referentially-transparent cloneImageInfo :: ForeignPtr HImageInfo -> IO (ForeignPtr HImageInfo) cloneImageInfo fp = withForeignPtr fp $ \p -> mkFinalizedImageInfo =<< clone_image_info p cloneImage :: HImage -> IO HImage cloneImage hImage = do clonedImagePtr <- withForeignPtr (getImage hImage) cloneImagePtr clonedImageInfo <- cloneImageInfo (getImageInfo hImage) clonedExceptionInfo <- mkNewExceptionInfo return $ mkImage clonedImagePtr (mkUnloadedImage clonedImageInfo clonedExceptionInfo) -- 0 and 0 say that the cloned image should have the same -- size as the original. 1 says this should be an orphan -- image (not part of a list.) where cloneImagePtr p = withExceptions (withForeignPtr (getExceptionInfo hImage) $ clone_image p 0 0 1) "cloneImagePtr: error cloning image" (== nullPtr) (getExceptionInfo hImage) ----------- Exceptions mkNewExceptionInfo :: IO (ForeignPtr ExceptionInfo) mkNewExceptionInfo = mkFinalizedExceptionInfo =<< mkNewExceptionInfo_ mkFinalizedExceptionInfo :: Ptr ExceptionInfo -> IO (ForeignPtr ExceptionInfo) mkFinalizedExceptionInfo p = FC.newForeignPtr p (destroyExceptionInfo p) nonFinalizedExceptionInfo :: Ptr ExceptionInfo -> IO (ForeignPtr ExceptionInfo) nonFinalizedExceptionInfo = newForeignPtr_ mkNewExceptionInfo_ :: IO (Ptr ExceptionInfo) mkNewExceptionInfo_ = do infoPtr <- malloc get_exception_info infoPtr return infoPtr destroyExceptionInfo :: Ptr ExceptionInfo -> IO () destroyExceptionInfo infoPtr = do destroy_exception_info infoPtr free infoPtr withTmpExceptionInfo :: (Ptr ExceptionInfo -> IO a) -> IO a withTmpExceptionInfo action = do infoPtr <- mkNewExceptionInfo_ result <- action infoPtr result `seq` destroyExceptionInfo infoPtr return result ----------- Image info mkNewImageInfo :: IO (ForeignPtr HImageInfo) mkNewImageInfo = mkFinalizedImageInfo =<< mkNewImageInfo_ mkFinalizedImageInfo :: Ptr HImageInfo -> IO (ForeignPtr HImageInfo) mkFinalizedImageInfo = newForeignPtr imageInfoFinalizer mkNewImageInfo_ :: IO (Ptr HImageInfo) mkNewImageInfo_ = clone_image_info nullPtr destroyImageInfo :: Ptr HImageInfo -> IO () destroyImageInfo = destroy_image_info foreign import ccall "static magick/api.h &DestroyImageInfo" imageInfoFinalizer :: FunPtr (Ptr HImageInfo -> IO ()) withTmpImageInfo :: (Ptr HImageInfo -> IO a) -> IO a withTmpImageInfo action = do imgInfo <- mkNewImageInfo_ result <- action imgInfo result `seq` destroy_image_info imgInfo return result ----------- Both mkNewUnloadedImage :: ImageNotLoaded mkNewUnloadedImage = unsafePerformIO $ do e <- mkNewExceptionInfo i <- mkNewImageInfo return $ mkUnloadedImage i e ----------- Type conversion -- meant to convert an integ>ral type to a C enum type toCEnum :: (Enum a, Num b) => a -> b toCEnum = fromIntegral.fromEnum ----------- dealing with pointers whose values may not be present maybeToPtr :: Storable a => Maybe a -> Ptr a -> IO (Ptr a) maybeToPtr Nothing _ = return nullPtr maybeToPtr (Just stuff) p = poke p stuff >> return p