MINOR: Stylistic Changes

MINOR: Stylistic Changes

{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE BangPatterns #-}
{-# OPTIONS_GHC -fno-cse -fno-full-laziness #-} -- recommended by GHC manual

module Codec.ShonkyCrypt.ShonkyCryptFFI where

import Control.Applicative ((<$>), (<*>))
import Control.Monad (liftM)
import Data.ByteString (ByteString)
import Data.Word (Word8)
import Foreign.C.String (CStringLen, CString)
import Foreign.C.Types (CChar(..), CULong(..), CDouble(..))
import Foreign.ForeignPtr
import Foreign.Marshal.Alloc (mallocBytes, free)
import Foreign.Marshal.Utils (with, fromBool, toBool)
import Foreign.Ptr
import Foreign.Storable (Storable(..))
import System.IO.Unsafe (unsafePerformIO)
import qualified Data.ByteString.Internal as BSI
import qualified Data.ByteString.Unsafe as BSU

#include "shonky-crypt.h"

data ShonkyCryptKey = ShonkyCryptKey
    { sckKeyStart :: !Word8
    , sckKeyInc :: !Word8
    , sckOnlyAlnum :: !Bool
    } deriving Show

instance Storable ShonkyCryptKey where
    sizeOf _ = {#sizeof shonky_crypt_key_t #}
    alignment _ = 4
    peek p = ShonkyCryptKey
               <$> liftM fromIntegral ({#get shonky_crypt_key_t->key_start #} p)
               <*> liftM fromIntegral ({#get shonky_crypt_key_t->key_inc #} p)
               <*> liftM toBool ({#get shonky_crypt_key_t->only_alnum #} p)
    poke p x =
      do {#set shonky_crypt_key_t.key_start #} p (fromIntegral $ sckKeyStart x)
         {#set shonky_crypt_key_t.key_inc #} p (fromIntegral $ sckKeyInc x)
         {#set shonky_crypt_key_t.only_alnum #} p (fromBool $ sckOnlyAlnum x)

{#pointer shonky_crypt_key_t as ShonkyCryptKeyPtr -> ShonkyCryptKey #}

fromMallocedStorable :: Storable a => Ptr a -> IO a
fromMallocedStorable p =
    do key <- peek p
       free p
       return key

newShonkyCryptContextPointer :: Ptr ShonkyCryptContext -> IO ShonkyCryptContext
newShonkyCryptContextPointer p =
    do fp <- newForeignPtr scReleaseContextPtr p
       return $! ShonkyCryptContext fp

unsafePackMallocCStringLen :: CStringLen -> IO ByteString
unsafePackMallocCStringLen (cstr, len) = do
    fp <- newForeignPtr BSI.c_free_finalizer (castPtr cstr)
    return $! BSI.PS fp 0 len

withShonkyCryptContext :: ShonkyCryptContext -> (Ptr ShonkyCryptContext -> IO b) -> IO b
{#pointer shonky_crypt_context_t as ShonkyCryptContext foreign newtype #}

foreign import ccall "shonky-crypt.h &sc_release_context"
  scReleaseContextPtr :: FunPtr (Ptr ShonkyCryptContext -> IO ())

withTrickC2HS :: Storable a => a -> (Ptr a -> IO b) -> IO b
withTrickC2HS = with

{#fun pure unsafe sc_alloc_context_with_key as
    ^ { withTrickC2HS *`ShonkyCryptKey' }
    -> `ShonkyCryptContext' newShonkyCryptContextPointer * #}

withByteStringLen :: ByteString -> ((CString, CULong) -> IO a) -> IO a
withByteStringLen str f = BSU.unsafeUseAsCStringLen str (\(cstr, len) ->
    f (cstr, fromIntegral len))

{#fun pure unsafe sc_entropy as
    ^ { withByteStringLen *`ByteString'& } -> `Double' #}

{#fun pure unsafe sc_copy_context as
    ^ { withShonkyCryptContext *`ShonkyCryptContext' }
    -> `ShonkyCryptContext' newShonkyCryptContextPointer * #}

type InPlaceEnDeCryptFun =
     Ptr ShonkyCryptContext -> Ptr CChar -> Ptr CChar -> CULong -> IO ()
type NewEnDeCryptFun =
     Ptr ShonkyCryptKey -> Ptr CChar -> CULong -> IO CString

scEnDeCryptInplace :: InPlaceEnDeCryptFun
                   -> ShonkyCryptContext
                   -> ByteString
                   -> (ByteString, ShonkyCryptContext)
scEnDeCryptInplace f ctx input =
     unsafePerformIO $
     BSU.unsafeUseAsCStringLen input $ \(inputBytes, inputLen) ->
     withShonkyCryptContext ctx $ \ctx' ->
     do
        newContext' <- {#call sc_copy_context #} ctx'
        outBuffer <- mallocBytes inputLen
        f newContext' inputBytes outBuffer (fromIntegral inputLen)
        out <- unsafePackMallocCStringLen (outBuffer, inputLen)
        newContext <- newShonkyCryptContextPointer newContext'
        return (out, newContext)

encryptS :: ShonkyCryptContext -> ByteString -> (ByteString, ShonkyCryptContext)
encryptS = scEnDeCryptInplace {#call unsafe sc_encrypt_inplace #}
decryptS :: ShonkyCryptContext -> ByteString -> (ByteString, ShonkyCryptContext)
decryptS = scEnDeCryptInplace {#call unsafe sc_decrypt_inplace #}

scEnDecryptNew :: NewEnDeCryptFun -> ShonkyCryptKey -> ByteString -> ByteString
scEnDecryptNew f key input =
    unsafePerformIO $
    BSU.unsafeUseAsCStringLen input $ \(inputBytes, inputLen) ->
    with key $ \key' ->
    do outputC <- f key' inputBytes (fromIntegral inputLen)
       unsafePackMallocCStringLen (outputC, inputLen)

encrypt :: ShonkyCryptKey -> ByteString -> ByteString
encrypt = scEnDecryptNew {#call unsafe sc_encrypt_new #}

decrypt :: ShonkyCryptKey -> ByteString -> ByteString
decrypt = scEnDecryptNew {#call unsafe sc_decrypt_new #}

{#fun pure unsafe sc_new_crypt_key_with as
    ^ { `Word8', `Word8', `Bool' } -> `ShonkyCryptKey' fromMallocedStorable * #}

{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE BangPatterns #-}
{-# OPTIONS_GHC -fno-cse -fno-full-laziness #-} -- recommended by GHC manual

module Codec.ShonkyCrypt.ShonkyCryptFFI where

import Control.Applicative ((<$>), (<*>))
import Control.Monad (liftM)
import Data.ByteString (ByteString)
import Data.Word (Word8)
import Foreign.C.String (CStringLen, CString)
import Foreign.C.Types (CChar(..), CULong(..), CDouble(..))
import Foreign.ForeignPtr
import Foreign.Marshal.Alloc (mallocBytes, free)
import Foreign.Marshal.Utils (with, fromBool, toBool)
import Foreign.Ptr
import Foreign.Storable (Storable(..))
import System.IO.Unsafe (unsafePerformIO)
import qualified Data.ByteString.Internal as BSI
import qualified Data.ByteString.Unsafe as BSU

#include "shonky-crypt.h"

data ShonkyCryptKey = ShonkyCryptKey
    { sckKeyStart :: !Word8
    , sckKeyInc :: !Word8
    , sckOnlyAlnum :: !Bool
    } deriving Show

instance Storable ShonkyCryptKey where
    sizeOf _ = {#sizeof shonky_crypt_key_t #}
    alignment _ = 4
    peek p = ShonkyCryptKey
               <$> liftM fromIntegral ({#get shonky_crypt_key_t->key_start #} p)
               <*> liftM fromIntegral ({#get shonky_crypt_key_t->key_inc #} p)
               <*> liftM toBool ({#get shonky_crypt_key_t->only_alnum #} p)
    poke p x =
      do {#set shonky_crypt_key_t.key_start #} p (fromIntegral $ sckKeyStart x)
         {#set shonky_crypt_key_t.key_inc #} p (fromIntegral $ sckKeyInc x)
         {#set shonky_crypt_key_t.only_alnum #} p (fromBool $ sckOnlyAlnum x)

{#pointer shonky_crypt_key_t as ShonkyCryptKeyPtr -> ShonkyCryptKey #}

fromMallocedStorable :: Storable a => Ptr a -> IO a
fromMallocedStorable p =
    do key <- peek p
       free p
       return key

newShonkyCryptContextPointer :: Ptr ShonkyCryptContext -> IO ShonkyCryptContext
newShonkyCryptContextPointer p =
    do fp <- newForeignPtr scReleaseContextPtr p
       return $ ShonkyCryptContext fp

unsafePackMallocCStringLen :: CStringLen -> IO ByteString
unsafePackMallocCStringLen (cstr, len) = do
    fp <- newForeignPtr BSI.c_free_finalizer (castPtr cstr)
    return $! BSI.PS fp 0 len

withShonkyCryptContext :: ShonkyCryptContext -> (Ptr ShonkyCryptContext -> IO b) -> IO b
{#pointer shonky_crypt_context_t as ShonkyCryptContext foreign newtype #}

foreign import ccall "shonky-crypt.h &sc_release_context"
  scReleaseContextPtr :: FunPtr (Ptr ShonkyCryptContext -> IO ())

withTrickC2HS :: Storable a => a -> (Ptr a -> IO b) -> IO b
withTrickC2HS = with

{#fun pure unsafe sc_alloc_context_with_key as
    ^ { withTrickC2HS* `ShonkyCryptKey' }
    -> `ShonkyCryptContext' newShonkyCryptContextPointer* #}

withByteStringLen :: ByteString -> ((CString, CULong) -> IO a) -> IO a
withByteStringLen str f = BSU.unsafeUseAsCStringLen str (\(cstr, len) ->
    f (cstr, fromIntegral len))

{#fun pure unsafe sc_entropy as
    ^ { withByteStringLen *`ByteString'& } -> `Double' #}

{#fun pure unsafe sc_copy_context as
    ^ { withShonkyCryptContext* `ShonkyCryptContext' }
    -> `ShonkyCryptContext' newShonkyCryptContextPointer* #}

type InPlaceEnDeCryptFun =
     Ptr ShonkyCryptContext -> Ptr CChar -> Ptr CChar -> CULong -> IO ()
type NewEnDeCryptFun =
     Ptr ShonkyCryptKey -> Ptr CChar -> CULong -> IO CString

scEnDeCryptInplace :: InPlaceEnDeCryptFun
                   -> ShonkyCryptContext
                   -> ByteString
                   -> (ByteString, ShonkyCryptContext)
scEnDeCryptInplace f ctx input =
     unsafePerformIO $
     BSU.unsafeUseAsCStringLen input $ \(inputBytes, inputLen) ->
     withShonkyCryptContext ctx $ \ctx' ->
     do
        newContext' <- {#call sc_copy_context #} ctx'
        outBuffer <- mallocBytes inputLen
        f newContext' inputBytes outBuffer (fromIntegral inputLen)
        out <- unsafePackMallocCStringLen (outBuffer, inputLen)
        newContext <- newShonkyCryptContextPointer newContext'
        return (out, newContext)

encryptS :: ShonkyCryptContext -> ByteString -> (ByteString, ShonkyCryptContext)
encryptS = scEnDeCryptInplace {#call unsafe sc_encrypt_inplace #}
decryptS :: ShonkyCryptContext -> ByteString -> (ByteString, ShonkyCryptContext)
decryptS = scEnDeCryptInplace {#call unsafe sc_decrypt_inplace #}

scEnDecryptNew :: NewEnDeCryptFun -> ShonkyCryptKey -> ByteString -> ByteString
scEnDecryptNew f key input =
    unsafePerformIO $
    BSU.unsafeUseAsCStringLen input $ \(inputBytes, inputLen) ->
    with key $ \key' ->
    do outputC <- f key' inputBytes (fromIntegral inputLen)
       unsafePackMallocCStringLen (outputC, inputLen)

encrypt :: ShonkyCryptKey -> ByteString -> ByteString
encrypt = scEnDecryptNew {#call unsafe sc_encrypt_new #}

decrypt :: ShonkyCryptKey -> ByteString -> ByteString
decrypt = scEnDecryptNew {#call unsafe sc_decrypt_new #}

{#fun pure unsafe sc_new_crypt_key_with as
    ^ { `Word8', `Word8', `Bool' } -> `ShonkyCryptKey' fromMallocedStorable* #}


Don't export valueUnset since it's not used outside of the module

-- -*-haskell-*-
--  GIMP Toolkit (GTK) GValue
--
--  Author : Axel Simon
--
--  Created: 1 June 2001
--
--  Version $Revision: 1.3 $ from $Date: 2005/11/16 13:14:16 $
--
--  Copyright (c) 1999..2002 Axel Simon
--
--  This library is free software; you can redistribute it and/or
--  modify it under the terms of the GNU Lesser General Public
--  License as published by the Free Software Foundation; either
--  version 2.1 of the License, or (at your option) any later version.
--
--  This library is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
--  Lesser General Public License for more details.
--
-- |
-- Maintainer  : gtk2hs-users@lists.sourceforge.net
-- Stability   : provisional
-- Portability : portable (depends on GHC)
--
-- This module implements only the necessities for the GTK binding.
--
-- * Everything here is only used by "Graphics.UI.Gtk.TreeList.TreeModel" and
-- friends.
--
module System.Glib.GValue (
  GValue(GValue),
  valueInit,
  valueGetType,
  allocaGValue
  ) where

import Monad	(liftM)

import System.Glib.FFI
import System.Glib.GType	(GType)

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

{# pointer *GValue newtype #}

-- | Clear a GValue.
--
valueInit :: GValue -> GType -> IO ()
valueInit gv gt = do
  -- The g_type field of the value must be zero or g_value_init will fail.
  {# call unsafe value_init #} gv gt
  return ()

-- | Get the type of the value stored in the GValue
--
valueGetType :: GValue -> IO GType
valueGetType (GValue gvPtr) = {# get GValue->g_type #} gvPtr

-- | Temporarily allocate a GValue.
--
allocaGValue :: (GValue -> IO b) -> IO b
allocaGValue body =
  -- c2hs is broken in that it can't handle arrays of compound arrays in the
  -- sizeof hook
  allocaBytes ({# sizeof GType #}+ 2* {# sizeof guint64 #}) $ \gvPtr -> do
  -- The g_type field of the value must be zero or g_value_init will fail.
  {# set GValue->g_type #} gvPtr (0 :: GType)
  result <- body (GValue gvPtr)
  {#call unsafe value_unset#} (GValue gvPtr)
  return result

-- -*-haskell-*-
--  GIMP Toolkit (GTK) GValue
--
--  Author : Axel Simon
--
--  Created: 1 June 2001
--
--  Version $Revision: 1.3 $ from $Date: 2005/11/16 13:14:16 $
--
--  Copyright (c) 1999..2002 Axel Simon
--
--  This library is free software; you can redistribute it and/or
--  modify it under the terms of the GNU Lesser General Public
--  License as published by the Free Software Foundation; either
--  version 2.1 of the License, or (at your option) any later version.
--
--  This library is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
--  Lesser General Public License for more details.
--
-- |
-- Maintainer  : gtk2hs-users@lists.sourceforge.net
-- Stability   : provisional
-- Portability : portable (depends on GHC)
--
-- This module implements only the necessities for the GTK binding.
--
-- * Everything here is only used by "Graphics.UI.Gtk.TreeList.TreeModel" and
-- friends.
--
module System.Glib.GValue (
  GValue(GValue),
  valueInit,
  valueUnset,
  valueGetType,
  allocaGValue
  ) where

import Monad	(liftM)

import System.Glib.FFI
import System.Glib.GType	(GType)

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

{# pointer *GValue newtype #}

-- | Clear a GValue.
--
valueInit :: GValue -> GType -> IO ()
valueInit gv gt = do
  -- The g_type field of the value must be zero or g_value_init will fail.
  {# call unsafe value_init #} gv gt
  return ()

-- | Free the data in a GValue.
--
valueUnset :: GValue -> IO ()
valueUnset = {#call unsafe value_unset#}

-- | Get the type of the value stored in the GValue
--
valueGetType :: GValue -> IO GType
valueGetType (GValue gvPtr) = {# get GValue->g_type #} gvPtr

-- | Temporarily allocate a GValue.
--
allocaGValue :: (GValue -> IO b) -> IO b
allocaGValue body =
  -- c2hs is broken in that it can't handle arrays of compound arrays in the
  -- sizeof hook
  allocaBytes ({# sizeof GType #}+ 2* {# sizeof guint64 #}) $ \gvPtr -> do
  -- The g_type field of the value must be zero or g_value_init will fail.
  {# set GValue->g_type #} gvPtr (0 :: GType)
  result <- body (GValue gvPtr)
  valueUnset (GValue gvPtr)
  return result


[project @ 2002-07-12 13:06:08 by dg22] Fixed references that used the old names for packing widgets.

-- -*-haskell-*-
--  GIMP Toolkit (GTK) @entry Widget Box@
--
--  Author : Axel Simon
--
--  Created: 15 May 2001
--
--  Version $Revision: 1.4 $ from $Date: 2002/07/12 13:06:08 $
--
--  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@ --------------------------------------------------------------
--
-- * This abstract container class is instatiated by using HBox or VBox. It
--   supplies all methods to add and remove children.
--
-- @documentation@ ------------------------------------------------------------
--
--
-- @todo@ ---------------------------------------------------------------------

module Box(
  Box,
  BoxClass,
  castToBox,
  Packing(..),
  boxPackStart,
  boxPackEnd,
  boxPackStartDefaults,
  boxPackEndDefaults,
  boxSetHomogeneous,
  boxGetSpacing,
  boxSetSpacing,
  boxReorderChild,
  boxQueryChildPacking,
  boxSetChildPacking
  ) where

import Monad	(liftM)
import Foreign
import UTFCForeign
import Object	(makeNewObject)
{#import Hierarchy#}
{#import Signal#}
import Enums	(PackType(..), Packing(..))

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

-- methods

-- @method boxPackStart@ Insert a widget at the beginning of the box
-- container.
--
-- * The @ref arg Packing@ parameter determines how the child behaves in the
--   horizontal or vertical way in an HBox or VBox, respectively.
--   @ref arg Natural@ means the child is as big as it reqests. All children
--   that have choosen @ref arg Repel@ for @ref arg p@ will be padded with
--   the remaining space. @ref arg Grow@ is the same as @ref arg Expand@
--   except that the child will receive the superfluous space.
--
boxPackStart :: (BoxClass b, WidgetClass w) => b -> w -> Packing -> Int ->
                IO ()
boxPackStart b w p pad = {#call box_pack_start#} (toBox b) (toWidget w)
  (fromBool $ p/=PackNatural) (fromBool $ p==PackGrow) (fromIntegral pad)

-- @method boxPackEnd@ Insert a widget at the end of the box container.
--
-- * See @ref method boxPackStart@.
--
boxPackEnd :: (BoxClass b, WidgetClass w) => b -> w -> Packing -> Int -> IO ()
boxPackEnd b w p pad = {#call box_pack_end#} (toBox b) (toWidget w)
  (fromBool $ p/=PackNatural) (fromBool $ p==PackGrow) (fromIntegral pad)

-- @method boxPackStartDefaults@ Like @ref method boxPackStart@ but uses the
-- default parameters @ref arg Fill@ and 0 for @ref arg Padding@.
--
boxPackStartDefaults :: (BoxClass b, WidgetClass w) => b -> w -> IO ()
boxPackStartDefaults b w =
  {#call box_pack_start_defaults#} (toBox b) (toWidget w)

-- @method boxPackEndDefaults@ Like @ref method boxPackEnd@ but uses the
-- default parameters @ref arg Fill@ and 0 for @ref arg Padding@.
--
boxPackEndDefaults :: (BoxClass b, WidgetClass w) => b -> w -> IO ()
boxPackEndDefaults b w =
  {#call box_pack_end_defaults#} (toBox b) (toWidget w)

-- @method boxSetHomogeneous@ Set if all children should be spread homogeneous
-- withing the box.
--
boxSetHomogeneous :: BoxClass b => b -> Bool -> IO ()
boxSetHomogeneous b homo =
  {#call box_set_homogeneous#} (toBox b) (fromBool homo)

-- @method boxSetSpacing@ Set the standard spacing between two children.
--
-- * This space is in addition to the padding parameter that is given for each
--   child.
--
boxSetSpacing :: BoxClass b => b -> Int -> IO ()
boxSetSpacing b spacing =
  {#call box_set_spacing#} (toBox b) (fromIntegral spacing)

-- @method boxReorderChild@ Move @ref arg child@ to a new @ref arg position@
-- (counted from 0) in the box.
--
boxReorderChild :: (BoxClass b, WidgetClass w) => b -> w -> Int -> IO ()
boxReorderChild b w position =
  {#call box_reorder_child#} (toBox b) (toWidget w) (fromIntegral position)

-- @method boxQueryChildPacking@ Query the packing parameter of a child.
-- Returns the behavious if free space is available (@Packing), the additional
-- padding for this widget (@Int) and if the widget was inserted at the start
-- or end of the container (@PackType).
--
boxQueryChildPacking :: (BoxClass b, WidgetClass w) => b -> w ->
                        IO (Packing,Int,PackType)
boxQueryChildPacking b w = alloca $ \expandPtr -> alloca $ \fillPtr ->
  alloca $ \paddingPtr -> alloca $ \packPtr -> do
    {#call unsafe box_query_child_packing#} (toBox b) (toWidget w)
      expandPtr fillPtr paddingPtr packPtr
    expand  <- liftM toBool $ peek expandPtr
    fill    <- liftM toBool $ peek fillPtr
    padding <- liftM fromIntegral $ peek paddingPtr
    pack    <- liftM (toEnum.fromIntegral) $ peek packPtr
    return (if fill then PackGrow else
            (if expand then PackRepel else PackNatural),
	    padding,pack)

-- @method boxSetChildPacking@ Set the packing parameter of a child.
--
boxSetChildPacking :: (BoxClass b, WidgetClass w) => b -> w -> Packing ->
                      Int -> PackType -> IO ()
boxSetChildPacking b w pack pad pt = {#call box_set_child_packing#} (toBox b)
  (toWidget w) (fromBool $ pack/=PackNatural) (fromBool $ pack==PackGrow)
  (fromIntegral pad) ((fromIntegral.fromEnum) pt)

-- @method boxGetSpacing@ Retrieves the standard spacing between widgets.
--
boxGetSpacing :: BoxClass b => b -> IO Int
boxGetSpacing b =
  liftM fromIntegral $ {#call unsafe box_get_spacing#} (toBox b)

-- -*-haskell-*-
--  GIMP Toolkit (GTK) @entry Widget Box@
--
--  Author : Axel Simon
--
--  Created: 15 May 2001
--
--  Version $Revision: 1.3 $ from $Date: 2002/07/11 12:15:22 $
--
--  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@ --------------------------------------------------------------
--
-- * This abstract container class is instatiated by using HBox or VBox. It
--   supplies all methods to add and remove children.
--
-- @documentation@ ------------------------------------------------------------
--
--
-- @todo@ ---------------------------------------------------------------------

module Box(
  Box,
  BoxClass,
  castToBox,
  Packing(..),
  boxPackStart,
  boxPackEnd,
  boxPackStartDefaults,
  boxPackEndDefaults,
  boxSetHomogeneous,
  boxGetSpacing,
  boxSetSpacing,
  boxReorderChild,
  boxQueryChildPacking,
  boxSetChildPacking
  ) where

import Monad	(liftM)
import Foreign
import UTFCForeign
import Object	(makeNewObject)
{#import Hierarchy#}
{#import Signal#}
import Enums	(PackType(..), Packing(..))

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

-- methods

-- @method boxPackStart@ Insert a widget at the beginning of the box
-- container.
--
-- * The @ref arg Packing@ parameter determines how the child behaves in the
--   horizontal or vertical way in an HBox or VBox, respectively.
--   @ref arg Natural@ means the child is as big as it reqests. All children
--   that have choosen @ref arg Repel@ for @ref arg p@ will be padded with
--   the remaining space. @ref arg Grow@ is the same as @ref arg Expand@
--   except that the child will receive the superfluous space.
--
boxPackStart :: (BoxClass b, WidgetClass w) => b -> w -> Packing -> Int ->
                IO ()
boxPackStart b w p pad = {#call box_pack_start#} (toBox b) (toWidget w)
  (fromBool $ p/=PackNatural) (fromBool $ p==PackGrow) (fromIntegral pad)

-- @method boxPackEnd@ Insert a widget at the end of the box container.
--
-- * See @ref method boxPackStart@.
--
boxPackEnd :: (BoxClass b, WidgetClass w) => b -> w -> Packing -> Int -> IO ()
boxPackEnd b w p pad = {#call box_pack_end#} (toBox b) (toWidget w)
  (fromBool $ p/=PackNatural) (fromBool $ p==PackFill) (fromIntegral pad)

-- @method boxPackStartDefaults@ Like @ref method boxPackStart@ but uses the
-- default parameters @ref arg Fill@ and 0 for @ref arg Padding@.
--
boxPackStartDefaults :: (BoxClass b, WidgetClass w) => b -> w -> IO ()
boxPackStartDefaults b w =
  {#call box_pack_start_defaults#} (toBox b) (toWidget w)

-- @method boxPackEndDefaults@ Like @ref method boxPackEnd@ but uses the
-- default parameters @ref arg Fill@ and 0 for @ref arg Padding@.
--
boxPackEndDefaults :: (BoxClass b, WidgetClass w) => b -> w -> IO ()
boxPackEndDefaults b w =
  {#call box_pack_end_defaults#} (toBox b) (toWidget w)

-- @method boxSetHomogeneous@ Set if all children should be spread homogeneous
-- withing the box.
--
boxSetHomogeneous :: BoxClass b => b -> Bool -> IO ()
boxSetHomogeneous b homo =
  {#call box_set_homogeneous#} (toBox b) (fromBool homo)

-- @method boxSetSpacing@ Set the standard spacing between two children.
--
-- * This space is in addition to the padding parameter that is given for each
--   child.
--
boxSetSpacing :: BoxClass b => b -> Int -> IO ()
boxSetSpacing b spacing =
  {#call box_set_spacing#} (toBox b) (fromIntegral spacing)

-- @method boxReorderChild@ Move @ref arg child@ to a new @ref arg position@
-- (counted from 0) in the box.
--
boxReorderChild :: (BoxClass b, WidgetClass w) => b -> w -> Int -> IO ()
boxReorderChild b w position =
  {#call box_reorder_child#} (toBox b) (toWidget w) (fromIntegral position)

-- @method boxQueryChildPacking@ Query the packing parameter of a child.
-- Returns the behavious if free space is available (@Packing), the additional
-- padding for this widget (@Int) and if the widget was inserted at the start
-- or end of the container (@PackType).
--
boxQueryChildPacking :: (BoxClass b, WidgetClass w) => b -> w ->
                        IO (Packing,Int,PackType)
boxQueryChildPacking b w = alloca $ \expandPtr -> alloca $ \fillPtr ->
  alloca $ \paddingPtr -> alloca $ \packPtr -> do
    {#call unsafe box_query_child_packing#} (toBox b) (toWidget w)
      expandPtr fillPtr paddingPtr packPtr
    expand  <- liftM toBool $ peek expandPtr
    fill    <- liftM toBool $ peek fillPtr
    padding <- liftM fromIntegral $ peek paddingPtr
    pack    <- liftM (toEnum.fromIntegral) $ peek packPtr
    return (if fill then PackFill else
            (if expand then PackExpand else PackNatural),
	    padding,pack)

-- @method boxSetChildPacking@ Set the packing parameter of a child.
--
boxSetChildPacking :: (BoxClass b, WidgetClass w) => b -> w -> Packing ->
                      Int -> PackType -> IO ()
boxSetChildPacking b w pack pad pt = {#call box_set_child_packing#} (toBox b)
  (toWidget w) (fromBool $ pack/=PackNatural) (fromBool $ pack==PackFill)
  (fromIntegral pad) ((fromIntegral.fromEnum) pt)

-- @method boxGetSpacing@ Retrieves the standard spacing between widgets.
--
boxGetSpacing :: BoxClass b => b -> IO Int
boxGetSpacing b =
  liftM fromIntegral $ {#call unsafe box_get_spacing#} (toBox b)


support for Integer64 ogr types

support for Integer64 ogr types

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

#include "bindings.h"

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

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

  , fieldDef
  , featureToHandle
  , featureFromHandle

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

#if MULTI_GEOM_FIELDS

{#pointer GeomFieldDefnH newtype#}

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

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

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

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

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

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

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

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

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

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

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

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

getFieldBy OFTWideString fname ix f = getFieldBy OFTString fname ix f

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

getFieldBy OFTWideStringList fname ix f = getFieldBy OFTStringList fname ix f

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

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

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

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

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

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

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

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

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

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

#include "bindings.h"

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

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

  , fieldDef
  , featureToHandle
  , featureFromHandle

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

#if MULTI_GEOM_FIELDS

{#pointer GeomFieldDefnH newtype#}

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

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

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

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

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

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

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

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

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

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

getFieldBy OFTWideString fname ix f = getFieldBy OFTString fname ix f

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

getFieldBy OFTWideStringList fname ix f = getFieldBy OFTStringList fname ix f

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

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

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

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

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

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

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

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

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