module Graphics.Rendering.Cairo.SVG (
svgRenderFromFile,
svgRenderFromHandle,
svgRenderFromString,
SVG,
svgRender,
svgGetSize,
withSvgFromFile,
withSvgFromHandle,
withSvgFromString,
svgNewFromFile,
svgNewFromHandle,
svgNewFromString,
) where
import Control.Monad (when)
import Foreign
import Foreign.C
import Control.Monad.Reader (ask, liftIO)
import System.IO (Handle, openFile, IOMode(ReadMode), hGetBuf)
import System.Glib.GError (GError(GError), checkGError)
import System.Glib.GObject (GObject(..), GObjectClass(..), wrapNewGObject,
unGObject, objectUnref)
import Graphics.Rendering.Cairo.Internal (Render, bracketR)
import Graphics.Rendering.Cairo.Types (Cairo(Cairo))
newtype SVG = SVG (ForeignPtr (SVG))
mkSVG = (SVG, objectUnref)
unSVG (SVG obj) = obj
instance GObjectClass SVG where
toGObject = GObject . castForeignPtr . unSVG
unsafeCastGObject = SVG . castForeignPtr . unGObject
withSvgFromFile :: FilePath -> (SVG -> Render a) -> Render a
withSvgFromFile file action =
withSVG $ \svg -> do
liftIO $ svgParseFromFile file svg
action svg
withSvgFromHandle :: Handle -> (SVG -> Render a) -> Render a
withSvgFromHandle hnd action =
withSVG $ \svg -> do
liftIO $ svgParseFromHandle hnd svg
action svg
withSvgFromString :: String -> (SVG -> Render a) -> Render a
withSvgFromString str action =
withSVG $ \svg -> do
liftIO $ svgParseFromString str svg
action svg
withSVG :: (SVG -> Render a) -> Render a
withSVG =
bracketR (do
g_type_init
svgPtr <- rsvg_handle_new
svgPtr' <- newForeignPtr_ svgPtr
return (SVG svgPtr'))
(\(SVG fptr) -> withForeignPtr fptr $ \ptr ->
g_object_unref (castPtr ptr))
svgNewFromFile :: FilePath -> IO SVG
svgNewFromFile file = do
svg <- svgNew
svgParseFromFile file svg
return svg
svgNewFromHandle :: Handle -> IO SVG
svgNewFromHandle hnd = do
svg <- svgNew
svgParseFromHandle hnd svg
return svg
svgNewFromString :: String -> IO SVG
svgNewFromString str = do
svg <- svgNew
svgParseFromString str svg
return svg
svgNew :: IO SVG
svgNew = do
g_type_init
wrapNewGObject mkSVG rsvg_handle_new
svgParseFromFile :: FilePath -> SVG -> IO ()
svgParseFromFile file svg = do
hnd <- openFile file ReadMode
svgParseFromHandle hnd svg
svgParseFromHandle :: Handle -> SVG -> IO ()
svgParseFromHandle hnd svg =
allocaBytes 4096 $ \bufferPtr -> do
let loop = do
count <- hGetBuf hnd bufferPtr 4096
when (count > 0)
(checkStatus $ (\(SVG arg1) arg2 arg3 arg4 -> withForeignPtr arg1 $ \argPtr1 ->rsvg_handle_write argPtr1 arg2 arg3 arg4)
svg (castPtr bufferPtr) (fromIntegral count))
when (count == 4096) loop
loop
checkStatus $ (\(SVG arg1) arg2 -> withForeignPtr arg1 $ \argPtr1 ->rsvg_handle_close argPtr1 arg2) svg
svgParseFromString :: String -> SVG -> IO ()
svgParseFromString str svg = do
let loop "" = return ()
loop str =
case splitAt 4096 str of
(chunk, str') -> do
withCStringLen chunk $ \(chunkPtr, len) ->
checkStatus $ (\(SVG arg1) arg2 arg3 arg4 -> withForeignPtr arg1 $ \argPtr1 ->rsvg_handle_write argPtr1 arg2 arg3 arg4)
svg (castPtr chunkPtr) (fromIntegral len)
loop str'
loop str
checkStatus $ (\(SVG arg1) arg2 -> withForeignPtr arg1 $ \argPtr1 ->rsvg_handle_close argPtr1 arg2) svg
svgRender :: SVG -> Render Bool
svgRender svg = do
cr <- ask
ret <- liftIO $ (\(SVG arg1) (Cairo arg2) -> withForeignPtr arg1 $ \argPtr1 ->rsvg_handle_render_cairo argPtr1 arg2) svg cr
return (ret /= 0)
svgGetSize ::
SVG
-> (Int, Int)
svgGetSize svg = unsafePerformIO $
allocaBytes 24 $ \dimentionsPtr -> do
(\(SVG arg1) arg2 -> withForeignPtr arg1 $ \argPtr1 ->rsvg_handle_get_dimensions argPtr1 arg2) svg dimentionsPtr
width <- (\ptr -> do {peekByteOff ptr 0 ::IO CInt}) dimentionsPtr
height <- (\ptr -> do {peekByteOff ptr 4 ::IO CInt}) dimentionsPtr
return (fromIntegral width, fromIntegral height)
svgRenderFromFile :: FilePath -> Render Bool
svgRenderFromFile file = withSvgFromFile file svgRender
svgRenderFromHandle :: Handle -> Render Bool
svgRenderFromHandle hnd = withSvgFromHandle hnd svgRender
svgRenderFromString :: String -> Render Bool
svgRenderFromString str = withSvgFromString str svgRender
checkStatus :: (Ptr (Ptr ()) -> IO CInt) -> IO ()
checkStatus action =
checkGError (\ptr -> action ptr >> return ())
(\(GError domain code msg) -> fail ("svg cairo error: " ++ msg))
foreign import ccall safe "g_type_init"
g_type_init :: (IO ())
foreign import ccall unsafe "rsvg_handle_new"
rsvg_handle_new :: (IO (Ptr SVG))
foreign import ccall unsafe "g_object_unref"
g_object_unref :: ((Ptr ()) -> (IO ()))
foreign import ccall unsafe "rsvg_handle_write"
rsvg_handle_write :: ((Ptr SVG) -> ((Ptr CUChar) -> (CUInt -> ((Ptr (Ptr ())) -> (IO CInt)))))
foreign import ccall unsafe "rsvg_handle_close"
rsvg_handle_close :: ((Ptr SVG) -> ((Ptr (Ptr ())) -> (IO CInt)))
foreign import ccall unsafe "rsvg_handle_render_cairo"
rsvg_handle_render_cairo :: ((Ptr SVG) -> ((Ptr Cairo) -> (IO CInt)))
foreign import ccall unsafe "rsvg_handle_get_dimensions"
rsvg_handle_get_dimensions :: ((Ptr SVG) -> ((Ptr ()) -> (IO ())))