module Graphics.ImageMagick.MagickWand.MagickWand
( withMagickWandGenesis
, localGenesis
, magickWand
, wandResource
, cloneMagickWand
, getSize
, setSize
, setImageArtifact
, deleteImageArtifact
, getIteratorIndex
, setIteratorIndex
, resetIterator
, magickIterate
, magickIterateReverse
, deleteOption
, getOption
, setOption
, getOptions
, deleteImageProperty
, getImageProperty
, setImageProperty
, getImageProperties
, getImageProfile
, removeImageProfile
, setImageProfile
, getImageProfiles
, getColorspace
, getCompression
, getCompressionQuality
, getImageArtifacts
, getImageResolution
, setColorspace
, setCompression
, setCompressionQuality
, setImageResolution
) where
import Control.Applicative ((<$>))
import Control.Exception
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans.Resource
import Data.ByteString
import Data.Text (Text)
import Data.Text.Encoding (decodeUtf8,
encodeUtf8)
import Data.Vector.Storable (Vector)
import qualified Data.Vector.Storable as V
import Foreign hiding
(void)
import Foreign.C.String
import Foreign.C.Types
import qualified Graphics.ImageMagick.MagickWand.FFI.MagickWand as F
import Graphics.ImageMagick.MagickWand.FFI.Types
import qualified Graphics.ImageMagick.MagickWand.FFI.WandProperties as F
import Graphics.ImageMagick.MagickWand.Types
import Graphics.ImageMagick.MagickWand.Utils
withMagickWandGenesis :: ResourceT IO c -> IO c
withMagickWandGenesis f = bracket start finish (\_ -> runResourceT f)
where
start = liftIO F.magickWandGenesis
finish = liftIO . const F.magickWandTerminus
localGenesis :: MonadBaseControl IO m => ResourceT m a -> m a
localGenesis f = runResourceT f
magickWand :: (MonadResource m) => m (ReleaseKey, Ptr MagickWand)
magickWand = wandResource F.newMagickWand
magickIterateF :: (MonadResource m) =>
(PMagickWand -> IO ())
-> (PMagickWand -> IO MagickBooleanType)
-> PMagickWand -> (PMagickWand -> m ()) -> m ()
magickIterateF initF next w f = liftIO (initF w) >> go
where
go = do
i <- liftIO $ next w
when (i==mTrue) $ f w >> go
magickIterate :: (MonadResource m) => Ptr MagickWand -> (Ptr MagickWand -> m ()) -> m ()
magickIterate = magickIterateF F.magickResetIterator F.magickNextImage
magickIterateReverse :: (MonadResource m) => Ptr MagickWand -> (Ptr MagickWand -> m ()) -> m ()
magickIterateReverse = magickIterateF F.magickSetLastIterator F.magickPreviousImage
wandResource :: (MonadResource m) => (IO (Ptr MagickWand)) -> m (ReleaseKey, Ptr MagickWand)
wandResource f = allocate f destroy
where destroy = void . F.destroyMagickWand
cloneMagickWand :: (MonadResource m) => Ptr MagickWand -> m (ReleaseKey, Ptr MagickWand)
cloneMagickWand = wandResource . F.cloneMagickWand
setSize :: (MonadResource m) => Ptr MagickWand -> Int -> Int -> m ()
setSize w cols rows = withException_ w $ F.magickSetSize w (fromIntegral cols) (fromIntegral rows)
getSize :: (MonadResource m) => Ptr MagickWand -> m (Int, Int)
getSize w = liftIO $ alloca $ \pw -> do
height <- alloca $ \ph -> F.magickGetSize w pw ph >> peek ph >>= return
width <- peek pw
return (fromIntegral width, fromIntegral height)
setImageArtifact :: (MonadResource m) => PMagickWand -> ByteString -> ByteString -> m ()
setImageArtifact w a v = withException_ w $ useAsCString a
$ \a' -> useAsCString v
$ F.magickSetImageArtifact w a'
deleteImageArtifact :: (MonadResource m) => PMagickWand -> ByteString -> m ()
deleteImageArtifact w a = withException_ w $ useAsCString a
$ F.magickDeleteImageArtifact w
setIteratorIndex :: (MonadResource m) => Ptr MagickWand -> Int -> m ()
setIteratorIndex w i = withException_ w $ F.magickSetIteratorIndex w (fromIntegral i)
getIteratorIndex :: (MonadResource m) => Ptr MagickWand -> m Int
getIteratorIndex w = liftIO $ fromIntegral <$> F.magickGetIteratorIndex w
resetIterator :: (MonadResource m) => Ptr MagickWand -> m ()
resetIterator = liftIO . F.magickResetIterator
getOption :: (MonadResource m) => Ptr MagickWand -> Text -> m Text
getOption w key = liftIO $ do
cstr <- useAsCString (encodeUtf8 key) (F.magickGetOption w)
value <- decodeUtf8 <$> packCString cstr
F.magickRelinquishMemory (castPtr cstr)
return value
deleteOption :: (MonadResource m) => Ptr MagickWand -> Text -> m ()
deleteOption w key =
withException_ w $ useAsCString (encodeUtf8 key) (F.magickDeleteOption w)
setOption :: (MonadResource m) => Ptr MagickWand -> Text -> Text -> m ()
setOption w key value =
withException_ w $ useAsCString (encodeUtf8 key) $
\cstr -> useAsCString (encodeUtf8 value) (F.magickSetOption w cstr)
getOptions :: (MonadResource m) => Ptr MagickWand -> Text -> m [Text]
getOptions w pattern = liftIO $ alloca $ \pn -> do
poptionps <- useAsCString (encodeUtf8 pattern) (\cstr -> F.magickGetOptions w cstr pn)
n <- fromIntegral <$> peek pn
optionps <- peekArray n poptionps
options <- forM optionps $ \optionp -> do
option <- decodeUtf8 <$> packCString optionp
F.magickRelinquishMemory (castPtr optionp)
return option
F.magickRelinquishMemory (castPtr poptionps)
return options
deleteImageProperty :: (MonadResource m) => Ptr MagickWand -> Text -> m ()
deleteImageProperty w prop =
withException_ w $ useAsCString (encodeUtf8 prop) (F.magickDeleteImageProperty w)
getImageProperty :: (MonadResource m) => Ptr MagickWand -> Text -> m Text
getImageProperty w prop = liftIO $ do
cstr <- useAsCString (encodeUtf8 prop) (F.magickGetImageProperty w)
value <- decodeUtf8 <$> packCString cstr
F.magickRelinquishMemory (castPtr cstr)
return value
setImageProperty :: (MonadResource m) => Ptr MagickWand -> Text -> Text -> m ()
setImageProperty w prop value =
withException_ w $ useAsCString (encodeUtf8 prop) $
\cstr -> useAsCString (encodeUtf8 value) (F.magickSetImageProperty w cstr)
getImageProperties :: (MonadResource m) => Ptr MagickWand -> Text -> m [Text]
getImageProperties w pattern = liftIO $ alloca $ \pn -> do
ppropps <- useAsCString (encodeUtf8 pattern) (\cstr -> F.magickGetImageProperties w cstr pn)
n <- fromIntegral <$> peek pn
propps <- peekArray n ppropps
props <- forM propps $ \propp -> do
prop <- decodeUtf8 <$> packCString propp
F.magickRelinquishMemory (castPtr propp)
return prop
F.magickRelinquishMemory (castPtr ppropps)
return props
getProfile :: (MonadResource m) =>
(PMagickWand -> CString -> Ptr CSize -> IO (Ptr Word8)) ->
PMagickWand -> Text -> m (Vector Word8)
getProfile f w name = liftIO $ do
(pprofile, len) <- alloca $ \pn -> useAsCString (encodeUtf8 name) $ \cstr -> do
p <- f w cstr pn
n <- fromIntegral <$> peek pn
return (p,n)
profile <- V.generateM len (peekElemOff pprofile)
F.magickRelinquishMemory (castPtr pprofile)
return profile
getImageProfile :: (MonadResource m) => Ptr MagickWand -> Text -> m (Vector Word8)
getImageProfile = getProfile F.magickGetImageProfile
removeImageProfile :: (MonadResource m) => Ptr MagickWand -> Text -> m (Vector Word8)
removeImageProfile = getProfile F.magickRemoveImageProfile
setImageProfile :: (MonadResource m) => Ptr MagickWand -> Text -> Vector Word8 -> m ()
setImageProfile w name profile =
withException_ w $ useAsCString (encodeUtf8 name) $
\cstr -> V.unsafeWith profile $
\p -> (F.magickSetImageProfile w cstr) p (fromIntegral $ V.length profile)
getImageProfiles :: (MonadResource m) => Ptr MagickWand -> Text -> m [Text]
getImageProfiles w pattern = liftIO $ alloca $ \pn -> do
pprofileps <- useAsCString (encodeUtf8 pattern) (\cstr -> F.magickGetImageProfiles w cstr pn)
n <- fromIntegral <$> peek pn
profileps <- peekArray n pprofileps
profiles <- forM profileps $ \profilep -> do
profile <- decodeUtf8 <$> packCString profilep
F.magickRelinquishMemory (castPtr profilep)
return profile
F.magickRelinquishMemory (castPtr pprofileps)
return profiles
getColorspace :: (MonadResource m) => PMagickWand -> m ColorspaceType
getColorspace = liftIO . F.magickGetColorspace
setColorspace :: (MonadResource m) => PMagickWand -> ColorspaceType -> m ()
setColorspace w c = withException_ w $ F.magickSetColorspace w c
getCompression :: (MonadResource m) => PMagickWand -> m CompressionType
getCompression = liftIO . F.magickGetCompression
setCompression :: (MonadResource m) => PMagickWand -> CompressionType -> m ()
setCompression w c = withException_ w $ F.magickSetCompression w c
getCompressionQuality :: (MonadResource m) => PMagickWand -> m Int
getCompressionQuality w = liftIO $ F.magickGetCompressionQuality w >>= return . fromIntegral
setCompressionQuality :: (MonadResource m) => PMagickWand -> Int -> m ()
setCompressionQuality w c = withException_ w $ F.magickSetCompressionQuality w (fromIntegral c)
getImageResolution :: (MonadResource m) => PMagickWand -> m (Double,Double)
getImageResolution w = liftIO $ alloca $ \py -> do
x <- alloca $ \px -> withExceptionIO w $ do
result <- F.magickGetImageResolution w px py
value <- peek px
return (result, value)
y <- peek py
return (realToFrac x, realToFrac y)
setImageResolution :: (MonadResource m) => PMagickWand -> Double -> Double -> m ()
setImageResolution w x y = withException_ w $ F.magickSetImageResolution w (realToFrac x) (realToFrac y)
getImageArtifacts :: (MonadResource m) => Ptr MagickWand -> Text -> m [Text]
getImageArtifacts w pattern = liftIO $ alloca $ \pn -> do
partifactps <- useAsCString (encodeUtf8 pattern) (\cstr -> F.magickGetImageArtifacts w cstr pn)
n <- fromIntegral <$> peek pn
artifactps <- peekArray n partifactps
artifacts <- forM artifactps $ \artifactp -> do
artifact <- decodeUtf8 <$> packCString artifactp
F.magickRelinquishMemory (castPtr artifactp)
return artifact
F.magickRelinquishMemory (castPtr partifactps)
return artifacts