hsmagick-0.5/0000755000000000000000000000000011537226472011343 5ustar0000000000000000hsmagick-0.5/LICENSE0000644000000000000000000000271711537226472012357 0ustar0000000000000000Copyright (c) Tim Chevalier 2008 All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 3. Neither the name of the author nor the names of his contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. hsmagick-0.5/Setup.lhs0000644000000000000000000000011411537226472013147 0ustar0000000000000000#!/usr/bin/env runhaskell > import Distribution.Simple > main = defaultMain hsmagick-0.5/README0000644000000000000000000000323211537226472012223 0ustar0000000000000000This is an incomplete set of FFI bindings for the GraphicsMagick library. You will need to install GraphicsMagick first -- see: http://www.graphicsmagick.org/ I have tested these bindings with GraphicsMagick 1.2, which is available as a "snapshot" from the above URL. The library will not build with GraphicsMagick 1.1.10 or 1.1.11 (the most recent released version as of this writing). If it's important to you to be able to use this library with a stable released version of GraphicsMagick, let me know. The Haddock documentation only includes type signatures so far, and that's not good enough. However, the API calls should mostly map onto those documented at: http://www.graphicsmagick.org/www/api.html Tests can be found in: Graphics.Transform.Magick.Test However, right now all tests are commented out since I didn't have time to change them to use non-hard-wired file names. I hope it should be obvious what my intentions were. A less ad hoc test framework would be better yet. Please submit bug reports, questions, feedback, complaints, praise, and especially patches (including documentation patches) to the maintainer at: vincent_AT_xenbox.fr I did a lot of this work during the second Haskell Hackathon (Hac II '07) in Freiburg in September 2007. I'd like to thank all the attendees at Hac II for their moral support, particularly Duncan Coutts for help with the FFI, as well as: Mark Jones, the members of the Portland Functional Programming Study Group, and David MacIver, for their encouragement. -- Tim Chevalier Portland, Oregon April 6, 2008 === Contributors === Thanks to "nonowarn", "Steffen Siering" for contributing patches. hsmagick-0.5/hsmagick.cabal0000644000000000000000000000264411537226472014123 0ustar0000000000000000name: hsmagick version: 0.5 synopsis: FFI bindings for the GraphicsMagick library description: FFI bindings for the GraphicsMagick library category: Graphics license: BSD3 license-file: LICENSE author: Tim Chevalier maintainer: Vincent Gerard, vincent@xenbox.fr copyright: (c) Tim Chevalier, 2008 stability: alpha homepage: https://github.com/vincentg/hsmagick Cabal-Version: >= 1.2.3 tested-with: GHC==6.10.4, GHC==6.12.2, GHC==7.0.2 build-type: Simple data-files: README Library { build-depends: base < 5, directory, filepath, pretty, process, bytestring exposed-modules: Graphics.Transform.Magick.Images, Graphics.Transform.Magick.Types, Graphics.Transform.Magick.Test other-modules: Graphics.Transform.Magick.FFIHelpers, Graphics.Transform.Magick.Util, Graphics.Transform.Magick.Errors, Graphics.Transform.Magick.Magick ghc-options: -Wall extra-libraries: tiff jasper jpeg png wmflite bz2 z m pkgconfig-depends: GraphicsMagick >= 1.3.3 , lcms , freetype2 , libxml-2.0 if impl(ghc > 6.8.2) { extensions: ScopedTypeVariables } else { extensions: PatternSignatures } extensions: CPP, ForeignFunctionInterface, MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances } hsmagick-0.5/Graphics/0000755000000000000000000000000011537226472013103 5ustar0000000000000000hsmagick-0.5/Graphics/Transform/0000755000000000000000000000000011537226472015056 5ustar0000000000000000hsmagick-0.5/Graphics/Transform/Magick/0000755000000000000000000000000011537226472016251 5ustar0000000000000000hsmagick-0.5/Graphics/Transform/Magick/Test.hs0000644000000000000000000003527411537226472017537 0ustar0000000000000000module Graphics.Transform.Magick.Test(runAllTests) where ------------------------------------------------------------------------------- -- | Ad hoc unit tests. Should really use HUnit. ------------------------------------------------------------------------------- {- import Graphics.Transform.Magick.Images import Graphics.Transform.Magick.Types import Graphics.Transform.Magick.FFIHelpers import Graphics.Transform.Magick.Errors import Control.Monad import Data.Word import System.Cmd import System.Directory import System.Exit import System.FilePath import Text.PrettyPrint.HughesPJ -} ------------------------------------------------------------------------------- -- Locations of test image files: change as you like. {- testDir, outDir :: FilePath testDir = "../../../test/data" outDir = "../../../test/out" imgFormat :: String imgFormat = "gif" ext :: FilePath -> FilePath ext = (flip addExtension) imgFormat absl :: FilePath -> FilePath -> FilePath absl d = (d ) . ext inFile, outFile :: FilePath inFile = absl testDir "lambda" outFile = absl outDir "out" generatedFiles :: [FilePath] generatedFiles = map generatedFile testNames testNames :: [String] testNames = ["flip", "flop", "rotate", "chop", "crop", "flatten", "mosaic", "roll", "shave", "scale", "sample", "resize", "affine", "shear", "contrast", "equalize", "gamma", "level", "levelImageChannel", "modulate", "negate", "normalize", "composite", "constitute", "importPixelArea", "setColormap", "append", "average", "cycleColormap"] base64File :: FilePath base64File = replaceExtension inFile "uu" generatedFile :: String -> FilePath generatedFile = absl outDir -- This assumes you have a program called "convert" that is consistent -- with your installed GraphicsMagick library. Change if necessary. convertCmdName :: String convertCmdName = "convert" gFile :: String -> FilePath gFile = id -- TODO -- change to actually execute the commands; this is for debugging exec :: String -> IO () exec = putStrLn ------------------------------------------------------------------------------- generateBase64 :: FilePath -> IO () generateBase64 _ = putStrLn ("generateBase64: TODO") generateInFile :: String -> String -> IO () generateInFile fileName transform = do let generated = anInFile fileName let command = convertCmd transform inFile generated res <- exec command checkSuccess res $ "Generating " ++ generated anInFile :: String -> FilePath anInFile s = replaceBaseName inFile s convertCmd :: String -> FilePath -> String convertCmd whatToDo inF outF = render $ convertCmdName <+> (char '-' <> whatToDo) <+> inF <+> outF mkBaseline :: IO () mkBaseline = generateBase64 base64File >> generateInFile "append" "negate" >> mapM_ generate generatedFiles where generate :: FilePath -> IO() -- Create the baseline image file if it doesn't exist generate fn = do exists <- doesFileExist fn unless exists $ do let command = convertCmd (dropExtension (takeFileName fn)) inFile fn res <- exec command checkSuccess res $ "Generating " ++ fn ------------------------------------------------------------------------------- -} runAllTests :: IO () runAllTests = putStrLn "Tests not implemented! Quitting" {- do mkBaseline readWriteTest vFlipTest hFlopTest rotateTest chopTest cropTest -- flattenTest mosaicTest rollTest shaveTest scaleTest magnifyTest minifyTest sampleTest thumbnailTest resizeTest -- TODO: fails for unknown reasons -- affineTest shearTest contrastTest equalizeTest gammaTest levelTest levelImageChannelTest modulateTest negateTest normalizeTest constituteTest dispatchTest --exportPixelImageAreaTest importPixelImageAreaTest pingTest readInlineImageTest compositeTest allocateTest setColormapTest appendTest averageTest cycleColormapTest -- not working/implemented yet -- animateTest -} {- readWriteTest, vFlipTest, hFlopTest, rotateTest, chopTest, cropTest, {-flattenTest,-} mosaicTest, rollTest, shaveTest, scaleTest, magnifyTest, minifyTest, sampleTest, thumbnailTest, resizeTest, {-affineTest,-} shearTest, contrastTest, equalizeTest, gammaTest, levelTest, levelImageChannelTest, modulateTest, negateTest, normalizeTest, constituteTest, dispatchTest, -- exportPixelImageAreaTest, importPixelImageAreaTest, pingTest, readInlineImageTest, compositeTest, allocateTest, setColormapTest, appendTest, averageTest, cycleColormapTest {-, _animateTest-} :: IO () readWriteTest = transformTest "/home/tjc/Desktop/pix/lambda_mangled.png" outFile "/home/tjc/Desktop/pix/lambda_mangled.png" id "readWriteTest" vFlipTest = transformTest inFile outFile (gFile "flip") flipImage "vFlipTest" hFlopTest = transformTest inFile outFile (gFile "flop") flopImage "hFlopTest" rotateTest = transformTest inFile outFile (gFile "rotate") (rotateImage 42) "rotateTest" shearTest = transformTest inFile outFile (gFile "shear") (shearImage 10.5 20.17) "shearTest" {- affineTest = transformTest inFile outFile affineFileGold (affineTransform (AffineMatrix { sx=3.0, rx=0.5, ry=(-1.1), sy=0.7, tx=0, ty=0 })) "affineTest" -} chopTest = transformTest inFile outFile (gFile "chop") (chopImage (Rectangle{ width=27, height=50, x=80, y=107 })) "chopTest" cropTest = transformTest inFile outFile (gFile "crop") (cropImage (Rectangle{ width=27, height=50, x=80, y=107 })) "cropTest" rollTest = transformTest inFile outFile (gFile "roll") (rollImage 115 134) "rollTest" shaveTest = transformTest inFile outFile (gFile "shave") (shaveImage (Rectangle{ width=32, height=45, x=32, y=45})) "shaveTest" -- Note: to generate the gold file for this, use: -- convert -scale \!35x70 in.jpg out.jpg scaleTest = transformTest inFile outFile (gFile "scale") (scaleImage 35 70) "scaleTest" -- Note: to generate the gold file for this, use: -- convert -sample \!35x70 in.jpg out.jpg sampleTest = transformTest inFile outFile (gFile "sample") (sampleImage 35 70) "sampleTest" -- the gold file has to be generated with a C program for -- this. fsr the command-line utility doesn't give you the -- same output despite being passed the same vals. resizeTest = transformTest inFile outFile (gFile "resize") (resizeImage 35 70 PointFilter 1) "resizeTest" contrastTest = transformTest inFile outFile (gFile "contrast") (contrastImage IncreaseContrast) "contrastTest" equalizeTest = transformTest inFile outFile (gFile "equalize") equalizeImage "equalizeTest" gammaTest = transformTest inFile outFile (gFile "gamma") (gammaImage (PixelPacket {red=1.2, green=0.9, blue=2.3, opacity=0})) "gammaTest" levelTest = transformTest inFile outFile (gFile "level") (levelImage (Level {black=10, mid=0.2, white=250})) "levelTest" levelImageChannelTest = transformTest inFile outFile (gFile "levelImageChannel") (levelImageChannel CyanChannel (Level {black=1.2, mid=0.9, white=2.3})) "levelImageChannelTest" modulateTest = transformTest inFile outFile (gFile "modulate") (modulateImage (Modulation { brightness=90, saturation=150, hue=200 })) "modulateTest" negateTest = transformTest inFile outFile (gFile "negate") (negateImage AllPixels) "negateTest" normalizeTest = transformTest inFile outFile (gFile "normalize") normalizeImage "normalizeTest" compositeTest = do baseImage <- readImage inFile transformTest inFile outFile (gFile "composite") (\ canvas -> compositeImage Minus 0 0 canvas baseImage) "compositeTest" constituteTest = do let theImage = allBlackImage writeImage outFile theImage result <- system $ "diff " ++ outFile ++ " " ++ (gFile "constitute") checkSuccess result "constituteTest" dispatchTest = do -- TODO: -- We have to give a type signature because the type can't -- depend on the value CharPixel that gets passed in. -- Is there a fix? let (pixels::[[Word8]]) = dispatchImage (PixMap [R,G,B]) CharPixel (Rectangle{x=0,y=0,width=50,height=50}) allBlackImage let result = all (all (== 0)) pixels && length (concat pixels) == 50*50*3 let (pixels2::[[Word8]]) = dispatchImage (PixMap [R,G,B]) CharPixel (Rectangle{x=0,y=0,width=50,height=50}) allWhiteImage let result2 = all (all (== 255)) pixels2 && length (concat pixels2) == 50*50*3 checkSuccess (boolToExitCode (result && result2)) "dispatchTest" {- -- TODO: broken _exportPixelImageAreaTest = do let purpleImage = constituteImage (PixMap [R,G,B]) (replicate 50 (concat (replicate 50 [255::Word8,0,255]))) let pixels::[[Word8]] = exportPixelImageArea RedQuantum 8 Nothing purpleImage let result = all (all (== 255)) pixels && length (concat pixels) == 50 debug 3 $ "result = " ++ show pixels ++ " len = " ++ show (length (concat pixels)) checkSuccess (boolToExitCode result) "exportPixelImageAreaTest" -} importPixelImageAreaTest = do let importedImage = importPixelImageArea GreenQuantum 8 (replicate 50 (replicate 50 255)) Nothing allBlackImage writeImage outFile importedImage result <- system $ "diff " ++ outFile ++ " " ++ gFile "import" checkSuccess result "importPixelImageAreaTest" pingTest = do -- just check that the operation succeeded for now _ <- pingImage inFile checkSuccess ExitSuccess "pingTest" readInlineImageTest = do base64Data <- readFile base64File let imageFromBase64 = readInlineImage base64Data writeImage outFile imageFromBase64 --result <- system $ "diff " ++ outFile ++ " " ++ inFile let result = ExitSuccess -- this is also failing. WHYYYYYYY checkSuccess result "readInlineImageTest" allocateTest = do let res = allocateImage mkNewUnloadedImage checkSuccess (res `seq` ExitSuccess) "allocateTest" setColormapTest = transformTest inFile outFile (gFile "setColormap") (setImageColormap 255) "colormapTest" appendTest = do img1 <- readImage inFile img2 <- readImage (anInFile "append") let res = appendImages LeftToRight [img1, cropImage (Rectangle {width=191, height=268, x=0, y=0}) (rotateImage (-90) img2)] writeImage outFile res result <- system $ "diff " ++ outFile ++ " " ++ (gFile "append") checkSuccess result "appendTest" averageTest = do img1 <- readImage inFile img2 <- readImage (anInFile "average") let cr = cropImage $ Rectangle{width=180, height=180, x=0, y=0} let res = averageImages [cr img1, cr img2] writeImage outFile res result <- system $ "diff " ++ outFile ++ " " ++ (gFile "average") checkSuccess result "averageTest" cycleColormapTest = do img <- readImage inFile let imgs = take 100 $ iterate (cycleColormapImage 10) img let appended = appendImages LeftToRight imgs writeImage outFile appended result <- system $ "diff " ++ outFile ++ " " ++ (gFile "cycle") checkSuccess result "cycleColormapTest" {- _animateTest = do img <- readImage _lambdaFile let imgs = take 100 $ iterate (cycleColormapImage 10) img animateImages imgs -} -- let filenames = map (\ n -> (filenamePart outFile) ++ "_" ++ show n ++ (extensionPart outFile)) [(3::Int)..13] -- mapM_ (uncurry writeImage) (zip filenames imgs) -- where -- this assumes there's exactly one extension... -- filenamePart = takeWhile (/= '.') -- extensionPart = dropWhile (/= '.') allBlackImage :: HImage allBlackImage = constituteImage (PixMap [R,G,B]) (replicate 50 (replicate 150 (0::Word8))) allWhiteImage :: HImage allWhiteImage = constituteImage (PixMap [R,G,B]) (replicate 50 (replicate 150 (255::Word8))) -- magnify and minify don't have command-line equivalents, -- but at least we can check the files exist. magnifyTest = fileExistsTest inFile outFile magnifyImage "magnifyTest" minifyTest = fileExistsTest inFile outFile minifyImage "minifyTest" -- ditto for thumbnail thumbnailTest = fileExistsTest inFile outFile (thumbnailImage 35 70) "thumbnailTest" {- flattenTest = do debug 3 $ "reading in images..." testImages <- mapM readImage [flatFile1, flatFile2] debug 3 $ "about to flatten image..." let flattenedImage = flattenImage testImages debug 3 $ flattenedImage `seq` "flatten, about to call writeImage..." writeImage outFile flattenedImage result <- system $ "diff " ++ outFile ++ " " ++ flatFileGold debug 3 $ "result = " ++ show result checkSuccess result "flattenTest" where flatFile1 = "/home/tjc/Desktop/pix/lambda.png" flatFile2 = "/home/tjc/ImageLib/PicDump/overlay_sparks.gif" -} mosaicTest = do testImages <- mapM readImage mosaicFiles let rects = (makeRectangles (100,100) [0, 100]) let mosaicImage = mosaic (zip testImages rects) debug 3 $ "rects = " ++ show rects writeImage outFile mosaicImage result <- system $ "diff " ++ outFile ++ " " ++ (gFile "mosaic") checkSuccess result "mosaicTest" where makeRectangles (wth,hht) coords = map (\ (w, h, x', y') -> Rectangle{width=w, height=h, x=x', y=y'}) [(wth, hht, ex, why) | ex <- coords, why <- coords] mosaicFiles = map ("/home/tjc/ImageLib/PicDump/"++) ["binkley.jpg", "unhelpful.png", "yearbook.jpeg", "mini.jpeg"] {- transformTestIgnoreResult :: FilePath -> FilePath -> FilePath -> (HImage -> HImage) -> String -> IO () transformTestIgnoreResult = transformTest' True -} transformTest :: FilePath -> FilePath -> FilePath -> (HImage -> HImage) -> String -> IO () transformTest = transformTest' False transformTest' :: Bool -> FilePath -> FilePath -> FilePath -> (HImage -> HImage) -> String -> IO () transformTest' ignoreResult inF outF goldF transform testName = do imagePtr <- readImage inF let newImage = transform imagePtr writeImage outF newImage result <- if ignoreResult then return ExitSuccess else system $ "diff " ++ outF ++ " " ++ goldF checkSuccess result testName fileExistsTest :: FilePath -> FilePath -> (HImage -> HImage) -> String -> IO () fileExistsTest inF outF transform testName = do imagePtr <- readImage inF let newImage = transform imagePtr writeImage outF newImage exists <- doesFileExist outF checkSuccess (if exists then ExitSuccess else (ExitFailure 1)) testName reportSuccess :: String -> IO () reportSuccess testName = putStrLn $ "-----------> Test " ++ testName ++ " passed! :-)" reportFailure :: Show a => String -> a -> IO () reportFailure testName exitCode = putStrLn $ "-----------> Test " ++ testName ++ " failed with " ++ show exitCode ++ " :-(" checkSuccess :: ExitCode -> String -> IO () checkSuccess result testName = case result of ExitSuccess -> reportSuccess testName _ -> reportFailure testName result boolToExitCode :: Bool -> ExitCode boolToExitCode True = ExitSuccess boolToExitCode _ = ExitFailure 1 -} hsmagick-0.5/Graphics/Transform/Magick/Errors.hs0000644000000000000000000000057611537226472020071 0ustar0000000000000000module Graphics.Transform.Magick.Errors where import Control.Exception -- Error handling functions -- Todo: something better signalException :: String -> IO a signalException = throwIO . ErrorCall tellUser :: String -> IO () tellUser = putStrLn debug :: Int -> String -> IO () debug n | n <= debugLevel = putStrLn debug _ = const $ return () debugLevel :: Int debugLevel = 2 hsmagick-0.5/Graphics/Transform/Magick/FFIHelpers.hsc0000644000000000000000000011630111537226472020701 0ustar0000000000000000{-# 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 hsmagick-0.5/Graphics/Transform/Magick/Magick.hs0000644000000000000000000003411611537226472020005 0ustar0000000000000000module Graphics.Transform.Magick.Magick(module Foreign.C.Types, module Foreign, module Foreign.C.String, initialize_magick, get_exception_info, destroy_exception_info, clone_image_info, read_image, write_image, catch_exception, ------- transformations flip_image, flop_image, rotate_image, affine_transform, shear_image, chop_image, crop_image, flatten_images, mosaic_images, roll_image, shave_image, ------- resizing scale_image, magnify_image, minify_image, sample_image, thumbnail_image, resize_image, -- enhancements contrast_image, equalize_image, gamma_image, level_image, level_image_channel, modulate_image, negate_image, normalize_image, -- constitution constitute_image, dispatch_image, -- blob blob_to_image, image_to_blob, --export_image_pixel_area, export_pixel_area_options_init, import_image_pixel_area, import_pixel_area_options_init, ping_image, read_inline_image, -- composition composite_image, -- image methods access_definition, add_definitions, allocate_image, allocate_image_colormap, append_images, average_images, clip_path_image, cycle_colormap_image, describe_image, destroy_image, finalize_image, destroy_image_info, get_image_clip_mask, get_image_depth, get_image_characteristics, get_image_geometry, get_image_info, get_image_statistics, get_image_type, image_equals, is_taint_image, plasma_image, reference_image, remove_definitions, replace_image_colormap, set_image, set_image_clip_mask, set_image_depth, set_image_opacity, set_image_type, texture_image, -- stuff what displays stuff animate_images, --- util (internal use only!) p_free, clone_image, fopen, fclose) where import Graphics.Transform.Magick.Types import Foreign import Foreign.C.Types import Foreign.C.String -- The internal interface to the GraphicsMagick library. This -- module should mostly (if not entirely) contain import declarations -- for foreign calls. -- also the place to dump in modules we'd like to re-export :-) --------------- Basics foreign import ccall "static magick/api.h InitializeMagick" initialize_magick :: Ptr a -> IO () foreign import ccall "static magick/api.h GetExceptionInfo" get_exception_info :: Ptr ExceptionInfo -> IO () foreign import ccall "static magick/api.h DestroyExceptionInfo" destroy_exception_info :: Ptr ExceptionInfo -> IO () foreign import ccall "static magick/api.h CloneImageInfo" clone_image_info :: Ptr HImageInfo -> IO (Ptr HImageInfo) foreign import ccall "static magick/api.h ReadImage" read_image :: Ptr HImageInfo -> Ptr ExceptionInfo -> IO (Ptr HImage_) foreign import ccall "static magick/api.h WriteImage" write_image :: Ptr HImageInfo -> Ptr HImage_ -> IO CUInt foreign import ccall "static magick/api.h CatchException" catch_exception :: Ptr ExceptionInfo -> IO () ----------------- Constituting an image foreign import ccall "static magick/api.h ConstituteImage" constitute_image :: CULong -> CULong -> CString -> CUInt -> Ptr a -> Ptr ExceptionInfo -> IO (Ptr HImage_) -- TODO: DestroyConstitute; do we need it? foreign import ccall "static magick/api.h DispatchImage" dispatch_image :: Ptr HImage_ -> CULong -> CULong -> CULong -> CULong -> CString -> CUInt -> Ptr a -> Ptr ExceptionInfo -> IO CUInt {- TODO: this doesn't seem to exist anymore... foreign import ccall "static magick/api.h ExportImagePixelArea" export_image_pixel_area :: Ptr HImage_ -> CUInt -> CUInt -> Ptr a -> Ptr ExportPixelAreaOptions -> Ptr ExportPixelAreaInfo -> IO CUInt -} foreign import ccall "static magick/api.h ExportPixelAreaOptionsInit" export_pixel_area_options_init :: Ptr ExportPixelAreaOptions -> IO () foreign import ccall "static magick/api.h ImportImagePixelArea" import_image_pixel_area :: Ptr HImage_ -> CUInt -> CUInt -> CString -> Ptr ImportPixelAreaOptions -> Ptr ImportPixelAreaInfo -> IO CUInt foreign import ccall "static magick/api.h ImportPixelAreaOptionsInit" import_pixel_area_options_init :: Ptr ImportPixelAreaOptions -> IO () foreign import ccall "static magick/api.h PingImage" ping_image :: Ptr HImageInfo -> Ptr ExceptionInfo -> IO (Ptr HImage_) foreign import ccall "static magick/api.h ReadInlineImage" read_inline_image :: Ptr HImageInfo -> CString -> Ptr ExceptionInfo -> IO (Ptr HImage_) ----------------- Blob foreign import ccall "static magick/api.h BlobToImage" blob_to_image :: Ptr HImageInfo -> Ptr CUChar -> CSize -> Ptr ExceptionInfo -> IO (Ptr HImage_) foreign import ccall "static magick/api.h ImageToBlob" image_to_blob :: Ptr HImageInfo -> Ptr HImage_ -> Ptr CSize -> Ptr ExceptionInfo -> IO (Ptr CUChar) ----------------- Transformations foreign import ccall "static magick/api.h FlipImage" flip_image :: Ptr HImage_ -> Ptr ExceptionInfo -> IO (Ptr HImage_) foreign import ccall "static magick/api.h FlopImage" flop_image :: Ptr HImage_ -> Ptr ExceptionInfo -> IO (Ptr HImage_) foreign import ccall "static magick/api.h RotateImage" rotate_image :: Ptr HImage_ -> CDouble -> Ptr ExceptionInfo -> IO (Ptr HImage_) foreign import ccall "static magick/api.h AffineTransformImage" affine_transform :: Ptr HImage_ -> Ptr AffineMatrix -> Ptr ExceptionInfo -> IO (Ptr HImage_) foreign import ccall "static magick/api.h ShearImage" shear_image :: Ptr HImage_ -> CDouble -> CDouble -> Ptr ExceptionInfo -> IO (Ptr HImage_) foreign import ccall "static magick/api.h ChopImage" chop_image :: Ptr HImage_ -> Ptr Rectangle -> Ptr ExceptionInfo -> IO (Ptr HImage_) foreign import ccall "static magick/api.h CropImage" crop_image :: Ptr HImage_ -> Ptr Rectangle -> Ptr ExceptionInfo -> IO (Ptr HImage_) foreign import ccall "static magick/api.h FlattenImages" flatten_images :: Ptr HImage_ -> Ptr ExceptionInfo -> IO (Ptr HImage_) foreign import ccall "static magick/api.h MosaicImages" mosaic_images :: Ptr HImage_ -> Ptr ExceptionInfo -> IO (Ptr HImage_) foreign import ccall "static magick/api.h RollImage" roll_image :: Ptr HImage_ -> CLong -> CLong -> Ptr ExceptionInfo -> IO (Ptr HImage_) foreign import ccall "static magick/api.h ShaveImage" shave_image :: Ptr HImage_ -> Ptr Rectangle -> Ptr ExceptionInfo -> IO (Ptr HImage_) ----------------- Resizing foreign import ccall "static magick/api.h ScaleImage" scale_image :: Ptr HImage_ -> CULong -> CULong -> Ptr ExceptionInfo -> IO (Ptr HImage_) foreign import ccall "static magick/api.h MagnifyImage" magnify_image :: Ptr HImage_ -> Ptr ExceptionInfo -> IO (Ptr HImage_) foreign import ccall "static magick/api.h MinifyImage" minify_image :: Ptr HImage_ -> Ptr ExceptionInfo -> IO (Ptr HImage_) foreign import ccall "static magick/api.h SampleImage" sample_image :: Ptr HImage_ -> CULong -> CULong -> Ptr ExceptionInfo -> IO (Ptr HImage_) foreign import ccall "static magick/api.h ThumbnailImage" thumbnail_image :: Ptr HImage_ -> CULong -> CULong -> Ptr ExceptionInfo -> IO (Ptr HImage_) foreign import ccall "static magick/api.h ResizeImage" resize_image :: Ptr HImage_ -> CULong -> CULong -> CUInt -> CDouble -> Ptr ExceptionInfo -> IO (Ptr HImage_) ---------- Enhancements -- Note that these side-effect the image! Higher-level API -- has to hide this from the user via copying. foreign import ccall "static magick/api.h ContrastImage" contrast_image :: Ptr HImage_ -> CUInt -> IO CUInt foreign import ccall "static magick/api.h EqualizeImage" equalize_image :: Ptr HImage_ -> IO CUInt foreign import ccall "static magick/api.h GammaImage" gamma_image :: Ptr HImage_ -> CString -> IO CUInt foreign import ccall "static magick/api.h LevelImage" level_image :: Ptr HImage_ -> CString -> IO CUInt foreign import ccall "static magick/api.h LevelImageChannel" level_image_channel :: Ptr HImage_ -> CUInt -> CDouble -> CDouble -> CDouble -> IO CUInt foreign import ccall "static magick/api.h ModulateImage" modulate_image :: Ptr HImage_ -> CString -> IO CUInt foreign import ccall "static magick/api.h NegateImage" negate_image :: Ptr HImage_ -> CUInt -> IO CUInt foreign import ccall "static magick/api.h NormalizeImage" normalize_image :: Ptr HImage_ -> IO CUInt ---------- Composition foreign import ccall "static magick/api.h CompositeImage" composite_image :: Ptr HImage_ -> CUInt -> Ptr HImage_ -> CLong -> CLong -> IO CUInt ---------- Image methods foreign import ccall "static magick/api.h AccessDefinition" access_definition :: Ptr HImageInfo -> CString -> CString -> IO CString foreign import ccall "static magick/api.h AddDefinitions" add_definitions :: Ptr HImageInfo -> CString -> IO () foreign import ccall "static magick/api.h AllocateImage" allocate_image :: Ptr HImageInfo -> IO (Ptr HImage_) foreign import ccall "static magick/api.h AllocateImageColormap" allocate_image_colormap :: Ptr HImage_ -> CULong -> IO CUInt foreign import ccall "static magick/api.h AnimateImages" animate_images :: Ptr HImageInfo -> Ptr HImage_ -> IO CUInt foreign import ccall "static magick/api.h AppendImages" append_images :: Ptr HImage_ -> CUInt -> Ptr ExceptionInfo -> IO (Ptr HImage_) foreign import ccall "static magick/api.h AverageImages" average_images :: Ptr HImage_ -> Ptr ExceptionInfo -> IO (Ptr HImage_) foreign import ccall "static magick/api.h ClipPathImage" clip_path_image :: Ptr HImage_ -> CString -> CUInt -> IO CUInt foreign import ccall "static magick/api.h CycleColormapImage" cycle_colormap_image :: Ptr HImage_ -> CInt -> IO CUInt foreign import ccall "static magick/api.h DescribeImage" describe_image :: Ptr HImage_ -> Ptr CFile -> CUInt -> IO CUInt foreign import ccall "static magick/api.h DestroyImage" destroy_image :: Ptr HImage_ -> IO () foreign import ccall "static magick/api.h &DestroyImage" finalize_image :: FunPtr(Ptr HImage_ -> IO ()) foreign import ccall "static magick/api.h DestroyImageInfo" destroy_image_info :: Ptr HImageInfo -> IO () foreign import ccall "static magick/api.h GetImageClipMask" get_image_clip_mask :: Ptr HImage_ -> Ptr ExceptionInfo -> Ptr HImage_ foreign import ccall "static magick/api.h GetImageDepth" get_image_depth :: Ptr HImage_ -> Ptr ExceptionInfo -> IO CULong foreign import ccall "static magick/api.h GetImageCharacteristics" get_image_characteristics :: Ptr HImage_ -> Ptr ImageCharacteristics -> CUInt -> Ptr ExceptionInfo -> IO CUInt foreign import ccall "static magick/api.h GetImageGeometry" get_image_geometry :: Ptr HImage_ -> CString -> CUInt -> Ptr Rectangle -> IO CInt foreign import ccall "static magick/api.h GetImageInfo" get_image_info :: Ptr HImageInfo -> IO () foreign import ccall "static magick/api.h GetImageStatistics" get_image_statistics :: Ptr HImage_ -> Ptr ImageStatistics -> Ptr ExceptionInfo -> IO CUInt foreign import ccall "static magick/api.h GetImageType" get_image_type :: Ptr HImage_ -> Ptr ExceptionInfo -> IO ImageType foreign import ccall "static magick/api.h IsImagesEqual" image_equals :: Ptr HImage_ -> Ptr HImage_ -> IO CUInt foreign import ccall "static magick/api.h IsTaintImage" is_taint_image :: Ptr HImage_ -> IO CUInt foreign import ccall "static magick/api.h PlasmaImage" plasma_image :: Ptr HImage_ -> Ptr SegmentInfo -> CULong -> CULong -> IO CUInt foreign import ccall "static magick/api.h ReferenceImage" reference_image :: Ptr HImage_ -> IO (Ptr HImage_) foreign import ccall "static magick/api.h RemoveDefinitions" remove_definitions :: Ptr HImageInfo -> CString -> Ptr ExceptionInfo -> IO () foreign import ccall "static magick/api.h ReplaceImageColormap" replace_image_colormap :: Ptr HImage_ -> Ptr (PixelPacket Word16) -> CUInt -> IO CUInt foreign import ccall "static magick/api.h SetImage" set_image :: Ptr HImage_ -> CUInt -> IO () foreign import ccall "static magick/api.h SetImageClipMask" set_image_clip_mask :: Ptr HImage_ -> Ptr HImage_ -> IO CUInt foreign import ccall "static magick/api.h SetImageDepth" set_image_depth :: Ptr HImage_ -> CULong -> IO CUInt foreign import ccall "static magick/api.h SetImageOpacity" set_image_opacity :: Ptr HImage_ -> CUInt -> IO () foreign import ccall "static magick/api.h SetImageType" set_image_type :: Ptr HImage_ -> ImageType -> IO () foreign import ccall "static magick/api.h TextureImage" texture_image :: Ptr HImage_ -> Ptr HImage_ -> IO CUInt ---------- util (internal library use only) foreign import ccall "stdlib.h &free" p_free :: FunPtr (Ptr a -> IO ()) foreign import ccall "static magick/api.h CloneImage" clone_image :: Ptr HImage_ -> CULong -> CULong -> CUInt -> Ptr ExceptionInfo -> IO (Ptr HImage_) foreign import ccall unsafe "stdlib.h fopen" fopen :: CString -> CString -> IO (Ptr CFile) foreign import ccall unsafe "stdlib.h fclose" fclose :: Ptr CFile -> IO () hsmagick-0.5/Graphics/Transform/Magick/Util.hs0000644000000000000000000000170111537226472017521 0ustar0000000000000000{-# OPTIONS -Wall #-} module Graphics.Transform.Magick.Util( allM, butLast, assertM, commaSep, groups) where import Data.List import Control.Exception ------------------ -- Monad utilities ------------------ allM :: Monad m => (a -> m Bool) -> [a] -> m Bool allM f xs = mapM f xs >>= (return . and) assertM :: Bool -> String -> IO () assertM True _ = return () assertM False s = throwIO (AssertionFailed s) ----------------- -- List utilities ----------------- -- returns an empty list if passed the empty list butLast :: [a] -> [a] butLast = reverse.safeTail.reverse safeTail :: [a] -> [a] safeTail [] = [] safeTail (_:xs) = xs sepBy :: [a] -> [[a]] -> [a] sepBy separator things = concat (intersperse separator things) commaSep :: Show a => [a] -> String commaSep xs = sepBy "," (map show xs) groups :: Integral a => a -> [b] -> [[b]] groups n xs | genericLength xs <= n = [xs] groups n xss = (genericTake n xss):(groups n (genericDrop n xss)) hsmagick-0.5/Graphics/Transform/Magick/Images.hsc0000644000000000000000000005752411537226472020172 0ustar0000000000000000module Graphics.Transform.Magick.Images(initializeMagick, readImage, writeImage, pingImage, readInlineImage, getFilename, blobToImage, imageToBlob, -- transformations flipImage, flopImage, rotateImage, affineTransform, shearImage, chopImage, cropImage, flattenImage, mosaic, rollImage, shaveImage, -- resizing scaleImage, magnifyImage, minifyImage, sampleImage, thumbnailImage, resizeImage, -- enhancements contrastImage, equalizeImage, gammaImage, levelImage, levelImageChannel, modulateImage, negateImage, normalizeImage, -- constitution constituteImage, dispatchImage, --exportPixelImageArea, importPixelImageArea, -- composition compositeImage, -- image methods allocateImage, setImageColormap, newImageColormap, appendImages, averageImages, cycleColormapImage, destroyImage, -- describeImage, -- Stuff what displays stuff animateImages) where #include import qualified Data.ByteString as BS import qualified Data.ByteString.Unsafe as BS import Graphics.Transform.Magick.Magick import Graphics.Transform.Magick.Types import Graphics.Transform.Magick.FFIHelpers import Graphics.Transform.Magick.Errors import Graphics.Transform.Magick.Util import Data.Char import Data.List import System.Directory -- The externally-visible Haskell API for GraphicsMagick. -- API: --------- Reading/writing readImage :: FilePath -> IO HImage writeImage :: FilePath -> HImage -> IO () pingImage :: FilePath -> IO HImage -- | initializeMagick must be invoked by the user program before making use -- of the library functions. initializeMagick :: IO () --------- Transformations flipImage, flopImage :: HImage -> HImage rotateImage :: Double -> HImage -> HImage affineTransform :: AffineMatrix -> HImage -> HImage shearImage :: Double -> Double -> HImage -> HImage chopImage, cropImage :: Rectangle -> HImage -> HImage flattenImage :: [HImage] -> HImage mosaic :: [(HImage, Rectangle)] -> HImage rollImage :: Int -> Int -> HImage -> HImage shaveImage :: Rectangle -> HImage -> HImage --------- Resizing scaleImage, sampleImage, thumbnailImage :: Word -> Word -> HImage -> HImage magnifyImage, minifyImage :: HImage -> HImage resizeImage :: Int -> Int -> FilterTypes -> Double -> HImage -> HImage --------- Enhancements contrastImage :: Contrast -> HImage -> HImage equalizeImage, normalizeImage :: HImage -> HImage gammaImage :: PixelPacket Double -> HImage -> HImage levelImage :: Level -> HImage -> HImage levelImageChannel :: ChannelType -> Level -> HImage -> HImage modulateImage :: Modulation -> HImage -> HImage negateImage :: Negation -> HImage -> HImage --------- Constitution -- This type says: if I can store blobs of type a as pixels of type b, -- and b is a Storable thing, then I can constitute an image from a list -- of blobs of type a. Gotta love Haskell! constituteImage :: (StorablePixel a b) => PixMap -> [[a]] -> HImage -- Not quite as nice, because we have to tell the GraphicsMagick library -- the StorageType so that it knows what type of pixels to put into the -- the array it's returning. dispatchImage :: (StorablePixel a b) => PixMap -> StorageType -> Rectangle -> HImage -> [[a]] {- TODO exportPixelImageArea :: (StorablePixel a b) => QuantumType2 -> Word -> Maybe ExportPixelAreaOptions -> HImage -> [[a]] -} -- TODO: this requires that the pixels are unsigned chars. Is there a better way? importPixelImageArea :: QuantumType2 -> Word -> [[Word8]] -> Maybe ImportPixelAreaOptions -> HImage -> HImage readInlineImage :: String -> HImage ------------- Composition compositeImage :: CompositeOp -> Int -> Int -> HImage -> HImage -> HImage ------------- Image methods -- returns a new image, initialized with default values allocateImage :: ImageNotLoaded -> HImage setImageColormap :: Word32 -> HImage -> HImage newImageColormap :: Word32 -> HImage appendImages :: ImageOrder -> [HImage] -> HImage averageImages :: [HImage] -> HImage cycleColormapImage :: Int -> HImage -> HImage destroyImage :: HImage -> IO () -- TODO. -- describeImage :: Verbosity -> HImage -> String ------------- Stuff what displays stuff animateImages :: [HImage] -> IO () -------------------------------------------------------------- ------------------- Reading/writing images ------------------- -------------------------------------------------------------- ----------------- readImage ------------------- -- readImage: reads in an image from a file. readImage = genericReadImage read_image --------------- writeImage -------------------- -- writeImage: writes the given image to the given file path -- TODO: has the side effect that it writes the filepath into the image filename -- fields. is this the right thing? writeImage fp hImage = withForeignPtr (getImage hImage) $ \img_ptr -> do -- hmm, side-effect the image info or make a copy of it? setFilename hImage fp debug 2 $ "About to write image..." excInfo <- nonFinalizedExceptionInfo ((#ptr Image, exception) img_ptr) -- write_image signals an exception by returning 0 withExceptions_ (withForeignPtr (getImageInfo hImage) (\ii -> (write_image ii img_ptr))) "writeImage: error writing image" (== 0) excInfo debug 2 $ "Wrote the image!" ex <- doesFileExist fp debug 3 $ fp ++ (if ex then " exists " else " doesn't exist") ------------- pingImage ----------------------- pingImage = genericReadImage ping_image ------------- composition --------------------- compositeImage op x_offset y_offset canvas_image comp_image = sideEffectingOp (\ canvasIm -> withExceptions ( withForeignPtr (getImage canvasIm) $ \canvasImPtr -> withForeignPtr (getImage comp_image) $ \comp_image_ptr -> composite_image canvasImPtr (toCEnum op) comp_image_ptr (fromIntegral x_offset) (fromIntegral y_offset)) "compositeImage: error compositing image" (== 0) (getExceptionInfo canvasIm)) canvas_image ------------- image methods ------------------- allocateImage imgNotLoaded = unsafePerformIO $ do imagePtr <- withForeignPtr (imageInfo imgNotLoaded) allocate_image if(imagePtr == nullPtr) then (signalException "allocateImage returned null") else return $ mkImage imagePtr imgNotLoaded -- optionaly let user destroy image and free memory immediately destroyImage (HImage img (ImageNotLoaded info exc)) = do finalizeForeignPtr img finalizeForeignPtr info finalizeForeignPtr exc setImageColormap clrs hImage = sideEffectingOp (\ im -> applyImageFn1 im allocate_image_colormap (fromIntegral clrs)) hImage newImageColormap clrs = unsafePerformIO $ do let hImage = allocateImage mkNewUnloadedImage withExceptions_ (applyImageFn1 hImage allocate_image_colormap (fromIntegral clrs)) "setImageColormap: error setting colormap" (== 0) (getExceptionInfo hImage) return hImage -- should require list to be nonempty appendImages order images@(img:_) = unsafePerformIO $ do linkImagesTogether images iPtr <- withExceptions (applyImageFn1' img append_images (toCEnum order)) "appendImage: error appending" (== nullPtr) (getExceptionInfo img) return $ setImage img iPtr appendImages _ [] = unsafePerformIO $ signalException "appendImages: empty list" -- TODO: -- should require a nonempty list -- TODO: -- hmm, appendImages and averageImages look a lot alike... averageImages images@(img:_) = unsafePerformIO $ do linkImagesTogether images iPtr <- withExceptions (applyImageFn' img average_images id) "averageImages: error averaging" (== nullPtr) (getExceptionInfo img) return $ setImage img iPtr averageImages [] = unsafePerformIO $ signalException "averageImages: empty list" -- TODO: should really abstract the patterns of "returns boolean" and -- "may return null pointer" cycleColormapImage amount img = sideEffectingOp (\ im -> applyImageFn1 im cycle_colormap_image (fromIntegral amount)) img {- TODO. describeImage verbosity img = unsafePerformIO $ do -- the API requires a file in which to dump the description -- grr tmpDir <- getTemporaryDirectory (fp, hdl) <- openTempFile tmpDir "hsMagick.tmp" hClose hdl withCString (\ fileStr -> withCString (\ modeStr -> do filePtr <- fopen fileStr modeStr withExceptions_ (describe_image (getImage img) filePtr (toCEnum verbosity)) "describeImage: error describing" (== 0) (getExceptionInfo img) fclose filePtr readFile fp)) -} ------------- Stuff what displays stuff animateImages images@(img:_) = do linkImagesTogether images withExceptions_ (withForeignPtr (getImageInfo img) (\ii -> (applyImageFn img (animate_images ii) id))) "animateImages: error animating" (== 0) (getExceptionInfo img) animateImages [] = return () ------------- genericReadImage - not exported genericReadImage :: (Ptr HImageInfo -> Ptr ExceptionInfo -> IO (Ptr HImage_)) -> FilePath -> IO HImage genericReadImage reader fp = genericReadOp ((flip setFilename) fp) reader "readImage: error reading image" genericReadOp :: (ImageNotLoaded -> IO ()) -> (Ptr HImageInfo -> Ptr ExceptionInfo -> IO (Ptr HImage_)) -> String -> IO HImage genericReadOp prepareImageInfo theAction errStr = do infoPtr <- mkNewExceptionInfo image_info <- mkNewImageInfo let theImage = mkUnloadedImage image_info infoPtr prepareImageInfo theImage iPtr <- withForeignPtr image_info $ \ii_ptr -> withForeignPtr infoPtr $ \exc_ptr -> withExceptions (theAction ii_ptr exc_ptr) errStr (== nullPtr) infoPtr return $ mkImage iPtr theImage ---------------------------------------------- ----------------------------------------------- ------------------ initializeMagick -------------- -- Initializes state in the Magick library, but I'm not sure where/when it needs to be called. -- initialize_magick takes an argv pointer, but just passing null seems to work initializeMagick = initialize_magick nullPtr -------------------------------------------------------------- ------------------- Transformations ------------------- -------------------------------------------------------------- ----------------- Simple transformations -- vertical flip. flipImage = doTransform flip_image -- horizontal flip (flop). flopImage = doTransform flop_image -- double size magnifyImage = doTransform magnify_image -- halve size minifyImage = doTransform minify_image -------------------------------------------- -- rotates an image by an arbitrary number of degrees rotateImage degrees hImage = doTransformIO (applyImageFn1' hImage rotate_image (realToFrac degrees)) hImage affineTransform affineMatrix hImage = unsafePerformIO $ do (matrixPtr::ForeignPtr AffineMatrix) <- mallocForeignPtr withForeignPtr matrixPtr $ (\ matrixP -> do poke matrixP affineMatrix return $ doTransformIO (applyImageFn1' hImage affine_transform matrixP) hImage) -- cuts the specified rectangle out of the image, -- and squishes the remaining part to fill it chopImage = rectOp chop_image -- returns an image consisting of the specified -- rectangle from the original image cropImage = rectOp crop_image -- returns an image consisting of the original image with the specified -- rectangle shaved from it shaveImage = rectOp shave_image rectOp :: ((Ptr HImage_) -> Ptr Rectangle -> Ptr ExceptionInfo -> IO (Ptr HImage_)) -> Rectangle -> HImage -> HImage rectOp fun rect im = unsafePerformIO $ withRectangle rect fun im -- takes a list of images and returns a single image consisting of all of them -- overlaid over each other -- TODO: require a nonempty list flattenImage [] = unsafePerformIO $ signalException "flattenImage: list cannot be empty" -- TODO: it's somewhat sketchy to do the side-effecting we do here -- (mutating the next fields of the images). rethink that flattenImage images@(img:_) = unsafePerformIO $ do debug 3 $ "Linking images..." linkImagesTogether images let res = doTransform flatten_images img debug 3 $ res `seq` "FlattenImage: done!" return res mosaic [] = unsafePerformIO $ signalException $ "mosaic: list cannot be empty" mosaic imagesAndRects@((img,_):_) = unsafePerformIO $ do let images = fst $ unzip imagesAndRects linkImagesTogether images mapM_ (uncurry setPage) imagesAndRects return $ doTransform mosaic_images img rollImage xOffset yOffset hImage = doTransformIO_XY roll_image hImage xOffset yOffset scaleImage xFactor yFactor hImage = doTransformIO_XY scale_image hImage xFactor yFactor sampleImage xFactor yFactor hImage = doTransformIO_XY sample_image hImage xFactor yFactor thumbnailImage xFactor yFactor hImage = doTransformIO_XY thumbnail_image hImage xFactor yFactor shearImage xFactor yFactor hImage = doTransformIO_XY_real shear_image hImage xFactor yFactor -- the stupid argument names are due to these names being already taken -- as record fields. resizeImage cols rws fltr blr hImage = doTransformIO (applyImageFn' hImage resize_image $ \f -> f (fromIntegral cols) (fromIntegral rws) (toCEnum fltr) (realToFrac blr)) hImage ------------ enhancements -- TODO: the contrastImage call only increases or decreases by a -- given increment. perhaps want to change our API to specify -- an amount of contrast contrastImage increaseOrDecrease hImage = sideEffectingOp (\ im -> applyImageFn1 im contrast_image sharpen) hImage where sharpen = case increaseOrDecrease of IncreaseContrast -> 1 DecreaseContrast -> 0 equalizeImage = simpleOp equalize_image normalizeImage = simpleOp normalize_image gammaImage (PixelPacket { red=gRed, green=gGreen, blue=gBlue }) hImage = sideEffectingOp (\ im -> applyImageFn im gamma_image $ withCString levelStr) hImage where levelStr = commaSep [gRed, gGreen, gBlue] levelImage (Level { black=lBlack, mid=lMid, white=lWhite }) hImage = sideEffectingOp (\ im -> applyImageFn im level_image $ withCString levelStr) hImage where levelStr = commaSep [lBlack, lMid, lWhite] levelImageChannel chanTy (Level { black=lBlack, mid=lMid, white=lWhite }) hImage = sideEffectingOp (\ im -> applyImageFn im level_image_channel $ \ f -> f (toCEnum chanTy) (realToFrac lBlack) (realToFrac lMid) (realToFrac lWhite)) hImage modulateImage (Modulation{ brightness=b, saturation=s, hue=h }) hImage = sideEffectingOp (\ im -> applyImageFn im modulate_image $ withCString modStr) hImage where modStr = commaSep [b, s, h] negateImage whatToNegate hImage = (sideEffectingOp (\ im -> applyImageFn1 im negate_image whatToDo) hImage) where whatToDo = case whatToNegate of AllPixels -> 0 GrayscalePixels -> 1 ------------- Constitution -- TODO: we should require pixels to be a non-empty list -- This constructs an image from a list of scanlines. -- A scanline is a list of pixels. -- A pixel is anything that can be stored as one of the C types -- that can be a pixel. -- All of the scanlines should have the same length, but I don't -- know how to enforce that. -- TODO: a pixel is really a triple (R,G,B) or a quadruple (C,M,Y,K) or... -- depending on the color space. as is, each scanline is just a flat list -- now. but we could do it in a more strongly typed way. constituteImage pixMap pixels = unsafePerformIO $ do eInfo <- mkNewExceptionInfo debug 3 $ "width = " ++ show wdth ++ " height = " ++ show hght ++ " sz = " ++ (show (pixelSize pixMap) ++ " len = " ++ show (length aScanline)) iPtr <- withExceptions (withArray (map marshalPixel (concat pixels)) (\ pixelArray -> withCString (show pixMap) $ (\ mapStr -> withForeignPtr eInfo $ constitute_image wdth -- this is kind of weak... the pixmap -- says how many numbers represent each pixel. seems bad. -- we should have a better type system for this. hght mapStr (toCEnum (storageType (head aScanline))) pixelArray))) "constituteImage: error" (== nullPtr) eInfo iInfo <- mkNewImageInfo return $ mkImage iPtr (mkUnloadedImage iInfo eInfo) -- TODO: freeing pixelArray and other memory? where aScanline = head pixels wdth = (fromIntegral $ (length aScanline) `div` (pixelSize pixMap)) hght = fromIntegral $ length pixels -- TODO: could we add a field in HImage for the pixMap and avoid the need to pass that? -- TODO: a fun QuickCheck property to add would be: -- forall pm blobs i . blobs == dispatchImage (pm all (constituteImage pm blobs i)) -- where all is a rectangle representing the entire image dispatchImage pixMap storType (Rectangle{ width=cols, height=rws, x=x_offset, y=y_offset}) hImage = unsafePerformIO $ (allocaArray len (\ pixelArray -> withCString (show pixMap) $ (\ mapStr -> do withExceptions_ (applyImageFn' hImage dispatch_image $ \f -> f (fromIntegral x_offset) (fromIntegral y_offset) (fromIntegral cols) (fromIntegral rws) mapStr (toCEnum storType) pixelArray) "dispatchImage: error" (== 0) (getExceptionInfo hImage) pixelList <- peekArray (fromIntegral len) pixelArray let blobs = map unmarshalPixel pixelList return $ groups cols blobs))) where len = (fromIntegral cols*fromIntegral rws*pixelSize pixMap) {- TODO: Seems to have disappeared from library -- note: the exportInfo structure that export_image_pixel_area initializes -- only contains the number of bytes exported, which we use to determine -- the length of the list exportPixelImageArea returns -- so we don't need -- to return it as well. -- TODO: quantumSize shouldn't be necessary -- TODO: have a test that uses a non-null options structure, -- and use exportPixelAreaOptionsInit exportPixelImageArea quantumType quantumSize options hImage = unsafePerformIO $ (allocaArray (fromIntegral (quantumSize * imagePixels)) (\ pixelArray -> (alloca (\ exportInfo -> (alloca (\ optionsPtr -> do optsPtr <- maybeToPtr options optionsPtr withExceptions_ (export_image_pixel_area (getImage hImage) (toCEnum quantumType) (fromIntegral quantumSize) pixelArray optsPtr exportInfo) "exportPixelImageArea: error exporting" (== 0) (getExceptionInfo hImage) bytes_exported <- (#peek ExportPixelAreaInfo, bytes_exported) exportInfo pixelList <- peekArray bytes_exported pixelArray let blobs = map unmarshalPixel pixelList return $ groups cols blobs)))))) where rws = hImageRows hImage cols = hImageColumns hImage imagePixels = rws*cols -} -- this may very well be wrong importPixelImageArea quantumType quantumSize pixels options hImage = sideEffectingOp (\ theImage -> (withArray (map (fromIntegral.ord) (unlines (map (map (chr.fromIntegral)) pixels))) (\ pixelArray -> (alloca (\ importInfo -> (alloca (\ optionsPtr -> do optsPtr <- maybeToPtr options optionsPtr -- this side-effects the image, so we need to make a copy res <- (applyImageFn theImage import_image_pixel_area $ \f -> f (toCEnum quantumType) (fromIntegral quantumSize) pixelArray optsPtr importInfo) bytes_imported <- (#peek ImportPixelAreaInfo, bytes_imported) importInfo assertM (bytes_imported == length pixels) ("importPixelImageArea: internal error, not all pixels were imported: only " ++ show bytes_imported ++ " bytes were imported") return res))))))) hImage readInlineImage base64content = unsafePerformIO $ do debug 47 $ "cleanedUpString = " ++ cleanedUpString genericReadOp (const (return ())) (\ image_info exception_info -> (withCString cleanedUpString (\ content_str -> read_inline_image image_info content_str exception_info))) "readInlineImage: error reading inline content" where cleanedUpString = insertComma (deleteNewlines (deleteEqualsSignLine base64content)) -- this ensures we can read data from uuencode -m without -- munging it somewhere else. I'm not sure whether the final -- version of the library should do this. deleteEqualsSignLine s | last (lines s) == "====" = unlines (butLast (lines s)) deleteEqualsSignLine s = s deleteNewlines = filter (/= '\n') insertComma s | ',' `elem` s = s insertComma s | null (", " `intersect` (nub s)) = (',':s) insertComma s = case (lines s) of (firstLine:secondLine:restLines) -> unlines (firstLine:((',':secondLine):restLines)) _ -> s blobToImage :: BS.ByteString -> HImage blobToImage bs = unsafePerformIO $ do genericReadOp (const (return ())) (\image_info exception_info -> BS.unsafeUseAsCStringLen bs (\(ptr, len) -> blob_to_image image_info (castPtr ptr) (fromIntegral len) exception_info)) "blobToImage: error loading image from blob" imageToBlob :: HImage -> BS.ByteString imageToBlob img = unsafePerformIO $ withTmpImageInfo $ \imgInfo -> alloca $ \sizePtr -> do excInfo <- mkNewExceptionInfo dat <- withExceptions (applyImageFn1' img (image_to_blob imgInfo) sizePtr) "imageToBlob: unable to encode image" (==nullPtr) excInfo len <- fromIntegral `fmap` peek sizePtr BS.unsafePackCStringFinalizer (castPtr dat) len (free dat) --------- helpers (private) ------------ simpleOp :: (Ptr HImage_ -> IO CUInt) -> HImage -> HImage simpleOp op im = sideEffectingOp (\hImage -> withForeignPtr (getImage hImage) $ \ii_ptr -> op ii_ptr) im withRectangle :: Rectangle -> (Ptr HImage_ -> Ptr Rectangle -> Ptr ExceptionInfo -> IO (Ptr HImage_)) -> HImage -> IO HImage withRectangle rect transform hImage = do -- Does this actually free the memory? -- Steffen: Yes, this will free the memory (rectPtr::ForeignPtr Rectangle) <- mallocForeignPtr -- This was causing a segfault so it\'s temporarily commented out. -- TODO: Worry about memory freeing. -- Steffen: this is not needed, mallocForeignPtr already installs a -- correct finalizer --addForeignPtrFinalizer p_free rectPtr withForeignPtr rectPtr $ (\ rectP -> do poke rectP rect return $ doTransformIO (applyImageFn1' hImage transform rectP) hImage) hsmagick-0.5/Graphics/Transform/Magick/Types.hs0000644000000000000000000002702711537226472017721 0ustar0000000000000000{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-} module Graphics.Transform.Magick.Types where import Foreign import Foreign.C.Types import Foreign.C.String -- types used for representing data from GraphicsMagick -- Types for external use. These are part of the Haskell -- GraphicsMagick interface. -- The idea here is that when we first create an image we -- have an exception info and an image info. -- Later after it's loaded, we have an image as well. -- getFilename and setFilename are class methods that work on -- either one, because if we have an image that's not loaded -- yet, we want to be able to set the filename (for loading it later), -- and if we have an image that *is* loaded, we want to be able to set -- the filename in both the image *and* the info. -- TODO: don't export the selectors for this. data HImage = HImage {image::ForeignPtr HImage_, otherInfo::ImageNotLoaded} data ImageNotLoaded = ImageNotLoaded { imageInfo::ForeignPtr HImageInfo, exceptionInfo::ForeignPtr ExceptionInfo } -- A rectangle is represented as a width, height, horizontal offset, and -- vertical offset data Rectangle = Rectangle { width :: Word, height :: Word, x :: Int, y :: Int } deriving Show data AffineMatrix = AffineMatrix { sx::Double, rx::Double, ry::Double, sy::Double, tx::Double, ty::Double } data PixelPacket a = PixelPacket { red::a, green::a, blue::a, opacity::a} data Level = Level { black::Double, mid::Double, white::Double } data Modulation = Modulation { brightness::Double, saturation::Double, hue::Double } data Negation = AllPixels | GrayscalePixels -- TODO: quantum depth (number of bits in a pixel) -- is determined at GraphicsMagick compile time. need -- to reflect that (I guess in a config file for this -- library...) type PixelPacketByte = PixelPacket Word8 data ChannelType = UndefinedChannel| RedChannel| CyanChannel| GreenChannel| MagentaChannel| BlueChannel| YellowChannel| OpacityChannel| BlackChannel| MatteChannel deriving Enum getImage :: HImage -> ForeignPtr HImage_ getImageInfo :: HImage -> ForeignPtr HImageInfo getExceptionInfo :: HImage -> ForeignPtr ExceptionInfo getImage = image getImageInfo = imageInfo.otherInfo getExceptionInfo = exceptionInfo.otherInfo mkUnloadedImage :: ForeignPtr HImageInfo -> ForeignPtr ExceptionInfo -> ImageNotLoaded mkUnloadedImage iInfo exInfo = ImageNotLoaded{ imageInfo = iInfo, exceptionInfo = exInfo } data FilterTypes = UndefinedFilter | PointFilter | BoxFilter | TriangleFilter | HermiteFilter | HanningFilter | HammingFilter | BlackmanFilter | GaussianFilter | QuadraticFilter | CubicFilter | CatromFilter | MitchellFilter | LacrosFilter | BesselFilter | SincFilter deriving Enum data CompositeOp = Undefined | Over | In | Out | Atop | Xor | Plus | Minus | Add | Subtract | Difference | Multiply | Bumpmap | Copy | CopyRed | CopyGreen | CopyBlue | CopyOpacity | Clear | Dissolve | Displace | Modulate | Threshold | No | Darken | Lighten | Hue | Saturate | Colorize | Luminize | Screen | Overlay | CopyCyan | CopyMagenta | CopyYellow | CopyBlack deriving Enum data Contrast = IncreaseContrast | DecreaseContrast data ImageCharacteristics = ImageC { cmyk::Bool, grayscale::Bool, mONOCHROME::Bool, opaque::Bool, palette::Bool } -- TODO: -- the Right Thing to do would be -- to use type classes rather than all these underscores data ImageStatistics = ImageS { red_::ImageChannelStatistics, green_::ImageChannelStatistics, blue_::ImageChannelStatistics, opacity_::ImageChannelStatistics } data ImageChannelStatistics = ImageCS { maximum::Double, minimum::Double, mean::Double, standard_deviation::Double, variance::Double } data SegmentInfo = SegmentInfo { x1::Double, y1::Double, x2::Double, y2::Double } data ImageOrder = LeftToRight | TopToBottom deriving Enum ----------- Storage (used by constituteImage) data StorageType = CharPixel | ShortPixel | IntegerPixel | LongPixel | FloatPixel | DoublePixel deriving Enum -- OMG functional dependencies squee!! class Storable b => StorablePixel a b | a -> b where storageType :: a -> StorageType marshalPixel :: a -> b unmarshalPixel :: b -> a instance StorablePixel Word8 CUChar where storageType _ = CharPixel marshalPixel = fromIntegral unmarshalPixel = fromIntegral instance StorablePixel Word16 CUShort where storageType _ = ShortPixel marshalPixel = fromIntegral unmarshalPixel = fromIntegral instance StorablePixel Word32 CUInt where storageType _ = IntegerPixel marshalPixel = fromIntegral unmarshalPixel = fromIntegral instance StorablePixel Word64 CULong where storageType _ = LongPixel marshalPixel = fromIntegral unmarshalPixel = fromIntegral instance StorablePixel Float CFloat where storageType _ = FloatPixel marshalPixel = realToFrac unmarshalPixel = realToFrac instance StorablePixel Double CDouble where storageType _ = DoublePixel marshalPixel = realToFrac unmarshalPixel = realToFrac -- TODO: -- should have better constraints. ex. no repeated -- quantums, list can't be empty. I don't think all -- combinations are legal. newtype PixMap = PixMap [QuantumType] instance Show PixMap where show (PixMap things) = concatMap show things pixelSize :: PixMap -> Int pixelSize (PixMap quantums) = length quantums data QuantumType = R|G|B|A|O|T|C|Y|M|K|I|P deriving Show -- TODO: better name data QuantumType2 = UndefinedQuantum | IndexQuantum | GrayQuantum | IndexAlphaQuantum | GrayAlphaQuantum | RedQuantum | CyanQuantum | GreenQuantum | YellowQuantum | BlueQuantum | MagentaQuantum | AlphaQuantum | BlackQuantum | RGBQuantum | RGBAQuantum | CMYKQuantum | CMYKAQuantum | CIEYQuantum | CIEXYZQuantum deriving Enum -- All types below should only be used internally to the library. -- we append underscores to names for fields that appear -- in multiple different record types, but there's ugly. -- must be a better way (type classes?) data ExceptionInfo = ExceptionInfo { severity :: ExceptionType, reason :: CString, description :: CString, error_number :: CInt, mODULE :: CString, function :: CString, line :: CULong, signature__ :: CULong } ------ TODO: stubs type ExportPixelAreaOptions = Word32 type ExportPixelAreaInfo = Word32 type ImportPixelAreaOptions = Word32 type ImportPixelAreaInfo = Word32 ------------- type ImagePtr = Ptr Image type Image = Word32 data CharArray = CharArray type CompressionType = Word32 type InterlaceType = Word32 type EndianType = Word32 type ResolutionType = Word32 type ColorspaceType = Word32 type ImageType = Word32 type StreamHandler = Word32 type PreviewType = Word32 type ClassType = Word32 type ChromaticityInfo = Word32 type OrientationType = Word32 type RenderingIntent = Word32 type GravityType = Word32 type DisposeType = Word32 type ErrorInfo = Word32 type TimerInfo = Word32 type CacheInfoPtr = Word32 type ImageAttributePtr = Word32 type Ascii85InfoPtr = Word32 type BlobInfoPtr = Word32 type SemaphoreInfoPtr = Word32 type ExceptionType = CUInt -- actually an enum type -- Correspondences: {- HImage_ <=> Image HImageInfo <=> ImageInfo -} -- This is from magick/image.h in GraphicsMagick 1.2. It may be subject to change! -- default values? -- some of these need fixing. ex., verbose should be -- a boolean, but the Storable instance should convert it appropriately. data HImageInfo = HImageInfo { compression :: CompressionType, temporary :: CUInt, adjoin :: CUInt, antialias :: CUInt, subimage :: CULong, subrange :: CULong, depth :: CULong, size :: CString, tile :: CString, page :: CString, interlace :: InterlaceType, endian :: EndianType, units :: ResolutionType, quality :: CULong, sampling_factor :: CString, server_name :: CString, font :: CString, texture :: CString, density :: CString, pointsize :: CDouble, fuzz :: CDouble, pen :: PixelPacketByte, background_color :: PixelPacketByte, border_color :: PixelPacketByte, matte_color :: PixelPacketByte, dither :: CUInt, monochrome :: CUInt, progress :: CUInt, colorspace :: ColorspaceType, tYPE :: ImageType, group :: CLong, verbose :: CUInt, view :: CString, authenticate :: CString, client_data :: CString, file :: Ptr CFile, -- these two are actually represented as arrays magick :: String, filename :: String, -- private from here on out cache :: CString, definitions :: CString, attributes :: Ptr Image, ping :: CUInt, preview_type :: PreviewType, affirm :: CUInt, blob :: CString, lENGTH :: CSize, unique :: CString, zero :: CString, signature :: CULong } -- Could we eliminate the duplicated fields and add code to copy them -- back and forth between the Image and the ImageInfo to the Storable -- instances? data HImage_ = HImage_ { storage_class :: ClassType, colorspace_ :: ColorspaceType, compression_ :: CompressionType, dither_ :: CUInt, matte :: CUInt, columns :: CULong, rows :: CULong, colors :: CUInt, depth_ :: CUInt, colormap :: CIntPtr, background_color_ :: PixelPacketByte, border_color_ :: PixelPacketByte, matte_color_ :: PixelPacketByte, gamma :: CDouble, chromaticity :: ChromaticityInfo, orientation :: OrientationType, rendering_intent :: RenderingIntent, units_ :: ResolutionType, montage :: CString, directory :: CString, geometry :: CString, offset :: CLong, x_resolution :: CDouble, y_resolution :: CDouble, page_ :: Rectangle, tile_info :: Rectangle, blur :: CDouble, fuzz_ :: CDouble, fILTER :: FilterTypes, interlace_ :: InterlaceType, endian_ :: EndianType, gravity :: GravityType, compose :: CompositeOp, dispose :: DisposeType, scene :: CULong, delay :: CULong, iterations :: CULong, total_colors :: CULong, start_loop :: CLong, eRROR :: ErrorInfo, timer :: TimerInfo, client_data_ :: CIntPtr, filename_ :: String, magick_filename :: String, magick_ :: String, magick_rows :: CULong, exception :: ExceptionInfo, previous :: CIntPtr, next :: CIntPtr, -- private from here on profiles :: CIntPtr, is_monochrome :: CUInt, is_grayscale :: CUInt, taint :: CUInt, clip_mask :: CIntPtr, cache_ :: CacheInfoPtr, attributes_ :: ImageAttributePtr, ascii85 :: Ascii85InfoPtr, blob_ :: BlobInfoPtr, reference_count :: CLong, semaphore :: SemaphoreInfoPtr, logging :: CUInt, list :: CIntPtr, signature_ :: CULong }