Remove spurious ',' which upset haddock

Remove spurious ',' which upset haddock

-----------------------------------------------------------------------------
-- |
-- Module      :  Graphics.Rendering.Cairo.Types
-- Copyright   :  (c) Paolo Martini 2005
-- License     :  BSD-style (see cairo/COPYRIGHT)
--
-- Maintainer  :  p.martini@neuralnoise.com
-- Stability   :  experimental
-- Portability :  portable
--
-- Haskell bindings to the cairo types.
-----------------------------------------------------------------------------

-- #hide
module Graphics.Rendering.Cairo.Types (
    Matrix(Matrix), MatrixPtr
  , Cairo(Cairo), unCairo
  , Surface(Surface), withSurface, mkSurface, manageSurface
  , Pattern(Pattern), unPattern
  , Status(..)
  , Operator(..)
  , Antialias(..)
  , FillRule(..)
  , LineCap(..)
  , LineJoin(..)
  , ScaledFont(..), unScaledFont
  , FontFace(..), unFontFace
  , Glyph, unGlyph
  , TextExtentsPtr
  , TextExtents(..)
  , FontExtentsPtr
  , FontExtents(..)
  , FontSlant(..)
  , FontWeight(..)
  , SubpixelOrder(..)
  , HintStyle(..)
  , HintMetrics(..)
  , FontOptions(..), withFontOptions, mkFontOptions
  , Path(..), unPath
  , Content(..)
  , Format(..)
  , Extend(..)
  , Filter(..)

  , cIntConv
  , cFloatConv
  , cFromBool
  , cToBool
  , cToEnum
  , cFromEnum
  , peekFloatConv
  , withFloatConv

  ) where

