SVG.chs

{-# LANGUAGE CPP #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Graphics.Rendering.Cairo.SVG
-- Copyright   :  (c) 2005 Duncan Coutts, Paolo Martini 
-- License     :  BSD-style (see cairo/COPYRIGHT)
--
-- Maintainer  :  gtk2hs-devel@lists.sourceforge.net
-- Stability   :  experimental
-- Portability :  portable
--
-- The SVG extension to the Cairo 2D graphics library.
--
-----------------------------------------------------------------------------

module Graphics.Rendering.Cairo.SVG (
  -- * Convenience API

  -- | These operations render an SVG image directly in the current 'Render'
  -- contect. Because they operate in the cairo 'Render' monad they are
  -- affected by the current transformation matrix. So it is possible, for
  -- example, to scale or rotate an SVG image.
  --
  -- In the following example we scale an SVG image to a unit square:
  --
  -- > let (width, height) = svgGetSize in
  -- > do scale (1/width) (1/height)
  -- >    svgRender svg

  svgRenderFromFile,
  svgRenderFromHandle,
  svgRenderFromString,

  -- * Standard API

  -- | With this API there are seperate functions for loading the SVG and
  -- rendering it. This allows us to be more effecient in the case that an SVG
  -- image is used many times - since it can be loaded just once and rendered
  -- many times. With the convenience API above the SVG would be parsed and
  -- processed each time it is drawn.

  SVG,
  svgRender,
  svgGetSize,

  -- ** Block scoped versions

  -- | These versions of the SVG loading operations give temporary access
  -- to the 'SVG' object within the scope of the handler function. These
  -- operations guarantee that the resources for the SVG object are deallocated
  -- at the end of the handler block. If this form of resource allocation is
  -- too restrictive you can use the GC-managed versions below.
  --
  -- These versions are ofen used in the following style:
  --
  -- > withSvgFromFile "foo.svg" $ \svg -> do
  -- >   ...
  -- >   svgRender svg
  -- >   ...

  withSvgFromFile,
  withSvgFromHandle,
  withSvgFromString,

  -- ** GC-managed versions

  -- | These versions of the SVG loading operations use the standard Haskell
  -- garbage collector to manage the resources associated with the 'SVG' object.
  -- As such they are more convenient to use but the GC cannot give
  -- strong guarantees about when the resources associated with the 'SVG' object
  -- will be released. In most circumstances this is not a problem, especially
  -- if the SVG files being used are not very big.

  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)
-- Importing qualified to avoid double import with GHC < 7.8
import qualified System.IO.Unsafe as Unsafe

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))

{# context lib="librsvg" prefix="rsvg_handle" #}

---------------------
-- Types
-- 

{# pointer *RsvgHandle as SVG foreign newtype #}

mkSVG = (SVG, objectUnref)
unSVG (SVG obj) = obj

instance GObjectClass SVG where
  toGObject = GObject . castForeignPtr . unSVG
  unsafeCastGObject = SVG . castForeignPtr . unGObject

---------------------
-- Basic API
-- 

-- block scoped versions

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
             {# call g_type_init #}
             svgPtr <- {# call unsafe new #}
             svgPtr' <- newForeignPtr_ svgPtr
             return (SVG svgPtr'))             
          (\(SVG fptr) -> withForeignPtr fptr $ \ptr ->
                            {# call unsafe g_object_unref #} (castPtr ptr))

-- GC managed versions

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
  {# call g_type_init #}
  wrapNewGObject mkSVG {# call unsafe new #}


-- internal implementation

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 $ {# call unsafe rsvg_handle_write #}
                svg (castPtr bufferPtr) (fromIntegral count))
        when (count == 4096) loop
  loop
  checkStatus $ {# call unsafe rsvg_handle_close #} 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 $ {# call unsafe rsvg_handle_write #}
                svg (castPtr chunkPtr) (fromIntegral len)
            loop str'
  loop str
  checkStatus $ {# call unsafe rsvg_handle_close #} svg

-- actually render it

-- | render an SVG file
--
-- Returns @False@ if an error was detected.
-- On librsvg before 2.22.3, @svgRender@ always returns @True@.
svgRender :: SVG -> Render Bool
svgRender svg = do
  cr <- ask
  ret <- liftIO $ {# call unsafe render_cairo #} svg cr
#if ! LIBRSVG_CHECK_VERSION(2,22,3)
  return True
#else
  return (ret /= 0)
#endif

-- | Get the width and height of the SVG image.
--
svgGetSize :: 
    SVG
 -> (Int, Int) -- ^ @(width, height)@
svgGetSize svg = Unsafe.unsafePerformIO $
  allocaBytes {# sizeof RsvgDimensionData #} $ \dimentionsPtr -> do
  {# call unsafe get_dimensions #} svg dimentionsPtr
  width  <- {# get RsvgDimensionData->width  #} dimentionsPtr
  height <- {# get RsvgDimensionData->height #} dimentionsPtr
  return (fromIntegral width, fromIntegral height)

---------------------
-- Convenience API
-- 

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

---------------------
-- Utils
-- 

checkStatus :: (Ptr (Ptr ()) -> IO CInt) -> IO ()
checkStatus action =
  checkGError (\ptr -> action ptr >> return ())
    (\(GError domain code msg) -> fail ("svg cairo error: " ++ msg))