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)


Config

Config

{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE CPP #-}

#include <git2/config.h>

module Data.HGit2.Config where

import Data.HGit2.Git2
import Data.HGit2.Errors
import Foreign
import Foreign.C

newtype Config = Config CPtr
newtype ConfigFile = ConfigFile CPtr

instance CWrapper Config where
  unwrap (Config c) = c

instance CWrapper ConfigFile where
  unwrap (ConfigFile cf) = cf

-- | Locate the path to the global configuration file
--
-- The user or global configuration file is usually located in
-- `$HOME/.gitconfig`.
--
-- This method will try to guess the full path to that file, if the file
-- exists. The returned path may be used on any `git_config` call to load the
-- global configuration file.
findGlobalConfig :: IO (Maybe String)
findGlobalConfig = alloca $ \pth -> do
  res <- {#call git_config_find_global#} pth
  if res == 0
    then fmap Just $ peekCString pth
    else return Nothing

-- | Open the global configuration file
openGlobalConfig :: IOEitherErr Config
openGlobalConfig = callPeek Config {#call git_config_open_global#}

-- | Create a configuration file backend for ondisk files
--
-- These are the normal `.gitconfig` files that Core Git processes. Note that
-- you first have to add this file to a configuration object before you can
-- query it for configuration variables.
createOnDisk :: String -> IOEitherErr ConfigFile
createOnDisk str =
  withCString str $ \str' ->
  callPeek ConfigFile (\out -> {#call git_config_file__ondisk#} out str')

-- | Allocate a new configuration object
--
-- This object is empty, so you have to add a file to it before you can do
-- anything with it.
newConfig :: IOEitherErr Config
newConfig = callPeek Config {#call git_config_new#}

-- | Add a generic config file instance to an existing config
--
-- Note that the configuration object will free the file automatically.
--
-- Further queries on this config object will access each of the config file
-- instances in order. Instances with a higher priority will be accessed first.
addFile :: Config -> ConfigFile -> Int -> IO GitError
addFile (Config cfp) (ConfigFile ffp) pr =
  withForeignPtr cfp $ \c ->
  withForeignPtr ffp $ \f ->
  retEnum $ {#call git_config_add_file#} c f (fromIntegral pr)

-- | Add an on-disk config file instance to an existing config
--
-- The on-disk file pointed at by `path` will be opened and parsed; it's
-- expected to be a native Git config file following the default Git config
-- syntax (see man git-config).
--
-- Note that the configuration object will free the file automatically.
--
-- Further queries on this config object will access each of the config file
-- instances in order. Instances with a higher priority will be accessed first.
addOnDisk :: Config -> String -> Int -> IO GitError
addOnDisk (Config cfp) pth pr =
  withForeignPtr cfp $ \c ->
  withCString pth $ \pth' ->
  retEnum $ {#call git_config_add_file_ondisk#} c pth' (fromIntegral pr)

-- | Create a new config instance containing a single on-disk file
--
-- This method is a simple utility wrapper for the following sequence of calls:
-- - newConfig
-- - addOnDisk
openOnDisk :: String -> IOEitherErr Config
openOnDisk str =
  withCString str $ \str' ->
  callPeek Config (\out -> {#call git_config_open_ondisk#} out str')

-- | Get the value of an integer config variable.
configInt :: Config -> String -> IOEitherErr Int
configInt (Config cfp) str = alloca $ \out ->
  withForeignPtr cfp $ \c ->
  withCString str $ \str' -> do
  res <- {#call git_config_get_int#} c str' out
  num <- peek out
  retEither res $ return . Right $ fromIntegral num

-- | Get the value of an integer config variable.
configInteger :: Config -> String -> IOEitherErr Integer
configInteger (Config cfp) str =  alloca $ \out ->
  withForeignPtr cfp $ \c ->
  withCString str $ \str' -> do
  res <- {#call git_config_get_long#} c str' out
  num <- peek out
  retEither res $ return . Right $ fromIntegral num

-- | Get the value of a boolean config variable.
configBool :: Config -> String -> IO (Either GitError Bool)
configBool (Config cfp) str =
  withForeignPtr cfp $ \c ->
  withCString str $ \str' -> alloca $ \out -> do
  res  <- {#call git_config_get_bool#} c str' out
  retEither res $ fmap (Right . toBool) $ peek out

-- | Get the value of a string config variable.
--
-- The string is owned by the variable and should not be freed by the user.
configString :: Config -> String -> IO (Either GitError String)
configString (Config cfp) vn =
  withForeignPtr cfp $ \c ->
  withCString vn $ \vn' -> alloca $ \out -> do
  res <- {#call git_config_get_string#} c vn' out
  retEither res $ fmap Right $ peekCString =<< peek out

-- | Set the value of an integer config variable.
setConfigInt :: Config -> String -> Int -> IOCanFail
setConfigInt conf vn val =
  mConfig {#call git_config_set_int#} conf vn (fromIntegral val)

-- | Set the value of a long integer config variable.
setConfigInteger :: Config -> String -> Integer -> IOCanFail
setConfigInteger conf vn val =
  mConfig {#call git_config_set_long#} conf vn (fromIntegral val)

-- | Set the value of a boolean config variable.
setConfigBool :: Config -> String -> Bool -> IOCanFail
setConfigBool conf vn val =
  mConfig {#call git_config_set_bool#} conf vn (fromBool val)

-- | Set the value of a string config variable.
setConfigString :: Config -> String -> String -> IOCanFail
setConfigString conf vn val = withCString val $ \val' ->
  mConfig {#call git_config_set_string#} conf vn val'

-- | Delete a config variable
delConfig :: Config -> String -> IOCanFail
delConfig (Config cfp) vn =
  withForeignPtr cfp $ \c ->
  withCString vn $ \str ->
  retMaybe =<< {#call git_config_delete#} c str

mConfig :: (Ptr () -> CString -> t -> IO CInt) -> Config -> String -> t
        -> IOCanFail
mConfig call (Config cfp) vn val =
  withForeignPtr cfp $ \c ->
  withCString vn $ \str ->
  retMaybe =<< call c str val

-- TODO: foreachConfig :: Config ->
{-
/**
 * Perform an operation on each config variable.
 *
 * The callback receives the normalized name and value of each variable
 * in the config backend, and the data pointer passed to this function.
 * As soon as one of the callback functions returns something other than 0,
 * this function returns that value.
 *
 * @param cfg where to get the variables from
 * @param callback the function to call on each variable
 * @param payload the data to pass to the callback
 * @return GIT_SUCCESS or the return value of the callback which didn't return 0
 */
GIT_EXTERN(int) git_config_foreach(
	git_config *cfg,
	int (*callback)(const char *var_name, const char *value, void *payload),
	void *payload);
-}

{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE CPP #-}

#include <git2/config.h>

module Data.HGit2.Config where

import Data.HGit2.Git2
import Data.HGit2.Errors
import Foreign
import Foreign.C

newtype Config = Config CPtr
newtype ConfigFile = ConfigFile CPtr

instance CWrapper Config where
  unwrap (Config c) = c

instance CWrapper ConfigFile where
  unwrap (ConfigFile cf) = cf

-- | Locate the path to the global configuration file
--
-- The user or global configuration file is usually located in
-- `$HOME/.gitconfig`.
--
-- This method will try to guess the full path to that file, if the file
-- exists. The returned path may be used on any `git_config` call to load the
-- global configuration file.
findGlobalConfig :: IO (Maybe String)
findGlobalConfig = alloca $ \pth -> do
  res <- {#call git_config_find_global#} pth
  if res == 0
    then fmap Just $ peekCString pth
    else return Nothing

-- | Open the global configuration file
openGlobalConfig :: IOEitherErr Config
openGlobalConfig = callPeek Config {#call git_config_open_global#}

-- | Create a configuration file backend for ondisk files
--
-- These are the normal `.gitconfig` files that Core Git processes. Note that
-- you first have to add this file to a configuration object before you can
-- query it for configuration variables.
createOnDisk :: String -> IOEitherErr ConfigFile
createOnDisk str = withCString str $ \str' ->
  callPeek ConfigFile (\out -> {#call git_config_file__ondisk#} out str')

-- | Allocate a new configuration object
--
-- This object is empty, so you have to add a file to it before you can do
-- anything with it.
newConfig :: IOEitherErr Config
newConfig = callPeek Config {#call git_config_new#}

-- | Add a generic config file instance to an existing config
--
-- Note that the configuration object will free the file automatically.
--
-- Further queries on this config object will access each of the config file
-- instances in order. Instances with a higher priority will be accessed first.
addFile :: Config -> ConfigFile -> Int -> IO GitError
addFile (Config cfp) (ConfigFile ffp) pr =
  withForeignPtr cfp $ \c ->
  withForeignPtr ffp $ \f ->
  retEnum $ {#call git_config_add_file#} c f (fromIntegral pr)

-- | Add an on-disk config file instance to an existing config
--
-- The on-disk file pointed at by `path` will be opened and parsed; it's
-- expected to be a native Git config file following the default Git config
-- syntax (see man git-config).
--
-- Note that the configuration object will free the file automatically.
--
-- Further queries on this config object will access each of the config file
-- instances in order. Instances with a higher priority will be accessed first.
addOnDisk :: Config -> String -> Int -> IO GitError
addOnDisk (Config cfp) pth pr =
  withForeignPtr cfp $ \c ->
  withCString pth $ \pth' ->
  retEnum $ {#call git_config_add_file_ondisk#} c pth' (fromIntegral pr)

-- | Create a new config instance containing a single on-disk file
--
-- This method is a simple utility wrapper for the following sequence of calls:
-- - newConfig
-- - addOnDisk
openOnDisk :: String -> IOEitherErr Config
openOnDisk str =
  withCString str $ \str' ->
  callPeek Config (\out -> {#call git_config_open_ondisk#} out str')

-- | Get the value of an integer config variable.
configInt :: Config -> String -> IOEitherErr Int
configInt (Config cfp) str =
  withForeignPtr cfp $ \c ->
  withCString str $ \str' ->
  undefined
  {- callPeek fromIntegral ({#call git_config_get_int#} c str')-}

-- | Get the value of an integer config variable.
configInteger :: Config -> String -> IOEitherErr Integer
configInteger (Config cfp) str =
  withForeignPtr cfp $ \c ->
  withCString str $ \str' ->
  undefined
  {- callPeek fromIntegral ({#call git_config_get_long#} c str')-}

-- | Get the value of a boolean config variable.
configBool :: Config -> String -> IO (Either GitError Bool)
configBool (Config cfp) str =
  withForeignPtr cfp $ \c ->
  withCString str $ \str' -> alloca $ \out -> do
  res  <- {#call git_config_get_bool#} c str' out
  retEither res $ fmap (Right . toBool) $ peek out

-- | Get the value of a string config variable.
--
-- The string is owned by the variable and should not be freed by the user.
configString :: Config -> String -> IO (Either GitError String)
configString (Config cfp) vn =
  withForeignPtr cfp $ \c ->
  withCString vn $ \vn' -> alloca $ \out -> do
  res <- {#call git_config_get_string#} c vn' out
  retEither res $ fmap Right $ peekCString =<< peek out

-- | Set the value of an integer config variable.
setConfigInt :: Config -> String -> Int -> IOCanFail
setConfigInt conf vn val =
  mConfig {#call git_config_set_int#} conf vn (fromIntegral val)

-- | Set the value of a long integer config variable.
setConfigInteger :: Config -> String -> Integer -> IOCanFail
setConfigInteger conf vn val =
  mConfig {#call git_config_set_long#} conf vn (fromIntegral val)

-- | Set the value of a boolean config variable.
setConfigBool :: Config -> String -> Bool -> IOCanFail
setConfigBool conf vn val =
  mConfig {#call git_config_set_bool#} conf vn (fromBool val)

-- | Set the value of a string config variable.
setConfigString :: Config -> String -> String -> IOCanFail
setConfigString conf vn val = withCString val $ \val' ->
  mConfig {#call git_config_set_string#} conf vn val'

-- | Delete a config variable
delConfig :: Config -> String -> IOCanFail
delConfig (Config cfp) vn =
  withForeignPtr cfp $ \c ->
  withCString vn $ \str ->
  retMaybe =<< {#call git_config_delete#} c str

{- mConfig :: (CPtr -> CString -> t -> IO CInt) -> Config -> String -> t-}
        {- -> IO (Maybe GitError)-}
mConfig :: (Ptr () -> CString -> t -> IO CInt) -> Config -> String -> t
        -> IOCanFail
mConfig call (Config cfp) vn val =
  withForeignPtr cfp $ \c ->
  withCString vn $ \str ->
  retMaybe =<< call c str val

-- TODO: foreachConfig :: Config ->
{-
/**
 * Perform an operation on each config variable.
 *
 * The callback receives the normalized name and value of each variable
 * in the config backend, and the data pointer passed to this function.
 * As soon as one of the callback functions returns something other than 0,
 * this function returns that value.
 *
 * @param cfg where to get the variables from
 * @param callback the function to call on each variable
 * @param payload the data to pass to the callback
 * @return GIT_SUCCESS or the return value of the callback which didn't return 0
 */
GIT_EXTERN(int) git_config_foreach(
	git_config *cfg,
	int (*callback)(const char *var_name, const char *value, void *payload),
	void *payload);
-}


warning police: orphans

warning police: orphans

{-# LANGUAGE BangPatterns             #-}
{-# LANGUAGE CPP                      #-}
{-# LANGUAGE EmptyCase                #-}
{-# LANGUAGE EmptyDataDecls           #-}
{-# LANGUAGE ForeignFunctionInterface #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
--------------------------------------------------------------------------------
-- |
-- Module    : Foreign.CUDA.Runtime.Device
-- Copyright : (c) [2009..2012] Trevor L. McDonell
-- License   : BSD
--
-- Device management routines
--
--------------------------------------------------------------------------------

module Foreign.CUDA.Runtime.Device (

  -- * Device Management
  Device, DeviceFlag(..), DeviceProperties(..), Compute(..), ComputeMode(..),
  choose, get, count, props, set, setFlags, setOrder, reset, sync,

  -- * Peer Access
  PeerFlag,
  accessible, add, remove,

  -- * Cache Configuration
  Limit(..),
  getLimit, setLimit

) where

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

-- Friends
import Foreign.CUDA.Analysis.Device
import Foreign.CUDA.Runtime.Error
import Foreign.CUDA.Internal.C2HS
import Foreign.CUDA.Internal.Offsets

-- System
import Foreign
import Foreign.C

#c
typedef struct cudaDeviceProp   cudaDeviceProp;

typedef enum
{
    cudaDeviceFlagScheduleAuto    = cudaDeviceScheduleAuto,
    cudaDeviceFlagScheduleSpin    = cudaDeviceScheduleSpin,
    cudaDeviceFlagScheduleYield   = cudaDeviceScheduleYield,
    cudaDeviceFlagBlockingSync    = cudaDeviceBlockingSync,
    cudaDeviceFlagMapHost         = cudaDeviceMapHost,
#if CUDART_VERSION >= 3000
    cudaDeviceFlagLMemResizeToMax = cudaDeviceLmemResizeToMax
#endif
} cudaDeviceFlags;
#endc

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

-- |
-- A device identifier
--
type Device = Int

{# pointer *cudaDeviceProp as ^ foreign -> DeviceProperties nocode #}

-- |
-- Device execution flags
--
{# enum cudaDeviceFlags as DeviceFlag { }
    with prefix="cudaDeviceFlag" deriving (Eq, Show) #}

instance Storable DeviceProperties where
  sizeOf _    = {#sizeof cudaDeviceProp#}
  alignment _ = alignment (undefined :: Ptr ())

  poke _ _    = error "no instance for Foreign.Storable.poke DeviceProperties"
  peek p      = do
    gm <- cIntConv     `fmap` {#get cudaDeviceProp.totalGlobalMem#} p
    sm <- cIntConv     `fmap` {#get cudaDeviceProp.sharedMemPerBlock#} p
    rb <- cIntConv     `fmap` {#get cudaDeviceProp.regsPerBlock#} p
    ws <- cIntConv     `fmap` {#get cudaDeviceProp.warpSize#} p
    mp <- cIntConv     `fmap` {#get cudaDeviceProp.memPitch#} p
    tb <- cIntConv     `fmap` {#get cudaDeviceProp.maxThreadsPerBlock#} p
    cl <- cIntConv     `fmap` {#get cudaDeviceProp.clockRate#} p
    cm <- cIntConv     `fmap` {#get cudaDeviceProp.totalConstMem#} p
    v1 <- fromIntegral `fmap` {#get cudaDeviceProp.major#} p
    v2 <- fromIntegral `fmap` {#get cudaDeviceProp.minor#} p
    ta <- cIntConv     `fmap` {#get cudaDeviceProp.textureAlignment#} p
    ov <- cToBool      `fmap` {#get cudaDeviceProp.deviceOverlap#} p
    pc <- cIntConv     `fmap` {#get cudaDeviceProp.multiProcessorCount#} p
    ke <- cToBool      `fmap` {#get cudaDeviceProp.kernelExecTimeoutEnabled#} p
    tg <- cToBool      `fmap` {#get cudaDeviceProp.integrated#} p
    hm <- cToBool      `fmap` {#get cudaDeviceProp.canMapHostMemory#} p
    md <- cToEnum      `fmap` {#get cudaDeviceProp.computeMode#} p
#if CUDART_VERSION >= 3000
    ck <- cToBool      `fmap` {#get cudaDeviceProp.concurrentKernels#} p
    u1 <- cIntConv     `fmap` {#get cudaDeviceProp.maxTexture1D#} p
#endif
#if CUDART_VERSION >= 3010
    ee <- cToBool      `fmap` {#get cudaDeviceProp.ECCEnabled#} p
#endif
#if CUDART_VERSION >= 4000
    ae <- cIntConv     `fmap` {#get cudaDeviceProp.asyncEngineCount#} p
    l2 <- cIntConv     `fmap` {#get cudaDeviceProp.l2CacheSize#} p
    tm <- cIntConv     `fmap` {#get cudaDeviceProp.maxThreadsPerMultiProcessor#} p
    mw <- cIntConv     `fmap` {#get cudaDeviceProp.memoryBusWidth#} p
    mc <- cIntConv     `fmap` {#get cudaDeviceProp.memoryClockRate#} p
    pb <- cIntConv     `fmap` {#get cudaDeviceProp.pciBusID#} p
    pd <- cIntConv     `fmap` {#get cudaDeviceProp.pciDeviceID#} p
    pm <- cIntConv     `fmap` {#get cudaDeviceProp.pciDomainID#} p
    tc <- cToBool      `fmap` {#get cudaDeviceProp.tccDriver#} p
    ua <- cToBool      `fmap` {#get cudaDeviceProp.unifiedAddressing#} p
#endif

    --
    -- C->Haskell returns the wrong type when accessing static arrays in
    -- structs, returning the dereferenced element but with a Ptr type. Work
    -- around this with manual pointer arithmetic...
    --
    n            <- peekCString (p `plusPtr` devNameOffset)
    (t1:t2:t3:_) <- map cIntConv `fmap` peekArray 3 (p `plusPtr` devMaxThreadDimOffset :: Ptr CInt)
    (g1:g2:g3:_) <- map cIntConv `fmap` peekArray 3 (p `plusPtr` devMaxGridSizeOffset  :: Ptr CInt)
#if CUDART_VERSION >= 3000
    (u21:u22:_)     <- map cIntConv `fmap` peekArray 2 (p `plusPtr` devMaxTexture2DOffset :: Ptr CInt)
    (u31:u32:u33:_) <- map cIntConv `fmap` peekArray 3 (p `plusPtr` devMaxTexture3DOffset :: Ptr CInt)
#endif

    return DeviceProperties
      {
        deviceName                      = n,
        computeCapability               = Compute v1 v2,
        totalGlobalMem                  = gm,
        totalConstMem                   = cm,
        sharedMemPerBlock               = sm,
        regsPerBlock                    = rb,
        warpSize                        = ws,
        maxThreadsPerBlock              = tb,
        maxBlockSize                    = (t1,t2,t3),
        maxGridSize                     = (g1,g2,g3),
        clockRate                       = cl,
        multiProcessorCount             = pc,
        memPitch                        = mp,
        textureAlignment                = ta,
        computeMode                     = md,
        deviceOverlap                   = ov,
#if CUDART_VERSION >= 3000
        concurrentKernels               = ck,
        maxTextureDim1D                 = u1,
        maxTextureDim2D                 = (u21,u22),
        maxTextureDim3D                 = (u31,u32,u33),
#endif
#if CUDART_VERSION >= 3010
        eccEnabled                      = ee,
#endif
#if CUDART_VERSION >= 3000 && CUDART_VERSION < 3010
        -- not visible from runtime API < 3.1
        eccEnabled                      = False,
#endif
#if CUDART_VERSION >= 4000
        asyncEngineCount                = ae,
        cacheMemL2                      = l2,
        maxThreadsPerMultiProcessor     = tm,
        memBusWidth                     = mw,
        memClockRate                    = mc,
        tccDriverEnabled                = tc,
        unifiedAddressing               = ua,
        pciInfo                         = PCI pb pd pm,
#endif
        kernelExecTimeoutEnabled        = ke,
        integrated                      = tg,
        canMapHostMemory                = hm
      }

--------------------------------------------------------------------------------
-- Device Management
--------------------------------------------------------------------------------

-- |
-- Select the compute device which best matches the given criteria
--
{-# INLINEABLE choose #-}
choose :: DeviceProperties -> IO Device
choose !dev = resultIfOk =<< cudaChooseDevice dev

{-# INLINE cudaChooseDevice #-}
{# fun unsafe cudaChooseDevice
  { alloca-      `Int'              peekIntConv*
  , withDevProp* `DeviceProperties'              } -> `Status' cToEnum #}
  where
      withDevProp = with

-- |
-- Returns which device is currently being used
--
{-# INLINEABLE get #-}
get :: IO Device
get = resultIfOk =<< cudaGetDevice

{-# INLINE cudaGetDevice #-}
{# fun unsafe cudaGetDevice
  { alloca- `Int' peekIntConv* } -> `Status' cToEnum #}

-- |
-- Returns the number of devices available for execution, with compute
-- capability >= 1.0
--
{-# INLINEABLE count #-}
count :: IO Int
count = resultIfOk =<< cudaGetDeviceCount

{-# INLINE cudaGetDeviceCount #-}
{# fun unsafe cudaGetDeviceCount
  { alloca- `Int' peekIntConv* } -> `Status' cToEnum #}

-- |
-- Return information about the selected compute device
--
{-# INLINEABLE props #-}
props :: Device -> IO DeviceProperties
props !n = resultIfOk =<< cudaGetDeviceProperties n

{-# INLINE cudaGetDeviceProperties #-}
{# fun unsafe cudaGetDeviceProperties
  { alloca- `DeviceProperties' peek*
  ,         `Int'                    } -> `Status' cToEnum #}

-- |
-- Set device to be used for GPU execution
--
{-# INLINEABLE set #-}
set :: Device -> IO ()
set !n = nothingIfOk =<< cudaSetDevice n

{-# INLINE cudaSetDevice #-}
{# fun unsafe cudaSetDevice
  { `Int' } -> `Status' cToEnum #}

-- |
-- Set flags to be used for device executions
--
{-# INLINEABLE setFlags #-}
setFlags :: [DeviceFlag] -> IO ()
setFlags !f = nothingIfOk =<< cudaSetDeviceFlags (combineBitMasks f)

{-# INLINE cudaSetDeviceFlags #-}
{# fun unsafe cudaSetDeviceFlags
  { `Int' } -> `Status' cToEnum #}

-- |
-- Set list of devices for CUDA execution in priority order
--
{-# INLINEABLE setOrder #-}
setOrder :: [Device] -> IO ()
setOrder !l = nothingIfOk =<< cudaSetValidDevices l (length l)

{-# INLINE cudaSetValidDevices #-}
{# fun unsafe cudaSetValidDevices
  { withArrayIntConv* `[Int]'
  ,                   `Int'   } -> `Status' cToEnum #}
  where
      withArrayIntConv = withArray . map cIntConv

-- |
-- Block until the device has completed all preceding requested tasks. Returns
-- an error if one of the tasks fails.
--
{-# INLINEABLE sync #-}
sync :: IO ()
#if CUDART_VERSION < 4000
{-# INLINE cudaThreadSynchronize #-}
sync = nothingIfOk =<< cudaThreadSynchronize
{# fun cudaThreadSynchronize { } -> `Status' cToEnum #}
#else
{-# INLINE cudaDeviceSynchronize #-}
sync = nothingIfOk =<< cudaDeviceSynchronize
{# fun cudaDeviceSynchronize { } -> `Status' cToEnum #}
#endif

-- |
-- Explicitly destroys and cleans up all runtime resources associated with the
-- current device in the current process. Any subsequent API call will
-- reinitialise the device.
--
-- Note that this function will reset the device immediately. It is the caller’s
-- responsibility to ensure that the device is not being accessed by any other
-- host threads from the process when this function is called.
--
{-# INLINEABLE reset #-}
reset :: IO ()
#if CUDART_VERSION >= 4000
{-# INLINE cudaDeviceReset #-}
reset = nothingIfOk =<< cudaDeviceReset
{# fun unsafe cudaDeviceReset { } -> `Status' cToEnum #}
#else
{-# INLINE cudaThreadExit #-}
reset = nothingIfOk =<< cudaThreadExit
{# fun unsafe cudaThreadExit  { } -> `Status' cToEnum #}
#endif

--------------------------------------------------------------------------------
-- Peer Access
--------------------------------------------------------------------------------

-- |
-- Possible option values for direct peer memory access
--
data PeerFlag
instance Enum PeerFlag where
  toEnum   x = case x of {}
  fromEnum x = case x of {}

-- |
-- Queries if the first device can directly access the memory of the second. If
-- direct access is possible, it can then be enabled with 'add'. Requires
-- cuda-4.0.
--
{-# INLINEABLE accessible #-}
accessible :: Device -> Device -> IO Bool
#if CUDART_VERSION < 4000
accessible _ _        = requireSDK 4.0 "accessible"
#else
accessible !dev !peer = resultIfOk =<< cudaDeviceCanAccessPeer dev peer

{-# INLINE cudaDeviceCanAccessPeer #-}
{# fun unsafe cudaDeviceCanAccessPeer
  { alloca-  `Bool'   peekBool*
  , cIntConv `Device'
  , cIntConv `Device'           } -> `Status' cToEnum #}
#endif

-- |
-- If the devices of both the current and supplied contexts support unified
-- addressing, then enable allocations in the supplied context to be accessible
-- by the current context. Requires cuda-4.0.
--
{-# INLINEABLE add #-}
add :: Device -> [PeerFlag] -> IO ()
#if CUDART_VERSION < 4000
add _ _         = requireSDK 4.0 "add"
#else
add !dev !flags = nothingIfOk =<< cudaDeviceEnablePeerAccess dev flags

{-# INLINE cudaDeviceEnablePeerAccess #-}
{# fun unsafe cudaDeviceEnablePeerAccess
  { cIntConv        `Device'
  , combineBitMasks `[PeerFlag]' } -> `Status' cToEnum #}
#endif

-- |
-- Disable direct memory access from the current context to the supplied
-- context. Requires cuda-4.0.
--
{-# INLINEABLE remove #-}
remove :: Device -> IO ()
#if CUDART_VERSION < 4000
remove _    = requireSDK 4.0 "remove"
#else
remove !dev = nothingIfOk =<< cudaDeviceDisablePeerAccess dev

{-# INLINE cudaDeviceDisablePeerAccess #-}
{# fun unsafe cudaDeviceDisablePeerAccess
  { cIntConv `Device' } -> `Status' cToEnum #}
#endif

--------------------------------------------------------------------------------
-- Cache Configuration
--------------------------------------------------------------------------------

-- |
-- Device limit flags
--
#if CUDART_VERSION < 3010
data Limit
#else
{# enum cudaLimit as Limit
    { underscoreToCase }
    with prefix="cudaLimit" deriving (Eq, Show) #}
#endif

-- |
-- Query compute 2.0 call stack limits. Requires cuda-3.1.
--
{-# INLINEABLE getLimit #-}
getLimit :: Limit -> IO Int
#if   CUDART_VERSION < 3010
getLimit _  = requireSDK 3.1 "getLimit"
#elif CUDART_VERSION < 4000
getLimit !l = resultIfOk =<< cudaThreadGetLimit l

{-# INLINE cudaThreadGetLimit #-}
{# fun unsafe cudaThreadGetLimit
  { alloca-   `Int' peekIntConv*
  , cFromEnum `Limit'            } -> `Status' cToEnum #}
#else
getLimit !l = resultIfOk =<< cudaDeviceGetLimit l

{-# INLINE cudaDeviceGetLimit #-}
{# fun unsafe cudaDeviceGetLimit
  { alloca-   `Int' peekIntConv*
  , cFromEnum `Limit'            } -> `Status' cToEnum #}
#endif

-- |
-- Set compute 2.0 call stack limits. Requires cuda-3.1.
--
{-# INLINEABLE setLimit #-}
setLimit :: Limit -> Int -> IO ()
#if   CUDART_VERSION < 3010
setLimit _ _   = requireSDK 3.1 "setLimit"
#elif CUDART_VERSION < 4000
setLimit !l !n = nothingIfOk =<< cudaThreadSetLimit l n

{-# INLINE cudaThreadSetLimit #-}
{# fun unsafe cudaThreadSetLimit
  { cFromEnum `Limit'
  , cIntConv  `Int'   } -> `Status' cToEnum #}
#else
setLimit !l !n = nothingIfOk =<< cudaDeviceSetLimit l n

{-# INLINE cudaDeviceSetLimit #-}
{# fun unsafe cudaDeviceSetLimit
  { cFromEnum `Limit'
  , cIntConv  `Int'   } -> `Status' cToEnum #}
#endif

{-# LANGUAGE BangPatterns             #-}
{-# LANGUAGE CPP                      #-}
{-# LANGUAGE EmptyCase                #-}
{-# LANGUAGE EmptyDataDecls           #-}
{-# LANGUAGE ForeignFunctionInterface #-}
--------------------------------------------------------------------------------
-- |
-- Module    : Foreign.CUDA.Runtime.Device
-- Copyright : (c) [2009..2012] Trevor L. McDonell
-- License   : BSD
--
-- Device management routines
--
--------------------------------------------------------------------------------

module Foreign.CUDA.Runtime.Device (

  -- * Device Management
  Device, DeviceFlag(..), DeviceProperties(..), Compute(..), ComputeMode(..),
  choose, get, count, props, set, setFlags, setOrder, reset, sync,

  -- * Peer Access
  PeerFlag,
  accessible, add, remove,

  -- * Cache Configuration
  Limit(..),
  getLimit, setLimit

) where

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

-- Friends
import Foreign.CUDA.Analysis.Device
import Foreign.CUDA.Runtime.Error
import Foreign.CUDA.Internal.C2HS
import Foreign.CUDA.Internal.Offsets

-- System
import Foreign
import Foreign.C

#c
typedef struct cudaDeviceProp   cudaDeviceProp;

typedef enum
{
    cudaDeviceFlagScheduleAuto    = cudaDeviceScheduleAuto,
    cudaDeviceFlagScheduleSpin    = cudaDeviceScheduleSpin,
    cudaDeviceFlagScheduleYield   = cudaDeviceScheduleYield,
    cudaDeviceFlagBlockingSync    = cudaDeviceBlockingSync,
    cudaDeviceFlagMapHost         = cudaDeviceMapHost,
#if CUDART_VERSION >= 3000
    cudaDeviceFlagLMemResizeToMax = cudaDeviceLmemResizeToMax
#endif
} cudaDeviceFlags;
#endc

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

-- |
-- A device identifier
--
type Device = Int

{# pointer *cudaDeviceProp as ^ foreign -> DeviceProperties nocode #}

-- |
-- Device execution flags
--
{# enum cudaDeviceFlags as DeviceFlag { }
    with prefix="cudaDeviceFlag" deriving (Eq, Show) #}

instance Storable DeviceProperties where
  sizeOf _    = {#sizeof cudaDeviceProp#}
  alignment _ = alignment (undefined :: Ptr ())

  poke _ _    = error "no instance for Foreign.Storable.poke DeviceProperties"
  peek p      = do
    gm <- cIntConv     `fmap` {#get cudaDeviceProp.totalGlobalMem#} p
    sm <- cIntConv     `fmap` {#get cudaDeviceProp.sharedMemPerBlock#} p
    rb <- cIntConv     `fmap` {#get cudaDeviceProp.regsPerBlock#} p
    ws <- cIntConv     `fmap` {#get cudaDeviceProp.warpSize#} p
    mp <- cIntConv     `fmap` {#get cudaDeviceProp.memPitch#} p
    tb <- cIntConv     `fmap` {#get cudaDeviceProp.maxThreadsPerBlock#} p
    cl <- cIntConv     `fmap` {#get cudaDeviceProp.clockRate#} p
    cm <- cIntConv     `fmap` {#get cudaDeviceProp.totalConstMem#} p
    v1 <- fromIntegral `fmap` {#get cudaDeviceProp.major#} p
    v2 <- fromIntegral `fmap` {#get cudaDeviceProp.minor#} p
    ta <- cIntConv     `fmap` {#get cudaDeviceProp.textureAlignment#} p
    ov <- cToBool      `fmap` {#get cudaDeviceProp.deviceOverlap#} p
    pc <- cIntConv     `fmap` {#get cudaDeviceProp.multiProcessorCount#} p
    ke <- cToBool      `fmap` {#get cudaDeviceProp.kernelExecTimeoutEnabled#} p
    tg <- cToBool      `fmap` {#get cudaDeviceProp.integrated#} p
    hm <- cToBool      `fmap` {#get cudaDeviceProp.canMapHostMemory#} p
    md <- cToEnum      `fmap` {#get cudaDeviceProp.computeMode#} p
#if CUDART_VERSION >= 3000
    ck <- cToBool      `fmap` {#get cudaDeviceProp.concurrentKernels#} p
    u1 <- cIntConv     `fmap` {#get cudaDeviceProp.maxTexture1D#} p
#endif
#if CUDART_VERSION >= 3010
    ee <- cToBool      `fmap` {#get cudaDeviceProp.ECCEnabled#} p
#endif
#if CUDART_VERSION >= 4000
    ae <- cIntConv     `fmap` {#get cudaDeviceProp.asyncEngineCount#} p
    l2 <- cIntConv     `fmap` {#get cudaDeviceProp.l2CacheSize#} p
    tm <- cIntConv     `fmap` {#get cudaDeviceProp.maxThreadsPerMultiProcessor#} p
    mw <- cIntConv     `fmap` {#get cudaDeviceProp.memoryBusWidth#} p
    mc <- cIntConv     `fmap` {#get cudaDeviceProp.memoryClockRate#} p
    pb <- cIntConv     `fmap` {#get cudaDeviceProp.pciBusID#} p
    pd <- cIntConv     `fmap` {#get cudaDeviceProp.pciDeviceID#} p
    pm <- cIntConv     `fmap` {#get cudaDeviceProp.pciDomainID#} p
    tc <- cToBool      `fmap` {#get cudaDeviceProp.tccDriver#} p
    ua <- cToBool      `fmap` {#get cudaDeviceProp.unifiedAddressing#} p
#endif

    --
    -- C->Haskell returns the wrong type when accessing static arrays in
    -- structs, returning the dereferenced element but with a Ptr type. Work
    -- around this with manual pointer arithmetic...
    --
    n            <- peekCString (p `plusPtr` devNameOffset)
    (t1:t2:t3:_) <- map cIntConv `fmap` peekArray 3 (p `plusPtr` devMaxThreadDimOffset :: Ptr CInt)
    (g1:g2:g3:_) <- map cIntConv `fmap` peekArray 3 (p `plusPtr` devMaxGridSizeOffset  :: Ptr CInt)
#if CUDART_VERSION >= 3000
    (u21:u22:_)     <- map cIntConv `fmap` peekArray 2 (p `plusPtr` devMaxTexture2DOffset :: Ptr CInt)
    (u31:u32:u33:_) <- map cIntConv `fmap` peekArray 3 (p `plusPtr` devMaxTexture3DOffset :: Ptr CInt)
#endif

    return DeviceProperties
      {
        deviceName                      = n,
        computeCapability               = Compute v1 v2,
        totalGlobalMem                  = gm,
        totalConstMem                   = cm,
        sharedMemPerBlock               = sm,
        regsPerBlock                    = rb,
        warpSize                        = ws,
        maxThreadsPerBlock              = tb,
        maxBlockSize                    = (t1,t2,t3),
        maxGridSize                     = (g1,g2,g3),
        clockRate                       = cl,
        multiProcessorCount             = pc,
        memPitch                        = mp,
        textureAlignment                = ta,
        computeMode                     = md,
        deviceOverlap                   = ov,
#if CUDART_VERSION >= 3000
        concurrentKernels               = ck,
        maxTextureDim1D                 = u1,
        maxTextureDim2D                 = (u21,u22),
        maxTextureDim3D                 = (u31,u32,u33),
#endif
#if CUDART_VERSION >= 3010
        eccEnabled                      = ee,
#endif
#if CUDART_VERSION >= 3000 && CUDART_VERSION < 3010
        -- not visible from runtime API < 3.1
        eccEnabled                      = False,
#endif
#if CUDART_VERSION >= 4000
        asyncEngineCount                = ae,
        cacheMemL2                      = l2,
        maxThreadsPerMultiProcessor     = tm,
        memBusWidth                     = mw,
        memClockRate                    = mc,
        tccDriverEnabled                = tc,
        unifiedAddressing               = ua,
        pciInfo                         = PCI pb pd pm,
#endif
        kernelExecTimeoutEnabled        = ke,
        integrated                      = tg,
        canMapHostMemory                = hm
      }

--------------------------------------------------------------------------------
-- Device Management
--------------------------------------------------------------------------------

-- |
-- Select the compute device which best matches the given criteria
--
{-# INLINEABLE choose #-}
choose :: DeviceProperties -> IO Device
choose !dev = resultIfOk =<< cudaChooseDevice dev

{-# INLINE cudaChooseDevice #-}
{# fun unsafe cudaChooseDevice
  { alloca-      `Int'              peekIntConv*
  , withDevProp* `DeviceProperties'              } -> `Status' cToEnum #}
  where
      withDevProp = with

-- |
-- Returns which device is currently being used
--
{-# INLINEABLE get #-}
get :: IO Device
get = resultIfOk =<< cudaGetDevice

{-# INLINE cudaGetDevice #-}
{# fun unsafe cudaGetDevice
  { alloca- `Int' peekIntConv* } -> `Status' cToEnum #}

-- |
-- Returns the number of devices available for execution, with compute
-- capability >= 1.0
--
{-# INLINEABLE count #-}
count :: IO Int
count = resultIfOk =<< cudaGetDeviceCount

{-# INLINE cudaGetDeviceCount #-}
{# fun unsafe cudaGetDeviceCount
  { alloca- `Int' peekIntConv* } -> `Status' cToEnum #}

-- |
-- Return information about the selected compute device
--
{-# INLINEABLE props #-}
props :: Device -> IO DeviceProperties
props !n = resultIfOk =<< cudaGetDeviceProperties n

{-# INLINE cudaGetDeviceProperties #-}
{# fun unsafe cudaGetDeviceProperties
  { alloca- `DeviceProperties' peek*
  ,         `Int'                    } -> `Status' cToEnum #}

-- |
-- Set device to be used for GPU execution
--
{-# INLINEABLE set #-}
set :: Device -> IO ()
set !n = nothingIfOk =<< cudaSetDevice n

{-# INLINE cudaSetDevice #-}
{# fun unsafe cudaSetDevice
  { `Int' } -> `Status' cToEnum #}

-- |
-- Set flags to be used for device executions
--
{-# INLINEABLE setFlags #-}
setFlags :: [DeviceFlag] -> IO ()
setFlags !f = nothingIfOk =<< cudaSetDeviceFlags (combineBitMasks f)

{-# INLINE cudaSetDeviceFlags #-}
{# fun unsafe cudaSetDeviceFlags
  { `Int' } -> `Status' cToEnum #}

-- |
-- Set list of devices for CUDA execution in priority order
--
{-# INLINEABLE setOrder #-}
setOrder :: [Device] -> IO ()
setOrder !l = nothingIfOk =<< cudaSetValidDevices l (length l)

{-# INLINE cudaSetValidDevices #-}
{# fun unsafe cudaSetValidDevices
  { withArrayIntConv* `[Int]'
  ,                   `Int'   } -> `Status' cToEnum #}
  where
      withArrayIntConv = withArray . map cIntConv

-- |
-- Block until the device has completed all preceding requested tasks. Returns
-- an error if one of the tasks fails.
--
{-# INLINEABLE sync #-}
sync :: IO ()
#if CUDART_VERSION < 4000
{-# INLINE cudaThreadSynchronize #-}
sync = nothingIfOk =<< cudaThreadSynchronize
{# fun cudaThreadSynchronize { } -> `Status' cToEnum #}
#else
{-# INLINE cudaDeviceSynchronize #-}
sync = nothingIfOk =<< cudaDeviceSynchronize
{# fun cudaDeviceSynchronize { } -> `Status' cToEnum #}
#endif

-- |
-- Explicitly destroys and cleans up all runtime resources associated with the
-- current device in the current process. Any subsequent API call will
-- reinitialise the device.
--
-- Note that this function will reset the device immediately. It is the caller’s
-- responsibility to ensure that the device is not being accessed by any other
-- host threads from the process when this function is called.
--
{-# INLINEABLE reset #-}
reset :: IO ()
#if CUDART_VERSION >= 4000
{-# INLINE cudaDeviceReset #-}
reset = nothingIfOk =<< cudaDeviceReset
{# fun unsafe cudaDeviceReset { } -> `Status' cToEnum #}
#else
{-# INLINE cudaThreadExit #-}
reset = nothingIfOk =<< cudaThreadExit
{# fun unsafe cudaThreadExit  { } -> `Status' cToEnum #}
#endif

--------------------------------------------------------------------------------
-- Peer Access
--------------------------------------------------------------------------------

-- |
-- Possible option values for direct peer memory access
--
data PeerFlag
instance Enum PeerFlag where
  toEnum   x = case x of {}
  fromEnum x = case x of {}

-- |
-- Queries if the first device can directly access the memory of the second. If
-- direct access is possible, it can then be enabled with 'add'. Requires
-- cuda-4.0.
--
{-# INLINEABLE accessible #-}
accessible :: Device -> Device -> IO Bool
#if CUDART_VERSION < 4000
accessible _ _        = requireSDK 4.0 "accessible"
#else
accessible !dev !peer = resultIfOk =<< cudaDeviceCanAccessPeer dev peer

{-# INLINE cudaDeviceCanAccessPeer #-}
{# fun unsafe cudaDeviceCanAccessPeer
  { alloca-  `Bool'   peekBool*
  , cIntConv `Device'
  , cIntConv `Device'           } -> `Status' cToEnum #}
#endif

-- |
-- If the devices of both the current and supplied contexts support unified
-- addressing, then enable allocations in the supplied context to be accessible
-- by the current context. Requires cuda-4.0.
--
{-# INLINEABLE add #-}
add :: Device -> [PeerFlag] -> IO ()
#if CUDART_VERSION < 4000
add _ _         = requireSDK 4.0 "add"
#else
add !dev !flags = nothingIfOk =<< cudaDeviceEnablePeerAccess dev flags

{-# INLINE cudaDeviceEnablePeerAccess #-}
{# fun unsafe cudaDeviceEnablePeerAccess
  { cIntConv        `Device'
  , combineBitMasks `[PeerFlag]' } -> `Status' cToEnum #}
#endif

-- |
-- Disable direct memory access from the current context to the supplied
-- context. Requires cuda-4.0.
--
{-# INLINEABLE remove #-}
remove :: Device -> IO ()
#if CUDART_VERSION < 4000
remove _    = requireSDK 4.0 "remove"
#else
remove !dev = nothingIfOk =<< cudaDeviceDisablePeerAccess dev

{-# INLINE cudaDeviceDisablePeerAccess #-}
{# fun unsafe cudaDeviceDisablePeerAccess
  { cIntConv `Device' } -> `Status' cToEnum #}
#endif

--------------------------------------------------------------------------------
-- Cache Configuration
--------------------------------------------------------------------------------

-- |
-- Device limit flags
--
#if CUDART_VERSION < 3010
data Limit
#else
{# enum cudaLimit as Limit
    { underscoreToCase }
    with prefix="cudaLimit" deriving (Eq, Show) #}
#endif

-- |
-- Query compute 2.0 call stack limits. Requires cuda-3.1.
--
{-# INLINEABLE getLimit #-}
getLimit :: Limit -> IO Int
#if   CUDART_VERSION < 3010
getLimit _  = requireSDK 3.1 "getLimit"
#elif CUDART_VERSION < 4000
getLimit !l = resultIfOk =<< cudaThreadGetLimit l

{-# INLINE cudaThreadGetLimit #-}
{# fun unsafe cudaThreadGetLimit
  { alloca-   `Int' peekIntConv*
  , cFromEnum `Limit'            } -> `Status' cToEnum #}
#else
getLimit !l = resultIfOk =<< cudaDeviceGetLimit l

{-# INLINE cudaDeviceGetLimit #-}
{# fun unsafe cudaDeviceGetLimit
  { alloca-   `Int' peekIntConv*
  , cFromEnum `Limit'            } -> `Status' cToEnum #}
#endif

-- |
-- Set compute 2.0 call stack limits. Requires cuda-3.1.
--
{-# INLINEABLE setLimit #-}
setLimit :: Limit -> Int -> IO ()
#if   CUDART_VERSION < 3010
setLimit _ _   = requireSDK 3.1 "setLimit"
#elif CUDART_VERSION < 4000
setLimit !l !n = nothingIfOk =<< cudaThreadSetLimit l n

{-# INLINE cudaThreadSetLimit #-}
{# fun unsafe cudaThreadSetLimit
  { cFromEnum `Limit'
  , cIntConv  `Int'   } -> `Status' cToEnum #}
#else
setLimit !l !n = nothingIfOk =<< cudaDeviceSetLimit l n

{-# INLINE cudaDeviceSetLimit #-}
{# fun unsafe cudaDeviceSetLimit
  { cFromEnum `Limit'
  , cIntConv  `Int'   } -> `Status' cToEnum #}
#endif


Index

Index

{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE CPP #-}

#include <git2/index.h>

module Data.HGit2.Index where

import Data.Bits
import Data.HGit2.Git2
import Data.HGit2.Errors
import Data.Maybe()
import Foreign
import Foreign.C.String
import Foreign.C.Types

newtype Index      = Index CPtr
newtype IndexEntry = IndexEntry CPtr
newtype IndexEntryUnMerged = IndexEntryUnMerged CPtr

instance CWrapper Index where
  unwrap (Index i) = i

instance CWrapper IndexEntry where
  unwrap (IndexEntry ie) = ie

instance CWrapper IndexEntryUnMerged where
  unwrap (IndexEntryUnMerged ieu) = ieu

{#enum define IdxEntry { GIT_IDXENTRY_NAMEMASK as NameMask
                       , GIT_IDXENTRY_STAGEMASK as StageMask
                       , GIT_IDXENTRY_EXTENDED as ExtendedOrSkipWorkTree
                       , GIT_IDXENTRY_VALID as ValidOrExtended2
                       , GIT_IDXENTRY_STAGESHIFT as StageShift
                       , GIT_IDXENTRY_UPDATE as Update
                       , GIT_IDXENTRY_REMOVE as Remove
                       , GIT_IDXENTRY_UPTODATE as UpToDate
                       , GIT_IDXENTRY_ADDED as Added
                       , GIT_IDXENTRY_HASHED as Hashed
                       , GIT_IDXENTRY_UNHASHED as UnHashed
                       , GIT_IDXENTRY_WT_REMOVE as WTRemove
                       , GIT_IDXENTRY_CONFLICTED as Conflicted
                       , GIT_IDXENTRY_UNPACKED as Unpacked
                       , GIT_IDXENTRY_NEW_SKIP_WORKTREE as NewSkipWorkTree
                       , GIT_IDXENTRY_INTENT_TO_ADD as IntentToAdd
                       , GIT_IDXENTRY_SKIP_WORKTREE as SkipWorkTree
                       , GIT_IDXENTRY_EXTENDED2 as Extended2
                       }#}

-- TODO: Can we get this into IdxEntry somehow?
idxExtFlags :: Int
idxExtFlags = fromEnum IntentToAdd .|. fromEnum SkipWorkTree

-- | Create a new bare Git index object as a memory representation of the Git
-- index file in the provided path, without a repository to back it.
openIndex :: String -> IOEitherErr Index
openIndex path =
  withCString path $ \pth ->
  callPeek Index (\out -> {#call git_index_open#} out pth)

-- | Clear the contents (all the entries) of an index object. This clears the
-- index object in memory; changes must be manually written to disk for them to
-- take effect.
clearIndex :: Index -> IO ()
clearIndex (Index ifp) =
  withForeignPtr ifp $ {#call git_index_clear#}

-- | Update the contents of an existing index object in memory by reading from
-- the hard disk.
readIndex :: Index -> IOCanFail
readIndex (Index ifp) =
  withForeignPtr ifp $ \i ->
  retMaybe =<< {#call git_index_read#} i

-- | Write an existing index object from memory back to disk using an atomic
-- file lock.
writeIndex :: Index -> IOCanFail
writeIndex (Index ifp) =
  withForeignPtr ifp $ \i ->
  retMaybe =<< {#call git_index_write#} i

-- | Find the first index of any entries which point to given path in the Git
-- index.
findIndex :: Index -> String -> IO (Maybe Int)
findIndex (Index ifp) path =
  withForeignPtr ifp $ \idx ->
  withCString path $ \path' -> do
    res <- {#call git_index_find#} idx path'
    return $ if res >= 0
               then Just $ fromIntegral res
               else Nothing

-- | Remove all entries with equal path except last added
uniqIndex :: Index -> IO ()
uniqIndex (Index ifp) =
  withForeignPtr ifp $ {#call git_index_uniq#}

-- | Add or update an index entry from a file in disk
addIndex :: Index -> String -> Int -> IO (Maybe GitError)
addIndex (Index ifp) path stage =
  withForeignPtr ifp $ \idx ->
  withCString path $ \pth ->
    retMaybe =<< {#call git_index_add#} idx pth (fromIntegral stage)

-- | Add or update an index entry from an in-memory struct
addIndex2 :: Index -> IndexEntry -> IO (Maybe GitError)
addIndex2 (Index ifp) (IndexEntry efp) =
  withForeignPtr ifp $ \idx ->
  withForeignPtr efp $ \ie ->
  retMaybe =<< {#call git_index_add2#} idx ie

-- | Add (append) an index entry from a file in disk
appendIndex :: Index -> String -> Int -> IO (Maybe GitError)
appendIndex (Index ifp) path stage =
  withForeignPtr ifp $ \idx ->
  withCString path $ \pth ->
    retMaybe =<< {#call git_index_append#} idx pth (fromIntegral stage)

-- | Add (append) an index entry from an in-memory struct
appendIndex2 :: Index -> IndexEntry -> IO (Maybe GitError)
appendIndex2 (Index ifp) (IndexEntry efp) =
  withForeignPtr ifp $ \idx ->
  withForeignPtr efp $ \ie ->
  retMaybe =<< {#call git_index_append2#} idx ie

-- | Remove an entry from the index
remove :: Index -> Int -> IO (Maybe GitError)
remove (Index ifp) n =
  withForeignPtr ifp $ \idx ->
  retMaybe =<< {#call git_index_remove#} idx (fromIntegral n)

-- | Get a pointer to one of the entries in the index
getIndex :: Index -> Int -> IO (Maybe IndexEntry)
getIndex (Index ifp) n =
  withForeignPtr ifp $ \idx -> do
  res <- {#call git_index_get#} idx (fromIntegral n)
  retRes IndexEntry =<< mkFPtr res

-- | Get the count of entries currently in the index
entryCount :: Index -> IO Int
entryCount (Index ifp) =
  withForeignPtr ifp $ retNum . {#call git_index_entrycount#}

-- | Get the count of unmerged entries currently in the index
entryCountUnMerged :: Index -> IO Int
entryCountUnMerged  (Index ifp) =
  withForeignPtr ifp $ retNum . {#call git_index_entrycount_unmerged#}

retIEU :: Ptr () -> IO (Maybe IndexEntryUnMerged)
retIEU ptr = retRes IndexEntryUnMerged =<< mkFPtr ptr

-- | Get an unmerged entry from the index.
unmergedByPath :: Index -> String -> IO (Maybe IndexEntryUnMerged)
unmergedByPath (Index ifp) path =
  withForeignPtr ifp $ \idx ->
  withCString path $ \pth ->
  retIEU =<< {#call git_index_get_unmerged_bypath#} idx pth

-- | Get an unmerged entry from the index.
unmergedByIndex :: Index -> Int -> IO (Maybe IndexEntryUnMerged)
unmergedByIndex (Index ifp) n =
  withForeignPtr ifp $ \idx ->
  retIEU =<< {#call git_index_get_unmerged_byindex#} idx (fromIntegral n)

-- | Return the stage number from a git index entry
entryStage :: IndexEntry -> IO Int
entryStage (IndexEntry ifp) =
  withForeignPtr ifp $ retNum . {#call git_index_entry_stage#}

{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE CPP #-}

#include <git2/index.h>

module Data.HGit2.Index where

import Data.Bits
import Data.HGit2.Git2
import Data.HGit2.Errors
import Data.Maybe()
import Foreign
import Foreign.C.String
import Foreign.C.Types

newtype Index      = Index CPtr
newtype IndexEntry = IndexEntry CPtr
newtype IndexEntryUnMerged = IndexEntryUnMerged CPtr

instance CWrapper Index where
  unwrap (Index i) = i

instance CWrapper IndexEntry where
  unwrap (IndexEntry ie) = ie

instance CWrapper IndexEntryUnMerged where
  unwrap (IndexEntryUnMerged ieu) = ieu

{#enum define IdxEntry { GIT_IDXENTRY_NAMEMASK as NameMask
                       , GIT_IDXENTRY_STAGEMASK as StageMask
                       , GIT_IDXENTRY_EXTENDED as ExtendedOrSkipWorkTree
                       , GIT_IDXENTRY_VALID as ValidOrExtended2
                       , GIT_IDXENTRY_STAGESHIFT as StageShift
                       , GIT_IDXENTRY_UPDATE as Update
                       , GIT_IDXENTRY_REMOVE as Remove
                       , GIT_IDXENTRY_UPTODATE as UpToDate
                       , GIT_IDXENTRY_ADDED as Added
                       , GIT_IDXENTRY_HASHED as Hashed
                       , GIT_IDXENTRY_UNHASHED as UnHashed
                       , GIT_IDXENTRY_WT_REMOVE as WTRemove
                       , GIT_IDXENTRY_CONFLICTED as Conflicted
                       , GIT_IDXENTRY_UNPACKED as Unpacked
                       , GIT_IDXENTRY_NEW_SKIP_WORKTREE as NewSkipWorkTree
                       , GIT_IDXENTRY_INTENT_TO_ADD as IntentToAdd
                       , GIT_IDXENTRY_SKIP_WORKTREE as SkipWorkTree
                       , GIT_IDXENTRY_EXTENDED2 as Extended2
                       }#}

-- TODO: Can we get this into IdxEntry somehow?
idxExtFlags :: Int
idxExtFlags = fromEnum IntentToAdd .|. fromEnum SkipWorkTree

-- | Create a new bare Git index object as a memory representation of the Git
-- index file in the provided path, without a repository to back it.
openIndex :: String -> IOEitherErr Index
openIndex path = withCString path $ \pth ->
  callPeek Index (\out -> {#call git_index_open#} out pth)

-- | Clear the contents (all the entries) of an index object. This clears the
-- index object in memory; changes must be manually written to disk for them to
-- take effect.
clearIndex :: Index -> IO ()
clearIndex (Index ifp) =
  withForeignPtr ifp $ {#call git_index_clear#}

-- | Update the contents of an existing index object in memory by reading from
-- the hard disk.
readIndex :: Index -> IOCanFail
readIndex = undefined -- callRetMaybe {#call git_index_read#}

-- | Write an existing index object from memory back to disk using an atomic
-- file lock.
writeIndex :: Index -> IOCanFail
writeIndex = undefined -- callRetMaybe {#call git_index_write#}

-- | Find the first index of any entries which point to given path in the Git
-- index.
findIndex :: Index -> String -> IO (Maybe Int)
findIndex (Index ifp) path =
  withForeignPtr ifp $ \idx ->
  withCString path $ \path' -> do
    res <- {#call git_index_find#} idx path'
    return $ if res >= 0
               then Just $ fromIntegral res
               else Nothing

-- | Remove all entries with equal path except last added
uniqIndex :: Index -> IO ()
uniqIndex (Index ifp) =
  withForeignPtr ifp $ {#call git_index_uniq#}

-- | Add or update an index entry from a file in disk
addIndex :: Index -> String -> Int -> IO (Maybe GitError)
addIndex (Index ifp) path stage =
  withForeignPtr ifp $ \idx ->
  withCString path $ \pth ->
    retMaybe =<< {#call git_index_add#} idx pth (fromIntegral stage)

-- | Add or update an index entry from an in-memory struct
addIndex2 :: Index -> IndexEntry -> IO (Maybe GitError)
addIndex2 (Index ifp) (IndexEntry efp) =
  withForeignPtr ifp $ \idx ->
  withForeignPtr efp $ \ie ->
  retMaybe =<< {#call git_index_add2#} idx ie

-- | Add (append) an index entry from a file in disk
appendIndex :: Index -> String -> Int -> IO (Maybe GitError)
appendIndex (Index ifp) path stage =
  withForeignPtr ifp $ \idx ->
  withCString path $ \pth ->
    retMaybe =<< {#call git_index_append#} idx pth (fromIntegral stage)

-- | Add (append) an index entry from an in-memory struct
appendIndex2 :: Index -> IndexEntry -> IO (Maybe GitError)
appendIndex2 (Index ifp) (IndexEntry efp) =
  withForeignPtr ifp $ \idx ->
  withForeignPtr efp $ \ie ->
  retMaybe =<< {#call git_index_append2#} idx ie

-- | Remove an entry from the index
remove :: Index -> Int -> IO (Maybe GitError)
remove (Index ifp) n =
  withForeignPtr ifp $ \idx ->
  retMaybe =<< {#call git_index_remove#} idx (fromIntegral n)

-- | Get a pointer to one of the entries in the index
getIndex :: Index -> Int -> IO (Maybe IndexEntry)
getIndex (Index ifp) n =
  withForeignPtr ifp $ \idx ->
  undefined
  {- retRes IndexEntry =<< {#call git_index_get#} idx (fromIntegral n)-}

-- | Get the count of entries currently in the index
entryCount :: Index -> IO Int
entryCount = undefined -- callRetNum {#call git_index_entrycount#}

-- | Get the count of unmerged entries currently in the index
entryCountUnMerged :: Index -> IO Int
entryCountUnMerged = undefined -- callRetNum {#call git_index_entrycount_unmerged#}

retIEU :: CPtr -> IO (Maybe IndexEntryUnMerged)
retIEU = undefined -- retRes IndexEntryUnMerged

-- | Get an unmerged entry from the index.
unmergedByPath :: Index -> String -> IO (Maybe IndexEntryUnMerged)
unmergedByPath (Index ifp) path =
  withForeignPtr ifp $ \idx ->
  withCString path $ \pth ->
  undefined
    {- retIEU =<< {#call git_index_get_unmerged_bypath#} idx pth-}

-- | Get an unmerged entry from the index.
unmergedByIndex :: Index -> Int -> IO (Maybe IndexEntryUnMerged)
unmergedByIndex (Index ifp) n =
  withForeignPtr ifp $ \idx ->
  undefined -- retIEU =<< {#call git_index_get_unmerged_byindex#} idx (fromIntegral n)

-- | Return the stage number from a git index entry
entryStage :: IndexEntry -> IO Int
entryStage = undefined -- callRetNum {#call git_index_entry_stage#}