{#import Graphics.Rendering.Cairo.Matrix#}

import Foreign hiding (rotate)
import CForeign

import Monad (liftM)

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

-- not visible
{#pointer *cairo_t as Cairo newtype#}
unCairo (Cairo x) = x

-- | The medium to draw on.
{#pointer *surface_t as Surface foreign newtype#}
withSurface (Surface x) = withForeignPtr x

mkSurface :: Ptr Surface -> IO Surface
mkSurface surfacePtr = do
  surfaceForeignPtr <- newForeignPtr_ surfacePtr
  return (Surface surfaceForeignPtr)

manageSurface :: Surface -> IO ()
manageSurface (Surface surfaceForeignPtr) = do
  addForeignPtrFinalizer surfaceDestroy surfaceForeignPtr

foreign import ccall unsafe "&cairo_surface_destroy"
  surfaceDestroy :: FinalizerPtr Surface

-- | Patterns can be simple solid colors, various kinds of gradients or
-- bitmaps. The current pattern for a 'Render' context is used by the 'stroke',
-- 'fill' and paint operations. These operations composite the current pattern
-- with the target surface using the currently selected 'Operator'.
--
{#pointer *pattern_t as Pattern newtype#}
unPattern (Pattern x) = x

-- | Cairo status.
--
-- * 'Status' is used to indicate errors that can occur when using
--   Cairo. In some cases it is returned directly by functions. When using
--   'Graphics.Rendering.Cairo.Render', the last error, if any, is stored
--   in the monad and can be retrieved with 'Graphics.Rendering.Cairo.status'.
--
{#enum status_t as Status {underscoreToCase} deriving(Eq)#}

-- | Composition operator for all drawing operations.
--
{#enum operator_t as Operator {underscoreToCase}#}

-- | Specifies the type of antialiasing to do when rendering text or shapes
--
-- ['AntialiasDefault']  Use the default antialiasing for the subsystem
-- and target device.
--
-- ['AntialiasNone']  Use a bilevel alpha mask.
--
-- ['AntialiasGray']  Perform single-color antialiasing (using shades of
-- gray for black text on a white background, for example).
--
-- ['AntialiasSubpixel']  Perform antialiasing by taking advantage of
-- the order of subpixel elements on devices such as LCD panels.
--
{#enum antialias_t as Antialias {underscoreToCase}#}

-- | Specify how paths are filled.
--
-- * For both fill rules, whether or not a point is included in the fill is
--   determined by taking a ray from that point to infinity and looking at
--   intersections with the path. The ray can be in any direction, as long
--   as it doesn't pass through the end point of a segment or have a tricky
--   intersection such as intersecting tangent to the path. (Note that
--   filling is not actually implemented in this way. This is just a
--   description of the rule that is applied.)
--
-- ['FillRuleWinding']  If the path crosses the ray from left-to-right,
--   counts +1. If the path crosses the ray from right to left, counts -1.
--   (Left and right are determined from the perspective of looking along
--   the ray from the starting point.) If the total count is non-zero, the
--   point will be filled.
--
-- ['FillRuleEvenOdd']  Counts the total number of intersections,
--   without regard to the orientation of the contour. If the total number
--   of intersections is odd, the point will be filled.
--
{#enum fill_rule_t as FillRule {underscoreToCase}#}

-- | Specify line endings.
--
-- ['LineCapButt'] Start(stop) the line exactly at the start(end) point.
--
-- ['LineCapRound'] Use a round ending, the center of the circle is the
--   end point.
--
-- ['LineCapSquare'] Use squared ending, the center of the square is the
--   end point
--
{#enum line_cap_t as LineCap {underscoreToCase}#}

-- | Specify how lines join.
--
{#enum line_join_t as LineJoin {underscoreToCase}#}

{#pointer *scaled_font_t as ScaledFont newtype#}
unScaledFont (ScaledFont x) = x

{#pointer *font_face_t as FontFace newtype#}
unFontFace (FontFace x) = x

{#pointer *glyph_t as Glyph newtype#}
unGlyph (Glyph x) = x

{#pointer *text_extents_t as TextExtentsPtr -> TextExtents#}

-- | Specify the extents of a text.
data TextExtents = TextExtents {
    textExtentsXbearing :: Double
  , textExtentsYbearing :: Double
  , textExtentsWidth    :: Double
  , textExtentsHeight   :: Double
  , textExtentsXadvance :: Double
  , textExtentsYadvance :: Double
  }

instance Storable TextExtents where
  sizeOf _ = {#sizeof text_extents_t#}
  alignment _ = alignment (undefined :: CDouble)
  peek p = do
    x_bearing <- {#get text_extents_t->x_bearing#} p
    y_bearing <- {#get text_extents_t->y_bearing#} p
    width     <- {#get text_extents_t->width#}     p
    height    <- {#get text_extents_t->height#}    p
    x_advance <- {#get text_extents_t->x_advance#} p
    y_advance <- {#get text_extents_t->y_advance#} p
    return $ TextExtents (cFloatConv x_bearing) (cFloatConv y_bearing)
                         (cFloatConv width)     (cFloatConv height)
                         (cFloatConv x_advance) (cFloatConv y_advance)
  poke p (TextExtents x_bearing y_bearing width height x_advance y_advance) = do
    {#set text_extents_t->x_bearing#} p (cFloatConv x_bearing)
    {#set text_extents_t->y_bearing#} p (cFloatConv y_bearing)
    {#set text_extents_t->width#}     p (cFloatConv width)
    {#set text_extents_t->height#}    p (cFloatConv height)
    {#set text_extents_t->x_advance#} p (cFloatConv x_advance)
    {#set text_extents_t->y_advance#} p (cFloatConv y_advance)
    return ()

{#pointer *font_extents_t as FontExtentsPtr -> FontExtents#}

-- | Result of querying the font extents.
data FontExtents = FontExtents {
    fontExtentsAscent      :: Double
  , fontExtentsDescent     :: Double
  , fontExtentsHeight      :: Double
  , fontExtentsMaxXadvance :: Double
  , fontExtentsMaxYadvance :: Double
  }

instance Storable FontExtents where
  sizeOf _ = {#sizeof font_extents_t#}
  alignment _ = alignment (undefined :: CDouble)
  peek p = do
    ascent        <- {#get font_extents_t->ascent#}        p
    descent       <- {#get font_extents_t->descent#}       p
    height        <- {#get font_extents_t->height#}        p
    max_x_advance <- {#get font_extents_t->max_x_advance#} p
    max_y_advance <- {#get font_extents_t->max_y_advance#} p
    return $ FontExtents (cFloatConv ascent) (cFloatConv descent) (cFloatConv height)
                         (cFloatConv max_x_advance) (cFloatConv max_y_advance)
  poke p (FontExtents ascent descent height max_x_advance max_y_advance) = do
    {#set font_extents_t->ascent#}        p (cFloatConv ascent)
    {#set font_extents_t->descent#}       p (cFloatConv descent)
    {#set font_extents_t->height#}        p (cFloatConv height)
    {#set font_extents_t->max_x_advance#} p (cFloatConv max_x_advance)
    {#set font_extents_t->max_y_advance#} p (cFloatConv max_y_advance)
    return ()

-- | Specify font slant.
{#enum font_slant_t as FontSlant {underscoreToCase}#}

-- | Specify font weight.
{#enum font_weight_t as FontWeight {underscoreToCase}#}

-- | The subpixel order specifies the order of color elements within each pixel
-- on the display device when rendering with an antialiasing mode of
-- 'AntialiasSubpixel'.
--
-- ['SubpixelOrderDefault'] Use the default subpixel order for for the
--                          target device
--
-- ['SubpixelOrderRgb']     Subpixel elements are arranged horizontally
--                          with red at the left
--
-- ['SubpixelOrderBgr']     Subpixel elements are arranged horizontally
--                          with blue at the left
--
-- ['SubpixelOrderVrgb']    Subpixel elements are arranged vertically
--                          with red at the top
--
-- ['SubpixelOrderVbgr']    Subpixel elements are arranged vertically
--                          with blue at the top
--
{#enum subpixel_order_t as SubpixelOrder {underscoreToCase}#}

-- | Specifies the type of hinting to do on font outlines.
--
-- Hinting is the process of fitting outlines to the pixel grid in order to
-- improve the appearance of the result. Since hinting outlines involves
-- distorting them, it also reduces the faithfulness to the original outline
-- shapes. Not all of the outline hinting styles are supported by all font
-- backends.
--
-- ['HintStyleDefault']  Use the default hint style for for font backend and
--                       target device
--
-- ['HintStyleNone']     Do not hint outlines
--
-- ['HintStyleSlight']   Hint outlines slightly to improve contrast while
--                       retaining good fidelity to the original shapes.
--
-- ['HintStyleMedium']   Hint outlines with medium strength giving a compromise
--                       between fidelity to the original shapes and contrast
--
-- ['HintStyleFull']     Hint outlines to maximize contrast
--
{#enum hint_style_t as HintStyle {underscoreToCase}#}

-- | Specifies whether to hint font metrics.
--
-- Hinting font metrics means quantizing them so that they are integer values
-- in device space. Doing this improves the consistency of letter and line
-- spacing, however it also means that text will be laid out differently at
-- different zoom factors.
--
-- ['HintMetricsDefault']  Hint metrics in the default manner for the font
--                         backend and target device
--
-- ['HintMetricsOff']      Do not hint font metrics
--
-- ['HintMetricsOn']       Hint font metrics
--
--
{#enum hint_metrics_t as HintMetrics {underscoreToCase}#}

-- | Specifies how to render text.
{#pointer *font_options_t as FontOptions foreign newtype#}

withFontOptions (FontOptions fptr) = withForeignPtr fptr

mkFontOptions :: Ptr FontOptions -> IO FontOptions
mkFontOptions fontOptionsPtr = do
  fontOptionsForeignPtr <- newForeignPtr fontOptionsDestroy fontOptionsPtr
  return (FontOptions fontOptionsForeignPtr)

foreign import ccall unsafe "&cairo_font_options_destroy"
  fontOptionsDestroy :: FinalizerPtr FontOptions

-- XXX: pathToList :: Path -> [PathData]
--
-- http://cairographics.org/manual/bindings-path.html
--
-- {#enum path_data_type_t as PathDataType {underscoreToCase}#}
--
-- type Point = (Double, Double)
-- data PathData = PathMoveTo Point
--               | PathLineTo Point
--               | PathCurveTo Point Point Point
--               | PathClose

-- | A Cairo path.
--
-- * A path is a sequence of drawing operations that are accumulated until
--   'Graphics.Rendering.Cairo.stroke' is called. Using a path is particularly
--   useful when drawing lines with special join styles and
--   'Graphics.Rendering.Cairo.closePath'.
--
{#pointer *path_t as Path newtype#}
unPath (Path x) = x

{#enum content_t as Content {underscoreToCase}#}

data Format = FormatARGB32
            | FormatRGB24
            | FormatA8
            | FormatA1
            deriving (Enum)

-- | FIXME: We should find out about this.
{#enum extend_t as Extend {underscoreToCase}#}

-- | Specify how filtering is done.
{#enum filter_t as Filter {underscoreToCase}#}

-- Marshalling functions

cIntConv :: (Integral a, Integral b) => a -> b
cIntConv  = fromIntegral

cFloatConv :: (RealFloat a, RealFloat b) => a -> b
cFloatConv  = realToFrac

cFromBool :: Num a => Bool -> a
cFromBool  = fromBool

cToBool :: Num a => a -> Bool
cToBool  = toBool

cToEnum :: (Integral i, Enum e) => i -> e
cToEnum  = toEnum . cIntConv

cFromEnum :: (Enum e, Integral i) => e -> i
cFromEnum  = cIntConv . fromEnum

peekFloatConv :: (Storable a, RealFloat a, RealFloat b) =>  Ptr a -> IO b
peekFloatConv  = liftM cFloatConv . peek

withFloatConv :: (Storable b, RealFloat a, RealFloat b) => a -> (Ptr b -> IO c) -> IO c
withFloatConv  = with . cFloatConv

withArrayFloatConv :: (Storable b, RealFloat a, RealFloat b) => [a] -> (Ptr b -> IO b1) -> IO b1
withArrayFloatConv = withArray . map (cFloatConv)

-----------------------------------------------------------------------------
-- |
-- Module      :  Graphics.Rendering.Cairo.Types
-- Copyright   :  (c) Paolo Martini 2005
-- License     :  BSD-style (see cairo/COPYRIGHT)
--
-- Maintainer  :  p.martini@neuralnoise.com
-- Stability   :  experimental
-- Portability :  portable
--
-- Haskell bindings to the cairo types.
-----------------------------------------------------------------------------

-- #hide
module Graphics.Rendering.Cairo.Types (
    Matrix(Matrix), MatrixPtr
  , Cairo(Cairo), unCairo
  , Surface(Surface), withSurface, mkSurface, manageSurface,
  , Pattern(Pattern), unPattern
  , Status(..)
  , Operator(..)
  , Antialias(..)
  , FillRule(..)
  , LineCap(..)
  , LineJoin(..)
  , ScaledFont(..), unScaledFont
  , FontFace(..), unFontFace
  , Glyph, unGlyph
  , TextExtentsPtr
  , TextExtents(..)
  , FontExtentsPtr
  , FontExtents(..)
  , FontSlant(..)
  , FontWeight(..)
  , SubpixelOrder(..)
  , HintStyle(..)
  , HintMetrics(..)
  , FontOptions(..), withFontOptions, mkFontOptions
  , Path(..), unPath
  , Content(..)
  , Format(..)
  , Extend(..)
  , Filter(..)

  , cIntConv
  , cFloatConv
  , cFromBool
  , cToBool
  , cToEnum
  , cFromEnum
  , peekFloatConv
  , withFloatConv

  ) where

{#import Graphics.Rendering.Cairo.Matrix#}

import Foreign hiding (rotate)
import CForeign

import Monad (liftM)

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

-- not visible
{#pointer *cairo_t as Cairo newtype#}
unCairo (Cairo x) = x

-- | The medium to draw on.
{#pointer *surface_t as Surface foreign newtype#}
withSurface (Surface x) = withForeignPtr x

mkSurface :: Ptr Surface -> IO Surface
mkSurface surfacePtr = do
  surfaceForeignPtr <- newForeignPtr_ surfacePtr
  return (Surface surfaceForeignPtr)

manageSurface :: Surface -> IO ()
manageSurface (Surface surfaceForeignPtr) = do
  addForeignPtrFinalizer surfaceDestroy surfaceForeignPtr

foreign import ccall unsafe "&cairo_surface_destroy"
  surfaceDestroy :: FinalizerPtr Surface

-- | Patterns can be simple solid colors, various kinds of gradients or
-- bitmaps. The current pattern for a 'Render' context is used by the 'stroke',
-- 'fill' and paint operations. These operations composite the current pattern
-- with the target surface using the currently selected 'Operator'.
--
{#pointer *pattern_t as Pattern newtype#}
unPattern (Pattern x) = x

-- | Cairo status.
--
-- * 'Status' is used to indicate errors that can occur when using
--   Cairo. In some cases it is returned directly by functions. When using
--   'Graphics.Rendering.Cairo.Render', the last error, if any, is stored
--   in the monad and can be retrieved with 'Graphics.Rendering.Cairo.status'.
--
{#enum status_t as Status {underscoreToCase} deriving(Eq)#}

-- | Composition operator for all drawing operations.
--
{#enum operator_t as Operator {underscoreToCase}#}

-- | Specifies the type of antialiasing to do when rendering text or shapes
--
-- ['AntialiasDefault']  Use the default antialiasing for the subsystem
-- and target device.
--
-- ['AntialiasNone']  Use a bilevel alpha mask.
--
-- ['AntialiasGray']  Perform single-color antialiasing (using shades of
-- gray for black text on a white background, for example).
--
-- ['AntialiasSubpixel']  Perform antialiasing by taking advantage of
-- the order of subpixel elements on devices such as LCD panels.
--
{#enum antialias_t as Antialias {underscoreToCase}#}

-- | Specify how paths are filled.
--
-- * For both fill rules, whether or not a point is included in the fill is
--   determined by taking a ray from that point to infinity and looking at
--   intersections with the path. The ray can be in any direction, as long
--   as it doesn't pass through the end point of a segment or have a tricky
--   intersection such as intersecting tangent to the path. (Note that
--   filling is not actually implemented in this way. This is just a
--   description of the rule that is applied.)
--
-- ['FillRuleWinding']  If the path crosses the ray from left-to-right,
--   counts +1. If the path crosses the ray from right to left, counts -1.
--   (Left and right are determined from the perspective of looking along
--   the ray from the starting point.) If the total count is non-zero, the
--   point will be filled.
--
-- ['FillRuleEvenOdd']  Counts the total number of intersections,
--   without regard to the orientation of the contour. If the total number
--   of intersections is odd, the point will be filled.
--
{#enum fill_rule_t as FillRule {underscoreToCase}#}

-- | Specify line endings.
--
-- ['LineCapButt'] Start(stop) the line exactly at the start(end) point.
--
-- ['LineCapRound'] Use a round ending, the center of the circle is the
--   end point.
--
-- ['LineCapSquare'] Use squared ending, the center of the square is the
--   end point
--
{#enum line_cap_t as LineCap {underscoreToCase}#}

-- | Specify how lines join.
--
{#enum line_join_t as LineJoin {underscoreToCase}#}

{#pointer *scaled_font_t as ScaledFont newtype#}
unScaledFont (ScaledFont x) = x

{#pointer *font_face_t as FontFace newtype#}
unFontFace (FontFace x) = x

{#pointer *glyph_t as Glyph newtype#}
unGlyph (Glyph x) = x

{#pointer *text_extents_t as TextExtentsPtr -> TextExtents#}

-- | Specify the extents of a text.
data TextExtents = TextExtents {
    textExtentsXbearing :: Double
  , textExtentsYbearing :: Double
  , textExtentsWidth    :: Double
  , textExtentsHeight   :: Double
  , textExtentsXadvance :: Double
  , textExtentsYadvance :: Double
  }

instance Storable TextExtents where
  sizeOf _ = {#sizeof text_extents_t#}
  alignment _ = alignment (undefined :: CDouble)
  peek p = do
    x_bearing <- {#get text_extents_t->x_bearing#} p
    y_bearing <- {#get text_extents_t->y_bearing#} p
    width     <- {#get text_extents_t->width#}     p
    height    <- {#get text_extents_t->height#}    p
    x_advance <- {#get text_extents_t->x_advance#} p
    y_advance <- {#get text_extents_t->y_advance#} p
    return $ TextExtents (cFloatConv x_bearing) (cFloatConv y_bearing)
                         (cFloatConv width)     (cFloatConv height)
                         (cFloatConv x_advance) (cFloatConv y_advance)
  poke p (TextExtents x_bearing y_bearing width height x_advance y_advance) = do
    {#set text_extents_t->x_bearing#} p (cFloatConv x_bearing)
    {#set text_extents_t->y_bearing#} p (cFloatConv y_bearing)
    {#set text_extents_t->width#}     p (cFloatConv width)
    {#set text_extents_t->height#}    p (cFloatConv height)
    {#set text_extents_t->x_advance#} p (cFloatConv x_advance)
    {#set text_extents_t->y_advance#} p (cFloatConv y_advance)
    return ()

{#pointer *font_extents_t as FontExtentsPtr -> FontExtents#}

-- | Result of querying the font extents.
data FontExtents = FontExtents {
    fontExtentsAscent      :: Double
  , fontExtentsDescent     :: Double
  , fontExtentsHeight      :: Double
  , fontExtentsMaxXadvance :: Double
  , fontExtentsMaxYadvance :: Double
  }

instance Storable FontExtents where
  sizeOf _ = {#sizeof font_extents_t#}
  alignment _ = alignment (undefined :: CDouble)
  peek p = do
    ascent        <- {#get font_extents_t->ascent#}        p
    descent       <- {#get font_extents_t->descent#}       p
    height        <- {#get font_extents_t->height#}        p
    max_x_advance <- {#get font_extents_t->max_x_advance#} p
    max_y_advance <- {#get font_extents_t->max_y_advance#} p
    return $ FontExtents (cFloatConv ascent) (cFloatConv descent) (cFloatConv height)
                         (cFloatConv max_x_advance) (cFloatConv max_y_advance)
  poke p (FontExtents ascent descent height max_x_advance max_y_advance) = do
    {#set font_extents_t->ascent#}        p (cFloatConv ascent)
    {#set font_extents_t->descent#}       p (cFloatConv descent)
    {#set font_extents_t->height#}        p (cFloatConv height)
    {#set font_extents_t->max_x_advance#} p (cFloatConv max_x_advance)
    {#set font_extents_t->max_y_advance#} p (cFloatConv max_y_advance)
    return ()

-- | Specify font slant.
{#enum font_slant_t as FontSlant {underscoreToCase}#}

-- | Specify font weight.
{#enum font_weight_t as FontWeight {underscoreToCase}#}

-- | The subpixel order specifies the order of color elements within each pixel
-- on the display device when rendering with an antialiasing mode of
-- 'AntialiasSubpixel'.
--
-- ['SubpixelOrderDefault'] Use the default subpixel order for for the
--                          target device
--
-- ['SubpixelOrderRgb']     Subpixel elements are arranged horizontally
--                          with red at the left
--
-- ['SubpixelOrderBgr']     Subpixel elements are arranged horizontally
--                          with blue at the left
--
-- ['SubpixelOrderVrgb']    Subpixel elements are arranged vertically
--                          with red at the top
--
-- ['SubpixelOrderVbgr']    Subpixel elements are arranged vertically
--                          with blue at the top
--
{#enum subpixel_order_t as SubpixelOrder {underscoreToCase}#}

-- | Specifies the type of hinting to do on font outlines.
--
-- Hinting is the process of fitting outlines to the pixel grid in order to
-- improve the appearance of the result. Since hinting outlines involves
-- distorting them, it also reduces the faithfulness to the original outline
-- shapes. Not all of the outline hinting styles are supported by all font
-- backends.
--
-- ['HintStyleDefault']  Use the default hint style for for font backend and
--                       target device
--
-- ['HintStyleNone']     Do not hint outlines
--
-- ['HintStyleSlight']   Hint outlines slightly to improve contrast while
--                       retaining good fidelity to the original shapes.
--
-- ['HintStyleMedium']   Hint outlines with medium strength giving a compromise
--                       between fidelity to the original shapes and contrast
--
-- ['HintStyleFull']     Hint outlines to maximize contrast
--
{#enum hint_style_t as HintStyle {underscoreToCase}#}

-- | Specifies whether to hint font metrics.
--
-- Hinting font metrics means quantizing them so that they are integer values
-- in device space. Doing this improves the consistency of letter and line
-- spacing, however it also means that text will be laid out differently at
-- different zoom factors.
--
-- ['HintMetricsDefault']  Hint metrics in the default manner for the font
--                         backend and target device
--
-- ['HintMetricsOff']      Do not hint font metrics
--
-- ['HintMetricsOn']       Hint font metrics
--
--
{#enum hint_metrics_t as HintMetrics {underscoreToCase}#}

-- | Specifies how to render text.
{#pointer *font_options_t as FontOptions foreign newtype#}

withFontOptions (FontOptions fptr) = withForeignPtr fptr

mkFontOptions :: Ptr FontOptions -> IO FontOptions
mkFontOptions fontOptionsPtr = do
  fontOptionsForeignPtr <- newForeignPtr fontOptionsDestroy fontOptionsPtr
  return (FontOptions fontOptionsForeignPtr)

foreign import ccall unsafe "&cairo_font_options_destroy"
  fontOptionsDestroy :: FinalizerPtr FontOptions

-- XXX: pathToList :: Path -> [PathData]
--
-- http://cairographics.org/manual/bindings-path.html
--
-- {#enum path_data_type_t as PathDataType {underscoreToCase}#}
--
-- type Point = (Double, Double)
-- data PathData = PathMoveTo Point
--               | PathLineTo Point
--               | PathCurveTo Point Point Point
--               | PathClose

-- | A Cairo path.
--
-- * A path is a sequence of drawing operations that are accumulated until
--   'Graphics.Rendering.Cairo.stroke' is called. Using a path is particularly
--   useful when drawing lines with special join styles and
--   'Graphics.Rendering.Cairo.closePath'.
--
{#pointer *path_t as Path newtype#}
unPath (Path x) = x

{#enum content_t as Content {underscoreToCase}#}

data Format = FormatARGB32
            | FormatRGB24
            | FormatA8
            | FormatA1
            deriving (Enum)

-- | FIXME: We should find out about this.
{#enum extend_t as Extend {underscoreToCase}#}

-- | Specify how filtering is done.
{#enum filter_t as Filter {underscoreToCase}#}

-- Marshalling functions

cIntConv :: (Integral a, Integral b) => a -> b
cIntConv  = fromIntegral

cFloatConv :: (RealFloat a, RealFloat b) => a -> b
cFloatConv  = realToFrac

cFromBool :: Num a => Bool -> a
cFromBool  = fromBool

cToBool :: Num a => a -> Bool
cToBool  = toBool

cToEnum :: (Integral i, Enum e) => i -> e
cToEnum  = toEnum . cIntConv

cFromEnum :: (Enum e, Integral i) => e -> i
cFromEnum  = cIntConv . fromEnum

peekFloatConv :: (Storable a, RealFloat a, RealFloat b) =>  Ptr a -> IO b
peekFloatConv  = liftM cFloatConv . peek

withFloatConv :: (Storable b, RealFloat a, RealFloat b) => a -> (Ptr b -> IO c) -> IO c
withFloatConv  = with . cFloatConv

withArrayFloatConv :: (Storable b, RealFloat a, RealFloat b) => [a] -> (Ptr b -> IO b1) -> IO b1
withArrayFloatConv = withArray . map (cFloatConv)


less weird bytestring to iovec code

less weird bytestring to iovec code

-- -*-haskell-*-

{-# LANGUAGE ForeignFunctionInterface, BangPatterns #-}

module Foreign.IOVec
    (IOVec()
    ,withByteString
    ,withLazyByteString
    ,withIOVec
    ,writev
    )
    where

import qualified Data.ByteString as S
import qualified Data.ByteString.Internal as S
import qualified Data.ByteString.Unsafe as S
import qualified Data.ByteString.Lazy as L

import Foreign
import Foreign.C.Types

#include <sys/uio.h>

#c
typedef struct iovec hs_iovec;
#endc

{#pointer *hs_iovec as IOVec newtype#}

withIOVec :: IOVec -> (Ptr IOVec -> IO a) -> IO a
withIOVec (IOVec ptr) f = f ptr
{-# INLINE withIOVec #-}

withByteString :: S.ByteString -> (IOVec -> Int -> IO b) -> IO b
withByteString b = withLazyByteString (L.fromChunks [b])

-- | This is intented for calling into something like writev.
-- But I suppose that nothing stops you from calling into
-- readv and blowing away the passed-in ByteString.
withLazyByteString :: L.ByteString -> (IOVec -> Int -> IO b) -> IO b
withLazyByteString lbs f =
    let bs = L.toChunks lbs
        num = length bs
    in allocaBytes (num * {#sizeof hs_iovec#}) $
           \vecAry -> do
             fill vecAry 0 bs
             x <- f (IOVec vecAry) num
             touchAllBS bs
             return x

   where fill _vecAry !_off [] = return ()
         fill vecAry !off (b:bs) =

             let vec = vecAry `plusPtr` (off * {#sizeof hs_iovec#})

             in do
               S.unsafeUseAsCStringLen b $ \(bsptr,bslen) -> do
                  {#set hs_iovec->iov_base#} vec $ castPtr $ bsptr
                  {#set hs_iovec->iov_len#}  vec $ fromIntegral bslen
               fill vecAry (off+1) bs

-- utility functions
touchBS :: S.ByteString -> IO ()
touchBS b = case S.toForeignPtr b of (fptr,_,_) -> touchForeignPtr fptr

touchAllBS :: [S.ByteString] -> IO ()
touchAllBS xs = mapM_ touchBS xs

-- | Binding to writev using 'withLazyByteString'. For testing.
writev :: CInt -> L.ByteString -> IO CSize
writev fd bs = withLazyByteString bs $ \iov count ->
               c_writev fd iov (fromIntegral count)

foreign import ccall unsafe "writev" c_writev :: CInt -> IOVec -> CInt -> IO CSize

-- -*-haskell-*-

{-# LANGUAGE ForeignFunctionInterface, BangPatterns #-}

module Foreign.IOVec
    (IOVec()
    ,withByteString
    ,withLazyByteString
    ,withIOVec
    ,writev
    )
    where

import qualified Data.ByteString as S
import qualified Data.ByteString.Internal as S
import qualified Data.ByteString.Lazy as L

import Foreign
import Foreign.C.Types

#include <sys/uio.h>

#c
typedef struct iovec hs_iovec;
#endc

{#pointer *hs_iovec as IOVec newtype#}

withIOVec :: IOVec -> (Ptr IOVec -> IO a) -> IO a
withIOVec (IOVec ptr) f = f ptr
{-# INLINE withIOVec #-}

withByteString :: S.ByteString -> (IOVec -> Int -> IO b) -> IO b
withByteString b = withLazyByteString (L.fromChunks [b])

-- | This is intented for calling into something like writev.
-- But I suppose that nothing stops you from calling into
-- readv and blowing away the passed-in ByteString.
withLazyByteString :: L.ByteString -> (IOVec -> Int -> IO b) -> IO b
withLazyByteString lbs f =
    let bs = L.toChunks lbs
        num = length bs
    in allocaBytes (num * {#sizeof hs_iovec#}) $ \vecAry -> go vecAry 0 bs

   where go vecAry !off [] = f (IOVec vecAry) off
         go vecAry !off (b:bs) =

             let vec = vecAry `plusPtr` (off * {#sizeof hs_iovec#})
                 (fptr, bsOff, bsLen) = S.toForeignPtr b

             in withForeignPtr fptr $ \bsPtr -> do
                  {#set hs_iovec->iov_base#} vec $ castPtr $ bsPtr `plusPtr` bsOff
                  {#set hs_iovec->iov_len#}  vec $ fromIntegral bsLen
                  go vecAry (off+1) bs

-- | Binding to writev using 'withLazyByteString'
writev :: CInt -> L.ByteString -> IO CSize
writev fd bs = withLazyByteString bs $ \iov count ->
               c_writev fd iov (fromIntegral count)

foreign import ccall unsafe "writev" c_writev :: CInt -> IOVec -> CInt -> IO CSize


add takeSocket/writev primitives

add takeSocket/writev primitives

-- -*-haskell-*-

{-# LANGUAGE
   StandaloneDeriving
  ,GeneralizedNewtypeDeriving
  #-}

module Graphics.X11.Xcb.Internal where

import Control.Applicative
import Control.Monad
import Foreign
import Foreign.C.String
import Foreign.C.Types

import qualified Data.ByteString as S
import qualified Data.ByteString.Internal as S
import qualified Data.ByteString.Lazy as L

{#import Foreign.IOVec#}

#include <xcb/xcb.h>
#include <xcb/xcbext.h>

peekIntConv
    :: (Integral a, Num b, Storable a)
       => Ptr a -> IO b
peekIntConv ptr = fromIntegral `liftM` peek ptr

{-
  Welcome to my sometimes-dodgy FFI bindings to XCB.
  The idea isn't really to write something to directly
  write X apps with, but to write a foundation for
  something higher-level and safer.

  So referential transparency can definetly be abused
  with a lot of the calls in here.

  So don't do it.
 -}

{#context lib="xcb" prefix="xcb_"#}

withConnection :: Connection -> (Ptr Connection -> IO b) -> IO b
{#pointer *connection_t as Connection foreign newtype#}
{#pointer *setup_t as Setup newtype#} -- no finalizer, part of the Connection

-- | Returns a connection to the indicated X server, as well
-- as the screen connected to.
-- The passed in string may be null, in which case
-- it will be the same as passing in the DISPLAY environment
-- variable.
connect :: String -> IO (Maybe (Connection, Int))
connect display
    = withCString display $ \displayPtr ->
      alloca $ \screenPtr -> do

      cPtr <- {#call connect as connect_#} displayPtr screenPtr
      screen <- peekIntConv screenPtr

      if cPtr == nullPtr then return Nothing else do

      c <- mkConnection cPtr
      return $ Just (c, screen)

-- | Parse the host, display and screen from a string.
-- The same as what we would do if the string were
-- passed to 'connect'.
parseDisplay :: String -> IO (Maybe (String, Int, Int))
parseDisplay display
    = withCString display $ \displayPtr ->
      alloca $ \hostStringPtr ->
      alloca $ \displayNumPtr ->
      alloca $ \screenPtr -> do
      success <- liftM toBool $
                 {#call unsafe parse_display#} displayPtr hostStringPtr displayNumPtr screenPtr
      if not success then return Nothing else do

      host <- peek hostStringPtr >>= peekCString
      peek hostStringPtr >>= free

      displayNum <- peekIntConv displayNumPtr
      screen <- peekIntConv screenPtr

      return $ Just (host, displayNum, screen)

-- | Flush the write buffers.
flush :: Connection -> IO Bool
flush c = withConnection c $ \cPtr ->
          liftM toBool $ {#call flush as flush_#} cPtr

-- | The memory backing this data structure is owned
-- by the passed in Connection - and will magicaly vanish
-- if your 'Connection' gets GCd before the return value
-- of this function.  Watch out.
unsafeGetSetup :: Connection -> IO Setup
unsafeGetSetup c = withConnection c $ \cPtr ->
                   {#call unsafe get_setup#} cPtr

-- | Length of the setup data in units of four bytes.
setupLength :: Setup -> IO Word16
setupLength (Setup s) = liftM fromIntegral $ {#get setup_t->length#} s

-- | This ByteString is just as unsafe as the passed in connection
-- object.  Please make a copy.
unsafeSetupData :: Setup -> IO S.ByteString
unsafeSetupData s@(Setup sPtr) = do
  len <- liftM (4*) $ setupLength s
  sFPtr <- newForeignPtr_ sPtr
  return $ S.fromForeignPtr (castForeignPtr sFPtr) 0 (fromIntegral len)

-- | Maximum size of a single request.
-- May not be an asynchronous call, as we'll make a call out
-- on the big-requests extension to find out if we can use that.
maximumRequestLength :: Connection -> IO Word32
maximumRequestLength c = withConnection c $ \cPtr ->
                         liftM fromIntegral $ {#call get_maximum_request_length#} cPtr

-- | Asynchronous version of 'maximumRequestLength'.  The return
-- from the server is cached for subsequent callse to 'maximumRequestLength'.
prefetchMaximumReuestLength :: Connection -> IO ()
prefetchMaximumReuestLength c = withConnection c $ \cPtr ->
                                {#call prefetch_maximum_request_length#} cPtr

-- | Is the connection in an error state?
connectionHasError :: Connection -> IO Bool
connectionHasError c = withConnection c $ \cPtr ->
                       liftM toBool $ {#call connection_has_error#} cPtr

newtype Cookie = Cookie CUInt

-- Working with extensions
{#pointer *extension_t as Extension newtype#} -- static data, no finalizer

-- :-(
instance Storable Extension where
    sizeOf (Extension ex) = sizeOf ex
    alignment (Extension ex) = alignment ex
    peekElemOff ptr off = liftM Extension $ peekElemOff (castPtr ptr) off
    pokeElemOff ptr off (Extension ex) = pokeElemOff (castPtr ptr) off ex
    peekByteOff ptr off = liftM Extension $ peekByteOff ptr off
    pokeByteOff ptr off (Extension ex) = pokeByteOff ptr off ex
    peek ptr = liftM Extension $ peek (castPtr ptr)
    poke ptr (Extension ex) = poke (castPtr ptr) ex

{#pointer *query_extension_reply_t as ExtensionInfo newtype#} -- freed with Connection, no finalizer

-- | May block if the data is not already cached.  For internal
-- use only - make a copy if you need something that will live
-- longer than the scope of the connection.
unsafeGetExtensionData :: Connection -> Extension -> IO ExtensionInfo
unsafeGetExtensionData c ext
    = withConnection c $ \cPtr ->
      {#call get_extension_data#} cPtr ext

extensionPresent :: ExtensionInfo -> IO Bool
extensionPresent (ExtensionInfo ext)
    = liftM toBool $ {#get query_extension_reply_t->present#} ext

extensionMajorOpcode :: ExtensionInfo -> IO Word8
extensionMajorOpcode (ExtensionInfo ext)
    = liftM fromIntegral $ {#get query_extension_reply_t->major_opcode#} ext

extensionFirstEvent :: ExtensionInfo -> IO Word8
extensionFirstEvent (ExtensionInfo ext)
    = liftM fromIntegral $ {#get query_extension_reply_t->first_event#} ext

extensionFirstError :: ExtensionInfo -> IO Word8
extensionFirstError (ExtensionInfo ext)
    = liftM fromIntegral $ {#get query_extension_reply_t->first_error#} ext

-- | Non-blocking query for extension data
prefetchExtension :: Connection -> Extension -> IO ()
prefetchExtension c ext
    = withConnection c $ \cPtr ->
      {#call prefetch_extension_data#} cPtr ext

class HasResponseType a where
    responseType :: a -> IO Int

isBigEvent :: HasResponseType a => a -> IO Bool
isBigEvent ev = (== 35) `liftM` responseType ev

isError :: HasResponseType a => a -> IO Bool
isError ev = (== 2) `liftM` responseType ev

-- Events
withGenericEvent :: GenericEvent -> (Ptr GenericEvent -> IO b) -> IO b
{#pointer *generic_event_t as GenericEvent foreign newtype#}
withGenericBigEvent :: GenericBigEvent -> (Ptr GenericBigEvent -> IO b) -> IO b
{#pointer *ge_event_t as GenericBigEvent foreign newtype#}

-- | The XCB documentation seems to imply that this can also return
-- errors, so be careful.
waitForEvent :: Connection -> IO GenericEvent
waitForEvent c = withConnection c $ \cPtr -> do
                 evPtr <- {#call wait_for_event#} cPtr
                 liftM GenericEvent $ newForeignPtr finalizerFree evPtr

instance HasResponseType GenericEvent where
    responseType = eventResponseType

eventResponseType :: GenericEvent -> IO Int
eventResponseType ev = withGenericEvent ev $ \evPtr ->
                       liftM fromIntegral $ {#get generic_event_t->response_type#} evPtr

-- | The conversion is not checked.
unsafeToBigEvent :: GenericEvent -> GenericBigEvent
unsafeToBigEvent (GenericEvent ev) = GenericBigEvent . castForeignPtr $ ev

-- | The conversion is not checked.
unsafeToError :: GenericEvent -> GenericError
unsafeToError (GenericEvent ev) = GenericError . castForeignPtr $ ev

-- | In units of four bytes.  Extra +1 for the 'full_sequence' field
-- introduced when XCB decodes from the wire.
bigEventLength :: GenericBigEvent -> IO Word32
bigEventLength bge = withGenericBigEvent bge $ \bgePtr -> do
                     lenField <- fromIntegral `liftM` {#get ge_event_t->length#} bgePtr
                     return $ 8 + 1 + lenField

-- | Unsafe in that referential transperency may be broken -
-- the ByteString is aliased to the same memory location as the
-- the event.
unsafeEventData :: GenericEvent -> IO S.ByteString
unsafeEventData ge = do
  isErr <- isError ge
  if isErr then unsafeErrorData (unsafeToError ge) else do

  isBig <- isBigEvent ge
  if isBig
     then do
       let bge@(GenericBigEvent bgeFPtr) = unsafeToBigEvent ge
       len <- bigEventLength bge
       return $ S.fromForeignPtr (castForeignPtr bgeFPtr) 0 (4 * fromIntegral len)
     else
       let GenericEvent evFPtr = ge
       in return $ S.fromForeignPtr (castForeignPtr evFPtr) 0 32

-- Errors
withGenericError :: GenericError -> (Ptr GenericError -> IO b) -> IO b
{#pointer *generic_error_t as GenericError foreign newtype#}

requestCheck :: Connection -> Cookie -> IO (Maybe GenericError)
requestCheck c cookie
    = withConnection c $ \cPtr -> do
      errPtr <- xcb_request_check cPtr cookie
      if errPtr == nullPtr then return Nothing else do
      liftM (Just . GenericError) $ newForeignPtr finalizerFree errPtr

foreign import ccall xcb_request_check :: Ptr Connection -> Cookie -> IO (Ptr GenericError)

-- | The returned ByteString is aliased to the same memory
-- location as the GenericError.
unsafeErrorData :: GenericError -> IO S.ByteString
unsafeErrorData (GenericError errFPtr) =
    return $ S.fromForeignPtr (castForeignPtr errFPtr) 0 32

-- Replies
withGenericReply :: GenericReply -> (Ptr GenericReply -> IO b) -> IO b
{#pointer *generic_reply_t as GenericReply foreign newtype#}

-- | Returns the length of the reply in units of four bytes
replyLength :: GenericReply -> IO Word32
replyLength rep = withGenericReply rep $ \repPtr -> do
                  lenField <- liftM fromIntegral $ {#get generic_reply_t->length#} repPtr
                  return $ lenField + 1 -- for the inserted full_sequence field

instance HasResponseType GenericReply where
    responseType = replyResponseType

replyResponseType :: GenericReply -> IO Int
replyResponseType rep = withGenericReply rep $ \repPtr ->
                        liftM fromIntegral $ {#get generic_reply_t->response_type#} repPtr

-- | Unchecked conversion
unsafeReplyToError :: GenericReply -> GenericError
unsafeReplyToError (GenericReply rep) = GenericError . castForeignPtr $ rep

-- | The returned ByteString is aliased to the same memory
-- location as the 'GenericReply'
unsafeReplyData :: GenericReply -> IO S.ByteString
unsafeReplyData rep@(GenericReply repFPtr) = do
  len <- fromIntegral `liftM` replyLength rep
  return $ S.fromForeignPtr (castForeignPtr repFPtr) 0 (4*len)

-- Sending requests
withRequestInfo :: RequestInfo -> (Ptr RequestInfo -> IO b) -> IO b
{#pointer *protocol_request_t as RequestInfo foreign newtype#}

mkRequestInfo :: (Maybe Extension) -> CUInt -> Bool -> IO RequestInfo
mkRequestInfo ext opcode isVoid = do
      fptr <- mallocForeignPtrBytes {#sizeof protocol_request_t#}
      withForeignPtr fptr $ \rptr -> do
        {#set protocol_request_t->ext#} rptr $ maybe (Extension nullPtr) id ext
        {#set protocol_request_t->opcode#} rptr (fromIntegral opcode)
        {#set protocol_request_t->isvoid#} rptr (fromBool isVoid)
      return $ RequestInfo fptr

{#enum send_request_flags_t as RequestFlags {underscoreToCase} deriving(Eq, Show)#}

-- |Note: the 'count' field in the request info is always
-- over-written to the number of chunks in the ByteString
sendRequest :: Connection -> Int -> L.ByteString -> RequestInfo -> IO Cookie
sendRequest c flags bytes rInfo
    = withConnection c $ \cPtr ->
      withRequestInfo rInfo $ \rPtr ->
      withLazyByteString bytes $ \vec vecNum ->
      withIOVec vec $ \vecPtr -> do
      {#set protocol_request_t->count#} rPtr (fromIntegral vecNum)
      liftM (Cookie . fromIntegral) $ {#call send_request#} cPtr (fromIntegral flags) (castPtr vecPtr) rPtr

-- | Return 'Nothing' on failure, or the last request id on success.
-- This must be called before calling 'writev', as it indicates that you would
-- like full control of the write end of the connection socket.
takeSocket :: Connection
           -> FunPtr (Ptr () -> IO ())  -- ^ Callback to return socket
           -> Ptr ()                    -- ^ Callback argument
           -> Int                       -- ^ Request flags
           -> IO (Maybe Word64)
takeSocket c fn fnArg flags
    = withConnection c $ \cPtr ->
      alloca $ \countPtr -> do
      ret <- toBool <$> {#call take_socket#} cPtr fn fnArg (fromIntegral flags) countPtr
      countOpt <- if ret then Just . fromIntegral <$> peek countPtr else return Nothing
      return countOpt

-- | Write raw bytes to the connection socket. The count parameter
-- indicates the number of requests in this call. It is assumed
-- that 'takeSocket' has been called prior to calling this. We force the
-- spine of the lazy bytestring argument before consuming it, so watch
-- out for that.
writev :: Connection -> L.ByteString -> Word64 -> IO Bool
writev c bytes reqCount
    = withConnection c $ \cPtr ->
      withLazyByteString bytes $ \vec vecNum ->
      withIOVec vec $ \vecPtr ->
      toBool <$> {#call xcb_writev#} cPtr (castPtr vecPtr) (fromIntegral vecNum) (fromIntegral reqCount)

waitForReply :: Connection -> Cookie -> IO (Either GenericError GenericReply)
waitForReply c (Cookie request) =
    withConnection c $ \cPtr ->
    alloca $ \errPtrPtr -> do
    repPtr <- {#call wait_for_reply#} cPtr (fromIntegral request) errPtrPtr
    if repPtr == nullPtr then do
        errPtr <- peek errPtrPtr
        errFPtr <- newForeignPtr finalizerFree errPtr
        return . Left . GenericError $ errFPtr
     else do
       repFPtr <- newForeignPtr finalizerFree $ castPtr repPtr
       return . Right . GenericReply $ repFPtr

-- Other
generateId :: Connection -> IO Word32
generateId c = withConnection c $ \cPtr ->
               liftM fromIntegral $ {#call generate_id#} cPtr

-- Internal utils

-- | Create a 'Connection' from a reference.
-- The connection will be shut down when it goes out of scope.
mkConnection :: Ptr Connection -> IO Connection
mkConnection = liftM Connection . newForeignPtr finalizerDisconnect

-- | Creates a connection from an unsafe reference,
-- with no asociated finalzer.
-- Only use this if the Haskell code does not own the connection.
mkConnection_ :: Ptr Connection -> IO Connection
mkConnection_ = liftM Connection . newForeignPtr_

-- | A finalizer for a Ptr Connection which shuts down the connection
-- and frees all resources associated with it.
finalizerDisconnect :: FinalizerPtr Connection
finalizerDisconnect = xcb_disconnect

foreign import ccall "&xcb_disconnect" xcb_disconnect :: FunPtr (Ptr Connection -> IO ())

-- -*-haskell-*-

{-# LANGUAGE
   StandaloneDeriving
  ,GeneralizedNewtypeDeriving
  #-}

module Graphics.X11.Xcb.Internal where

import Control.Monad
import Foreign
import Foreign.C.String
import Foreign.C.Types

import qualified Data.ByteString as S
import qualified Data.ByteString.Internal as S
import qualified Data.ByteString.Lazy as L

{#import Foreign.IOVec#}

#include <xcb/xcb.h>
#include <xcb/xcbext.h>

peekIntConv
    :: (Integral a, Num b, Storable a)
       => Ptr a -> IO b
peekIntConv ptr = fromIntegral `liftM` peek ptr

{-
  Welcome to my sometimes-dodgy FFI bindings to XCB.
  The idea isn't really to write something to directly
  write X apps with, but to write a foundation for
  something higher-level and safer.

  So referential transparency can definetly be abused
  with a lot of the calls in here.

  So don't do it.
 -}

{#context lib="xcb" prefix="xcb_"#}

withConnection :: Connection -> (Ptr Connection -> IO b) -> IO b
{#pointer *connection_t as Connection foreign newtype#}
{#pointer *setup_t as Setup newtype#} -- no finalizer, part of the Connection

-- | Returns a connection to the indicated X server, as well
-- as the screen connected to.
-- The passed in string may be null, in which case
-- it will be the same as passing in the DISPLAY environment
-- variable.
connect :: String -> IO (Maybe (Connection, Int))
connect display
    = withCString display $ \displayPtr ->
      alloca $ \screenPtr -> do

      cPtr <- {#call connect as connect_#} displayPtr screenPtr
      screen <- peekIntConv screenPtr

      if cPtr == nullPtr then return Nothing else do

      c <- mkConnection cPtr
      return $ Just (c, screen)

-- | Parse the host, display and screen from a string.
-- The same as what we would do if the string were
-- passed to 'connect'.
parseDisplay :: String -> IO (Maybe (String, Int, Int))
parseDisplay display
    = withCString display $ \displayPtr ->
      alloca $ \hostStringPtr ->
      alloca $ \displayNumPtr ->
      alloca $ \screenPtr -> do
      success <- liftM toBool $
                 {#call unsafe parse_display#} displayPtr hostStringPtr displayNumPtr screenPtr
      if not success then return Nothing else do

      host <- peek hostStringPtr >>= peekCString
      peek hostStringPtr >>= free

      displayNum <- peekIntConv displayNumPtr
      screen <- peekIntConv screenPtr

      return $ Just (host, displayNum, screen)

-- | Flush the write buffers.
flush :: Connection -> IO Bool
flush c = withConnection c $ \cPtr ->
          liftM toBool $ {#call flush as flush_#} cPtr

-- | The memory backing this data structure is owned
-- by the passed in Connection - and will magicaly vanish
-- if your 'Connection' gets GCd before the return value
-- of this function.  Watch out.
unsafeGetSetup :: Connection -> IO Setup
unsafeGetSetup c = withConnection c $ \cPtr ->
                   {#call unsafe get_setup#} cPtr

-- | Length of the setup data in units of four bytes.
setupLength :: Setup -> IO Word16
setupLength (Setup s) = liftM fromIntegral $ {#get setup_t->length#} s

-- | This ByteString is just as unsafe as the passed in connection
-- object.  Please make a copy.
unsafeSetupData :: Setup -> IO S.ByteString
unsafeSetupData s@(Setup sPtr) = do
  len <- liftM (4*) $ setupLength s
  sFPtr <- newForeignPtr_ sPtr
  return $ S.fromForeignPtr (castForeignPtr sFPtr) 0 (fromIntegral len)

-- | Maximum size of a single request.
-- May not be an asynchronous call, as we'll make a call out
-- on the big-requests extension to find out if we can use that.
maximumRequestLength :: Connection -> IO Word32
maximumRequestLength c = withConnection c $ \cPtr ->
                         liftM fromIntegral $ {#call get_maximum_request_length#} cPtr

-- | Asynchronous version of 'maximumRequestLength'.  The return
-- from the server is cached for subsequent callse to 'maximumRequestLength'.
prefetchMaximumReuestLength :: Connection -> IO ()
prefetchMaximumReuestLength c = withConnection c $ \cPtr ->
                                {#call prefetch_maximum_request_length#} cPtr

-- | Is the connection in an error state?
connectionHasError :: Connection -> IO Bool
connectionHasError c = withConnection c $ \cPtr ->
                       liftM toBool $ {#call connection_has_error#} cPtr

newtype Cookie = Cookie CUInt

-- Working with extensions
{#pointer *extension_t as Extension newtype#} -- static data, no finalizer

-- :-(
instance Storable Extension where
    sizeOf (Extension ex) = sizeOf ex
    alignment (Extension ex) = alignment ex
    peekElemOff ptr off = liftM Extension $ peekElemOff (castPtr ptr) off
    pokeElemOff ptr off (Extension ex) = pokeElemOff (castPtr ptr) off ex
    peekByteOff ptr off = liftM Extension $ peekByteOff ptr off
    pokeByteOff ptr off (Extension ex) = pokeByteOff ptr off ex
    peek ptr = liftM Extension $ peek (castPtr ptr)
    poke ptr (Extension ex) = poke (castPtr ptr) ex

{#pointer *query_extension_reply_t as ExtensionInfo newtype#} -- freed with Connection, no finalizer

-- | May block if the data is not already cached.  For internal
-- use only - make a copy if you need something that will live
-- longer than the scope of the connection.
unsafeGetExtensionData :: Connection -> Extension -> IO ExtensionInfo
unsafeGetExtensionData c ext
    = withConnection c $ \cPtr ->
      {#call get_extension_data#} cPtr ext

extensionPresent :: ExtensionInfo -> IO Bool
extensionPresent (ExtensionInfo ext)
    = liftM toBool $ {#get query_extension_reply_t->present#} ext

extensionMajorOpcode :: ExtensionInfo -> IO Word8
extensionMajorOpcode (ExtensionInfo ext)
    = liftM fromIntegral $ {#get query_extension_reply_t->major_opcode#} ext

extensionFirstEvent :: ExtensionInfo -> IO Word8
extensionFirstEvent (ExtensionInfo ext)
    = liftM fromIntegral $ {#get query_extension_reply_t->first_event#} ext

extensionFirstError :: ExtensionInfo -> IO Word8
extensionFirstError (ExtensionInfo ext)
    = liftM fromIntegral $ {#get query_extension_reply_t->first_error#} ext

-- | Non-blocking query for extension data
prefetchExtension :: Connection -> Extension -> IO ()
prefetchExtension c ext
    = withConnection c $ \cPtr ->
      {#call prefetch_extension_data#} cPtr ext

class HasResponseType a where
    responseType :: a -> IO Int

isBigEvent :: HasResponseType a => a -> IO Bool
isBigEvent ev = (== 35) `liftM` responseType ev

isError :: HasResponseType a => a -> IO Bool
isError ev = (== 2) `liftM` responseType ev

-- Events
withGenericEvent :: GenericEvent -> (Ptr GenericEvent -> IO b) -> IO b
{#pointer *generic_event_t as GenericEvent foreign newtype#}
withGenericBigEvent :: GenericBigEvent -> (Ptr GenericBigEvent -> IO b) -> IO b
{#pointer *ge_event_t as GenericBigEvent foreign newtype#}

-- | The XCB documentation seems to imply that this can also return
-- errors, so be careful.
waitForEvent :: Connection -> IO GenericEvent
waitForEvent c = withConnection c $ \cPtr -> do
                 evPtr <- {#call wait_for_event#} cPtr
                 liftM GenericEvent $ newForeignPtr finalizerFree evPtr

instance HasResponseType GenericEvent where
    responseType = eventResponseType

eventResponseType :: GenericEvent -> IO Int
eventResponseType ev = withGenericEvent ev $ \evPtr ->
                       liftM fromIntegral $ {#get generic_event_t->response_type#} evPtr

-- | The conversion is not checked.
unsafeToBigEvent :: GenericEvent -> GenericBigEvent
unsafeToBigEvent (GenericEvent ev) = GenericBigEvent . castForeignPtr $ ev

-- | The conversion is not checked.
unsafeToError :: GenericEvent -> GenericError
unsafeToError (GenericEvent ev) = GenericError . castForeignPtr $ ev

-- | In units of four bytes.  Extra +1 for the 'full_sequence' field
-- introduced when XCB decodes from the wire.
bigEventLength :: GenericBigEvent -> IO Word32
bigEventLength bge = withGenericBigEvent bge $ \bgePtr -> do
                     lenField <- fromIntegral `liftM` {#get ge_event_t->length#} bgePtr
                     return $ 8 + 1 + lenField

-- | Unsafe in that referential transperency may be broken -
-- the ByteString is aliased to the same memory location as the
-- the event.
unsafeEventData :: GenericEvent -> IO S.ByteString
unsafeEventData ge = do
  isErr <- isError ge
  if isErr then unsafeErrorData (unsafeToError ge) else do

  isBig <- isBigEvent ge
  if isBig
     then do
       let bge@(GenericBigEvent bgeFPtr) = unsafeToBigEvent ge
       len <- bigEventLength bge
       return $ S.fromForeignPtr (castForeignPtr bgeFPtr) 0 (4 * fromIntegral len)
     else
       let GenericEvent evFPtr = ge
       in return $ S.fromForeignPtr (castForeignPtr evFPtr) 0 32

-- Errors
withGenericError :: GenericError -> (Ptr GenericError -> IO b) -> IO b
{#pointer *generic_error_t as GenericError foreign newtype#}

requestCheck :: Connection -> Cookie -> IO (Maybe GenericError)
requestCheck c cookie
    = withConnection c $ \cPtr -> do
      errPtr <- xcb_request_check cPtr cookie
      if errPtr == nullPtr then return Nothing else do
      liftM (Just . GenericError) $ newForeignPtr finalizerFree errPtr

foreign import ccall xcb_request_check :: Ptr Connection -> Cookie -> IO (Ptr GenericError)

-- | The returned ByteString is aliased to the same memory
-- location as the GenericError.
unsafeErrorData :: GenericError -> IO S.ByteString
unsafeErrorData (GenericError errFPtr) =
    return $ S.fromForeignPtr (castForeignPtr errFPtr) 0 32

-- Replies
withGenericReply :: GenericReply -> (Ptr GenericReply -> IO b) -> IO b
{#pointer *generic_reply_t as GenericReply foreign newtype#}

-- | Returns the length of the reply in units of four bytes
replyLength :: GenericReply -> IO Word32
replyLength rep = withGenericReply rep $ \repPtr -> do
                  lenField <- liftM fromIntegral $ {#get generic_reply_t->length#} repPtr
                  return $ lenField + 1 -- for the inserted full_sequence field

instance HasResponseType GenericReply where
    responseType = replyResponseType

replyResponseType :: GenericReply -> IO Int
replyResponseType rep = withGenericReply rep $ \repPtr ->
                        liftM fromIntegral $ {#get generic_reply_t->response_type#} repPtr

-- | Unchecked conversion
unsafeReplyToError :: GenericReply -> GenericError
unsafeReplyToError (GenericReply rep) = GenericError . castForeignPtr $ rep

-- | The returned ByteString is aliased to the same memory
-- location as the 'GenericReply'
unsafeReplyData :: GenericReply -> IO S.ByteString
unsafeReplyData rep@(GenericReply repFPtr) = do
  len <- fromIntegral `liftM` replyLength rep
  return $ S.fromForeignPtr (castForeignPtr repFPtr) 0 (4*len)

-- Sending requests
withRequestInfo :: RequestInfo -> (Ptr RequestInfo -> IO b) -> IO b
{#pointer *protocol_request_t as RequestInfo foreign newtype#}

mkRequestInfo :: (Maybe Extension) -> CUInt -> Bool -> IO RequestInfo
mkRequestInfo ext opcode isVoid = do
      fptr <- mallocForeignPtrBytes {#sizeof protocol_request_t#}
      withForeignPtr fptr $ \rptr -> do
        {#set protocol_request_t->ext#} rptr $ maybe (Extension nullPtr) id ext
        {#set protocol_request_t->opcode#} rptr (fromIntegral opcode)
        {#set protocol_request_t->isvoid#} rptr (fromBool isVoid)
      return $ RequestInfo fptr

{#enum send_request_flags_t as RequestFlags {underscoreToCase} deriving(Eq, Show)#}

-- |Note: the 'count' field in the request info is always
-- over-written to the number of chunks in the ByteString
sendRequest :: Connection -> Int -> L.ByteString -> RequestInfo -> IO Cookie
sendRequest c flags bytes rInfo
    = withConnection c $ \cPtr ->
      withRequestInfo rInfo $ \rPtr ->
      withLazyByteString bytes $ \vec vecNum ->
      withIOVec vec $ \vecPtr -> do
      {#set protocol_request_t->count#} rPtr (fromIntegral vecNum)
      liftM (Cookie . fromIntegral) $ {#call send_request#} cPtr (fromIntegral flags) (castPtr vecPtr) rPtr

waitForReply :: Connection -> Cookie -> IO (Either GenericError GenericReply)
waitForReply c (Cookie request) =
    withConnection c $ \cPtr ->
    alloca $ \errPtrPtr -> do
    repPtr <- {#call wait_for_reply#} cPtr (fromIntegral request) errPtrPtr
    if repPtr == nullPtr then do
        errPtr <- peek errPtrPtr
        errFPtr <- newForeignPtr finalizerFree errPtr
        return . Left . GenericError $ errFPtr
     else do
       repFPtr <- newForeignPtr finalizerFree $ castPtr repPtr
       return . Right . GenericReply $ repFPtr

-- Other
generateId :: Connection -> IO Word32
generateId c = withConnection c $ \cPtr ->
               liftM fromIntegral $ {#call generate_id#} cPtr

-- Internal utils

-- | Create a 'Connection' from a reference.
-- The connection will be shut down when it goes out of scope.
mkConnection :: Ptr Connection -> IO Connection
mkConnection = liftM Connection . newForeignPtr finalizerDisconnect

-- | Creates a connection from an unsafe reference,
-- with no asociated finalzer.
-- Only use this if the Haskell code does not own the connection.
mkConnection_ :: Ptr Connection -> IO Connection
mkConnection_ = liftM Connection . newForeignPtr_

-- | A finalizer for a Ptr Connection which shuts down the connection
-- and frees all resources associated with it.
finalizerDisconnect :: FinalizerPtr Connection
finalizerDisconnect = xcb_disconnect

foreign import ccall "&xcb_disconnect" xcb_disconnect :: FunPtr (Ptr Connection -> IO ())


Replace deprecated #import with #include

module Database.HyperDex.Internal.Space
  ( addSpace, removeSpace
  )
  where

{#import Database.HyperDex.Internal.Client #}
{#import Database.HyperDex.Internal.ReturnCode #}
import Database.HyperDex.Internal.Util

#include "hyperclient.h"

addSpace :: Client -> ByteString -> IO ReturnCode
addSpace c desc  = withClientImmediate c $ \hc -> do
  hyperclientAddSpace hc desc

removeSpace :: Client -> ByteString -> IO ReturnCode
removeSpace c name = withClientImmediate c $ \hc -> do
  hyperclientRemoveSpace hc name

-- enum hyperclient_returncode
-- hyperclient_add_space(struct hyperclient* client, const char* description);
hyperclientAddSpace :: Hyperclient -> ByteString -> IO ReturnCode
hyperclientAddSpace client d = withCBString d $ \description -> do
  fmap (toEnum . fromIntegral) $ {#call hyperclient_add_space #} client description

-- enum hyperclient_returncode
-- hyperclient_rm_space(struct hyperclient* client, const char* space);
hyperclientRemoveSpace :: Hyperclient -> ByteString -> IO ReturnCode
hyperclientRemoveSpace client s = withCBString s $ \space -> do
  fmap (toEnum . fromIntegral) $ {#call hyperclient_rm_space #} client space

module Database.HyperDex.Internal.Space
  ( addSpace, removeSpace
  )
  where

{#import Database.HyperDex.Internal.Client #}
{#import Database.HyperDex.Internal.ReturnCode #}
import Database.HyperDex.Internal.Util

#import "hyperclient.h"

addSpace :: Client -> ByteString -> IO ReturnCode
addSpace c desc  = withClientImmediate c $ \hc -> do
  hyperclientAddSpace hc desc

removeSpace :: Client -> ByteString -> IO ReturnCode
removeSpace c name = withClientImmediate c $ \hc -> do
  hyperclientRemoveSpace hc name

-- enum hyperclient_returncode
-- hyperclient_add_space(struct hyperclient* client, const char* description);
hyperclientAddSpace :: Hyperclient -> ByteString -> IO ReturnCode
hyperclientAddSpace client d = withCBString d $ \description -> do
  fmap (toEnum . fromIntegral) $ {#call hyperclient_add_space #} client description

-- enum hyperclient_returncode
-- hyperclient_rm_space(struct hyperclient* client, const char* space);
hyperclientRemoveSpace :: Hyperclient -> ByteString -> IO ReturnCode
hyperclientRemoveSpace client s = withCBString s $ \space -> do
  fmap (toEnum . fromIntegral) $ {#call hyperclient_rm_space #} client space


additional error strings for cuda-3.0

additional error strings for cuda-3.0

Ignore-this: 6c350bc3b9ba31f7acb78a47a58fe594

darcs-hash:20100413035338-dcabc-1f3b1a688a58fecbcfb12ee4bf2e307fc81fed4e.gz

{-# LANGUAGE DeriveDataTypeable #-}
--------------------------------------------------------------------------------
-- |
-- Module    : Foreign.CUDA.Driver.Error
-- Copyright : (c) [2009..2010] Trevor L. McDonell
-- License   : BSD
--
-- Error handling
--
--------------------------------------------------------------------------------

module Foreign.CUDA.Driver.Error
  where

-- System
import Data.Typeable
import Control.Exception.Extensible

#include <cuda.h>
{# context lib="cuda" #}

--------------------------------------------------------------------------------
-- Return Status
--------------------------------------------------------------------------------

--
-- Error Codes
--
{# enum CUresult as Status
    { underscoreToCase
    , CUDA_SUCCESS as Success
    , CUDA_ERROR_NO_BINARY_FOR_GPU as NoBinaryForGPU }
    with prefix="CUDA_ERROR" deriving (Eq, Show) #}

-- |
-- Return a descriptive error string associated with a particular error code
--
describe :: Status -> String
describe Success                     = "no error"
describe InvalidValue                = "invalid argument"
describe OutOfMemory                 = "out of memory"
describe NotInitialized              = "driver not initialised"
describe Deinitialized               = "driver deinitialised"
describe NoDevice                    = "no CUDA-capable device is available"
describe InvalidDevice               = "invalid device ordinal"
describe InvalidImage                = "invalid kernel image"
describe InvalidContext              = "invalid context handle"
describe ContextAlreadyCurrent       = "context already current"
describe MapFailed                   = "map failed"
describe UnmapFailed                 = "unmap failed"
describe ArrayIsMapped               = "array is mapped"
describe AlreadyMapped               = "already mapped"
describe NoBinaryForGPU              = "no binary available for this GPU"
describe AlreadyAcquired             = "resource already acquired"
describe NotMapped                   = "not mapped"
describe InvalidSource               = "invalid source"
describe FileNotFound                = "file not found"
describe InvalidHandle               = "invalid handle"
describe NotFound                    = "not found"
describe NotReady                    = "device not ready"
describe LaunchFailed                = "unspecified launch failure"
describe LaunchOutOfResources        = "too many resources requested for launch"
describe LaunchTimeout               = "the launch timed out and was terminated"
describe LaunchIncompatibleTexturing = "launch with incompatible texturing"
#if CUDA_VERSION >= 3000
describe NotMappedAsArray            = "mapped resource not available for access as an array"
describe NotMappedAsPointer          = "mapped resource not available for access as a pointer"
describe EccUncorrectable            = "uncorrectable ECC error detected"
describe PointerIs64bit              = "attempt to retrieve a 64-bit pointer via a 32-bit API function"
describe SizeIs64bit                 = "attempt to retrieve 64-bit size via a 32-bit API function"
#endif
describe Unknown                     = "unknown error"

--------------------------------------------------------------------------------
-- Exceptions
--------------------------------------------------------------------------------

data CUDAException
  = ExitCode Status
  | UserError String
  deriving Typeable

instance Exception CUDAException

instance Show CUDAException where
  showsPrec _ (ExitCode  s) = showString ("CUDA Exception: " ++ describe s)
  showsPrec _ (UserError s) = showString ("CUDA Exception: " ++ s)

-- |
-- Raise a CUDAException in the IO Monad
--
cudaError :: String -> IO a
cudaError s = throwIO (UserError s)

-- |
-- Run a CUDA computation
--
{-
runCUDA f = runEMT $ do
  f `catchWithSrcLoc` \l e -> lift (handle l e)
  where
    handle :: CallTrace -> CUDAException -> IO ()
    handle l e = putStrLn $ showExceptionWithTrace l e
-}

--------------------------------------------------------------------------------
-- Helper Functions
--------------------------------------------------------------------------------

-- |
-- Return the results of a function on successful execution, otherwise throw an
-- exception with an error string associated with the return code
--
resultIfOk :: (Status, a) -> IO a
resultIfOk (status,result) =
    case status of
        Success -> return  result
        _       -> throwIO (ExitCode status)

-- |
-- Throw an exception with an error string associated with an unsuccessful
-- return code, otherwise return unit.
--
nothingIfOk :: Status -> IO ()
nothingIfOk status =
    case status of
        Success -> return  ()
        _       -> throwIO (ExitCode status)

{-# LANGUAGE DeriveDataTypeable #-}
--------------------------------------------------------------------------------
-- |
-- Module    : Foreign.CUDA.Driver.Error
-- Copyright : (c) [2009..2010] Trevor L. McDonell
-- License   : BSD
--
-- Error handling
--
--------------------------------------------------------------------------------

module Foreign.CUDA.Driver.Error
  where

-- System
import Data.Typeable
import Control.Exception.Extensible

#include <cuda.h>
{# context lib="cuda" #}

--------------------------------------------------------------------------------
-- Return Status
--------------------------------------------------------------------------------

--
-- Error Codes
--
{# enum CUresult as Status
    { underscoreToCase
    , CUDA_SUCCESS as Success
    , CUDA_ERROR_NO_BINARY_FOR_GPU as NoBinaryForGPU }
    with prefix="CUDA_ERROR" deriving (Eq, Show) #}

-- |
-- Return a descriptive error string associated with a particular error code
--
describe :: Status -> String
describe Success                     = "no error"
describe InvalidValue                = "invalid argument"
describe OutOfMemory                 = "out of memory"
describe NotInitialized              = "driver not initialised"
describe Deinitialized               = "driver deinitialised"
describe NoDevice                    = "no CUDA-capable device is available"
describe InvalidDevice               = "invalid device ordinal"
describe InvalidImage                = "invalid kernel image"
describe InvalidContext              = "invalid context handle"
describe ContextAlreadyCurrent       = "context already current"
describe MapFailed                   = "map failed"
describe UnmapFailed                 = "unmap failed"
describe ArrayIsMapped               = "array is mapped"
describe AlreadyMapped               = "already mapped"
describe NoBinaryForGPU              = "no binary available for this GPU"
describe AlreadyAcquired             = "resource already acquired"
describe NotMapped                   = "not mapped"
describe InvalidSource               = "invalid source"
describe FileNotFound                = "file not found"
describe InvalidHandle               = "invalid handle"
describe NotFound                    = "not found"
describe NotReady                    = "device not ready"
describe LaunchFailed                = "unspecified launch failure"
describe LaunchOutOfResources        = "too many resources requested for launch"
describe LaunchTimeout               = "the launch timed out and was terminated"
describe LaunchIncompatibleTexturing = "launch with incompatible texturing"
describe Unknown                     = "unknown error"

--------------------------------------------------------------------------------
-- Exceptions
--------------------------------------------------------------------------------

data CUDAException
  = ExitCode Status
  | UserError String
  deriving Typeable

instance Exception CUDAException

instance Show CUDAException where
  showsPrec _ (ExitCode  s) = showString ("CUDA Exception: " ++ describe s)
  showsPrec _ (UserError s) = showString ("CUDA Exception: " ++ s)

-- |
-- Raise a CUDAException in the IO Monad
--
cudaError :: String -> IO a
cudaError s = throwIO (UserError s)

-- |
-- Run a CUDA computation
--
{-
runCUDA f = runEMT $ do
  f `catchWithSrcLoc` \l e -> lift (handle l e)
  where
    handle :: CallTrace -> CUDAException -> IO ()
    handle l e = putStrLn $ showExceptionWithTrace l e
-}

--------------------------------------------------------------------------------
-- Helper Functions
--------------------------------------------------------------------------------

-- |
-- Return the results of a function on successful execution, otherwise throw an
-- exception with an error string associated with the return code
--
resultIfOk :: (Status, a) -> IO a
resultIfOk (status,result) =
    case status of
        Success -> return  result
        _       -> throwIO (ExitCode status)

-- |
-- Throw an exception with an error string associated with an unsuccessful
-- return code, otherwise return unit.
--
nothingIfOk :: Status -> IO ()
nothingIfOk status =
    case status of
        Success -> return  ()
        _       -> throwIO (ExitCode status)


CLong -> CLLong

CLong -> CLLong

{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ForeignFunctionInterface #-}

#include "bindings.h"

module GDAL.Internal.OGRFeature (
    FieldType (..)
  , Field
  , Feature (..)
  , FeatureH
  , FieldDefnH (..)
  , FeatureDefnH (..)
  , Justification (..)

  , FeatureDef (..)
  , GeomFieldDef (..)
  , FieldDef (..)

  , fieldDef
  , featureToHandle
  , featureFromHandle

  , withFeatureH
  , withFieldDefnH
  , fieldDefFromHandle
  , featureDefFromHandle
#if MULTI_GEOM_FIELDS
  , GeomFieldDefnH (..)
  , withGeomFieldDefnH
#endif
) where

{#context lib = "gdal" prefix = "OGR" #}

import Control.Applicative ((<$>), (<*>), pure)
import Control.Monad (liftM, (>=>), (<=<), when)
import Control.Monad.Catch (bracket)
import Control.Monad.IO.Class (MonadIO(liftIO))

import Data.ByteString (ByteString)
import Data.ByteString.Char8 (packCStringLen)
import Data.Int (Int32, Int64)
import Data.Monoid (mempty)
import Data.Text (Text)
import Data.Time.LocalTime (
    LocalTime(..)
  , TimeOfDay(..)
  , ZonedTime(..)
  , getCurrentTimeZone
  , minutesToTimeZone
  , utc
  )
import Data.Time ()
import Data.Time.Calendar (Day, fromGregorian)
import qualified Data.Vector.Storable as St
import qualified Data.Vector.Storable.Mutable as Stm
import qualified Data.Vector as V

import Foreign.C.Types (
    CInt(..)
  , CLLong(..)
  , CDouble(..)
  , CChar(..)
  , CUChar(..)
  )
import Foreign.ForeignPtr (
    ForeignPtr
  , FinalizerPtr
  , withForeignPtr
  )
import Foreign.Marshal.Alloc (alloca)
import Foreign.Marshal.Utils (copyBytes)
import Foreign.Ptr (Ptr, castPtr)
import Foreign.Storable (Storable, sizeOf, peek, peekElemOff)

import GDAL.Internal.Types
import GDAL.Internal.Util (
    toEnumC
  , fromEnumC
  , peekEncodedCString
  , useAsEncodedCString
  )
{#import GDAL.Internal.OSR #}
{#import GDAL.Internal.CPLError #}
{#import GDAL.Internal.OGRGeometry #}
{#import GDAL.Internal.OGRError #}

#include "gdal.h"
#include "ogr_core.h"
#include "ogr_api.h"
#include "cpl_string.h"

{#enum FieldType {} omit (OFTMaxType) deriving (Eq,Show,Read,Bounded) #}

{#enum Justification  {}
    omit (JustifyUndefined)
    with prefix = "OJ"
    add  prefix = "Justify"
    deriving (Eq,Show,Read,Bounded) #}

data Field
  = OGRInteger       {-# UNPACK #-} !Int32
  | OGRIntegerList   {-# UNPACK #-} !(St.Vector Int32)
  | OGRInteger64     {-# UNPACK #-} !Int64
  | OGRInteger64List {-# UNPACK #-} !(St.Vector Int64)
  | OGRReal          {-# UNPACK #-} !Double
  | OGRRealList      {-# UNPACK #-} !(St.Vector Double)
  | OGRString        {-# UNPACK #-} !Text
  | OGRStringList    {-# UNPACK #-} !(V.Vector Text)
  | OGRBinary        {-# UNPACK #-} !ByteString
  | OGRDateTime      {-# UNPACK #-} !ZonedTime
  | OGRDate          {-# UNPACK #-} !Day
  | OGRTime          {-# UNPACK #-} !TimeOfDay
  deriving (Show)

data FieldDef
  = FieldDef {
      fldName  :: {-# UNPACK #-} !Text
    , fldType  :: {-# UNPACK #-} !FieldType
    , fldWidth :: {-# UNPACK #-} !(Maybe Int)
    , fldPrec  :: {-# UNPACK #-} !(Maybe Int)
    , fldJust  :: {-# UNPACK #-} !(Maybe Justification)
    } deriving (Show, Eq)

fieldDef :: FieldType -> Text -> FieldDef
fieldDef ftype name = FieldDef name ftype Nothing Nothing Nothing

data Feature
  = Feature {
      fId      :: {-# UNPACK #-} !Int64
    , fFields  :: {-# UNPACK #-} !(V.Vector Field)
    , fGeoms   :: {-# UNPACK #-} !(V.Vector Geometry)
    } deriving (Show)

data FeatureDef
  = FeatureDef {
      fdName    :: {-# UNPACK #-} !Text
    , fdFields  :: {-# UNPACK #-} !(V.Vector FieldDef)
    , fdGeom    :: {-# UNPACK #-} !GeomFieldDef
    , fdGeoms   :: {-# UNPACK #-} !(V.Vector GeomFieldDef)
    } deriving (Show, Eq)

data GeomFieldDef
  = GeomFieldDef {
      gfdName  :: {-# UNPACK #-} !Text
    , gfdType  :: {-# UNPACK #-} !GeometryType
    , gfdSrs   :: {-# UNPACK #-} !(Maybe SpatialReference)
    } deriving (Show, Eq)

{#pointer FeatureH foreign finalizer OGR_F_Destroy as ^ newtype#}
{#pointer FieldDefnH   newtype#}
{#pointer FeatureDefnH newtype#}

withFieldDefnH :: FieldDef -> (FieldDefnH -> IO a) -> IO a
withFieldDefnH FieldDef{..} f =
  useAsEncodedCString fldName $ \pName ->
  bracket ({#call unsafe OGR_Fld_Create as ^#} pName (fromEnumC fldType))
          ({#call unsafe OGR_Fld_Destroy as ^#}) (\p -> populate p >> f p)
  where
    populate h = do
      case fldWidth of
        Just w  -> {#call unsafe OGR_Fld_SetWidth as ^#} h (fromIntegral w)
        Nothing -> return ()
      case fldPrec of
        Just p  -> {#call unsafe OGR_Fld_SetPrecision as ^#} h (fromIntegral p)
        Nothing -> return ()
      case fldJust of
        Just j  -> {#call unsafe OGR_Fld_SetJustify as ^#} h (fromEnumC j)
        Nothing -> return ()

fieldDefFromHandle :: FieldDefnH -> IO FieldDef
fieldDefFromHandle p =
  FieldDef
    <$> getFieldName p
    <*> liftM toEnumC ({#call unsafe OGR_Fld_GetType as ^#} p)
    <*> liftM iToMaybe ({#call unsafe OGR_Fld_GetWidth as ^#} p)
    <*> liftM iToMaybe ({#call unsafe OGR_Fld_GetPrecision as ^#} p)
    <*> liftM jToMaybe ({#call unsafe OGR_Fld_GetJustify as ^#} p)
  where
    iToMaybe = (\v -> if v==0 then Nothing else Just (fromIntegral v))
    jToMaybe = (\j -> if j==0 then Nothing else Just (toEnumC j))

featureDefFromHandle :: GeomFieldDef -> FeatureDefnH -> IO FeatureDef
featureDefFromHandle gfd p =
  FeatureDef
    <$> ({#call unsafe OGR_FD_GetName as ^#} p >>= peekEncodedCString)
    <*> fieldDefsFromFeatureDefnH p
    <*> pure gfd
    <*> geomFieldDefsFromFeatureDefnH p
  where

fieldDefsFromFeatureDefnH :: FeatureDefnH -> IO (V.Vector FieldDef)
fieldDefsFromFeatureDefnH p = do
  nFields <- {#call unsafe OGR_FD_GetFieldCount as ^#} p
  V.generateM (fromIntegral nFields) $
    fieldDefFromHandle <=<
      ({#call unsafe OGR_FD_GetFieldDefn as ^#} p . fromIntegral)

geomFieldDefsFromFeatureDefnH :: FeatureDefnH -> IO (V.Vector GeomFieldDef)

#if MULTI_GEOM_FIELDS

{#pointer GeomFieldDefnH newtype#}

geomFieldDefsFromFeatureDefnH p = do
  nFields <- {#call unsafe OGR_FD_GetGeomFieldCount as ^#} p
  V.generateM (fromIntegral (nFields-1)) $
    gFldDef <=< ( {#call unsafe OGR_FD_GetGeomFieldDefn as ^#} p
                . (+1)
                . fromIntegral
                )
  where
    gFldDef g =
      GeomFieldDef
        <$> ({#call unsafe OGR_GFld_GetNameRef as ^#} g >>= peekEncodedCString)
        <*> liftM toEnumC ({#call unsafe OGR_GFld_GetType as ^#} g)
        <*> ({#call unsafe OGR_GFld_GetSpatialRef as ^#} g >>=
          maybeNewSpatialRefBorrowedHandle)

withGeomFieldDefnH :: GeomFieldDef -> (GeomFieldDefnH -> IO a) -> IO a
withGeomFieldDefnH GeomFieldDef{..} f =
  useAsEncodedCString gfdName $ \pName ->
  bracket ({#call unsafe OGR_GFld_Create as ^#} pName (fromEnumC gfdType))
          ({#call unsafe OGR_GFld_Destroy as ^#}) (\p -> populate p >> f p)
  where
    populate = withMaybeSpatialReference gfdSrs .
                 {#call unsafe OGR_GFld_SetSpatialRef as ^#}
#else
-- | GDAL < 1.11 only supports 1 geometry field and associates it the layer
geomFieldDefsFromFeatureDefnH = const (return V.empty)
#endif

featureToHandle :: FeatureDef   -> Feature -> GDAL s FeatureH
featureToHandle = undefined

featureFromHandle :: FeatureDef -> FeatureH -> GDAL s Feature
featureFromHandle = undefined

getFieldBy :: FieldType -> Text -> CInt -> Ptr FeatureH -> IO Field

getFieldBy OFTInteger _ ix f
  = liftM (OGRInteger . fromIntegral)
    ({#call unsafe OGR_F_GetFieldAsInteger as ^#} f ix)

getFieldBy OFTIntegerList _ ix f = alloca $ \lenP -> do
  buf <- {#call unsafe OGR_F_GetFieldAsIntegerList as ^#} f ix lenP
  nElems <- peekIntegral lenP
  vec <- Stm.new nElems
  Stm.unsafeWith vec $ \vP ->
    copyBytes vP (buf :: Ptr CInt) (nElems * sizeOf (undefined :: CInt))
  liftM OGRIntegerList (St.unsafeFreeze (Stm.unsafeCast vec))

#if (GDAL_VERSION_MAJOR >= 2)
getFieldBy OFTInteger64 _ ix f
  = liftM (OGRInteger64 . fromIntegral)
    ({#call unsafe OGR_F_GetFieldAsInteger64 as ^#} f ix)

getFieldBy OFTInteger64List _ ix f = alloca $ \lenP -> do
  buf <- {#call unsafe OGR_F_GetFieldAsInteger64List as ^#} f ix lenP
  nElems <- peekIntegral lenP
  vec <- Stm.new nElems
  Stm.unsafeWith vec $ \vP ->
    copyBytes vP (buf :: Ptr CLLong) (nElems * sizeOf (undefined :: CLLong))
  liftM OGRInteger64List (St.unsafeFreeze (Stm.unsafeCast vec))
#endif

getFieldBy OFTReal _ ix f
  = liftM (OGRReal . realToFrac)
    ({#call unsafe OGR_F_GetFieldAsDouble as ^#} f ix)

getFieldBy OFTRealList _ ix f = alloca $ \lenP -> do
  buf <- {#call unsafe OGR_F_GetFieldAsDoubleList as ^#} f ix lenP
  nElems <- peekIntegral lenP
  vec <- Stm.new nElems
  Stm.unsafeWith vec $ \vP ->
     copyBytes vP (buf :: Ptr CDouble) (nElems * sizeOf (undefined :: CDouble))
  liftM OGRRealList (St.unsafeFreeze (Stm.unsafeCast vec))

getFieldBy OFTString _ ix f = liftM OGRString
  (({#call unsafe OGR_F_GetFieldAsString as ^#} f ix) >>= peekEncodedCString)

getFieldBy OFTWideString fname ix f = getFieldBy OFTString fname ix f

getFieldBy OFTStringList _ ix f = liftM OGRStringList $ do
  ptr <- {#call unsafe OGR_F_GetFieldAsStringList as ^#} f ix
  nElems <- liftM fromIntegral ({#call unsafe CSLCount as ^#} ptr)
  V.generateM nElems (peekElemOff ptr >=> peekEncodedCString)

getFieldBy OFTWideStringList fname ix f = getFieldBy OFTStringList fname ix f

getFieldBy OFTBinary _ ix f = alloca $ \lenP -> do
  buf <- liftM castPtr ({#call unsafe OGR_F_GetFieldAsBinary as ^#} f ix lenP)
  nElems <- peekIntegral lenP
  liftM OGRBinary (packCStringLen (buf, nElems))

getFieldBy OFTDateTime fname ix f
  = liftM OGRDateTime $ alloca $ \y -> alloca $ \m -> alloca $ \d ->
    alloca $ \h -> alloca $ \mn -> alloca $ \s -> alloca $ \tz -> do
      ret <- {#call unsafe OGR_F_GetFieldAsDateTime as ^#} f ix y m d h mn s tz
      when (ret==0) $ throwBindingException (FieldParseError fname)
      day <- fromGregorian <$> peekIntegral y
                           <*> peekIntegral m
                           <*> peekIntegral d
      tod <- TimeOfDay <$> peekIntegral h
                       <*> peekIntegral mn
                       <*> peekIntegral s
      let lt = return . ZonedTime (LocalTime day tod)
      tzV <- peekIntegral tz
      case tzV of
        -- Unknown timezone, assume utc
        0   -> lt utc
        1   -> getCurrentTimeZone >>= lt
        100 -> lt utc
        n   -> lt (minutesToTimeZone ((n-100) * 15))

getFieldBy OFTDate fname ix f
  = liftM (OGRDate . localDay . zonedTimeToLocalTime . unDateTime)
          (getFieldBy OFTDateTime fname ix f)

getFieldBy OFTTime fname ix f
  = liftM (OGRTime . localTimeOfDay . zonedTimeToLocalTime. unDateTime)
          (getFieldBy OFTDateTime fname ix f)

unDateTime :: Field -> ZonedTime
unDateTime (OGRDateTime f) = f
unDateTime _               = error "GDAL.Internal.OGRFeature.unDateTime"

peekIntegral :: (Storable a, Integral a, Num b) => Ptr a -> IO b
peekIntegral = liftM fromIntegral . peek

getFieldName :: FieldDefnH -> IO Text
getFieldName =
  {#call unsafe OGR_Fld_GetNameRef as ^#} >=> peekEncodedCString

geometryByName :: Text -> FeatureH -> GDAL s Geometry
geometryByName = undefined

geometryByIndex :: FeatureH -> Int -> GDAL s Geometry
geometryByIndex = undefined

{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ForeignFunctionInterface #-}

#include "bindings.h"

module GDAL.Internal.OGRFeature (
    FieldType (..)
  , Field
  , Feature (..)
  , FeatureH
  , FieldDefnH (..)
  , FeatureDefnH (..)
  , Justification (..)

  , FeatureDef (..)
  , GeomFieldDef (..)
  , FieldDef (..)

  , fieldDef
  , featureToHandle
  , featureFromHandle

  , withFeatureH
  , withFieldDefnH
  , fieldDefFromHandle
  , featureDefFromHandle
#if MULTI_GEOM_FIELDS
  , GeomFieldDefnH (..)
  , withGeomFieldDefnH
#endif
) where

{#context lib = "gdal" prefix = "OGR" #}

import Control.Applicative ((<$>), (<*>), pure)
import Control.Monad (liftM, (>=>), (<=<), when)
import Control.Monad.Catch (bracket)
import Control.Monad.IO.Class (MonadIO(liftIO))

import Data.ByteString (ByteString)
import Data.ByteString.Char8 (packCStringLen)
import Data.Int (Int32, Int64)
import Data.Monoid (mempty)
import Data.Text (Text)
import Data.Time.LocalTime (
    LocalTime(..)
  , TimeOfDay(..)
  , ZonedTime(..)
  , getCurrentTimeZone
  , minutesToTimeZone
  , utc
  )
import Data.Time ()
import Data.Time.Calendar (Day, fromGregorian)
import qualified Data.Vector.Storable as St
import qualified Data.Vector.Storable.Mutable as Stm
import qualified Data.Vector as V

import Foreign.C.Types (CInt(..), CLong(..), CDouble(..), CChar(..), CUChar(..))
import Foreign.ForeignPtr (
    ForeignPtr
  , FinalizerPtr
  , withForeignPtr
  )
import Foreign.Marshal.Alloc (alloca)
import Foreign.Marshal.Utils (copyBytes)
import Foreign.Ptr (Ptr, castPtr)
import Foreign.Storable (Storable, sizeOf, peek, peekElemOff)

import GDAL.Internal.Types
import GDAL.Internal.Util (
    toEnumC
  , fromEnumC
  , peekEncodedCString
  , useAsEncodedCString
  )
{#import GDAL.Internal.OSR #}
{#import GDAL.Internal.CPLError #}
{#import GDAL.Internal.OGRGeometry #}
{#import GDAL.Internal.OGRError #}

#include "gdal.h"
#include "ogr_core.h"
#include "ogr_api.h"
#include "cpl_string.h"

{#enum FieldType {} omit (OFTMaxType) deriving (Eq,Show,Read,Bounded) #}

{#enum Justification  {}
    omit (JustifyUndefined)
    with prefix = "OJ"
    add  prefix = "Justify"
    deriving (Eq,Show,Read,Bounded) #}

data Field
  = OGRInteger       {-# UNPACK #-} !Int32
  | OGRIntegerList   {-# UNPACK #-} !(St.Vector Int32)
  | OGRInteger64     {-# UNPACK #-} !Int64
  | OGRInteger64List {-# UNPACK #-} !(St.Vector Int64)
  | OGRReal          {-# UNPACK #-} !Double
  | OGRRealList      {-# UNPACK #-} !(St.Vector Double)
  | OGRString        {-# UNPACK #-} !Text
  | OGRStringList    {-# UNPACK #-} !(V.Vector Text)
  | OGRBinary        {-# UNPACK #-} !ByteString
  | OGRDateTime      {-# UNPACK #-} !ZonedTime
  | OGRDate          {-# UNPACK #-} !Day
  | OGRTime          {-# UNPACK #-} !TimeOfDay
  deriving (Show)

data FieldDef
  = FieldDef {
      fldName  :: {-# UNPACK #-} !Text
    , fldType  :: {-# UNPACK #-} !FieldType
    , fldWidth :: {-# UNPACK #-} !(Maybe Int)
    , fldPrec  :: {-# UNPACK #-} !(Maybe Int)
    , fldJust  :: {-# UNPACK #-} !(Maybe Justification)
    } deriving (Show, Eq)

fieldDef :: FieldType -> Text -> FieldDef
fieldDef ftype name = FieldDef name ftype Nothing Nothing Nothing

data Feature
  = Feature {
      fId      :: {-# UNPACK #-} !Int64
    , fFields  :: {-# UNPACK #-} !(V.Vector Field)
    , fGeoms   :: {-# UNPACK #-} !(V.Vector Geometry)
    } deriving (Show)

data FeatureDef
  = FeatureDef {
      fdName    :: {-# UNPACK #-} !Text
    , fdFields  :: {-# UNPACK #-} !(V.Vector FieldDef)
    , fdGeom    :: {-# UNPACK #-} !GeomFieldDef
    , fdGeoms   :: {-# UNPACK #-} !(V.Vector GeomFieldDef)
    } deriving (Show, Eq)

data GeomFieldDef
  = GeomFieldDef {
      gfdName  :: {-# UNPACK #-} !Text
    , gfdType  :: {-# UNPACK #-} !GeometryType
    , gfdSrs   :: {-# UNPACK #-} !(Maybe SpatialReference)
    } deriving (Show, Eq)

{#pointer FeatureH foreign finalizer OGR_F_Destroy as ^ newtype#}
{#pointer FieldDefnH   newtype#}
{#pointer FeatureDefnH newtype#}

withFieldDefnH :: FieldDef -> (FieldDefnH -> IO a) -> IO a
withFieldDefnH FieldDef{..} f =
  useAsEncodedCString fldName $ \pName ->
  bracket ({#call unsafe OGR_Fld_Create as ^#} pName (fromEnumC fldType))
          ({#call unsafe OGR_Fld_Destroy as ^#}) (\p -> populate p >> f p)
  where
    populate h = do
      case fldWidth of
        Just w  -> {#call unsafe OGR_Fld_SetWidth as ^#} h (fromIntegral w)
        Nothing -> return ()
      case fldPrec of
        Just p  -> {#call unsafe OGR_Fld_SetPrecision as ^#} h (fromIntegral p)
        Nothing -> return ()
      case fldJust of
        Just j  -> {#call unsafe OGR_Fld_SetJustify as ^#} h (fromEnumC j)
        Nothing -> return ()

fieldDefFromHandle :: FieldDefnH -> IO FieldDef
fieldDefFromHandle p =
  FieldDef
    <$> getFieldName p
    <*> liftM toEnumC ({#call unsafe OGR_Fld_GetType as ^#} p)
    <*> liftM iToMaybe ({#call unsafe OGR_Fld_GetWidth as ^#} p)
    <*> liftM iToMaybe ({#call unsafe OGR_Fld_GetPrecision as ^#} p)
    <*> liftM jToMaybe ({#call unsafe OGR_Fld_GetJustify as ^#} p)
  where
    iToMaybe = (\v -> if v==0 then Nothing else Just (fromIntegral v))
    jToMaybe = (\j -> if j==0 then Nothing else Just (toEnumC j))

featureDefFromHandle :: GeomFieldDef -> FeatureDefnH -> IO FeatureDef
featureDefFromHandle gfd p =
  FeatureDef
    <$> ({#call unsafe OGR_FD_GetName as ^#} p >>= peekEncodedCString)
    <*> fieldDefsFromFeatureDefnH p
    <*> pure gfd
    <*> geomFieldDefsFromFeatureDefnH p
  where

fieldDefsFromFeatureDefnH :: FeatureDefnH -> IO (V.Vector FieldDef)
fieldDefsFromFeatureDefnH p = do
  nFields <- {#call unsafe OGR_FD_GetFieldCount as ^#} p
  V.generateM (fromIntegral nFields) $
    fieldDefFromHandle <=<
      ({#call unsafe OGR_FD_GetFieldDefn as ^#} p . fromIntegral)

geomFieldDefsFromFeatureDefnH :: FeatureDefnH -> IO (V.Vector GeomFieldDef)

#if MULTI_GEOM_FIELDS

{#pointer GeomFieldDefnH newtype#}

geomFieldDefsFromFeatureDefnH p = do
  nFields <- {#call unsafe OGR_FD_GetGeomFieldCount as ^#} p
  V.generateM (fromIntegral (nFields-1)) $
    gFldDef <=< ( {#call unsafe OGR_FD_GetGeomFieldDefn as ^#} p
                . (+1)
                . fromIntegral
                )
  where
    gFldDef g =
      GeomFieldDef
        <$> ({#call unsafe OGR_GFld_GetNameRef as ^#} g >>= peekEncodedCString)
        <*> liftM toEnumC ({#call unsafe OGR_GFld_GetType as ^#} g)
        <*> ({#call unsafe OGR_GFld_GetSpatialRef as ^#} g >>=
          maybeNewSpatialRefBorrowedHandle)

withGeomFieldDefnH :: GeomFieldDef -> (GeomFieldDefnH -> IO a) -> IO a
withGeomFieldDefnH GeomFieldDef{..} f =
  useAsEncodedCString gfdName $ \pName ->
  bracket ({#call unsafe OGR_GFld_Create as ^#} pName (fromEnumC gfdType))
          ({#call unsafe OGR_GFld_Destroy as ^#}) (\p -> populate p >> f p)
  where
    populate = withMaybeSpatialReference gfdSrs .
                 {#call unsafe OGR_GFld_SetSpatialRef as ^#}
#else
-- | GDAL < 1.11 only supports 1 geometry field and associates it the layer
geomFieldDefsFromFeatureDefnH = const (return V.empty)
#endif

featureToHandle :: FeatureDef   -> Feature -> GDAL s FeatureH
featureToHandle = undefined

featureFromHandle :: FeatureDef -> FeatureH -> GDAL s Feature
featureFromHandle = undefined

getFieldBy :: FieldType -> Text -> CInt -> Ptr FeatureH -> IO Field

getFieldBy OFTInteger _ ix f
  = liftM (OGRInteger . fromIntegral)
    ({#call unsafe OGR_F_GetFieldAsInteger as ^#} f ix)

getFieldBy OFTIntegerList _ ix f = alloca $ \lenP -> do
  buf <- {#call unsafe OGR_F_GetFieldAsIntegerList as ^#} f ix lenP
  nElems <- peekIntegral lenP
  vec <- Stm.new nElems
  Stm.unsafeWith vec $ \vP ->
    copyBytes vP (buf :: Ptr CInt) (nElems * sizeOf (undefined :: CInt))
  liftM OGRIntegerList (St.unsafeFreeze (Stm.unsafeCast vec))

#if (GDAL_VERSION_MAJOR >= 2)
getFieldBy OFTInteger64 _ ix f
  = liftM (OGRInteger64 . fromIntegral)
    ({#call unsafe OGR_F_GetFieldAsInteger64 as ^#} f ix)

getFieldBy OFTInteger64List _ ix f = alloca $ \lenP -> do
  buf <- {#call unsafe OGR_F_GetFieldAsInteger64List as ^#} f ix lenP
  nElems <- peekIntegral lenP
  vec <- Stm.new nElems
  Stm.unsafeWith vec $ \vP ->
    copyBytes vP (buf :: Ptr CLong) (nElems * sizeOf (undefined :: CLong))
  liftM OGRInteger64List (St.unsafeFreeze (Stm.unsafeCast vec))
#endif

getFieldBy OFTReal _ ix f
  = liftM (OGRReal . realToFrac)
    ({#call unsafe OGR_F_GetFieldAsDouble as ^#} f ix)

getFieldBy OFTRealList _ ix f = alloca $ \lenP -> do
  buf <- {#call unsafe OGR_F_GetFieldAsDoubleList as ^#} f ix lenP
  nElems <- peekIntegral lenP
  vec <- Stm.new nElems
  Stm.unsafeWith vec $ \vP ->
     copyBytes vP (buf :: Ptr CDouble) (nElems * sizeOf (undefined :: CDouble))
  liftM OGRRealList (St.unsafeFreeze (Stm.unsafeCast vec))

getFieldBy OFTString _ ix f = liftM OGRString
  (({#call unsafe OGR_F_GetFieldAsString as ^#} f ix) >>= peekEncodedCString)

getFieldBy OFTWideString fname ix f = getFieldBy OFTString fname ix f

getFieldBy OFTStringList _ ix f = liftM OGRStringList $ do
  ptr <- {#call unsafe OGR_F_GetFieldAsStringList as ^#} f ix
  nElems <- liftM fromIntegral ({#call unsafe CSLCount as ^#} ptr)
  V.generateM nElems (peekElemOff ptr >=> peekEncodedCString)

getFieldBy OFTWideStringList fname ix f = getFieldBy OFTStringList fname ix f

getFieldBy OFTBinary _ ix f = alloca $ \lenP -> do
  buf <- liftM castPtr ({#call unsafe OGR_F_GetFieldAsBinary as ^#} f ix lenP)
  nElems <- peekIntegral lenP
  liftM OGRBinary (packCStringLen (buf, nElems))

getFieldBy OFTDateTime fname ix f
  = liftM OGRDateTime $ alloca $ \y -> alloca $ \m -> alloca $ \d ->
    alloca $ \h -> alloca $ \mn -> alloca $ \s -> alloca $ \tz -> do
      ret <- {#call unsafe OGR_F_GetFieldAsDateTime as ^#} f ix y m d h mn s tz
      when (ret==0) $ throwBindingException (FieldParseError fname)
      day <- fromGregorian <$> peekIntegral y
                           <*> peekIntegral m
                           <*> peekIntegral d
      tod <- TimeOfDay <$> peekIntegral h
                       <*> peekIntegral mn
                       <*> peekIntegral s
      let lt = return . ZonedTime (LocalTime day tod)
      tzV <- peekIntegral tz
      case tzV of
        -- Unknown timezone, assume utc
        0   -> lt utc
        1   -> getCurrentTimeZone >>= lt
        100 -> lt utc
        n   -> lt (minutesToTimeZone ((n-100) * 15))

getFieldBy OFTDate fname ix f
  = liftM (OGRDate . localDay . zonedTimeToLocalTime . unDateTime)
          (getFieldBy OFTDateTime fname ix f)

getFieldBy OFTTime fname ix f
  = liftM (OGRTime . localTimeOfDay . zonedTimeToLocalTime. unDateTime)
          (getFieldBy OFTDateTime fname ix f)

unDateTime :: Field -> ZonedTime
unDateTime (OGRDateTime f) = f
unDateTime _               = error "GDAL.Internal.OGRFeature.unDateTime"

peekIntegral :: (Storable a, Integral a, Num b) => Ptr a -> IO b
peekIntegral = liftM fromIntegral . peek

getFieldName :: FieldDefnH -> IO Text
getFieldName =
  {#call unsafe OGR_Fld_GetNameRef as ^#} >=> peekEncodedCString

geometryByName :: Text -> FeatureH -> GDAL s Geometry
geometryByName = undefined

geometryByIndex :: FeatureH -> Int -> GDAL s Geometry
geometryByIndex = undefined