gtk2hs-commit

[Axel S. <si...@co...>]

Sun Nov  1 13:14:31 EST 2009  Axe...@en...
  * Remove the two broken functions that were meant to interface Pixbuf and Cairo surfaces. Add an array access function for image surfaces so that pixel values can be copied manually.

    hunk ./cairo/Graphics/Rendering/Cairo.hs.pp 1
    +{-# LANGUAGE ScopedTypeVariables #-}
    +{-# LANGUAGE MultiParamTypeClasses #-}
    +{-# LANGUAGE FlexibleInstances #-}
    hunk ./cairo/Graphics/Rendering/Cairo.hs.pp 173
    +#if CAIRO_CHECK_VERSION(1,6,0)
    +  , formatStrideForWidth
    +#endif
    hunk ./cairo/Graphics/Rendering/Cairo.hs.pp 180
    +  , imageSurfaceGetFormat
    hunk ./cairo/Graphics/Rendering/Cairo.hs.pp 185
    +  , SurfaceData
    +  , imageSurfaceGetPixels
    hunk ./cairo/Graphics/Rendering/Cairo.hs.pp 253
    -import Control.Monad (unless)
    +import Control.Monad (unless, when)
    hunk ./cairo/Graphics/Rendering/Cairo.hs.pp 256
    -import Foreign.Ptr (castPtr)
    +import Foreign.Ptr (Ptr, nullPtr, castPtr)
    +import Foreign.Storable (Storable(..))
    +import Foreign.ForeignPtr ( touchForeignPtr )
    hunk ./cairo/Graphics/Rendering/Cairo.hs.pp 262
    +import Data.Ix
    +-- internal module of GHC
    +import Data.Array.Base ( MArray, newArray, newArray_, unsafeRead, unsafeWrite,
    +#if __GLASGOW_HASKELL__ < 605
    +			 HasBounds, bounds
    +#else
    +			 getBounds
    +#endif
    +#if __GLASGOW_HASKELL__ >= 608
    +			 ,getNumElements
    +#endif
    +                       )
    hunk ./cairo/Graphics/Rendering/Cairo.hs.pp 1552
    +#if CAIRO_CHECK_VERSION(1,6,0)
    +-- | This function provides a stride value that will respect all alignment
    +--   requirements of the accelerated image-rendering code within cairo.
    +--
    +formatStrideForWidth ::
    +     Format -- ^ format of pixels in the surface to create
    +  -> Int    -- ^ width of the surface, in pixels
    +  -> Int    -- ^ the stride (number of bytes necessary to store one line) [_$_]
    +            --   or @-1@ if the format is invalid or the width is too large
    +formatStrideForWidth = Internal.formatStrideForWidth
    +#endif
    +
    hunk ./cairo/Graphics/Rendering/Cairo.hs.pp 1621
    +
    +-- | Get the format of the surface.
    +--
    +imageSurfaceGetFormat :: MonadIO m => Surface -> m Format
    +imageSurfaceGetFormat a = liftIO $ Internal.imageSurfaceGetFormat a
    +
    hunk ./cairo/Graphics/Rendering/Cairo.hs.pp 1643
    +
    +
    +-- | Retrieve the internal array of raw image data.
    +--
    +-- * Image data in an image surface is stored in memory in uncompressed,
    +--   packed format. Rows in the image are stored top to bottom, and in each
    +--   row pixels are stored from left to right. There may be padding at the end
    +--   of a row. The value returned by 'imageSurfaceGetStride' indicates the
    +--   number of bytes between rows.
    +--
    +-- * The returned array is a flat representation of a three dimensional array:
    +--   x-coordiante, y-coordinate and several channels for each color. The
    +--   format depends on the 'Format' of the surface:
    +--
    +--   'FormatARGB32': each pixel is 32 bits with alpha in the upper 8 bits,
    +--    followed by 8 bits for red, green and blue. Pre-multiplied alpha is used.
    +--    (That is, 50% transparent red is 0x80800000, not 0x80ff0000.)
    +--
    +--   'FormatRGB24': each pixel is 32 bits with the upper 8 bits being unused,
    +--    followed by 8 bits for red, green and blue.
    +--
    +--   'FormatA8': each pixel is 8 bits holding an alpha value
    +--
    +--   'FormatA1': each pixel is one bit where pixels are packed into 32 bit
    +--   quantities. The ordering depends on the endianes of the platform. On a
    +--   big-endian machine, the first pixel is in the uppermost bit, on a
    +--   little-endian machine the first pixel is in the least-significant bit.
    +--
    +-- * To read or write a specific pixel use the formula:
    +--   @p = y * (rowstride `div` 4) + x@ for the pixel and force the array to
    +--   have 32-bit words or integers.
    +--
    +-- * Calling this function without explicitly giving it a type will often lead
    +--   to a compiler error since the type parameter @e@ is underspecified. If
    +--   this happens the function can be explicitly typed:
    +--   @surData <- (imageSurfaceGetPixels pb :: IO (SurfaceData Int Word32))@
    +--
    +-- * If modifying an image through Haskell\'s array interface is not fast
    +--   enough, it is possible to use 'unsafeRead' and 'unsafeWrite' which have
    +--   the same type signatures as 'readArray' and 'writeArray'. Note that these
    +--   are internal functions that might change with GHC.
    +--
    +-- * After each write access to the array, you need to inform Cairo that
    +--   about the area that has changed using 'surfaceMarkDirty'.
    +--
    +-- * The function will return an error if the surface is not an image
    +--   surface of if 'surfaceFinish' has been called on the surface.
    +-- [_$_]
    +imageSurfaceGetPixels :: Storable e => Surface -> IO (SurfaceData Int e)
    +imageSurfaceGetPixels pb = do
    +  pixPtr_ <- Internal.imageSurfaceGetData pb
    +  when (pixPtr_==nullPtr) $ do
    +    fail "imageSurfaceGetPixels: image surface not available"
    +  fmt <- imageSurfaceGetFormat pb
    +  let bits = case fmt of
    +               FormatARGB32 -> 32
    +               FormatRGB24 -> 32
    +               FormatA8 -> 8
    +               FormatA1 -> 1
    +  h <- imageSurfaceGetHeight pb
    +  r <- imageSurfaceGetStride pb
    +  let pixPtr = castPtr pixPtr_
    +  let bytes = h*((r*bits)+7) `div` 8
    +  return (mkSurfaceData pb pixPtr bytes)
    +
    +-- | An array that stores the raw pixel data of an image 'Surface'.
    +--
    +data Ix i => SurfaceData i e = SurfaceData !Surface
    +                          {-# UNPACK #-} !(Ptr e)
    +                                         !(i,i)
    +                          {-# UNPACK #-} !Int
    +
    +mkSurfaceData :: Storable e => Surface -> Ptr e -> Int -> SurfaceData Int e
    +mkSurfaceData pb (ptr :: Ptr e) size =
    +  SurfaceData pb ptr (0, count) count
    +  where count = fromIntegral (size `div` sizeOf (undefined :: e))
    +
    +#if __GLASGOW_HASKELL__ < 605
    +instance HasBounds SurfaceData where
    +  bounds (SurfaceData pb ptr bd cnt) = bd
    +#endif
    +
    +-- | 'SurfaceData' is a mutable array.
    +instance Storable e => MArray SurfaceData e IO where
    +  newArray (l,u) e = error "Graphics.Rendering.Cairo.newArray: not implemented"
    +  newArray_ (l,u)  = error "Graphics.Rendering.Cairo.newArray_: not implemented"
    +  {-# INLINE unsafeRead #-}
    +  unsafeRead (SurfaceData (Surface pb) pixPtr _ _) idx = do
    +      e <- peekElemOff pixPtr idx
    +      touchForeignPtr pb
    +      return e
    +  {-# INLINE unsafeWrite #-}
    +  unsafeWrite (SurfaceData (Surface pb) pixPtr _ _) idx elem = do
    +      pokeElemOff pixPtr idx elem
    +      touchForeignPtr pb
    +#if __GLASGOW_HASKELL__ >= 605
    +  {-# INLINE getBounds #-}
    +  getBounds (SurfaceData _ _ bd _) = return bd
    +#endif
    +#if __GLASGOW_HASKELL__ >= 608
    +  {-# INLINE getNumElements #-}
    +  getNumElements (SurfaceData _ _ _ count) = return count
    +#endif
    +
    +
    hunk ./cairo/Graphics/Rendering/Cairo/Internal/Surfaces/Image.chs.pp 28
    +{#fun image_surface_get_format as imageSurfaceGetFormat { withSurface* `Surface' } -> `Format' cToEnum#}
    hunk ./cairo/Graphics/Rendering/Cairo/Internal/Surfaces/Image.chs.pp 30
    +#if CAIRO_CHECK_VERSION(1,6,0)
    +{#fun pure format_stride_for_width as formatStrideForWidth { cFromEnum `Format', `Int' } -> `Int'#}
    +#endif
    hunk ./gtk/Graphics/UI/Gtk/Cairo.chs.pp 49
    -  -- * Using 'Graphics.UI.Gtk.Gdk.Pixbuf.Pixbuf' functions together with Cairo
    -  cairoImageSurfaceFromPixbuf,
    -#if CAIRO_CHECK_VERSION(1,2,0)
    -  pixbufFromImageSurface,
    -#endif
    hunk ./gtk/Graphics/UI/Gtk/Cairo.chs.pp 96
    --- | Treat a 'Graphics.UI.Gtk.Gdk.Pixbuf.Pixbuf' as an image
    ---   'Graphics..Rendering.Cairo.Surface'.
    ---
    --- * The image data is shared between the two objects. Note that everytime you
    ---   use 'Graphics.UI.Gtk.Gdk.Pixbuf.Pixbuf' functions on the image, it is
    ---   necessary to tell Cairo that the image data has changed using
    ---   'Graphics..Rendering.Cairo.surfaceMarkDirty' since it might cache certain areas of
    ---   an image.
    ---
    -cairoImageSurfaceFromPixbuf :: Pixbuf -> IO Surface
    -cairoImageSurfaceFromPixbuf pb = do
    -  alpha <- pixbufGetHasAlpha pb
    -  chan <- pixbufGetNChannels pb
    -  cs <- pixbufGetColorSpace pb
    -  width <- pixbufGetWidth pb
    -  height <- pixbufGetHeight pb
    -  stride <- pixbufGetRowstride pb
    -  cairoFormat <- case (alpha, chan, cs) of
    -    (True, 4, ColorspaceRgb) -> return FormatARGB32
    -    (False, 3, ColorspaceRgb) -> return FormatRGB24
    -    (_, 1, _) -> return FormatA8 -- pixbuf doesn't actually do that
    -    _ -> error "cairoImageSurfaceFromPixbuf: cannot create cairo context form given format"
    -  dPtr <- {#call unsafe pixbuf_get_pixels#} pb
    -  sfPtr <- {#call cairo_image_surface_create_for_data#} dPtr
    -    (fromIntegral (fromEnum cairoFormat)) (fromIntegral width)
    -    (fromIntegral height) (fromIntegral stride)
    -  sf <- mkSurface sfPtr
    -  let pbPtr = unsafeForeignPtrToPtr (unPixbuf pb)
    -  objectRef pbPtr
    -  {#call cairo_surface_set_user_data#} sf (castPtr pbPtr)
    -    (castPtr pbPtr) objectUnref
    -  manageSurface sf
    -  return sf
    -
    -#if CAIRO_CHECK_VERSION(1,2,0)
    --- | Treat an image 'Graphics.Rendering.Cairo.Surface' as a
    --- 'Graphics.UI.Gtk.Gdk.Pixbuf.Pixbuf'.
    ---
    --- * The image data is shared between the two objects. Note that everytime you
    ---   use 'Graphics.UI.Gtk.Gdk.Pixbuf.Pixbuf' functions on the image, it is
    ---   necessary to tell Cairo that the image data has changed using
    ---   'Graphics.Rendering.Cairo.surfaceMarkDirty' since it might cache certain
    ---   areas of an image. This function throws an error if the
    ---   'Graphics.Rendering.Cairo.Surface' has any other format than
    ---   'Graphics.Rendering.Cairo.FormatARGB32' or
    ---   'Graphics.Rendering.Cairo.FormatRGB32' since
    ---   'Graphics.UI.Gtk.Gdk.Pixbuf.Pixbuf' can currently only handle these two
    ---   formats.
    ---
    --- * Requires Cairo 1.2 or higher.
    ---
    -pixbufFromImageSurface :: Surface -> IO Pixbuf
    -pixbufFromImageSurface sf = do
    -  con <- Cairo.Internal.surfaceGetContent sf
    -  hasAlpha <- case con of
    -    Cairo.Internal.ContentColor -> return False
    -    Cairo.Internal.ContentColorAlpha -> return True
    -    _ -> error ("pixbufFromImageSurface: Pixbufs do not support Cairo format "++show con)    [_$_]
    -  width <- Cairo.Internal.imageSurfaceGetWidth sf
    -  height <- Cairo.Internal.imageSurfaceGetHeight sf
    -  stride <- Cairo.Internal.imageSurfaceGetStride sf
    -  dPtr <- Cairo.Internal.imageSurfaceGetData sf
    -  let (Cairo.Surface sfFPtr) = sf
    -  let sfPtr = unsafeForeignPtrToPtr sfFPtr
    -  Cairo.Internal.surfaceReference sf
    -  fPtrRef <- newIORef nullFunPtr
    -  fPtr <- mkPixbufDestroyNotify $ \_ _ -> do
    -    Cairo.Internal.surfaceDestroy sf
    -    fPtr <- readIORef fPtrRef
    -    freeHaskellFunPtr fPtr
    -  writeIORef fPtrRef fPtr
    -  makeNewGObject mkPixbuf $
    -    {#call unsafe gdk_pixbuf_new_from_data#} dPtr 0 (fromBool hasAlpha)
    -      8 (fromIntegral width) (fromIntegral height) (fromIntegral stride)
    -      fPtr nullPtr
    -#endif
    -
    --- the following should be ifdef'd out as well but then we need to conditionally
    --- link in the _stub.o file of that is then only sometimes generated...
    -{#pointer GdkPixbufDestroyNotify as PixbufDestroyNotify#}
    -
    -foreign import ccall "wrapper" mkPixbufDestroyNotify ::
    -  (Ptr () -> Ptr Surface -> IO ()) -> IO PixbufDestroyNotify
    -
    hunk ./gtk/Graphics/UI/Gtk/Gdk/Pixbuf.chs.pp 196
    ---   fast enough, it is possible to use 'Data.Array.Base.unsafeRead' and
    ---   'Data.Array.Base.unsafeWrite' which have the same type signatures
    ---   as 'Data.Array.MArray.readArray' and 'Data.Array.MArray.writeArray'.
    +--   fast enough, it is possible to use 'unsafeRead' and
    +--   'unsafeWrite' which have the same type signatures
    +--   as 'readArray' and 'writeArray'.