export Event constructor

export Event constructor

{-# LANGUAGE BangPatterns             #-}
{-# LANGUAGE CPP                      #-}
{-# LANGUAGE EmptyDataDecls           #-}
{-# LANGUAGE ForeignFunctionInterface #-}
--------------------------------------------------------------------------------
-- |
-- Module    : Foreign.CUDA.Driver.Event
-- Copyright : (c) [2009..2012] Trevor L. McDonell
-- License   : BSD
--
-- Event management for low-level driver interface
--
--------------------------------------------------------------------------------

module Foreign.CUDA.Driver.Event (

  -- * Event Management
  Event(..), EventFlag(..), WaitFlag,
  create, destroy, elapsedTime, query, record, wait, block

) where

#include "cbits/stubs.h"
{# context lib="cuda" #}

-- Friends
import Foreign.CUDA.Internal.C2HS
import Foreign.CUDA.Driver.Error
import Foreign.CUDA.Driver.Stream               (Stream(..))

-- System
import Foreign
import Foreign.C
import Control.Monad                            (liftM)

--------------------------------------------------------------------------------
-- Data Types
--------------------------------------------------------------------------------

-- |
-- Events
--
newtype Event = Event { useEvent :: {# type CUevent #}}
  deriving (Eq, Show)

-- |
-- Event creation flags
--
{# enum CUevent_flags as EventFlag
    { underscoreToCase }
    with prefix="CU_EVENT" deriving (Eq, Show) #}

-- |
-- Possible option flags for waiting for events
--
data WaitFlag
instance Enum WaitFlag where

--------------------------------------------------------------------------------
-- Event management
--------------------------------------------------------------------------------

-- |
-- Create a new event
--
{-# INLINEABLE create #-}
create :: [EventFlag] -> IO Event
create !flags = resultIfOk =<< cuEventCreate flags

{-# INLINE cuEventCreate #-}
{# fun unsafe cuEventCreate
  { alloca-         `Event'       peekEvt*
  , combineBitMasks `[EventFlag]'          } -> `Status' cToEnum #}
  where peekEvt = liftM Event . peek

-- |
-- Destroy an event
--
{-# INLINEABLE destroy #-}
destroy :: Event -> IO ()
destroy !ev = nothingIfOk =<< cuEventDestroy ev

{-# INLINE cuEventDestroy #-}
{# fun unsafe cuEventDestroy
  { useEvent `Event' } -> `Status' cToEnum #}

-- |
-- Determine the elapsed time (in milliseconds) between two events
--
{-# INLINEABLE elapsedTime #-}
elapsedTime :: Event -> Event -> IO Float
elapsedTime !ev1 !ev2 = resultIfOk =<< cuEventElapsedTime ev1 ev2

{-# INLINE cuEventElapsedTime #-}
{# fun unsafe cuEventElapsedTime
  { alloca-  `Float' peekFloatConv*
  , useEvent `Event'
  , useEvent `Event'                } -> `Status' cToEnum #}

-- |
-- Determines if a event has actually been recorded
--
{-# INLINEABLE query #-}
query :: Event -> IO Bool
query !ev =
  cuEventQuery ev >>= \rv ->
  case rv of
    Success  -> return True
    NotReady -> return False
    _        -> resultIfOk (rv,undefined)

{-# INLINE cuEventQuery #-}
{# fun unsafe cuEventQuery
  { useEvent `Event' } -> `Status' cToEnum #}

-- |
-- Record an event once all operations in the current context (or optionally
-- specified stream) have completed. This operation is asynchronous.
--
{-# INLINEABLE record #-}
record :: Event -> Maybe Stream -> IO ()
record !ev !mst =
  nothingIfOk =<< case mst of
    Just st -> cuEventRecord ev st
    Nothing -> cuEventRecord ev (Stream nullPtr)

{-# INLINE cuEventRecord #-}
{# fun unsafe cuEventRecord
  { useEvent  `Event'
  , useStream `Stream' } -> `Status' cToEnum #}

-- |
-- Makes all future work submitted to the (optional) stream wait until the given
-- event reports completion before beginning execution. Requires cuda-3.2.
--
{-# INLINEABLE wait #-}
wait :: Event -> Maybe Stream -> [WaitFlag] -> IO ()
#if CUDA_VERSION < 3020
wait _ _ _           = requireSDK 3.2 "wait"
#else
wait !ev !mst !flags =
  nothingIfOk =<< case mst of
    Just st -> cuStreamWaitEvent st ev flags
    Nothing -> cuStreamWaitEvent (Stream nullPtr) ev flags

{-# INLINE cuStreamWaitEvent #-}
{# fun unsafe cuStreamWaitEvent
  { useStream       `Stream'
  , useEvent        `Event'
  , combineBitMasks `[WaitFlag]' } -> `Status' cToEnum #}
#endif

-- |
-- Wait until the event has been recorded
--
{-# INLINEABLE block #-}
block :: Event -> IO ()
block !ev = nothingIfOk =<< cuEventSynchronize ev

{-# INLINE cuEventSynchronize #-}
{# fun unsafe cuEventSynchronize
  { useEvent `Event' } -> `Status' cToEnum #}

{-# LANGUAGE BangPatterns             #-}
{-# LANGUAGE CPP                      #-}
{-# LANGUAGE EmptyDataDecls           #-}
{-# LANGUAGE ForeignFunctionInterface #-}
--------------------------------------------------------------------------------
-- |
-- Module    : Foreign.CUDA.Driver.Event
-- Copyright : (c) [2009..2012] Trevor L. McDonell
-- License   : BSD
--
-- Event management for low-level driver interface
--
--------------------------------------------------------------------------------

module Foreign.CUDA.Driver.Event (

  -- * Event Management
  Event, EventFlag(..), WaitFlag,
  create, destroy, elapsedTime, query, record, wait, block

) where

#include "cbits/stubs.h"
{# context lib="cuda" #}

-- Friends
import Foreign.CUDA.Internal.C2HS
import Foreign.CUDA.Driver.Error
import Foreign.CUDA.Driver.Stream               (Stream(..))

-- System
import Foreign
import Foreign.C
import Control.Monad                            (liftM)

--------------------------------------------------------------------------------
-- Data Types
--------------------------------------------------------------------------------

-- |
-- Events
--
newtype Event = Event { useEvent :: {# type CUevent #}}
  deriving (Eq, Show)

-- |
-- Event creation flags
--
{# enum CUevent_flags as EventFlag
    { underscoreToCase }
    with prefix="CU_EVENT" deriving (Eq, Show) #}

-- |
-- Possible option flags for waiting for events
--
data WaitFlag
instance Enum WaitFlag where

--------------------------------------------------------------------------------
-- Event management
--------------------------------------------------------------------------------

-- |
-- Create a new event
--
{-# INLINEABLE create #-}
create :: [EventFlag] -> IO Event
create !flags = resultIfOk =<< cuEventCreate flags

{-# INLINE cuEventCreate #-}
{# fun unsafe cuEventCreate
  { alloca-         `Event'       peekEvt*
  , combineBitMasks `[EventFlag]'          } -> `Status' cToEnum #}
  where peekEvt = liftM Event . peek

-- |
-- Destroy an event
--
{-# INLINEABLE destroy #-}
destroy :: Event -> IO ()
destroy !ev = nothingIfOk =<< cuEventDestroy ev

{-# INLINE cuEventDestroy #-}
{# fun unsafe cuEventDestroy
  { useEvent `Event' } -> `Status' cToEnum #}

-- |
-- Determine the elapsed time (in milliseconds) between two events
--
{-# INLINEABLE elapsedTime #-}
elapsedTime :: Event -> Event -> IO Float
elapsedTime !ev1 !ev2 = resultIfOk =<< cuEventElapsedTime ev1 ev2

{-# INLINE cuEventElapsedTime #-}
{# fun unsafe cuEventElapsedTime
  { alloca-  `Float' peekFloatConv*
  , useEvent `Event'
  , useEvent `Event'                } -> `Status' cToEnum #}

-- |
-- Determines if a event has actually been recorded
--
{-# INLINEABLE query #-}
query :: Event -> IO Bool
query !ev =
  cuEventQuery ev >>= \rv ->
  case rv of
    Success  -> return True
    NotReady -> return False
    _        -> resultIfOk (rv,undefined)

{-# INLINE cuEventQuery #-}
{# fun unsafe cuEventQuery
  { useEvent `Event' } -> `Status' cToEnum #}

-- |
-- Record an event once all operations in the current context (or optionally
-- specified stream) have completed. This operation is asynchronous.
--
{-# INLINEABLE record #-}
record :: Event -> Maybe Stream -> IO ()
record !ev !mst =
  nothingIfOk =<< case mst of
    Just st -> cuEventRecord ev st
    Nothing -> cuEventRecord ev (Stream nullPtr)

{-# INLINE cuEventRecord #-}
{# fun unsafe cuEventRecord
  { useEvent  `Event'
  , useStream `Stream' } -> `Status' cToEnum #}

-- |
-- Makes all future work submitted to the (optional) stream wait until the given
-- event reports completion before beginning execution. Requires cuda-3.2.
--
{-# INLINEABLE wait #-}
wait :: Event -> Maybe Stream -> [WaitFlag] -> IO ()
#if CUDA_VERSION < 3020
wait _ _ _           = requireSDK 3.2 "wait"
#else
wait !ev !mst !flags =
  nothingIfOk =<< case mst of
    Just st -> cuStreamWaitEvent st ev flags
    Nothing -> cuStreamWaitEvent (Stream nullPtr) ev flags

{-# INLINE cuStreamWaitEvent #-}
{# fun unsafe cuStreamWaitEvent
  { useStream       `Stream'
  , useEvent        `Event'
  , combineBitMasks `[WaitFlag]' } -> `Status' cToEnum #}
#endif

-- |
-- Wait until the event has been recorded
--
{-# INLINEABLE block #-}
block :: Event -> IO ()
block !ev = nothingIfOk =<< cuEventSynchronize ev

{-# INLINE cuEventSynchronize #-}
{# fun unsafe cuEventSynchronize
  { useEvent `Event' } -> `Status' cToEnum #}


Add some functions in SourceCompletionProvider module

{-# LANGUAGE CPP #-}
-- -*-haskell-*-
--  GIMP Toolkit (GTK) Widget SourceCompletionProvider
--
--  Author : Andy Stewart
--
--  Created: 08 Aug 2010
--
--  Copyright (C) 2010 Andy Stewart
--
--  This library is free software; you can redistribute it and/or
--  modify it under the terms of the GNU Lesser General Public
--  License as published by the Free Software Foundation; either
--  version 2.1 of the License, or (at your option) any later version.
--
--  This library is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
--  Lesser General Public License for more details.
--
-- |
-- Maintainer  : gtk2hs-users@lists.sourceforge.net
-- Stability   : provisional
-- Portability : portable (depends on GHC)
--
module Graphics.UI.Gtk.SourceView.SourceCompletionProvider (
-- * Description
-- | You must implement this interface to provide proposals to 'SourceCompletion'

-- * Types
   SourceCompletionProvider,
   SourceCompletionProviderClass,

-- * Methods
   sourceCompletionProviderGetName,
   sourceCompletionProviderGetIcon,
   sourceCompletionProviderGetInteractiveDelay,
   sourceCompletionProviderGetPriority,
   sourceCompletionProviderGetInfoWidget,
   sourceCompletionProviderActivateProposal,
) where

import Control.Monad	(liftM)

import System.Glib.FFI
import System.Glib.UTFString
import System.Glib.GObject	(makeNewGObject)
import System.Glib.Attributes
import System.Glib.Properties
import Graphics.UI.Gtk.Abstract.Object	(makeNewObject)
{#import Graphics.UI.Gtk.SourceView.Signals#}
{#import Graphics.UI.Gtk.SourceView.Types#}

{# context lib="gtk" prefix="gtk" #}

-- | Get the name of the provider. This should be a translatable name for display to the user. For
-- example: _("Document word completion provider").
sourceCompletionProviderGetName :: SourceCompletionProviderClass scp => scp
                                -> IO String -- ^ returns  A new string containing the name of the provider.
sourceCompletionProviderGetName scp =
  {#call gtk_source_completion_provider_get_name #}
    (toSourceCompletionProvider scp)
  >>= peekUTFString

-- | Get the icon of the provider.
sourceCompletionProviderGetIcon :: SourceCompletionProviderClass scp => scp
                                -> IO (Maybe Pixbuf)
sourceCompletionProviderGetIcon scp =
  maybeNull (makeNewGObject mkPixbuf) $
  {#call gtk_source_completion_provider_get_icon #}
    (toSourceCompletionProvider scp)

-- | Get the delay in milliseconds before starting interactive completion for this provider. A value of
-- -1 indicates to use the default value as set by 'autoCompleteDelay'.
sourceCompletionProviderGetInteractiveDelay :: SourceCompletionProviderClass scp => scp
                                            -> IO Int -- ^ returns  the interactive delay in milliseconds.
sourceCompletionProviderGetInteractiveDelay scp =
  liftM fromIntegral $
  {#call gtk_source_completion_provider_get_interactive_delay #}
     (toSourceCompletionProvider scp)

-- | Get the provider priority. The priority determines the order in which proposals appear in the
-- completion popup. Higher priorities are sorted before lower priorities. The default priority is 0.
sourceCompletionProviderGetPriority :: SourceCompletionProviderClass scp => scp
                                    -> IO Int -- ^ returns  the provider priority.
sourceCompletionProviderGetPriority scp =
  liftM fromIntegral $
  {#call gtk_source_completion_provider_get_priority #}
    (toSourceCompletionProvider scp)

-- | Get a customized info widget to show extra information of a proposal. This allows for customized
-- widgets on a proposal basis, although in general providers will have the same custom widget for all
-- their proposals and proposal can be ignored.  The implementation of this function is optional. If
-- implemented, 'sourceCompletionProviderUpdateInfo' MUST also be implemented. If not
-- implemented, the default 'sourceCompletionProposalGetInfo' will be used to display extra
-- information about a 'SourceCompletionProposal'.
sourceCompletionProviderGetInfoWidget :: SourceCompletionProviderClass scp => scp
                                      -> SourceCompletionProposal -- ^ @proposal@ The currently selected 'SourceCompletionProposal'
                                     -> IO Widget -- ^ returns  a custom 'Widget' to show extra information about proposal.
sourceCompletionProviderGetInfoWidget scp proposal =
  makeNewObject mkWidget $
  {#call gtk_source_completion_provider_get_info_widget #}
    (toSourceCompletionProvider scp)
    proposal

-- | Activate proposal at iter. When this functions returns 'False', the default activation of proposal
-- will take place which replaces the word at iter with the label of proposal.
sourceCompletionProviderActivateProposal :: SourceCompletionProviderClass scp => scp
                                         -> SourceCompletionProposal
                                         -> TextIter
                                         -> IO Bool -- ^ returns  'True' to indicate that the proposal activation has been handled, 'False' otherwise.
sourceCompletionProviderActivateProposal scp proposal iter =
  liftM toBool $
  {#call gtk_source_completion_provider_activate_proposal #}
    (toSourceCompletionProvider scp)
    proposal
    iter

{-# LANGUAGE CPP #-}
-- -*-haskell-*-
--  GIMP Toolkit (GTK) Widget SourceCompletionProvider
--
--  Author : Andy Stewart
--
--  Created: 08 Aug 2010
--
--  Copyright (C) 2010 Andy Stewart
--
--  This library is free software; you can redistribute it and/or
--  modify it under the terms of the GNU Lesser General Public
--  License as published by the Free Software Foundation; either
--  version 2.1 of the License, or (at your option) any later version.
--
--  This library is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
--  Lesser General Public License for more details.
--
-- |
-- Maintainer  : gtk2hs-users@lists.sourceforge.net
-- Stability   : provisional
-- Portability : portable (depends on GHC)
--
module Graphics.UI.Gtk.SourceView.SourceCompletionProvider (
-- * Description
-- | You must implement this interface to provide proposals to 'SourceCompletion'

-- * Types
   SourceCompletionProvider,
   SourceCompletionProviderClass,

-- * Methods
   sourceCompletionProviderGetName,
   sourceCompletionProviderGetIcon,
   sourceCompletionProviderGetInteractiveDelay,
   sourceCompletionProviderGetPriority,
) where

import Control.Monad	(liftM)

import System.Glib.FFI
import System.Glib.UTFString
import System.Glib.GObject	(makeNewGObject)
import System.Glib.Attributes
import System.Glib.Properties
{#import Graphics.UI.Gtk.SourceView.Signals#}
{#import Graphics.UI.Gtk.SourceView.Types#}

{# context lib="gtk" prefix="gtk" #}

-- | Get the name of the provider. This should be a translatable name for display to the user. For
-- example: _("Document word completion provider").
sourceCompletionProviderGetName :: SourceCompletionProviderClass scp => scp
                                -> IO String -- ^ returns  A new string containing the name of the provider.
sourceCompletionProviderGetName scp =
  {#call gtk_source_completion_provider_get_name #}
    (toSourceCompletionProvider scp)
  >>= peekUTFString

-- | Get the icon of the provider.
sourceCompletionProviderGetIcon :: SourceCompletionProviderClass scp => scp
                                -> IO (Maybe Pixbuf)
sourceCompletionProviderGetIcon scp =
  maybeNull (makeNewGObject mkPixbuf) $
  {#call gtk_source_completion_provider_get_icon #}
    (toSourceCompletionProvider scp)

-- | Get the delay in milliseconds before starting interactive completion for this provider. A value of
-- -1 indicates to use the default value as set by 'autoCompleteDelay'.
sourceCompletionProviderGetInteractiveDelay :: SourceCompletionProviderClass scp => scp
                                            -> IO Int -- ^ returns  the interactive delay in milliseconds.
sourceCompletionProviderGetInteractiveDelay scp =
  liftM fromIntegral $
  {#call gtk_source_completion_provider_get_interactive_delay #}
     (toSourceCompletionProvider scp)

-- | Get the provider priority. The priority determines the order in which proposals appear in the
-- completion popup. Higher priorities are sorted before lower priorities. The default priority is 0.
sourceCompletionProviderGetPriority :: SourceCompletionProviderClass scp => scp
                                    -> IO Int -- ^ returns  the provider priority.
sourceCompletionProviderGetPriority scp =
  liftM fromIntegral $
  {#call gtk_source_completion_provider_get_priority #}
    (toSourceCompletionProvider scp)


SVG: provide implementation for GObjectClass

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

import System.Glib.GError (GError(GError), checkGError)
import System.Glib.GObject (GObjectClass(..), constructNewGObject, unGObject, mkGObject)

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
unSVG (SVG o) = o

instance GObjectClass SVG where
  toGObject = mkGObject . castForeignPtr . unSVG
  unsafeCastGObject = mkSVG . 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 #}
  constructNewGObject SVG {# 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

svgRender :: SVG -> Render ()
svgRender svg = do
  cr <- ask
  liftIO $ {# call unsafe render_cairo #} svg cr

-- | Get the width and height of the SVG image.
--
svgGetSize ::
    SVG
 -> (Int, Int) -- ^ @(width, height)@
svgGetSize svg = 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 ()
svgRenderFromFile file = withSvgFromFile file svgRender

svgRenderFromHandle :: Handle -> Render ()
svgRenderFromHandle hnd = withSvgFromHandle hnd svgRender

svgRenderFromString :: String -> Render ()
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))

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

import System.Glib.GError (GError(GError), checkGError)
import System.Glib.GObject (GObjectClass, constructNewGObject)

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 #}

instance GObjectClass SVG

---------------------
-- 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 #}
  constructNewGObject SVG {# 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

svgRender :: SVG -> Render ()
svgRender svg = do
  cr <- ask
  liftIO $ {# call unsafe render_cairo #} svg cr

-- | Get the width and height of the SVG image.
--
svgGetSize ::
    SVG
 -> (Int, Int) -- ^ @(width, height)@
svgGetSize svg = 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 ()
svgRenderFromFile file = withSvgFromFile file svgRender

svgRenderFromHandle :: Handle -> Render ()
svgRenderFromHandle hnd = withSvgFromHandle hnd svgRender

svgRenderFromString :: String -> Render ()
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))