[project @ 2005-10-30 11:56:30 by as49] Fix wrong link.

-----------------------------------------------------------------------------
-- |
-- 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), unSurface
  , 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 newtype#}
unSurface (Surface x) = x

-- | Attributes for drawing operations.
{#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}#}

-- | Specify subpixel order.
{#enum subpixel_order_t as SubpixelOrder {underscoreToCase}#}

-- | FIXME: Document.
{#enum hint_style_t as HintStyle {underscoreToCase}#}

-- | FIXME: Document.
{#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)

-- | FIX ME: 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), unSurface
  , 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 newtype#}
unSurface (Surface x) = x

-- | Attributes for drawing operations.
{#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}#}

-- | Specify subpixel order.
{#enum subpixel_order_t as SubpixelOrder {underscoreToCase}#}

-- | FIXME: Document.
{#enum hint_style_t as HintStyle {underscoreToCase}#}

-- | FIXME: Document.
{#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.Render.Cairo.stroke' is called. Using a path is particularly
--   useful when drawing lines with special join styles and
--   'Graphics.Render.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)

-- | FIX ME: 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)


Unneeded extensions

Unneeded extensions

[ci skip]

{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE StaticPointers #-}

--------------------------------------------------------------------------------
-- |
-- Module    : Foreign.HPX
-- Copyright :
-- License   : BSD
--
-- Haskell Bindings for HPX.
--
--------------------------------------------------------------------------------

module Foreign.HPX {-
(
  Action(..),
  Foreign.HPX.init, initWith,
  registerAction,
  run, shutdown
)
       -}  where

import           Control.Monad (liftM2, unless)

import           Data.Bifunctor (first)
import           Data.Binary (Binary(..), decode, encode)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BL
import           Data.ByteString.Unsafe (unsafePackCStringLen, unsafeUseAsCStringLen)
-- import qualified Data.HVect as HVect (length)
-- import           Data.HVect (HVect, sNatToInt)
import           Data.Function ((&))
import           Data.Ix (Ix)
import qualified Data.Map as M
import           Data.Map (Map)
import           Data.IORef
import           Data.Proxy

import           Foreign
import           Foreign.C
import           Foreign.C2HS
-- import           Foreign.HPX.Classes
-- import           Foreign.LibFFI

import           GHC.StaticPtr

import           System.Environment (getProgName, getArgs)
import           System.Exit (exitFailure)
import           System.IO.Unsafe (unsafePerformIO)

import Debug.Trace (traceShowM)

#include <hpx/hpx.h>
#include "wr_hpx_types.h"

--------------------------------------------------------------------------------
-- Global Mutable Structures
--------------------------------------------------------------------------------

-- {-# NOINLINE hpxActionTable #-}
-- hpxActionTable :: IORef (Map (FunPtr a) Action)
-- hpxActionTable = unsafePerformIO $ newIORef M.empty

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

type Consumer a = forall b. (a -> IO b) -> IO b

newtype Action a = Action { useAction :: Ptr CAction }
  deriving (Eq, Show)
type CAction = {#type hpx_action_t #}

type ActionHandler = Ptr () -> {# type size_t #} -> IO CInt

foreign import ccall unsafe "wrapper"
    newActionHandler :: ActionHandler -> IO (FunPtr ActionHandler)

-- TODO: Figure out best resource-freeing strategy for HPX
withFunWrapper :: (a -> IO (FunPtr a)) -> a -> (FunPtr a -> IO b) -> IO b
withFunWrapper wrapper hFun f = wrapper hFun >>= f

--------------------------------------------------------------------------------
-- Initialization
--------------------------------------------------------------------------------

{-# INLINEABLE init #-}
init :: IO [String]
init = initWith =<< liftM2 (:) getProgName getArgs

initWith :: [String] -> IO [String]
initWith argv =
  withMany withCString argv $ \argv'  -> -- argv' :: [CString]
  withArray argv'           $ \argv'' -> -- argv'' :: Ptr CString
  with argv''               $ \argv''' -> do -- argv''' :: Ptr (Ptr CString)

    (r, argc) <- hpxInit (length argv) argv'''
    unless (r == 0) $ printHelp >> exitFailure
    x <- peekArray argc =<< peek argv''' -- :: [Ptr CString]
    mapM peekCString x

{#fun unsafe hpx_init as ^
  { withIntConv* `Int'                   peekIntConv*
  , id           `Ptr (Ptr (Ptr CChar))'
  }           -> `Int' cIntConv #}

--------------------------------------------------------------------------------
-- Action Registration
--------------------------------------------------------------------------------

--Different # of args:

-- {#fun unsafe variadic hpx_register_action[??] as ^
--   { alloca-      `Action' peekAction*
--   , withCString* `String'
--   , id           `Handler'
--   }           -> `Int' cIntConv #}
--  where peekAction = fmap Action . peek

{#enum hpx_action_type_t as ActionType
  { HPX_DEFAULT   as Default
  , HPX_TASK      as Task
  , HPX_INTERRUPT as Interrupt
  , HPX_FUNCTION  as Function
  } deriving (Bounded, Eq, Ix, Ord, Read, Show) #}

{#enum define HPXAttribute
  { HPX_ATTR_NONE  as NoAttribute
  , HPX_MARSHALLED as Marshalled
  , HPX_PINNED     as Pinned
  } deriving (Bounded, Eq, Ix, Ord, Read, Show) #}

-- -- TODO: Convert Int into Enum
-- {#fun unsafe variadic hpx_register_action[??] as ^
--   {
--   , cIntConv     `Int'
--   , withCString* `String'
--   , alloca-      `Action' peekAction*
--   , id           `Handler'
--   }           -> `Int' cIntConv #}
--  where peekAction = fmap Action . peek

-- foreign import ccall "hpx.h &hpx_register_action"
--     hpx_register_action_fun :: FunPtr ()
--
-- foreign import ccall "hpx.h &_hpx_run"
--     hpx_run_fun :: FunPtr ()
--
-- hpx_register_action :: forall f.
--                     ( All FFIType (HMap Proxy (ArgList f))
--                     , FFIFunction f
--                     , FunReturnType f ~ CInt
--                     , HVectSing (HMap Proxy (ArgList f))
--                     ) => ActionType -> Int -> String -> f -> IO (CInt, Action f)
-- hpx_register_action actionType attr key actionHandler = alloca $ \(idPtr :: Ptr CAction) -> do
--   let hArgs   = hSing :: HVect (HMap Proxy (ArgList f))
--       numArgs = fromIntegral . sNatToInt $ HVect.length hArgs
--   h  <- wrapFunPtr actionHandler
--   rc <- callFFI hpx_register_action_fun retCInt $
--     [ toArg (fromIntegral $ fromEnum actionType :: {#type hpx_action_type_t #})
--     , argCUInt (fromIntegral attr)
--     , argString key
--     , argPtr idPtr
--     , argFunPtr h
--     , argCInt numArgs
--     ] ++ map argPtr (toFFITypeList hArgs)
-- --   actionID <- fmap Action $ peek idPtr
--   return (rc, Action idPtr)
--
-- registerAction :: forall f.
--                 ( All FFIType (HMap Proxy (ArgList f))
--                 , FFIFunction f
--                 , FunReturnType f ~ CInt
--                 , HVectSing (HMap Proxy (ArgList f))
--                 ) => ActionType -> Int -> String -> f -> IO (Action f)
-- registerAction actionType attr key = fmap snd . hpx_register_action actionType attr key

{#fun pure wr_hpx_pointer as hpxPointer {} -> `Ptr ()' #}
{#fun pure wr_hpx_size    as hpxSize    {} -> `Ptr ()' #}

{#fun unsafe variadic hpx_register_action[hpx_type_t, hpx_type_t] as ^
  {              `ActionType'
  ,              `HPXAttribute'
  ,              `String'
  ,      alloca- `Action a' Action
  , withHandler* `ActionHandler'
  ,         two- `Int'
  ,    pointerT- `Ptr ()'
  ,       sizeT- `Ptr ()'
  }           -> `Int' #}
  where
    pointerT, sizeT :: Consumer (Ptr ())
    pointerT = (hpxPointer &)
    sizeT    = (hpxSize &)

    withHandler :: ActionHandler -> (FunPtr ActionHandler -> IO a) -> IO a
    withHandler = withFunWrapper newActionHandler

-- TODO: Remove the need to pass an explicit String ID
registerAction :: Binary a
               => ActionType
               -> HPXAttribute
               -> String
               -> StaticPtr (a -> IO ())
               -> IO (Action a)
registerAction actionT attr key clbk = do
    -- TODO: Figure out what error codes can be produced here
    (_r, a) <- hpxRegisterAction actionT attr key c_callback
    return a
  where
    c_callback :: ActionHandler
    c_callback cstr len = do
        bs <- unsafePackCStringLen (castPtr cstr, fromIntegral len)
        0 <$ deRefStaticPtr clbk (decode (BL.fromStrict bs))

-- {-# INLINEABLE registerAction#-}
-- registerAction :: String -> (Ptr () -> IO CInt) -> IO ()
-- registerAction s p = do
--   ptr <- wrap p
--   (_r, act) <- hpxRegisterAction s ptr
--   -- TODO throw exception on '_r'
--   modifyIORef hpxActionTable (M.insert ptr act)
--   putStrLn $ "Registered action pointer: " ++ show ptr ++ " with key: " ++ show s

--------------------------------------------------------------------------------
-- Runtime Calls
--------------------------------------------------------------------------------

-- {#fun _hpx_run as ^
--   { withAction*  `Action'
--   , cIntConv     `Int'
-- --  , id           `Ptr ()'
--   }           -> `Int' cIntConv #}
--   where
--     withAction = with . useAction

-- run :: (Ptr () -> IO CInt) -> Ptr () -> Int -> IO Int
-- run p _args size = do
--   tbl <- readIORef hpxActionTable
--   ptr <- wrap p
--   case M.lookup ptr tbl of
--      Nothing -> error $ "ERROR: Invalid action pointer: " ++ show ptr
--      Just action -> hpxRun action size -- _args

{#fun variadic _hpx_run[const char*, const int] as ^
  {           useAction `Action a' Action
  ,                two- `Int'
  , withCStringLenConv* `BS.ByteString'&
  }                  -> `Int' #}
  where
    withCStringLenConv :: BS.ByteString -> Consumer (CString, CInt)
    withCStringLenConv bs f = unsafeUseAsCStringLen bs $ \(cstr, len) -> f (cstr, fromIntegral len)

run :: Binary a => Action a -> a -> IO (Int, Action a)
run action = fmap (first fromIntegral) . hpxRun action . BL.toStrict . encode

-- hpx_run :: ( ToHVect args
--            , All ToArg (HVectOf args)
--            , ArgList f ~ HVectOf args
--            ) => Action f -> args -> IO CInt
-- hpx_run action args =
--     let hArgs   = hFromTuple args
--         numArgs = fromIntegral . sNatToInt $ HVect.length hArgs
--     in callFFI hpx_run_fun retCInt $ [argPtr (useAction action), argCInt numArgs] ++ toArgList hArgs
--
-- run :: ( ToHVect args
--        , All ToArg (HVectOf args)
--        , ArgList f ~ HVectOf args
--        ) => Action f -> args -> IO ()
-- run action = void . hpx_run action

{#fun unsafe hpx_print_help as ^ {} -> `()' #}

printHelp :: IO ()
printHelp = hpxPrintHelp

{#fun unsafe hpx_finalize as ^ {} -> `()' #}

finalize :: IO ()
finalize = hpxFinalize

{#fun hpx_exit as ^
  { cIntConv `Int'
  }       -> `()' #}

exit :: Int -> IO ()
exit = hpxExit

two :: Num n => Consumer n
two = (2 &)

{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StaticPointers #-}
{-# LANGUAGE TypeFamilies #-}

--------------------------------------------------------------------------------
-- |
-- Module    : Foreign.HPX
-- Copyright :
-- License   : BSD
--
-- Haskell Bindings for HPX.
--
--------------------------------------------------------------------------------

module Foreign.HPX {-
(
  Action(..),
  Foreign.HPX.init, initWith,
  registerAction,
  run, shutdown
)
       -}  where

import           Control.Monad (liftM2, unless)

import           Data.Bifunctor (first)
import           Data.Binary (Binary(..), decode, encode)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BL
import           Data.ByteString.Unsafe (unsafePackCStringLen, unsafeUseAsCStringLen)
-- import qualified Data.HVect as HVect (length)
-- import           Data.HVect (HVect, sNatToInt)
import           Data.Function ((&))
import           Data.Ix (Ix)
import qualified Data.Map as M
import           Data.Map (Map)
import           Data.IORef
import           Data.Proxy

import           Foreign
import           Foreign.C
import           Foreign.C2HS
-- import           Foreign.HPX.Classes
-- import           Foreign.LibFFI

import           GHC.StaticPtr

import           System.Environment (getProgName, getArgs)
import           System.Exit (exitFailure)
import           System.IO.Unsafe (unsafePerformIO)

import Debug.Trace (traceShowM)

#include <hpx/hpx.h>
#include "wr_hpx_types.h"

--------------------------------------------------------------------------------
-- Global Mutable Structures
--------------------------------------------------------------------------------

-- {-# NOINLINE hpxActionTable #-}
-- hpxActionTable :: IORef (Map (FunPtr a) Action)
-- hpxActionTable = unsafePerformIO $ newIORef M.empty

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

type Consumer a = forall b. (a -> IO b) -> IO b

newtype Action a = Action { useAction :: Ptr CAction }
  deriving (Eq, Show)
type CAction = {#type hpx_action_t #}

type ActionHandler = Ptr () -> {# type size_t #} -> IO CInt

foreign import ccall unsafe "wrapper"
    newActionHandler :: ActionHandler -> IO (FunPtr ActionHandler)

-- TODO: Figure out best resource-freeing strategy for HPX
withFunWrapper :: (a -> IO (FunPtr a)) -> a -> (FunPtr a -> IO b) -> IO b
withFunWrapper wrapper hFun f = wrapper hFun >>= f

--------------------------------------------------------------------------------
-- Initialization
--------------------------------------------------------------------------------

{-# INLINEABLE init #-}
init :: IO [String]
init = initWith =<< liftM2 (:) getProgName getArgs

initWith :: [String] -> IO [String]
initWith argv =
  withMany withCString argv $ \argv'  -> -- argv' :: [CString]
  withArray argv'           $ \argv'' -> -- argv'' :: Ptr CString
  with argv''               $ \argv''' -> do -- argv''' :: Ptr (Ptr CString)

    (r, argc) <- hpxInit (length argv) argv'''
    unless (r == 0) $ printHelp >> exitFailure
    x <- peekArray argc =<< peek argv''' -- :: [Ptr CString]
    mapM peekCString x

{#fun unsafe hpx_init as ^
  { withIntConv* `Int'                   peekIntConv*
  , id           `Ptr (Ptr (Ptr CChar))'
  }           -> `Int' cIntConv #}

--------------------------------------------------------------------------------
-- Action Registration
--------------------------------------------------------------------------------

--Different # of args:

-- {#fun unsafe variadic hpx_register_action[??] as ^
--   { alloca-      `Action' peekAction*
--   , withCString* `String'
--   , id           `Handler'
--   }           -> `Int' cIntConv #}
--  where peekAction = fmap Action . peek

{#enum hpx_action_type_t as ActionType
  { HPX_DEFAULT   as Default
  , HPX_TASK      as Task
  , HPX_INTERRUPT as Interrupt
  , HPX_FUNCTION  as Function
  } deriving (Bounded, Eq, Ix, Ord, Read, Show) #}

{#enum define HPXAttribute
  { HPX_ATTR_NONE  as NoAttribute
  , HPX_MARSHALLED as Marshalled
  , HPX_PINNED     as Pinned
  } deriving (Bounded, Eq, Ix, Ord, Read, Show) #}

-- -- TODO: Convert Int into Enum
-- {#fun unsafe variadic hpx_register_action[??] as ^
--   {
--   , cIntConv     `Int'
--   , withCString* `String'
--   , alloca-      `Action' peekAction*
--   , id           `Handler'
--   }           -> `Int' cIntConv #}
--  where peekAction = fmap Action . peek

-- foreign import ccall "hpx.h &hpx_register_action"
--     hpx_register_action_fun :: FunPtr ()
--
-- foreign import ccall "hpx.h &_hpx_run"
--     hpx_run_fun :: FunPtr ()
--
-- hpx_register_action :: forall f.
--                     ( All FFIType (HMap Proxy (ArgList f))
--                     , FFIFunction f
--                     , FunReturnType f ~ CInt
--                     , HVectSing (HMap Proxy (ArgList f))
--                     ) => ActionType -> Int -> String -> f -> IO (CInt, Action f)
-- hpx_register_action actionType attr key actionHandler = alloca $ \(idPtr :: Ptr CAction) -> do
--   let hArgs   = hSing :: HVect (HMap Proxy (ArgList f))
--       numArgs = fromIntegral . sNatToInt $ HVect.length hArgs
--   h  <- wrapFunPtr actionHandler
--   rc <- callFFI hpx_register_action_fun retCInt $
--     [ toArg (fromIntegral $ fromEnum actionType :: {#type hpx_action_type_t #})
--     , argCUInt (fromIntegral attr)
--     , argString key
--     , argPtr idPtr
--     , argFunPtr h
--     , argCInt numArgs
--     ] ++ map argPtr (toFFITypeList hArgs)
-- --   actionID <- fmap Action $ peek idPtr
--   return (rc, Action idPtr)
--
-- registerAction :: forall f.
--                 ( All FFIType (HMap Proxy (ArgList f))
--                 , FFIFunction f
--                 , FunReturnType f ~ CInt
--                 , HVectSing (HMap Proxy (ArgList f))
--                 ) => ActionType -> Int -> String -> f -> IO (Action f)
-- registerAction actionType attr key = fmap snd . hpx_register_action actionType attr key

{#fun pure wr_hpx_pointer as hpxPointer {} -> `Ptr ()' #}
{#fun pure wr_hpx_size    as hpxSize    {} -> `Ptr ()' #}

{#fun unsafe variadic hpx_register_action[hpx_type_t, hpx_type_t] as ^
  {              `ActionType'
  ,              `HPXAttribute'
  ,              `String'
  ,      alloca- `Action a' Action
  , withHandler* `ActionHandler'
  ,         two- `Int'
  ,    pointerT- `Ptr ()'
  ,       sizeT- `Ptr ()'
  }           -> `Int' #}
  where
    pointerT, sizeT :: Consumer (Ptr ())
    pointerT = (hpxPointer &)
    sizeT    = (hpxSize &)

    withHandler :: ActionHandler -> (FunPtr ActionHandler -> IO a) -> IO a
    withHandler = withFunWrapper newActionHandler

-- TODO: Remove the need to pass an explicit String ID
registerAction :: Binary a
               => ActionType
               -> HPXAttribute
               -> String
               -> StaticPtr (a -> IO ())
               -> IO (Action a)
registerAction actionT attr key clbk = do
    -- TODO: Figure out what error codes can be produced here
    (_r, a) <- hpxRegisterAction actionT attr key c_callback
    return a
  where
    c_callback :: ActionHandler
    c_callback cstr len = do
        bs <- unsafePackCStringLen (castPtr cstr, fromIntegral len)
        0 <$ deRefStaticPtr clbk (decode (BL.fromStrict bs))

-- {-# INLINEABLE registerAction#-}
-- registerAction :: String -> (Ptr () -> IO CInt) -> IO ()
-- registerAction s p = do
--   ptr <- wrap p
--   (_r, act) <- hpxRegisterAction s ptr
--   -- TODO throw exception on '_r'
--   modifyIORef hpxActionTable (M.insert ptr act)
--   putStrLn $ "Registered action pointer: " ++ show ptr ++ " with key: " ++ show s

--------------------------------------------------------------------------------
-- Runtime Calls
--------------------------------------------------------------------------------

-- {#fun _hpx_run as ^
--   { withAction*  `Action'
--   , cIntConv     `Int'
-- --  , id           `Ptr ()'
--   }           -> `Int' cIntConv #}
--   where
--     withAction = with . useAction

-- run :: (Ptr () -> IO CInt) -> Ptr () -> Int -> IO Int
-- run p _args size = do
--   tbl <- readIORef hpxActionTable
--   ptr <- wrap p
--   case M.lookup ptr tbl of
--      Nothing -> error $ "ERROR: Invalid action pointer: " ++ show ptr
--      Just action -> hpxRun action size -- _args

{#fun variadic _hpx_run[const char*, const int] as ^
  {           useAction `Action a' Action
  ,                two- `Int'
  , withCStringLenConv* `BS.ByteString'&
  }                  -> `Int' #}
  where
    withCStringLenConv :: BS.ByteString -> Consumer (CString, CInt)
    withCStringLenConv bs f = unsafeUseAsCStringLen bs $ \(cstr, len) -> f (cstr, fromIntegral len)

run :: Binary a => Action a -> a -> IO (Int, Action a)
run action = fmap (first fromIntegral) . hpxRun action . BL.toStrict . encode

-- hpx_run :: ( ToHVect args
--            , All ToArg (HVectOf args)
--            , ArgList f ~ HVectOf args
--            ) => Action f -> args -> IO CInt
-- hpx_run action args =
--     let hArgs   = hFromTuple args
--         numArgs = fromIntegral . sNatToInt $ HVect.length hArgs
--     in callFFI hpx_run_fun retCInt $ [argPtr (useAction action), argCInt numArgs] ++ toArgList hArgs
--
-- run :: ( ToHVect args
--        , All ToArg (HVectOf args)
--        , ArgList f ~ HVectOf args
--        ) => Action f -> args -> IO ()
-- run action = void . hpx_run action

{#fun unsafe hpx_print_help as ^ {} -> `()' #}

printHelp :: IO ()
printHelp = hpxPrintHelp

{#fun unsafe hpx_finalize as ^ {} -> `()' #}

finalize :: IO ()
finalize = hpxFinalize

{#fun hpx_exit as ^
  { cIntConv `Int'
  }       -> `()' #}

exit :: Int -> IO ()
exit = hpxExit

two :: Num n => Consumer n
two = (2 &)


gio: S.G.File: specify module exports

gio: S.G.File: specify module exports

--  GIMP Toolkit (GTK) Binding for Haskell: binding to gio -*-haskell-*-
--
--  Author : Peter Gavin
--  Created: 13-Oct-2008
--
--  Copyright (c) 2008 Peter Gavin
--
--  This library is free software: you can redistribute it and/or
--  modify it under the terms of the GNU Lesser General Public License
--  as published by the Free Software Foundation, either version 3 of
--  the License, or (at your option) any later version.
--
--  This library is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
--  Lesser General Public License for more details.
--
--  You should have received a copy of the GNU Lesser General Public
--  License along with this program.  If not, see
--  <http://www.gnu.org/licenses/>.
--
--  GIO, the C library which this Haskell library depends on, is
--  available under LGPL Version 2. The documentation included with
--  this library is based on the original GIO documentation,
--  Copyright (c) 2001 Seth Nickell <snickell@stanford.edu>. The
--  documentation is covered by the GNU Free Documentation License,
--  version 1.2.
--
-- | Maintainer  : gtk2hs-devel@lists.sourceforge.net
--   Stability   : alpha
--   Portability : portable (depends on GHC)
module System.GIO.File (
    File,
    FileClass,
    FileQueryInfoFlags,
    FileCreateFlags,
    FileCopyFlags,
    FileMonitorFlags,
    FilesystemPreviewType,
    FileProgressCallback,
    FileReadMoreCallback,
    fileNewForPath,
    fileNewForURI,
    fileNewForCommandlineArg,
    fileParseName,
    fileDup,
    fileEqual,
    fileGetBasename,
    fileGetPath,
    fileGetURI,
    fileGetParseName,
    fileGetChild,
    fileGetChildForDisplayName,
    fileHasPrefix,
    fileGetRelativePath,
    fileResolveRelativePath,
    fileIsNative,
    fileHasURIScheme,
    fileGetURIScheme,
    fileRead,
    fileReadAsync,
    fileReadFinish,
    fileAppendTo,
    fileCreate,
    fileReplace,
    fileAppendToAsync,
    fileAppendToFinish,
    fileCreateAsync,
    fileCreateFinish,
    fileReplaceAsync,
    fileReplaceFinish,
    fileQueryInfo,
    fileQueryInfoAsync,
    fileQueryExists,
    fileQueryFilesystemInfo
    ) where

import Control.Monad
import qualified Data.ByteString as BS
import Data.Typeable

import System.Glib.FFI
import System.Glib.Flags
import System.Glib.GError
import System.Glib.UTFString

import System.GIO.Base
{#import System.GIO.Types#}

{# context lib = "gio" prefix = "g" #}

{# enum GFileQueryInfoFlags as FileQueryInfoFlags {underscoreToCase} with prefix = "G" deriving (Eq, Ord, Bounded, Show, Typeable) #}
instance Flags FileQueryInfoFlags

{# enum GFileCreateFlags as FileCreateFlags {underscoreToCase} with prefix = "G" deriving (Eq, Ord, Bounded, Show, Typeable) #}
instance Flags FileCreateFlags

{# enum GFileCopyFlags as FileCopyFlags {underscoreToCase} with prefix = "G" deriving (Eq, Ord, Bounded, Show, Typeable) #}
instance Flags FileCopyFlags

{# enum GFileMonitorFlags as FileMonitorFlags {underscoreToCase} with prefix = "G" deriving (Eq, Ord, Bounded, Show, Typeable) #}
instance Flags FileMonitorFlags

{# enum GFilesystemPreviewType as FilesystemPreviewType {underscoreToCase} with prefix = "G" deriving (Eq, Ord, Bounded, Show, Typeable) #}

type FileProgressCallback = {# type goffset #} -> {# type goffset #} -> IO ()
type FileReadMoreCallback = BS.ByteString -> IO Bool

fileNewForPath :: FilePath -> IO File
fileNewForPath path =
    withUTFString path $ {# call file_new_for_path #} >=> takeGObject

fileNewForURI :: String -> IO File
fileNewForURI uri =
    withUTFString uri $ {# call file_new_for_uri #} >=> takeGObject

fileNewForCommandlineArg :: String -> IO File
fileNewForCommandlineArg arg =
    withUTFString arg $ {# call file_new_for_commandline_arg #} >=> takeGObject

fileParseName :: String -> IO File
fileParseName parseName =
    withUTFString parseName $ {# call file_parse_name #} >=> takeGObject

fileDup :: FileClass file
        => file -> IO file
fileDup =
    {# call file_dup #} . toFile >=> takeGObject . castPtr

fileEqual :: (FileClass file1, FileClass file2)
          => file1 -> file2 -> IO Bool
fileEqual file1 file2 =
    liftM toBool $ {# call file_equal #} (toFile file1) (toFile file2)

fileGetBasename :: FileClass file => file -> IO String
fileGetBasename =
    {# call file_get_basename #} . toFile >=> readUTFString

fileGetPath :: FileClass file => file -> IO FilePath
fileGetPath =
    {# call file_get_path #} . toFile >=> readUTFString

fileGetURI :: FileClass file => file -> IO String
fileGetURI =
    {# call file_get_uri #} . toFile >=> readUTFString

fileGetParseName :: FileClass file => file -> IO String
fileGetParseName =
    {# call file_get_parse_name #} . toFile >=> readUTFString

fileGetParent :: FileClass file => file -> IO (Maybe File)
fileGetParent =
    {# call file_get_parent #} . toFile >=> maybePeek takeGObject

fileGetChild :: FileClass file => file -> String -> IO (Maybe File)
fileGetChild file name =
    withUTFString name $ {# call file_get_child #} (toFile file) >=> maybePeek takeGObject

fileGetChildForDisplayName :: FileClass file => file -> String -> IO File
fileGetChildForDisplayName file displayName =
    withUTFString displayName $ \cDisplayName ->
        propagateGError ({# call file_get_child_for_display_name #} (toFile file) cDisplayName) >>=
        takeGObject

fileHasPrefix :: (FileClass file1, FileClass file2) => file1 -> file2 -> IO Bool
fileHasPrefix file1 file2 =
    liftM toBool $ {# call file_has_prefix #} (toFile file1) (toFile file2)

fileGetRelativePath :: (FileClass file1, FileClass file2) => file1 -> file2 -> IO FilePath
fileGetRelativePath file1 file2 =
    {# call file_get_relative_path #} (toFile file1) (toFile file2) >>= readUTFString

fileResolveRelativePath :: FileClass file => file -> FilePath -> IO (Maybe File)
fileResolveRelativePath file relativePath =
    withUTFString relativePath $ \cRelativePath ->
        {# call file_resolve_relative_path #} (toFile file) cRelativePath >>=
        maybePeek takeGObject

fileIsNative :: FileClass file => file -> IO Bool
fileIsNative =
    liftM toBool . {# call file_is_native #} . toFile

fileHasURIScheme :: FileClass file => file -> String -> IO Bool
fileHasURIScheme file uriScheme =
    withUTFString uriScheme $ \cURIScheme ->
        liftM toBool $ {# call file_has_uri_scheme #} (toFile file) cURIScheme

fileGetURIScheme :: FileClass file => file -> IO String
fileGetURIScheme =
    {# call file_get_uri_scheme #} . toFile >=> readUTFString

fileRead :: FileClass file => file -> Maybe Cancellable -> IO FileInputStream
fileRead file cancellable =
    withGObject (toFile file) $ \cFile ->
        maybeWith withGObject cancellable $ \cCancellable ->
            propagateGError (g_file_read cFile cCancellable) >>= takeGObject
    where _ = {# call file_read #}

fileReadAsync :: FileClass file
              => file
              -> Int
              -> Maybe Cancellable
              -> AsyncReadyCallback
              -> IO ()
fileReadAsync file ioPriority mbCancellable callback =
    withGObject (toFile file) $ \cFile ->
        maybeWith withGObject mbCancellable $ \cCancellable -> do
          cCallback <- marshalAsyncReadyCallback callback
          g_file_read_async cFile
                            (fromIntegral ioPriority)
                            cCancellable
                            cCallback
                            (castFunPtrToPtr cCallback)
    where _ = {# call file_read_async #}

fileReadFinish :: FileClass file
               => file
               -> AsyncResult
               -> IO FileInputStream
fileReadFinish file asyncResult =
    propagateGError ({# call file_read_finish #} (toFile file) asyncResult) >>= takeGObject

fileAppendTo :: FileClass file
             => file
             -> [FileCreateFlags]
             -> Maybe Cancellable
             -> IO FileOutputStream
fileAppendTo file flags cancellable =
    withGObject (toFile file) $ \cFile ->
        maybeWith withGObject cancellable $ \cCancellable ->
        propagateGError (g_file_append_to cFile (cFromFlags flags) cCancellable) >>=
        takeGObject
    where _ = {# call file_append_to #}

fileCreate :: FileClass file
           => file
           -> [FileCreateFlags]
           -> Maybe Cancellable
           -> IO FileOutputStream
fileCreate file flags cancellable =
    withGObject (toFile file) $ \cFile ->
        maybeWith withGObject cancellable $ \cCancellable ->
        propagateGError (g_file_create cFile (cFromFlags flags) cCancellable) >>=
        takeGObject
    where _ = {# call file_create #}

fileReplace :: FileClass file
            => file
            -> Maybe String
            -> Bool
            -> [FileCreateFlags]
            -> Maybe Cancellable
            -> IO FileOutputStream
fileReplace file etag makeBackup flags cancellable =
    withGObject (toFile file) $ \cFile ->
        maybeWith withUTFString etag $ \cEtag ->
        maybeWith withGObject cancellable $ \cCancellable ->
        propagateGError (g_file_replace cFile
                                        cEtag
                                        (fromBool makeBackup)
                                        (cFromFlags flags) cCancellable) >>=
        takeGObject
    where _ = {# call file_replace #}

fileAppendToAsync :: FileClass file
                  => file
                  -> [FileCreateFlags]
                  -> Int
                  -> Maybe Cancellable
                  -> AsyncReadyCallback
                  -> IO ()
fileAppendToAsync file flags ioPriority cancellable callback =
    withGObject (toFile file) $ \cFile ->
        maybeWith withGObject cancellable $ \cCancellable -> do
          cCallback <- marshalAsyncReadyCallback callback
          g_file_append_to_async cFile
                                 (cFromFlags flags)
                                 (fromIntegral ioPriority)
                                 cCancellable
                                 cCallback
                                 (castFunPtrToPtr cCallback)
    where _ = {# call file_append_to_async #}

fileAppendToFinish :: FileClass file
                   => file
                   -> AsyncResult
                   -> IO FileOutputStream
fileAppendToFinish file asyncResult =
    propagateGError ({# call file_append_to_finish #} (toFile file) asyncResult) >>= takeGObject

fileCreateAsync :: FileClass file
                  => file
                  -> [FileCreateFlags]
                  -> Int
                  -> Maybe Cancellable
                  -> AsyncReadyCallback
                  -> IO ()
fileCreateAsync file flags ioPriority cancellable callback =
    withGObject (toFile file) $ \cFile ->
        maybeWith withGObject cancellable $ \cCancellable -> do
          cCallback <- marshalAsyncReadyCallback callback
          g_file_create_async cFile
                              (cFromFlags flags)
                              (fromIntegral ioPriority)
                              cCancellable
                              cCallback
                              (castFunPtrToPtr cCallback)
    where _ = {# call file_create_async #}

fileCreateFinish :: FileClass file
                   => file
                   -> AsyncResult
                   -> IO FileOutputStream
fileCreateFinish file asyncResult =
    propagateGError ({# call file_create_finish #} (toFile file) asyncResult) >>= takeGObject

fileReplaceAsync :: FileClass file
                 => file
                 -> String
                 -> Bool
                 -> [FileCreateFlags]
                 -> Int
                 -> Maybe Cancellable
                 -> AsyncReadyCallback
                 -> IO ()
fileReplaceAsync file etag makeBackup flags ioPriority cancellable callback =
    withGObject (toFile file) $ \cFile ->
        withUTFString etag $ \cEtag ->
        maybeWith withGObject cancellable $ \cCancellable -> do
          cCallback <- marshalAsyncReadyCallback callback
          g_file_replace_async cFile
                               cEtag
                               (fromBool makeBackup)
                               (cFromFlags flags)
                               (fromIntegral ioPriority)
                               cCancellable
                               cCallback
                               (castFunPtrToPtr cCallback)
    where _ = {# call file_replace_async #}

fileReplaceFinish :: FileClass file
                  => file
                  -> AsyncResult
                  -> IO FileOutputStream
fileReplaceFinish file asyncResult =
    propagateGError ({# call file_replace_finish #} (toFile file) asyncResult) >>= takeGObject

fileQueryInfo :: FileClass file
              => file
              -> String
              -> [FileQueryInfoFlags]
              -> Maybe Cancellable
              -> IO FileInfo
fileQueryInfo file attributes flags cancellable =
    withGObject (toFile file) $ \cFile ->
        withUTFString attributes $ \cAttributes ->
        maybeWith withGObject cancellable $ \cCancellable ->
        propagateGError (g_file_query_info cFile cAttributes (cFromFlags flags) cCancellable) >>=
        takeGObject
    where _ = {# call file_query_info #}

fileQueryInfoAsync :: FileClass file
                   => file
                   -> String
                   -> [FileQueryInfoFlags]
                   -> Int
                   -> Maybe Cancellable
                   -> AsyncReadyCallback
                   -> IO ()
fileQueryInfoAsync file attributes flags ioPriority cancellable callback =
    withGObject (toFile file) $ \cFile ->
        withUTFString attributes $ \cAttributes ->
        maybeWith withGObject cancellable $ \cCancellable -> do
          cCallback <- marshalAsyncReadyCallback callback
          g_file_query_info_async cFile
                                  cAttributes
                                  (cFromFlags flags)
                                  (fromIntegral ioPriority)
                                  cCancellable
                                  cCallback
                                  (castFunPtrToPtr cCallback)
    where _ = {# call file_query_info_async #}

fileQueryExists :: FileClass file
                => file
                -> Maybe Cancellable
                -> IO Bool
fileQueryExists file cancellable =
    withGObject (toFile file) $ \cFile ->
        maybeWith withGObject cancellable $ \cCancellable ->
            liftM toBool $ g_file_query_exists cFile cCancellable
    where _ = {# call file_query_exists #}

fileQueryFilesystemInfo :: FileClass file
                        => file
                        -> String
                        -> Maybe Cancellable
                        -> IO FileInfo
fileQueryFilesystemInfo file attributes cancellable =
    withGObject (toFile file) $ \cFile ->
        withUTFString attributes $ \cAttributes ->
        maybeWith withGObject cancellable $ \cCancellable ->
        propagateGError (g_file_query_filesystem_info cFile cAttributes cCancellable) >>=
        takeGObject
    where _ = {# call file_query_filesystem_info #}

--  GIMP Toolkit (GTK) Binding for Haskell: binding to gio -*-haskell-*-
--
--  Author : Peter Gavin
--  Created: 13-Oct-2008
--
--  Copyright (c) 2008 Peter Gavin
--
--  This library is free software: you can redistribute it and/or
--  modify it under the terms of the GNU Lesser General Public License
--  as published by the Free Software Foundation, either version 3 of
--  the License, or (at your option) any later version.
--
--  This library is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
--  Lesser General Public License for more details.
--
--  You should have received a copy of the GNU Lesser General Public
--  License along with this program.  If not, see
--  <http://www.gnu.org/licenses/>.
--
--  GIO, the C library which this Haskell library depends on, is
--  available under LGPL Version 2. The documentation included with
--  this library is based on the original GIO documentation,
--  Copyright (c) 2001 Seth Nickell <snickell@stanford.edu>. The
--  documentation is covered by the GNU Free Documentation License,
--  version 1.2.
--
-- | Maintainer  : gtk2hs-devel@lists.sourceforge.net
--   Stability   : alpha
--   Portability : portable (depends on GHC)
module System.GIO.File where

import Control.Monad
import qualified Data.ByteString as BS
import Data.Typeable

import System.Glib.FFI
import System.Glib.Flags
import System.Glib.GError
import System.Glib.UTFString

import System.GIO.Base
{#import System.GIO.Types#}

{# context lib = "gio" prefix = "g" #}

{# enum GFileQueryInfoFlags as FileQueryInfoFlags {underscoreToCase} with prefix = "G" deriving (Eq, Ord, Bounded, Show, Typeable) #}
instance Flags FileQueryInfoFlags

{# enum GFileCreateFlags as FileCreateFlags {underscoreToCase} with prefix = "G" deriving (Eq, Ord, Bounded, Show, Typeable) #}
instance Flags FileCreateFlags

{# enum GFileCopyFlags as FileCopyFlags {underscoreToCase} with prefix = "G" deriving (Eq, Ord, Bounded, Show, Typeable) #}
instance Flags FileCopyFlags

{# enum GFileMonitorFlags as FileMonitorFlags {underscoreToCase} with prefix = "G" deriving (Eq, Ord, Bounded, Show, Typeable) #}
instance Flags FileMonitorFlags

{# enum GFilesystemPreviewType as FilesystemPreviewType {underscoreToCase} with prefix = "G" deriving (Eq, Ord, Bounded, Show, Typeable) #}

type FileProgressCallback = {# type goffset #} -> {# type goffset #} -> IO ()
type FileReadMoreCallback = BS.ByteString -> IO Bool

fileNewForPath :: FilePath -> IO File
fileNewForPath path =
    withUTFString path $ {# call file_new_for_path #} >=> takeGObject

fileNewForURI :: String -> IO File
fileNewForURI uri =
    withUTFString uri $ {# call file_new_for_uri #} >=> takeGObject

fileNewForCommandlineArg :: String -> IO File
fileNewForCommandlineArg arg =
    withUTFString arg $ {# call file_new_for_commandline_arg #} >=> takeGObject

fileParseName :: String -> IO File
fileParseName parseName =
    withUTFString parseName $ {# call file_parse_name #} >=> takeGObject

fileDup :: FileClass file
        => file -> IO file
fileDup =
    {# call file_dup #} . toFile >=> takeGObject . castPtr

fileEqual :: (FileClass file1, FileClass file2)
          => file1 -> file2 -> IO Bool
fileEqual file1 file2 =
    liftM toBool $ {# call file_equal #} (toFile file1) (toFile file2)

fileGetBasename :: FileClass file => file -> IO String
fileGetBasename =
    {# call file_get_basename #} . toFile >=> readUTFString

fileGetPath :: FileClass file => file -> IO FilePath
fileGetPath =
    {# call file_get_path #} . toFile >=> readUTFString

fileGetURI :: FileClass file => file -> IO String
fileGetURI =
    {# call file_get_uri #} . toFile >=> readUTFString

fileGetParseName :: FileClass file => file -> IO String
fileGetParseName =
    {# call file_get_parse_name #} . toFile >=> readUTFString

fileGetParent :: FileClass file => file -> IO (Maybe File)
fileGetParent =
    {# call file_get_parent #} . toFile >=> maybePeek takeGObject

fileGetChild :: FileClass file => file -> String -> IO (Maybe File)
fileGetChild file name =
    withUTFString name $ {# call file_get_child #} (toFile file) >=> maybePeek takeGObject

fileGetChildForDisplayName :: FileClass file => file -> String -> IO File
fileGetChildForDisplayName file displayName =
    withUTFString displayName $ \cDisplayName ->
        propagateGError ({# call file_get_child_for_display_name #} (toFile file) cDisplayName) >>=
        takeGObject

fileHasPrefix :: (FileClass file1, FileClass file2) => file1 -> file2 -> IO Bool
fileHasPrefix file1 file2 =
    liftM toBool $ {# call file_has_prefix #} (toFile file1) (toFile file2)

fileGetRelativePath :: (FileClass file1, FileClass file2) => file1 -> file2 -> IO FilePath
fileGetRelativePath file1 file2 =
    {# call file_get_relative_path #} (toFile file1) (toFile file2) >>= readUTFString

fileResolveRelativePath :: FileClass file => file -> FilePath -> IO (Maybe File)
fileResolveRelativePath file relativePath =
    withUTFString relativePath $ \cRelativePath ->
        {# call file_resolve_relative_path #} (toFile file) cRelativePath >>=
        maybePeek takeGObject

fileIsNative :: FileClass file => file -> IO Bool
fileIsNative =
    liftM toBool . {# call file_is_native #} . toFile

fileHasURIScheme :: FileClass file => file -> String -> IO Bool
fileHasURIScheme file uriScheme =
    withUTFString uriScheme $ \cURIScheme ->
        liftM toBool $ {# call file_has_uri_scheme #} (toFile file) cURIScheme

fileGetURIScheme :: FileClass file => file -> IO String
fileGetURIScheme =
    {# call file_get_uri_scheme #} . toFile >=> readUTFString

fileRead :: FileClass file => file -> Maybe Cancellable -> IO FileInputStream
fileRead file cancellable =
    withGObject (toFile file) $ \cFile ->
        maybeWith withGObject cancellable $ \cCancellable ->
            propagateGError (g_file_read cFile cCancellable) >>= takeGObject
    where _ = {# call file_read #}

fileReadAsync :: FileClass file
              => file
              -> Int
              -> Maybe Cancellable
              -> AsyncReadyCallback
              -> IO ()
fileReadAsync file ioPriority mbCancellable callback =
    withGObject (toFile file) $ \cFile ->
        maybeWith withGObject mbCancellable $ \cCancellable -> do
          cCallback <- marshalAsyncReadyCallback callback
          g_file_read_async cFile
                            (fromIntegral ioPriority)
                            cCancellable
                            cCallback
                            (castFunPtrToPtr cCallback)
    where _ = {# call file_read_async #}

fileReadFinish :: FileClass file
               => file
               -> AsyncResult
               -> IO FileInputStream
fileReadFinish file asyncResult =
    propagateGError ({# call file_read_finish #} (toFile file) asyncResult) >>= takeGObject

fileAppendTo :: FileClass file
             => file
             -> [FileCreateFlags]
             -> Maybe Cancellable
             -> IO FileOutputStream
fileAppendTo file flags cancellable =
    withGObject (toFile file) $ \cFile ->
        maybeWith withGObject cancellable $ \cCancellable ->
        propagateGError (g_file_append_to cFile (cFromFlags flags) cCancellable) >>=
        takeGObject
    where _ = {# call file_append_to #}

fileCreate :: FileClass file
           => file
           -> [FileCreateFlags]
           -> Maybe Cancellable
           -> IO FileOutputStream
fileCreate file flags cancellable =
    withGObject (toFile file) $ \cFile ->
        maybeWith withGObject cancellable $ \cCancellable ->
        propagateGError (g_file_create cFile (cFromFlags flags) cCancellable) >>=
        takeGObject
    where _ = {# call file_create #}

fileReplace :: FileClass file
            => file
            -> Maybe String
            -> Bool
            -> [FileCreateFlags]
            -> Maybe Cancellable
            -> IO FileOutputStream
fileReplace file etag makeBackup flags cancellable =
    withGObject (toFile file) $ \cFile ->
        maybeWith withUTFString etag $ \cEtag ->
        maybeWith withGObject cancellable $ \cCancellable ->
        propagateGError (g_file_replace cFile
                                        cEtag
                                        (fromBool makeBackup)
                                        (cFromFlags flags) cCancellable) >>=
        takeGObject
    where _ = {# call file_replace #}

fileAppendToAsync :: FileClass file
                  => file
                  -> [FileCreateFlags]
                  -> Int
                  -> Maybe Cancellable
                  -> AsyncReadyCallback
                  -> IO ()
fileAppendToAsync file flags ioPriority cancellable callback =
    withGObject (toFile file) $ \cFile ->
        maybeWith withGObject cancellable $ \cCancellable -> do
          cCallback <- marshalAsyncReadyCallback callback
          g_file_append_to_async cFile
                                 (cFromFlags flags)
                                 (fromIntegral ioPriority)
                                 cCancellable
                                 cCallback
                                 (castFunPtrToPtr cCallback)
    where _ = {# call file_append_to_async #}

fileAppendToFinish :: FileClass file
                   => file
                   -> AsyncResult
                   -> IO FileOutputStream
fileAppendToFinish file asyncResult =
    propagateGError ({# call file_append_to_finish #} (toFile file) asyncResult) >>= takeGObject

fileCreateAsync :: FileClass file
                  => file
                  -> [FileCreateFlags]
                  -> Int
                  -> Maybe Cancellable
                  -> AsyncReadyCallback
                  -> IO ()
fileCreateAsync file flags ioPriority cancellable callback =
    withGObject (toFile file) $ \cFile ->
        maybeWith withGObject cancellable $ \cCancellable -> do
          cCallback <- marshalAsyncReadyCallback callback
          g_file_create_async cFile
                              (cFromFlags flags)
                              (fromIntegral ioPriority)
                              cCancellable
                              cCallback
                              (castFunPtrToPtr cCallback)
    where _ = {# call file_create_async #}

fileCreateFinish :: FileClass file
                   => file
                   -> AsyncResult
                   -> IO FileOutputStream
fileCreateFinish file asyncResult =
    propagateGError ({# call file_create_finish #} (toFile file) asyncResult) >>= takeGObject

fileReplaceAsync :: FileClass file
                 => file
                 -> String
                 -> Bool
                 -> [FileCreateFlags]
                 -> Int
                 -> Maybe Cancellable
                 -> AsyncReadyCallback
                 -> IO ()
fileReplaceAsync file etag makeBackup flags ioPriority cancellable callback =
    withGObject (toFile file) $ \cFile ->
        withUTFString etag $ \cEtag ->
        maybeWith withGObject cancellable $ \cCancellable -> do
          cCallback <- marshalAsyncReadyCallback callback
          g_file_replace_async cFile
                               cEtag
                               (fromBool makeBackup)
                               (cFromFlags flags)
                               (fromIntegral ioPriority)
                               cCancellable
                               cCallback
                               (castFunPtrToPtr cCallback)
    where _ = {# call file_replace_async #}

fileReplaceFinish :: FileClass file
                  => file
                  -> AsyncResult
                  -> IO FileOutputStream
fileReplaceFinish file asyncResult =
    propagateGError ({# call file_replace_finish #} (toFile file) asyncResult) >>= takeGObject

fileQueryInfo :: FileClass file
              => file
              -> String
              -> [FileQueryInfoFlags]
              -> Maybe Cancellable
              -> IO FileInfo
fileQueryInfo file attributes flags cancellable =
    withGObject (toFile file) $ \cFile ->
        withUTFString attributes $ \cAttributes ->
        maybeWith withGObject cancellable $ \cCancellable ->
        propagateGError (g_file_query_info cFile cAttributes (cFromFlags flags) cCancellable) >>=
        takeGObject
    where _ = {# call file_query_info #}

fileQueryInfoAsync :: FileClass file
                   => file
                   -> String
                   -> [FileQueryInfoFlags]
                   -> Int
                   -> Maybe Cancellable
                   -> AsyncReadyCallback
                   -> IO ()
fileQueryInfoAsync file attributes flags ioPriority cancellable callback =
    withGObject (toFile file) $ \cFile ->
        withUTFString attributes $ \cAttributes ->
        maybeWith withGObject cancellable $ \cCancellable -> do
          cCallback <- marshalAsyncReadyCallback callback
          g_file_query_info_async cFile
                                  cAttributes
                                  (cFromFlags flags)
                                  (fromIntegral ioPriority)
                                  cCancellable
                                  cCallback
                                  (castFunPtrToPtr cCallback)
    where _ = {# call file_query_info_async #}

fileQueryExists :: FileClass file
                => file
                -> Maybe Cancellable
                -> IO Bool
fileQueryExists file cancellable =
    withGObject (toFile file) $ \cFile ->
        maybeWith withGObject cancellable $ \cCancellable ->
            liftM toBool $ g_file_query_exists cFile cCancellable
    where _ = {# call file_query_exists #}

fileQueryFilesystemInfo :: FileClass file
                        => file
                        -> String
                        -> Maybe Cancellable
                        -> IO FileInfo
fileQueryFilesystemInfo file attributes cancellable =
    withGObject (toFile file) $ \cFile ->
        withUTFString attributes $ \cAttributes ->
        maybeWith withGObject cancellable $ \cCancellable ->
        propagateGError (g_file_query_filesystem_info cFile cAttributes cCancellable) >>=
        takeGObject
    where _ = {# call file_query_filesystem_info #}


Retain the ByteBuffer in toLazyByteString.

The GHC does not know about the relationship of the ByteBuffer and the
ByteBufferReader. We need to explicitly retain the ByteBuffer while
we're reading its slices.

If we don't retain the ByteBuffer it may be GCed while or before we read
its data.

-- Copyright (c) 2016, Google Inc.
-- All rights reserved.
--
-- Redistribution and use in source and binary forms, with or without
-- modification, are permitted provided that the following conditions are met:
--     * Redistributions of source code must retain the above copyright
--       notice, this list of conditions and the following disclaimer.
--     * Redistributions in binary form must reproduce the above copyright
--       notice, this list of conditions and the following disclaimer in the
--       documentation and/or other materials provided with the distribution.
--     * Neither the name of Google Inc. nor the
--       names of its contributors may be used to endorse or promote products
--       derived from this software without specific prior written permission.
--
-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
-- ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
-- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
-- DISCLAIMED. IN NO EVENT SHALL Google Inc. BE LIABLE FOR ANY
-- DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
-- (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
-- LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
-- ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
-- (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
--
--------------------------------------------------------------------------------
{-# LANGUAGE ForeignFunctionInterface #-}
module Network.Grpc.Lib.ByteBuffer
  ( CByteBuffer
  , fromByteString
  , addBBFinalizer
  , toLazyByteString

  , CByteBufferReader
  ) where

import Foreign.C.Types
import Foreign.ForeignPtr
import Foreign.Marshal.Alloc
import Foreign.Ptr

import Control.Exception (bracket)

import Data.ByteString (ByteString)
import qualified Data.ByteString as B
import qualified Data.ByteString.Internal as B
import qualified Data.ByteString.Lazy as L

#include <grpc/byte_buffer.h>
#include <grpc/byte_buffer_reader.h>
#include "hs_byte_buffer.h"

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

data CByteBuffer
{#pointer *byte_buffer as ByteBuffer foreign -> CByteBuffer#}
data CByteBufferReader
{#pointer *byte_buffer_reader as ByteBufferReader -> CByteBufferReader#}

data CSlice
{#pointer *gpr_slice as Slice -> CSlice#}

fromByteString :: ByteString -> IO ByteBuffer
fromByteString = hsRawByteBufferCreate

withByteString :: ByteString -> ((Ptr CChar, CULong) -> IO a) -> IO a
withByteString bs act = do
  let (fPtr, offset, len) = B.toForeignPtr bs
  withForeignPtr fPtr $ \ptr -> act (ptr `plusPtr` offset, fromIntegral len)

{#fun unsafe hs_raw_byte_buffer_create as ^
  {withByteString* `ByteString'&} -> `ByteBuffer' addBBFinalizer* #}

addBBFinalizer :: Ptr CByteBuffer -> IO ByteBuffer
addBBFinalizer bb = newForeignPtr grpc_byte_buffer_destroy bb

foreign import ccall "Network/Grpc/Core/ByteBuffer.chs.h &grpc_byte_buffer_destroy"
  grpc_byte_buffer_destroy :: FinalizerPtr CByteBuffer

toByteString :: Slice -> IO ByteString
toByteString slice = do
  refcount <- {#get gpr_slice->refcount#} slice
  if refcount == nullPtr
    then fromInlined
    else fromRefcounted
  where
    fromInlined = do
      len <- {#get gpr_slice->data.inlined.length#} slice
      ptr <- {#get gpr_slice->data.inlined.bytes#} slice
      B.packCStringLen (castPtr ptr, fromIntegral len)
    fromRefcounted = do
      len <- {#get gpr_slice->data.refcounted.length#} slice
      ptr <- {#get gpr_slice->data.refcounted.bytes#} slice
      B.packCStringLen (castPtr ptr, fromIntegral len)

toLazyByteString :: ByteBuffer -> IO L.ByteString
toLazyByteString bb = withForeignPtr bb $ \_ -> do
  bracket
    (byteBufferReaderInit bb)
    (byteBufferReaderDestroy)
    (\bbr -> fmap L.fromChunks (go bbr []))
  where
    go bbr acc = do
      (tag, slice) <- byteBufferReaderNext bbr
      case tag of
        0 -> return $ reverse acc
        _ -> do
          bs <- toByteString slice
          go bbr (bs:acc)

{#fun unsafe byte_buffer_reader_init as ^
  {allocaByteBufferReader- `ByteBufferReader' id, `ByteBuffer'} -> `()' #}

allocaSlice :: (Slice -> IO a) -> IO a
allocaSlice act = do
  allocaBytes {#sizeof gpr_slice#} $ \p -> act p

allocaByteBufferReader :: (ByteBufferReader -> IO a) -> IO a
allocaByteBufferReader act = do
  allocaBytes {#sizeof grpc_byte_buffer_reader#} $ \p -> act p

{#fun unsafe byte_buffer_reader_next as ^
  {`ByteBufferReader', allocaSlice- `Slice' id} -> `Int' fromIntegral#}

{#fun unsafe byte_buffer_reader_destroy as ^
  {`ByteBufferReader'} -> `()'#}

-- Copyright (c) 2016, Google Inc.
-- All rights reserved.
--
-- Redistribution and use in source and binary forms, with or without
-- modification, are permitted provided that the following conditions are met:
--     * Redistributions of source code must retain the above copyright
--       notice, this list of conditions and the following disclaimer.
--     * Redistributions in binary form must reproduce the above copyright
--       notice, this list of conditions and the following disclaimer in the
--       documentation and/or other materials provided with the distribution.
--     * Neither the name of Google Inc. nor the
--       names of its contributors may be used to endorse or promote products
--       derived from this software without specific prior written permission.
--
-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
-- ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
-- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
-- DISCLAIMED. IN NO EVENT SHALL Google Inc. BE LIABLE FOR ANY
-- DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
-- (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
-- LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
-- ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
-- (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
--
--------------------------------------------------------------------------------
{-# LANGUAGE ForeignFunctionInterface #-}
module Network.Grpc.Lib.ByteBuffer
  ( CByteBuffer
  , fromByteString
  , addBBFinalizer
  , toLazyByteString

  , CByteBufferReader
  ) where

import Foreign.C.Types
import Foreign.ForeignPtr
import Foreign.Marshal.Alloc
import Foreign.Ptr

import Control.Exception (bracket)

import Data.ByteString (ByteString)
import qualified Data.ByteString as B
import qualified Data.ByteString.Internal as B
import qualified Data.ByteString.Lazy as L

#include <grpc/byte_buffer.h>
#include <grpc/byte_buffer_reader.h>
#include "hs_byte_buffer.h"

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

data CByteBuffer
{#pointer *byte_buffer as ByteBuffer foreign -> CByteBuffer#}
data CByteBufferReader
{#pointer *byte_buffer_reader as ByteBufferReader -> CByteBufferReader#}

data CSlice
{#pointer *gpr_slice as Slice -> CSlice#}

fromByteString :: ByteString -> IO ByteBuffer
fromByteString = hsRawByteBufferCreate

withByteString :: ByteString -> ((Ptr CChar, CULong) -> IO a) -> IO a
withByteString bs act = do
  let (fPtr, offset, len) = B.toForeignPtr bs
  withForeignPtr fPtr $ \ptr -> act (ptr `plusPtr` offset, fromIntegral len)

{#fun unsafe hs_raw_byte_buffer_create as ^
  {withByteString* `ByteString'&} -> `ByteBuffer' addBBFinalizer* #}

addBBFinalizer :: Ptr CByteBuffer -> IO ByteBuffer
addBBFinalizer bb = newForeignPtr grpc_byte_buffer_destroy bb

foreign import ccall "Network/Grpc/Core/ByteBuffer.chs.h &grpc_byte_buffer_destroy"
  grpc_byte_buffer_destroy :: FinalizerPtr CByteBuffer

toByteString :: Slice -> IO ByteString
toByteString slice = do
  refcount <- {#get gpr_slice->refcount#} slice
  if refcount == nullPtr
    then fromInlined
    else fromRefcounted
  where
    fromInlined = do
      len <- {#get gpr_slice->data.inlined.length#} slice
      ptr <- {#get gpr_slice->data.inlined.bytes#} slice
      B.packCStringLen (castPtr ptr, fromIntegral len)
    fromRefcounted = do
      len <- {#get gpr_slice->data.refcounted.length#} slice
      ptr <- {#get gpr_slice->data.refcounted.bytes#} slice
      B.packCStringLen (castPtr ptr, fromIntegral len)

toLazyByteString :: ByteBuffer -> IO L.ByteString
toLazyByteString bb =
  bracket
    (byteBufferReaderInit bb)
    (byteBufferReaderDestroy)
    (\bbr -> fmap L.fromChunks (go bbr []))
  where
    go bbr acc = do
      (tag, slice) <- byteBufferReaderNext bbr
      case tag of
        0 -> return $ reverse acc
        _ -> do
          bs <- toByteString slice
          go bbr (bs:acc)

{#fun unsafe byte_buffer_reader_init as ^
  {allocaByteBufferReader- `ByteBufferReader' id, `ByteBuffer'} -> `()' #}

allocaSlice :: (Slice -> IO a) -> IO a
allocaSlice act = do
  allocaBytes {#sizeof gpr_slice#} $ \p -> act p

allocaByteBufferReader :: (ByteBufferReader -> IO a) -> IO a
allocaByteBufferReader act = do
  allocaBytes {#sizeof grpc_byte_buffer_reader#} $ \p -> act p

{#fun unsafe byte_buffer_reader_next as ^
  {`ByteBufferReader', allocaSlice- `Slice' id} -> `Int' fromIntegral#}

{#fun unsafe byte_buffer_reader_destroy as ^
  {`ByteBufferReader'} -> `()'#}


[project @ 2003-01-18 17:44:07 by as49] Move Plug.chs to ../embedding. It makes more sense and makes building on Windows easier.

-- -*-haskell-*-
--  GIMP Toolkit (GTK) @entry Widget Plug@
--
--  Author : Axel Simon
--
--  Created: 23 May 2001
--
--  Version $Revision: 1.3 $ from $Date: 2002/08/05 16:41:35 $
--
--  Copyright (c) 1999..2002 Axel Simon
--
--  This file is free software; you can redistribute it and/or modify
--  it under the terms of the GNU General Public License as published by
--  the Free Software Foundation; either version 2 of the License, or
--  (at your option) any later version.
--
--  This file is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
--  GNU General Public License for more details.
--
-- @description@ --------------------------------------------------------------
--
-- * Plug is a window that is to be attached to the window of another
--   application. If you have managed to receive the @ref type XID@ from
--   the inviting application you can construct the Plug and add your widgets
--   to it.
--
-- @documentation@ ------------------------------------------------------------
--
--
-- @todo@ ---------------------------------------------------------------------

module Plug(
  Plug,
  PlugClass,
  castToPlug,
  XID,
  plugNew
  ) where

import Monad	(liftM)
import Foreign
import UTFCForeign
import Object	(makeNewObject)
{#import Hierarchy#}
{#import Signal#}
import Structs	(XID)

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

-- methods

plugNew :: XID -> IO Plug
plugNew nw = makeNewObject mkPlug $ liftM castPtr $
  {#call unsafe plug_new#} nw