fix for 7.8.4

fix for 7.8.4

{-# LANGUAGE CPP #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE ScopedTypeVariables #-}

#include "bindings.h"

module GDAL.Internal.OGRFeature (
    OGRFeature (..)
  , OGRFeatureDef (..)
  , OGRField   (..)
  , OGRTimeZone (..)
  , Fid (..)
  , FieldType (..)
  , Field (..)
  , Feature (..)
  , FeatureH (..)
  , FieldDefnH (..)
  , FeatureDefnH (..)
  , Justification (..)

  , FeatureDef (..)
  , GeomFieldDef (..)
  , FieldDef (..)
  , fieldTypedAs
  , (.:)
  , (.=)
  , aGeom
  , aNullableGeom
  , theGeom
  , theNullableGeom
  , feature

  , featureToHandle
  , featureFromHandle
  , getFid

  , withFieldDefnH
  , fieldDefFromHandle
  , featureDefFromHandle
  , fieldDefsFromFeatureDefnH
  , geomFieldDefsFromFeatureDefnH
#if SUPPORTS_MULTI_GEOM_FIELDS
  , GeomFieldDefnH (..)
  , withGeomFieldDefnH
#endif
) where

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

import Control.Applicative ((<$>), (<*>), pure)
import Control.Monad (liftM, liftM2, (>=>), (<=<), when, void, join)
import Control.Monad.Catch (bracket)

import Data.ByteString (ByteString)
import Data.ByteString.Char8 (packCStringLen)
import Data.ByteString.Unsafe (unsafeUseAsCStringLen)
import qualified Data.HashMap.Strict as HM
import Data.Int (Int32, Int64)
import Data.Monoid (mempty, (<>))
import Data.Proxy (Proxy(Proxy))

import Data.Text (Text)
import Data.Time.LocalTime (
    LocalTime(..)
  , TimeOfDay(..)
  , TimeZone(..)
  , minutesToTimeZone
  , utc
  )
import Data.Time ()
import Data.Time.Calendar (Day, fromGregorian, toGregorian)
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(..)
  , CLong(..)
  )
import Foreign.Marshal.Alloc (alloca)
import Foreign.Marshal.Utils (copyBytes, toBool)
import Foreign.Ptr (Ptr, castPtr, nullPtr)
import Foreign.Storable (Storable, sizeOf, peek, peekElemOff)
#if GDAL_VERSION_MAJOR >= 2
import Foreign.C.Types (CLLong(..))
import Foreign.Marshal.Utils (fromBool)
#endif

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"

newtype Fid = Fid { unFid :: Int64 }
  deriving (Eq, Show, Num)

class OGRField a where
  fieldDef  :: Proxy a -> FieldDef
  toField   :: a  -> Field
  fromField :: Field -> Either Text a

(.:) :: OGRField a => Feature -> Text -> Either Text a
feat .: name =
  maybe (Left ("fromFeature: field '"<>name<>"' not present"))
        fromField
        (HM.lookup name (fFields feat))

(.=) :: OGRField a => Text -> a -> (Text, Field)
name .= value = (name, toField value)

class OGRFeature a where
  toFeature   :: a -> Feature
  fromFeature :: Feature -> Either Text a

theGeom :: Feature -> Either Text Geometry
theGeom = maybe (Left "Feature has no geometry") Right . fGeom

theNullableGeom :: Feature -> Either Text (Maybe Geometry)
theNullableGeom = Right . fGeom

aGeom :: Feature -> Text -> Either Text Geometry
feat `aGeom` name =
  maybe (Left ("fromFeature: geometry field '"<>name<>"' not present"))
        (maybe (Left ("fromFeature: geometry '"<>name<>"' is NULL")) Right)
        (HM.lookup name (fGeoms feat))

aNullableGeom :: Feature -> Text -> Either Text (Maybe Geometry)
feat `aNullableGeom` name =
  maybe (Left ("fromFeature: geometry field '"<>name<>"' not present"))
        Right
        (HM.lookup name (fGeoms feat))

class OGRFeature a => OGRFeatureDef a where
  featureDef  :: Proxy a -> FeatureDef

fieldTypedAs :: forall a. OGRField a => Text -> a -> (Text, FieldDef)
name `fieldTypedAs` _ = (name, fieldDef (Proxy :: Proxy a))

{#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       !Int32
  | OGRIntegerList   !(St.Vector Int32)
#if SUPPORTS_64_BIT_INT_FIELDS
  | OGRInteger64     !Int64
  | OGRInteger64List !(St.Vector Int64)
#endif
  | OGRReal          !Double
  | OGRRealList      !(St.Vector Double)
  | OGRString        !Text
  | OGRStringList    !(V.Vector Text)
  | OGRBinary        !ByteString
  | OGRDateTime      !LocalTime !OGRTimeZone
  | OGRDate          !Day
  | OGRTime          !TimeOfDay
  | OGRNullField
  deriving (Show, Eq)

data OGRTimeZone
  = UnknownTimeZone
  | LocalTimeZone
  | KnownTimeZone !TimeZone
  deriving (Eq, Show)

data FieldDef
  = FieldDef {
      fldType     :: !FieldType
    , fldWidth    :: !(Maybe Int)
    , fldPrec     :: !(Maybe Int)
    , fldJust     :: !(Maybe Justification)
    , fldNullable :: !Bool
    } deriving (Show, Eq)

data GeomFieldDef
  = GeomFieldDef {
      gfdType     :: !GeometryType
    , gfdSrs      :: !(Maybe SpatialReference)
    , gfdNullable :: !Bool
    } deriving (Show, Eq)

type Map a = HM.HashMap Text a

data Feature
  = Feature {
      fFields  :: !(Map Field)
    , fGeom    :: !(Maybe Geometry)
    , fGeoms   :: !(Map (Maybe Geometry))
    } deriving (Show, Eq)

feature :: Geometry -> [(Text,Field)] -> Feature
feature g fs =
  Feature { fFields = HM.fromList fs
          , fGeom   = Just g
          , fGeoms  = mempty
          }

instance OGRFeature Feature where
  toFeature    = id
  fromFeature  = Right

data FeatureDef
  = FeatureDef {
      fdName    :: !Text
    , fdFields  :: !FieldDefs
    , fdGeom    :: !GeomFieldDef
    , fdGeoms   :: !GeomFieldDefs
    } deriving (Show, Eq)

type FieldDefs = V.Vector (Text, FieldDef)
type GeomFieldDefs = V.Vector (Text, GeomFieldDef)

{#pointer FeatureH     newtype#}
{#pointer FieldDefnH   newtype#}
{#pointer FeatureDefnH newtype#}

deriving instance Eq FeatureH

nullFeatureH :: FeatureH
nullFeatureH = FeatureH nullPtr

withFieldDefnH :: Text -> FieldDef -> (FieldDefnH -> IO a) -> IO a
withFieldDefnH fldName 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 ()
#if SUPPORTS_NULLABLE_FIELD_DEFS
      {#call unsafe OGR_Fld_SetNullable as ^#} h (fromBool fldNullable)
#endif

fieldDefFromHandle :: FieldDefnH -> IO FieldDef
fieldDefFromHandle p =
  FieldDef
    <$> 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)
#if SUPPORTS_NULLABLE_FIELD_DEFS
    <*> liftM toBool ({#call unsafe OGR_Fld_IsNullable as ^#} p)
#else
    <*> pure True
#endif
  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 = do
#if SUPPORTS_MULTI_GEOM_FIELDS
  gfields <- geomFieldDefsFromFeatureDefnH p
  let (gfd', gfields')
        -- should not happen but just in case
        | V.null gfields = (gfd, gfields)
        -- ignore layer definition since it doesn't carry correct nullability
        -- info
        | otherwise      = (snd (V.unsafeHead gfields), V.unsafeTail gfields)
#else
  let (gfd', gfields') = (gfd, mempty)
#endif
  FeatureDef
    <$> ({#call unsafe OGR_FD_GetName as ^#} p >>= peekEncodedCString)
    <*> fieldDefsFromFeatureDefnH p
    <*> pure gfd'
    <*> pure gfields'

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

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

#if SUPPORTS_MULTI_GEOM_FIELDS

{#pointer GeomFieldDefnH newtype#}

geomFieldDefsFromFeatureDefnH p = do
  nFields <- {#call unsafe OGR_FD_GetGeomFieldCount as ^#} p
  V.generateM (fromIntegral nFields) $
    gFldDef <=< ({#call unsafe OGR_FD_GetGeomFieldDefn as ^#} p . fromIntegral)
  where
    gFldDef g = do
      name <- {#call unsafe OGR_GFld_GetNameRef as ^#} g >>= peekEncodedCString
      gDef <- GeomFieldDef
              <$> liftM toEnumC ({#call unsafe OGR_GFld_GetType as ^#} g)
              <*> ({#call unsafe OGR_GFld_GetSpatialRef as ^#} g >>=
                    maybeNewSpatialRefBorrowedHandle)
#if SUPPORTS_NULLABLE_FIELD_DEFS
              <*> liftM toBool ({#call unsafe OGR_GFld_IsNullable as ^#} g)
#else
              <*> pure True
#endif
      return (name, gDef)

withGeomFieldDefnH :: Text -> GeomFieldDef -> (GeomFieldDefnH -> IO a) -> IO a
withGeomFieldDefnH gfdName 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 p = do
      withMaybeSpatialReference gfdSrs $
        {#call unsafe OGR_GFld_SetSpatialRef as ^#} p
#if SUPPORTS_NULLABLE_FIELD_DEFS
      {#call unsafe OGR_GFld_SetNullable as ^#} p (fromBool gfdNullable)
#endif

#else
geomFieldDefsFromFeatureDefnH = const (return mempty)
#endif -- SUPPORTS_MULTI_GEOM_FIELDS

nullFID :: Fid
nullFID = Fid ({#const OGRNullFID#})

featureToHandle
  :: OGRFeature f
  => FeatureDefnH -> Maybe Fid -> f -> (FeatureH -> IO a) -> IO a
featureToHandle fdH fId ft act =
  bracket ({#call unsafe OGR_F_Create as ^#} fdH)
          ({#call unsafe OGR_F_Destroy as ^#}) $ \pF -> do
    case fId of
      Just (Fid fid) ->
        void $ {#call unsafe OGR_F_SetFID as ^#} pF (fromIntegral fid)
      Nothing        -> return ()
    fieldDefs <- fieldDefsFromFeatureDefnH fdH
    flip imapM_ fieldDefs $ \ix (name, _) -> do
      case HM.lookup name fFields of
        Just f  -> setField f ix pF
        Nothing -> return ()
    case fGeom of
      Just g  -> void $ withGeometry g ({#call unsafe OGR_F_SetGeometry as ^#} pF)
      Nothing -> return ()
    when (not (HM.null fGeoms)) $ do
#if SUPPORTS_MULTI_GEOM_FIELDS
      geomFieldDefs <- geomFieldDefsFromFeatureDefnH fdH
      flip imapM_ (V.tail geomFieldDefs) $ \ix (name, _) -> do
        case join (HM.lookup name fGeoms) of
          Just g  ->
            void $ withGeometry g ({#call unsafe OGR_F_SetGeomField as ^#} pF (ix+1))
          Nothing ->
            return ()
#else
      throwBindingException MultipleGeomFieldsNotSupported
#endif
    act pF
  where Feature {..} = toFeature ft

imapM :: (Monad m, Num a) => (a -> b -> m c) -> V.Vector b -> m (V.Vector c)
imapM f v  = V.mapM  (uncurry f) (V.zip (V.enumFromN 0 (V.length v)) v)

imapM_ :: (Monad m, Num a) => (a -> b -> m ()) -> V.Vector b -> m ()
imapM_ f v = V.mapM_ (uncurry f) (V.zip (V.enumFromN 0 (V.length v)) v)

getFid :: FeatureH -> IO (Maybe Fid)
getFid pF = do
  mFid <- liftM fromIntegral ({#call unsafe OGR_F_GetFID as ^#} pF)
  return (if mFid == nullFID then Nothing else Just mFid)

featureFromHandle
  :: OGRFeature a
  => FeatureDef -> IO FeatureH -> IO (Maybe (Maybe Fid, a))
featureFromHandle FeatureDef{..} act =
  bracket act {#call unsafe OGR_F_Destroy as ^#} $ \pF -> do
    if (pF == nullFeatureH)
      then return Nothing
      else do
        fid <- getFid pF
        fields <- flip imapM fdFields $ \i (fldName, fd) -> do
          isSet <- liftM toBool ({#call unsafe OGR_F_IsFieldSet as ^#} pF i)
          if isSet
            then getField (fldType fd) i pF >>=
                  maybe (throwBindingException (FieldParseError fldName))
                        (\f -> return (fldName, f))
            else return (fldName, OGRNullField)
        geomRef <- {#call unsafe OGR_F_StealGeometry as ^#} pF
        geom <- if geomRef /= nullPtr
                  then liftM Just (newGeometryHandle geomRef)
                  else return Nothing
#if SUPPORTS_MULTI_GEOM_FIELDS
        geoms <- flip imapM fdGeoms $ \ix (gfdName, _) -> do
          pG <- {#call unsafe OGR_F_GetGeomFieldRef as ^#} pF (ix + 1)
          g <- if pG /= nullPtr
                then liftM Just (cloneGeometry pG)
                else return Nothing
          return (gfdName, g)
#else
        let geoms = mempty
#endif
        either (throwBindingException . FromFeatureError)
               (\f -> return (Just (fid,f)))
               (fromFeature Feature {
                     fFields = HM.fromList (V.toList fields)
                   , fGeom   = geom
                   , fGeoms  = HM.fromList (V.toList geoms)
                   })

-- ############################################################################
-- setField
-- ############################################################################

setField :: Field -> CInt -> FeatureH -> IO ()

setField (OGRInteger v) ix f =
  {#call unsafe OGR_F_SetFieldInteger as ^#} f (fromIntegral ix) (fromIntegral v)

setField (OGRIntegerList v) ix f =
  St.unsafeWith v $
    {#call unsafe OGR_F_SetFieldIntegerList as ^#} f (fromIntegral ix)
      (fromIntegral (St.length v)) . castPtr

#if SUPPORTS_64_BIT_INT_FIELDS
setField (OGRInteger64 v) ix f =
  {#call unsafe OGR_F_SetFieldInteger64 as ^#} f (fromIntegral ix) (fromIntegral v)

setField (OGRInteger64List v) ix f =
  St.unsafeWith v $
    {#call unsafe OGR_F_SetFieldInteger64List as ^#} f (fromIntegral ix)
      (fromIntegral (St.length v)) . castPtr
#endif

setField (OGRReal v) ix f =
  {#call unsafe OGR_F_SetFieldDouble as ^#} f (fromIntegral ix) (realToFrac v)

setField (OGRRealList v) ix f =
  St.unsafeWith v $
    {#call unsafe OGR_F_SetFieldDoubleList as ^#} f (fromIntegral ix)
      (fromIntegral (St.length v)) . castPtr

setField (OGRString v) ix f = useAsEncodedCString v $
  {#call unsafe OGR_F_SetFieldString as ^#} f (fromIntegral ix)

setField (OGRStringList v) ix f =
  bracket createList {#call unsafe CSLDestroy as ^#} $
    {#call unsafe OGR_F_SetFieldStringList as ^#} f (fromIntegral ix)
  where
    createList = V.foldM' folder nullPtr v
    folder acc k =
      useAsEncodedCString k $ {#call unsafe CSLAddString as ^#} acc

setField (OGRBinary v) ix f = unsafeUseAsCStringLen v $ \(p,l) ->
  {#call unsafe OGR_F_SetFieldBinary as ^#}
    f (fromIntegral ix) (fromIntegral l) (castPtr p)

setField (OGRDateTime (LocalTime day (TimeOfDay h mn s)) tz) ix f =
  {#call unsafe OGR_F_SetFieldDateTime as ^#} f (fromIntegral ix)
  (fromIntegral y) (fromIntegral m) (fromIntegral d)
  (fromIntegral h) (fromIntegral mn) (truncate s) (fromOGRTimeZone tz)
  where (y, m, d) = toGregorian day

setField (OGRDate day) ix f =
  {#call unsafe OGR_F_SetFieldDateTime as ^#} f (fromIntegral ix)
  (fromIntegral y) (fromIntegral m) (fromIntegral d) 0 0 0 (fromOGRTimeZone tz)
  where (y, m, d) = toGregorian day
        tz = UnknownTimeZone

setField (OGRTime (TimeOfDay h mn s)) ix f =
  {#call unsafe OGR_F_SetFieldDateTime as ^#} f (fromIntegral ix) 0 0 0
  (fromIntegral h) (fromIntegral mn) (truncate s) (fromOGRTimeZone tz)
  where tz = UnknownTimeZone

setField OGRNullField ix f = {#call unsafe OGR_F_UnsetField as ^#} f ix

-- ############################################################################
-- getField
-- ############################################################################

getField :: FieldType -> CInt -> FeatureH -> IO (Maybe Field)

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

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

#if SUPPORTS_64_BIT_INT_FIELDS
getField OFTInteger64 ix f
  = liftM (Just . OGRInteger64 . fromIntegral)
    ({#call unsafe OGR_F_GetFieldAsInteger64 as ^#} f ix)

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

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

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

getField OFTString ix f = liftM (Just . OGRString)
  (({#call unsafe OGR_F_GetFieldAsString as ^#} f ix) >>= peekEncodedCString)

getField OFTWideString ix f = getField OFTString ix f

getField OFTStringList ix f = liftM (Just . 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)

getField OFTWideStringList ix f = getField OFTStringList ix f

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

getField OFTDateTime ix f =
  liftM (fmap (uncurry OGRDateTime)) (getDateTime ix f)

getField OFTDate ix f =
  liftM (fmap (\(LocalTime d _,_) -> OGRDate d)) (getDateTime ix f)

getField OFTTime ix f =
  liftM (fmap (\(LocalTime _ t,_) -> OGRTime t)) (getDateTime ix f)

getDateTime :: CInt -> FeatureH -> IO (Maybe (LocalTime, OGRTimeZone))
getDateTime ix f
  = alloca $ \y -> alloca $ \m -> alloca $ \d ->
    alloca $ \h -> alloca $ \mn -> alloca $ \s -> alloca $ \pTz -> do
      ret <- {#call unsafe OGR_F_GetFieldAsDateTime as ^#} f ix y m d h mn s pTz
      if ret == 0
        then return Nothing
        else do
          day <- fromGregorian <$> peekIntegral y
                               <*> peekIntegral m
                               <*> peekIntegral d
          tod <- TimeOfDay <$> peekIntegral h
                           <*> peekIntegral mn
                           <*> peekIntegral s
          iTz <- peekIntegral pTz
          return (Just (LocalTime day tod, toOGRTimezone iTz))

toOGRTimezone :: CInt -> OGRTimeZone
toOGRTimezone tz =
  case tz of
    0   -> UnknownTimeZone
    1   -> LocalTimeZone
    100 -> KnownTimeZone utc
    n   -> KnownTimeZone (minutesToTimeZone ((fromIntegral n - 100) * 15))

fromOGRTimeZone :: OGRTimeZone -> CInt
fromOGRTimeZone UnknownTimeZone    = 0
fromOGRTimeZone LocalTimeZone      = 1
fromOGRTimeZone (KnownTimeZone tz) = truncate ((mins / 15) + 100)
  where mins = fromIntegral (timeZoneMinutes tz) :: Double

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

{-# LANGUAGE CPP #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE ScopedTypeVariables #-}

#include "bindings.h"

module GDAL.Internal.OGRFeature (
    OGRFeature (..)
  , OGRFeatureDef (..)
  , OGRField   (..)
  , OGRTimeZone (..)
  , Fid (..)
  , FieldType (..)
  , Field (..)
  , Feature (..)
  , FeatureH (..)
  , FieldDefnH (..)
  , FeatureDefnH (..)
  , Justification (..)

  , FeatureDef (..)
  , GeomFieldDef (..)
  , FieldDef (..)
  , fieldTypedAs
  , (.:)
  , (.=)
  , aGeom
  , aNullableGeom
  , theGeom
  , theNullableGeom
  , feature

  , featureToHandle
  , featureFromHandle
  , getFid

  , withFieldDefnH
  , fieldDefFromHandle
  , featureDefFromHandle
  , fieldDefsFromFeatureDefnH
  , geomFieldDefsFromFeatureDefnH
#if SUPPORTS_MULTI_GEOM_FIELDS
  , GeomFieldDefnH (..)
  , withGeomFieldDefnH
#endif
) where

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

import Control.Applicative ((<$>), (<*>), pure)
import Control.Monad (liftM, liftM2, (>=>), (<=<), when, void)
import Control.Monad.Catch (bracket)

import Data.ByteString (ByteString)
import Data.ByteString.Char8 (packCStringLen)
import Data.ByteString.Unsafe (unsafeUseAsCStringLen)
import qualified Data.HashMap.Strict as HM
import Data.Int (Int32, Int64)
import Data.Monoid (mempty, (<>))
import Data.Proxy (Proxy(Proxy))

import Data.Text (Text)
import Data.Time.LocalTime (
    LocalTime(..)
  , TimeOfDay(..)
  , TimeZone(..)
  , minutesToTimeZone
  , utc
  )
import Data.Time ()
import Data.Time.Calendar (Day, fromGregorian, toGregorian)
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(..)
  , CLong(..)
  )
import Foreign.Marshal.Alloc (alloca)
import Foreign.Marshal.Utils (copyBytes, toBool)
import Foreign.Ptr (Ptr, castPtr, nullPtr)
import Foreign.Storable (Storable, sizeOf, peek, peekElemOff)
#if GDAL_VERSION_MAJOR >= 2
import Foreign.C.Types (CLLong(..))
import Foreign.Marshal.Utils (fromBool)
#endif

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"

newtype Fid = Fid { unFid :: Int64 }
  deriving (Eq, Show, Num)

class OGRField a where
  fieldDef  :: Proxy a -> FieldDef
  toField   :: a  -> Field
  fromField :: Field -> Either Text a

(.:) :: OGRField a => Feature -> Text -> Either Text a
feat .: name =
  maybe (Left ("fromFeature: field '"<>name<>"' not present"))
        fromField
        (HM.lookup name (fFields feat))

(.=) :: OGRField a => Text -> a -> (Text, Field)
name .= value = (name, toField value)

class OGRFeature a where
  toFeature   :: a -> Feature
  fromFeature :: Feature -> Either Text a

theGeom :: Feature -> Either Text Geometry
theGeom = maybe (Left "Feature has no geometry") Right . fGeom

theNullableGeom :: Feature -> Either Text (Maybe Geometry)
theNullableGeom = Right . fGeom

aGeom :: Feature -> Text -> Either Text Geometry
feat `aGeom` name =
  maybe (Left ("fromFeature: geometry field '"<>name<>"' not present"))
        (maybe (Left ("fromFeature: geometry '"<>name<>"' is NULL")) Right)
        (HM.lookup name (fGeoms feat))

aNullableGeom :: Feature -> Text -> Either Text (Maybe Geometry)
feat `aNullableGeom` name =
  maybe (Left ("fromFeature: geometry field '"<>name<>"' not present"))
        Right
        (HM.lookup name (fGeoms feat))

class OGRFeature a => OGRFeatureDef a where
  featureDef  :: Proxy a -> FeatureDef

fieldTypedAs :: forall a. OGRField a => Text -> a -> (Text, FieldDef)
name `fieldTypedAs` _ = (name, fieldDef (Proxy :: Proxy a))

{#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       !Int32
  | OGRIntegerList   !(St.Vector Int32)
#if SUPPORTS_64_BIT_INT_FIELDS
  | OGRInteger64     !Int64
  | OGRInteger64List !(St.Vector Int64)
#endif
  | OGRReal          !Double
  | OGRRealList      !(St.Vector Double)
  | OGRString        !Text
  | OGRStringList    !(V.Vector Text)
  | OGRBinary        !ByteString
  | OGRDateTime      !LocalTime !OGRTimeZone
  | OGRDate          !Day
  | OGRTime          !TimeOfDay
  | OGRNullField
  deriving (Show, Eq)

data OGRTimeZone
  = UnknownTimeZone
  | LocalTimeZone
  | KnownTimeZone !TimeZone
  deriving (Eq, Show)

data FieldDef
  = FieldDef {
      fldType     :: !FieldType
    , fldWidth    :: !(Maybe Int)
    , fldPrec     :: !(Maybe Int)
    , fldJust     :: !(Maybe Justification)
    , fldNullable :: !Bool
    } deriving (Show, Eq)

data GeomFieldDef
  = GeomFieldDef {
      gfdType     :: !GeometryType
    , gfdSrs      :: !(Maybe SpatialReference)
    , gfdNullable :: !Bool
    } deriving (Show, Eq)

type Map a = HM.HashMap Text a

data Feature
  = Feature {
      fFields  :: !(Map Field)
    , fGeom    :: !(Maybe Geometry)
    , fGeoms   :: !(Map (Maybe Geometry))
    } deriving (Show, Eq)

feature :: Geometry -> [(Text,Field)] -> Feature
feature g fs =
  Feature { fFields = HM.fromList fs
          , fGeom   = Just g
          , fGeoms  = mempty
          }

instance OGRFeature Feature where
  toFeature    = id
  fromFeature  = Right

data FeatureDef
  = FeatureDef {
      fdName    :: !Text
    , fdFields  :: !FieldDefs
    , fdGeom    :: !GeomFieldDef
    , fdGeoms   :: !GeomFieldDefs
    } deriving (Show, Eq)

type FieldDefs = V.Vector (Text, FieldDef)
type GeomFieldDefs = V.Vector (Text, GeomFieldDef)

{#pointer FeatureH     newtype#}
{#pointer FieldDefnH   newtype#}
{#pointer FeatureDefnH newtype#}

deriving instance Eq FeatureH

nullFeatureH :: FeatureH
nullFeatureH = FeatureH nullPtr

withFieldDefnH :: Text -> FieldDef -> (FieldDefnH -> IO a) -> IO a
withFieldDefnH fldName 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 ()
#if SUPPORTS_NULLABLE_FIELD_DEFS
      {#call unsafe OGR_Fld_SetNullable as ^#} h (fromBool fldNullable)
#endif

fieldDefFromHandle :: FieldDefnH -> IO FieldDef
fieldDefFromHandle p =
  FieldDef
    <$> 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)
#if SUPPORTS_NULLABLE_FIELD_DEFS
    <*> liftM toBool ({#call unsafe OGR_Fld_IsNullable as ^#} p)
#else
    <*> pure True
#endif
  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 = do
#if SUPPORTS_MULTI_GEOM_FIELDS
  gfields <- geomFieldDefsFromFeatureDefnH p
  let (gfd', gfields')
        -- should not happen but just in case
        | V.null gfields = (gfd, gfields)
        -- ignore layer definition since it doesn't carry correct nullability
        -- info
        | otherwise      = (snd (V.unsafeHead gfields), V.unsafeTail gfields)
#else
  let (gfd', gfields') = (gfd, mempty)
#endif
  FeatureDef
    <$> ({#call unsafe OGR_FD_GetName as ^#} p >>= peekEncodedCString)
    <*> fieldDefsFromFeatureDefnH p
    <*> pure gfd'
    <*> pure gfields'

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

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

#if SUPPORTS_MULTI_GEOM_FIELDS

{#pointer GeomFieldDefnH newtype#}

geomFieldDefsFromFeatureDefnH p = do
  nFields <- {#call unsafe OGR_FD_GetGeomFieldCount as ^#} p
  V.generateM (fromIntegral nFields) $
    gFldDef <=< ({#call unsafe OGR_FD_GetGeomFieldDefn as ^#} p . fromIntegral)
  where
    gFldDef g = do
      name <- {#call unsafe OGR_GFld_GetNameRef as ^#} g >>= peekEncodedCString
      gDef <- GeomFieldDef
              <$> liftM toEnumC ({#call unsafe OGR_GFld_GetType as ^#} g)
              <*> ({#call unsafe OGR_GFld_GetSpatialRef as ^#} g >>=
                    maybeNewSpatialRefBorrowedHandle)
#if SUPPORTS_NULLABLE_FIELD_DEFS
              <*> liftM toBool ({#call unsafe OGR_GFld_IsNullable as ^#} g)
#else
              <*> pure True
#endif
      return (name, gDef)

withGeomFieldDefnH :: Text -> GeomFieldDef -> (GeomFieldDefnH -> IO a) -> IO a
withGeomFieldDefnH gfdName 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 p = do
      withMaybeSpatialReference gfdSrs $
        {#call unsafe OGR_GFld_SetSpatialRef as ^#} p
#if SUPPORTS_NULLABLE_FIELD_DEFS
      {#call unsafe OGR_GFld_SetNullable as ^#} p (fromBool gfdNullable)
#endif

#else
geomFieldDefsFromFeatureDefnH = const (return mempty)
#endif -- SUPPORTS_MULTI_GEOM_FIELDS

nullFID :: Fid
nullFID = Fid ({#const OGRNullFID#})

featureToHandle
  :: OGRFeature f
  => FeatureDefnH -> Maybe Fid -> f -> (FeatureH -> IO a) -> IO a
featureToHandle fdH fId ft act =
  bracket ({#call unsafe OGR_F_Create as ^#} fdH)
          ({#call unsafe OGR_F_Destroy as ^#}) $ \pF -> do
    case fId of
      Just (Fid fid) ->
        void $ {#call unsafe OGR_F_SetFID as ^#} pF (fromIntegral fid)
      Nothing        -> return ()
    fieldDefs <- fieldDefsFromFeatureDefnH fdH
    flip imapM_ fieldDefs $ \ix (name, _) -> do
      case HM.lookup name fFields of
        Just f  -> setField f ix pF
        Nothing -> return ()
    case fGeom of
      Just g  -> void $ withGeometry g ({#call unsafe OGR_F_SetGeometry as ^#} pF)
      Nothing -> return ()
    when (not (HM.null fGeoms)) $ do
#if SUPPORTS_MULTI_GEOM_FIELDS
      geomFieldDefs <- geomFieldDefsFromFeatureDefnH fdH
      flip imapM_ (V.tail geomFieldDefs) $ \ix (name, _) -> do
        case join (HM.lookup name fGeoms) of
          Just g  ->
            void $ withGeometry g ({#call unsafe OGR_F_SetGeomField as ^#} pF (ix+1))
          Nothing ->
            return ()
#else
      throwBindingException MultipleGeomFieldsNotSupported
#endif
    act pF
  where Feature {..} = toFeature ft

imapM :: (Monad m, Num a) => (a -> b -> m c) -> V.Vector b -> m (V.Vector c)
imapM f v  = V.mapM  (uncurry f) (V.zip (V.enumFromN 0 (V.length v)) v)

imapM_ :: (Monad m, Num a) => (a -> b -> m ()) -> V.Vector b -> m ()
imapM_ f v = V.mapM_ (uncurry f) (V.zip (V.enumFromN 0 (V.length v)) v)

getFid :: FeatureH -> IO (Maybe Fid)
getFid pF = do
  mFid <- liftM fromIntegral ({#call unsafe OGR_F_GetFID as ^#} pF)
  return (if mFid == nullFID then Nothing else Just mFid)

featureFromHandle
  :: OGRFeature a
  => FeatureDef -> IO FeatureH -> IO (Maybe (Maybe Fid, a))
featureFromHandle FeatureDef{..} act =
  bracket act {#call unsafe OGR_F_Destroy as ^#} $ \pF -> do
    if (pF == nullFeatureH)
      then return Nothing
      else do
        fid <- getFid pF
        fields <- flip imapM fdFields $ \i (fldName, fd) -> do
          isSet <- liftM toBool ({#call unsafe OGR_F_IsFieldSet as ^#} pF i)
          if isSet
            then getField (fldType fd) i pF >>=
                  maybe (throwBindingException (FieldParseError fldName))
                        (\f -> return (fldName, f))
            else return (fldName, OGRNullField)
        geomRef <- {#call unsafe OGR_F_StealGeometry as ^#} pF
        geom <- if geomRef /= nullPtr
                  then liftM Just (newGeometryHandle geomRef)
                  else return Nothing
#if SUPPORTS_MULTI_GEOM_FIELDS
        geoms <- flip imapM fdGeoms $ \ix (gfdName, _) -> do
          pG <- {#call unsafe OGR_F_GetGeomFieldRef as ^#} pF (ix + 1)
          g <- if pG /= nullPtr
                then liftM Just (cloneGeometry pG)
                else return Nothing
          return (gfdName, g)
#else
        let geoms = mempty
#endif
        either (throwBindingException . FromFeatureError)
               (\f -> return (Just (fid,f)))
               (fromFeature Feature {
                     fFields = HM.fromList (V.toList fields)
                   , fGeom   = geom
                   , fGeoms  = HM.fromList (V.toList geoms)
                   })

-- ############################################################################
-- setField
-- ############################################################################

setField :: Field -> CInt -> FeatureH -> IO ()

setField (OGRInteger v) ix f =
  {#call unsafe OGR_F_SetFieldInteger as ^#} f (fromIntegral ix) (fromIntegral v)

setField (OGRIntegerList v) ix f =
  St.unsafeWith v $
    {#call unsafe OGR_F_SetFieldIntegerList as ^#} f (fromIntegral ix)
      (fromIntegral (St.length v)) . castPtr

#if SUPPORTS_64_BIT_INT_FIELDS
setField (OGRInteger64 v) ix f =
  {#call unsafe OGR_F_SetFieldInteger64 as ^#} f (fromIntegral ix) (fromIntegral v)

setField (OGRInteger64List v) ix f =
  St.unsafeWith v $
    {#call unsafe OGR_F_SetFieldInteger64List as ^#} f (fromIntegral ix)
      (fromIntegral (St.length v)) . castPtr
#endif

setField (OGRReal v) ix f =
  {#call unsafe OGR_F_SetFieldDouble as ^#} f (fromIntegral ix) (realToFrac v)

setField (OGRRealList v) ix f =
  St.unsafeWith v $
    {#call unsafe OGR_F_SetFieldDoubleList as ^#} f (fromIntegral ix)
      (fromIntegral (St.length v)) . castPtr

setField (OGRString v) ix f = useAsEncodedCString v $
  {#call unsafe OGR_F_SetFieldString as ^#} f (fromIntegral ix)

setField (OGRStringList v) ix f =
  bracket createList {#call unsafe CSLDestroy as ^#} $
    {#call unsafe OGR_F_SetFieldStringList as ^#} f (fromIntegral ix)
  where
    createList = V.foldM' folder nullPtr v
    folder acc k =
      useAsEncodedCString k $ {#call unsafe CSLAddString as ^#} acc

setField (OGRBinary v) ix f = unsafeUseAsCStringLen v $ \(p,l) ->
  {#call unsafe OGR_F_SetFieldBinary as ^#}
    f (fromIntegral ix) (fromIntegral l) (castPtr p)

setField (OGRDateTime (LocalTime day (TimeOfDay h mn s)) tz) ix f =
  {#call unsafe OGR_F_SetFieldDateTime as ^#} f (fromIntegral ix)
  (fromIntegral y) (fromIntegral m) (fromIntegral d)
  (fromIntegral h) (fromIntegral mn) (truncate s) (fromOGRTimeZone tz)
  where (y, m, d) = toGregorian day

setField (OGRDate day) ix f =
  {#call unsafe OGR_F_SetFieldDateTime as ^#} f (fromIntegral ix)
  (fromIntegral y) (fromIntegral m) (fromIntegral d) 0 0 0 (fromOGRTimeZone tz)
  where (y, m, d) = toGregorian day
        tz = UnknownTimeZone

setField (OGRTime (TimeOfDay h mn s)) ix f =
  {#call unsafe OGR_F_SetFieldDateTime as ^#} f (fromIntegral ix) 0 0 0
  (fromIntegral h) (fromIntegral mn) (truncate s) (fromOGRTimeZone tz)
  where tz = UnknownTimeZone

setField OGRNullField ix f = {#call unsafe OGR_F_UnsetField as ^#} f ix

-- ############################################################################
-- getField
-- ############################################################################

getField :: FieldType -> CInt -> FeatureH -> IO (Maybe Field)

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

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

#if SUPPORTS_64_BIT_INT_FIELDS
getField OFTInteger64 ix f
  = liftM (Just . OGRInteger64 . fromIntegral)
    ({#call unsafe OGR_F_GetFieldAsInteger64 as ^#} f ix)

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

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

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

getField OFTString ix f = liftM (Just . OGRString)
  (({#call unsafe OGR_F_GetFieldAsString as ^#} f ix) >>= peekEncodedCString)

getField OFTWideString ix f = getField OFTString ix f

getField OFTStringList ix f = liftM (Just . 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)

getField OFTWideStringList ix f = getField OFTStringList ix f

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

getField OFTDateTime ix f =
  liftM (fmap (uncurry OGRDateTime)) (getDateTime ix f)

getField OFTDate ix f =
  liftM (fmap (\(LocalTime d _,_) -> OGRDate d)) (getDateTime ix f)

getField OFTTime ix f =
  liftM (fmap (\(LocalTime _ t,_) -> OGRTime t)) (getDateTime ix f)

getDateTime :: CInt -> FeatureH -> IO (Maybe (LocalTime, OGRTimeZone))
getDateTime ix f
  = alloca $ \y -> alloca $ \m -> alloca $ \d ->
    alloca $ \h -> alloca $ \mn -> alloca $ \s -> alloca $ \pTz -> do
      ret <- {#call unsafe OGR_F_GetFieldAsDateTime as ^#} f ix y m d h mn s pTz
      if ret == 0
        then return Nothing
        else do
          day <- fromGregorian <$> peekIntegral y
                               <*> peekIntegral m
                               <*> peekIntegral d
          tod <- TimeOfDay <$> peekIntegral h
                           <*> peekIntegral mn
                           <*> peekIntegral s
          iTz <- peekIntegral pTz
          return (Just (LocalTime day tod, toOGRTimezone iTz))

toOGRTimezone :: CInt -> OGRTimeZone
toOGRTimezone tz =
  case tz of
    0   -> UnknownTimeZone
    1   -> LocalTimeZone
    100 -> KnownTimeZone utc
    n   -> KnownTimeZone (minutesToTimeZone ((fromIntegral n - 100) * 15))

fromOGRTimeZone :: OGRTimeZone -> CInt
fromOGRTimeZone UnknownTimeZone    = 0
fromOGRTimeZone LocalTimeZone      = 1
fromOGRTimeZone (KnownTimeZone tz) = truncate ((mins / 15) + 100)
  where mins = fromIntegral (timeZoneMinutes tz) :: Double

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


Add writeAttr for Enums. This is needed for MessageDialog.

-- -*-haskell-*-
--  GIMP Toolkit (GTK) GObject Properties
--
--  Author : Duncan Coutts
--
--  Created: 16 April 2005
--
--  Version $Revision: 1.8 $ from $Date: 2005/08/29 11:15:58 $
--
--  Copyright (C) 2005 Duncan Coutts
--
--  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)
--
-- Functions for getting and setting GObject properties
--
module System.Glib.Properties (
  -- * per-type functions for getting and setting GObject properties
  objectSetPropertyInt,
  objectGetPropertyInt,
  objectSetPropertyUInt,
  objectGetPropertyUInt,
  objectSetPropertyBool,
  objectGetPropertyBool,
  objectSetPropertyEnum,
  objectGetPropertyEnum,
  objectSetPropertyFlags,
  objectGetPropertyFlags,
  objectSetPropertyFloat,
  objectGetPropertyFloat,
  objectSetPropertyDouble,
  objectGetPropertyDouble,
  objectSetPropertyString,
  objectGetPropertyString,
  objectSetPropertyMaybeString,
  objectGetPropertyMaybeString,
  objectSetPropertyBoxedOpaque,
  objectGetPropertyBoxedOpaque,
  objectSetPropertyBoxedStorable,
  objectGetPropertyBoxedStorable,
  objectSetPropertyGObject,
  objectGetPropertyGObject,

  -- * constructors for attributes backed by GObject properties
  newAttrFromIntProperty,
  readAttrFromIntProperty,
  newAttrFromUIntProperty,
  writeAttrFromUIntProperty,
  newAttrFromBoolProperty,
  newAttrFromFloatProperty,
  newAttrFromDoubleProperty,
  newAttrFromEnumProperty,
  readAttrFromEnumProperty,
  writeAttrFromEnumProperty,
  newAttrFromFlagsProperty,
  newAttrFromStringProperty,
  readAttrFromStringProperty,
  writeAttrFromStringProperty,
  writeAttrFromMaybeStringProperty,
  newAttrFromMaybeStringProperty,
  newAttrFromBoxedOpaqueProperty,
  writeAttrFromBoxedOpaqueProperty,
  newAttrFromBoxedStorableProperty,
  newAttrFromObjectProperty,
  writeAttrFromObjectProperty,
  ) where

import Monad (liftM)

import System.Glib.FFI
import System.Glib.Flags	(Flags, fromFlags, toFlags)
import System.Glib.UTFString
{#import System.Glib.Types#}
{#import System.Glib.GValue#}	(GValue(GValue), valueInit, allocaGValue)
import System.Glib.GObject	(makeNewGObject)
import qualified System.Glib.GTypeConstants as GType
import System.Glib.GType
import System.Glib.GValueTypes
import System.Glib.Attributes	(Attr, ReadAttr, WriteAttr, ReadWriteAttr,
				newAttr, readAttr, writeAttr)

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

objectSetPropertyInternal :: GObjectClass gobj => GType -> (GValue -> a -> IO ()) -> String -> gobj -> a -> IO ()
objectSetPropertyInternal gtype valueSet prop obj val =
  withCString prop $ \propPtr ->
  allocaGValue $ \gvalue -> do
  valueInit gvalue gtype
  valueSet gvalue val
  {# call g_object_set_property #}
    (toGObject obj)
    propPtr
    gvalue

objectGetPropertyInternal :: GObjectClass gobj => GType -> (GValue -> IO a) -> String -> gobj -> IO a
objectGetPropertyInternal gtype valueGet prop obj =
  withCString prop $ \propPtr ->
  allocaGValue $ \gvalue -> do
  valueInit gvalue gtype
  {# call unsafe g_object_get_property #}
    (toGObject obj)
    propPtr
    gvalue
  valueGet gvalue

objectSetPropertyInt :: GObjectClass gobj => String -> gobj -> Int -> IO ()
objectSetPropertyInt = objectSetPropertyInternal GType.int valueSetInt

objectGetPropertyInt :: GObjectClass gobj => String -> gobj -> IO Int
objectGetPropertyInt = objectGetPropertyInternal GType.int valueGetInt

objectSetPropertyUInt :: GObjectClass gobj => String -> gobj -> Int -> IO ()
objectSetPropertyUInt = objectSetPropertyInternal GType.uint (\gv v -> valueSetUInt gv (fromIntegral v))

objectGetPropertyUInt :: GObjectClass gobj => String -> gobj -> IO Int
objectGetPropertyUInt = objectGetPropertyInternal GType.uint (\gv -> liftM fromIntegral $ valueGetUInt gv)

objectSetPropertyBool :: GObjectClass gobj => String -> gobj -> Bool -> IO ()
objectSetPropertyBool = objectSetPropertyInternal GType.bool valueSetBool

objectGetPropertyBool :: GObjectClass gobj => String -> gobj -> IO Bool
objectGetPropertyBool = objectGetPropertyInternal GType.bool valueGetBool

objectSetPropertyEnum :: (GObjectClass gobj, Enum enum) => GType -> String -> gobj -> enum -> IO ()
objectSetPropertyEnum gtype = objectSetPropertyInternal gtype valueSetEnum

objectGetPropertyEnum :: (GObjectClass gobj, Enum enum) => GType -> String -> gobj -> IO enum
objectGetPropertyEnum gtype = objectGetPropertyInternal gtype valueGetEnum

objectSetPropertyFlags :: (GObjectClass gobj, Flags flag) => String -> gobj -> [flag] -> IO ()
objectSetPropertyFlags = objectSetPropertyInternal GType.flags valueSetFlags

objectGetPropertyFlags :: (GObjectClass gobj, Flags flag) => String -> gobj -> IO [flag]
objectGetPropertyFlags = objectGetPropertyInternal GType.flags valueGetFlags

objectSetPropertyFloat :: GObjectClass gobj => String -> gobj -> Float -> IO ()
objectSetPropertyFloat = objectSetPropertyInternal GType.float valueSetFloat

objectGetPropertyFloat :: GObjectClass gobj => String -> gobj -> IO Float
objectGetPropertyFloat = objectGetPropertyInternal GType.float valueGetFloat

objectSetPropertyDouble :: GObjectClass gobj => String -> gobj -> Double -> IO ()
objectSetPropertyDouble = objectSetPropertyInternal GType.double valueSetDouble

objectGetPropertyDouble :: GObjectClass gobj => String -> gobj -> IO Double
objectGetPropertyDouble = objectGetPropertyInternal GType.double valueGetDouble

objectSetPropertyString :: GObjectClass gobj => String -> gobj -> String -> IO ()
objectSetPropertyString = objectSetPropertyInternal GType.string valueSetString

objectGetPropertyString :: GObjectClass gobj => String -> gobj -> IO String
objectGetPropertyString = objectGetPropertyInternal GType.string valueGetString

objectSetPropertyMaybeString :: GObjectClass gobj => String -> gobj -> Maybe String -> IO ()
objectSetPropertyMaybeString = objectSetPropertyInternal GType.string valueSetMaybeString

objectGetPropertyMaybeString :: GObjectClass gobj => String -> gobj -> IO (Maybe String)
objectGetPropertyMaybeString = objectGetPropertyInternal GType.string valueGetMaybeString

objectSetPropertyBoxedOpaque :: GObjectClass gobj => (boxed -> (Ptr boxed -> IO ()) -> IO ()) -> GType -> String -> gobj -> boxed -> IO ()
objectSetPropertyBoxedOpaque with gtype = objectSetPropertyInternal gtype (valueSetBoxed with)

objectGetPropertyBoxedOpaque :: GObjectClass gobj => (Ptr boxed -> IO boxed) -> GType -> String -> gobj -> IO boxed
objectGetPropertyBoxedOpaque peek gtype = objectGetPropertyInternal gtype (valueGetBoxed peek)

objectSetPropertyBoxedStorable :: (GObjectClass gobj, Storable boxed) => GType -> String -> gobj -> boxed -> IO ()
objectSetPropertyBoxedStorable = objectSetPropertyBoxedOpaque with

objectGetPropertyBoxedStorable :: (GObjectClass gobj, Storable boxed) => GType -> String -> gobj -> IO boxed
objectGetPropertyBoxedStorable = objectGetPropertyBoxedOpaque peek

objectSetPropertyGObject :: (GObjectClass gobj, GObjectClass gobj') => GType -> String -> gobj -> gobj' -> IO ()
objectSetPropertyGObject gtype = objectSetPropertyInternal gtype valueSetGObject

objectGetPropertyGObject :: (GObjectClass gobj, GObjectClass gobj') => GType -> String -> gobj -> IO gobj'
objectGetPropertyGObject gtype = objectGetPropertyInternal gtype valueGetGObject

-- Convenience functions to make attribute implementations in the other modules
-- shorter and more easily extensible.
--

newAttrFromIntProperty :: GObjectClass gobj => String -> Attr gobj Int
newAttrFromIntProperty propName =
  newAttr (objectGetPropertyInt propName) (objectSetPropertyInt propName)

readAttrFromIntProperty :: GObjectClass gobj => String -> ReadAttr gobj Int
readAttrFromIntProperty propName =
  readAttr (objectGetPropertyInt propName)

newAttrFromUIntProperty :: GObjectClass gobj => String -> Attr gobj Int
newAttrFromUIntProperty propName =
  newAttr (objectGetPropertyUInt propName) (objectSetPropertyUInt propName)

writeAttrFromUIntProperty :: GObjectClass gobj => String -> WriteAttr gobj Int
writeAttrFromUIntProperty propName =
  writeAttr (objectSetPropertyUInt propName)

newAttrFromBoolProperty :: GObjectClass gobj => String -> Attr gobj Bool
newAttrFromBoolProperty propName =
  newAttr (objectGetPropertyBool propName) (objectSetPropertyBool propName)

newAttrFromFloatProperty :: GObjectClass gobj => String -> Attr gobj Float
newAttrFromFloatProperty propName =
  newAttr (objectGetPropertyFloat propName) (objectSetPropertyFloat propName)

newAttrFromDoubleProperty :: GObjectClass gobj => String -> Attr gobj Double
newAttrFromDoubleProperty propName =
  newAttr (objectGetPropertyDouble propName) (objectSetPropertyDouble propName)

newAttrFromEnumProperty :: (GObjectClass gobj, Enum enum) => String -> GType -> Attr gobj enum
newAttrFromEnumProperty propName gtype =
  newAttr (objectGetPropertyEnum gtype propName) (objectSetPropertyEnum gtype propName)

readAttrFromEnumProperty :: (GObjectClass gobj, Enum enum) => String -> GType -> ReadAttr gobj enum
readAttrFromEnumProperty propName gtype =
  readAttr (objectGetPropertyEnum gtype propName)

writeAttrFromEnumProperty :: (GObjectClass gobj, Enum enum) => String -> GType -> WriteAttr gobj enum
writeAttrFromEnumProperty propName gtype =
  writeAttr (objectSetPropertyEnum gtype propName)

newAttrFromFlagsProperty :: (GObjectClass gobj, Flags flag) => String -> Attr gobj [flag]
newAttrFromFlagsProperty propName =
  newAttr (objectGetPropertyFlags propName) (objectSetPropertyFlags propName)

newAttrFromStringProperty :: GObjectClass gobj => String -> Attr gobj String
newAttrFromStringProperty propName =
  newAttr (objectGetPropertyString propName) (objectSetPropertyString propName)

readAttrFromStringProperty :: GObjectClass gobj => String -> ReadAttr gobj String
readAttrFromStringProperty propName =
  readAttr (objectGetPropertyString propName)

writeAttrFromStringProperty :: GObjectClass gobj => String -> WriteAttr gobj String
writeAttrFromStringProperty propName =
  writeAttr (objectSetPropertyString propName)

writeAttrFromMaybeStringProperty :: GObjectClass gobj => String -> WriteAttr gobj (Maybe String)
writeAttrFromMaybeStringProperty propName =
  writeAttr (objectSetPropertyMaybeString propName)

newAttrFromMaybeStringProperty :: GObjectClass gobj => String -> Attr gobj (Maybe String)
newAttrFromMaybeStringProperty propName =
  newAttr (objectGetPropertyMaybeString propName) (objectSetPropertyMaybeString propName)

newAttrFromBoxedOpaqueProperty :: GObjectClass gobj => (Ptr boxed -> IO boxed) -> (boxed -> (Ptr boxed -> IO ()) -> IO ()) -> String -> GType -> Attr gobj boxed
newAttrFromBoxedOpaqueProperty peek with propName gtype =
  newAttr (objectGetPropertyBoxedOpaque peek gtype propName) (objectSetPropertyBoxedOpaque with gtype propName)

writeAttrFromBoxedOpaqueProperty :: GObjectClass gobj => (boxed -> (Ptr boxed -> IO ()) -> IO ()) -> String -> GType -> WriteAttr gobj boxed
writeAttrFromBoxedOpaqueProperty with propName gtype =
  writeAttr (objectSetPropertyBoxedOpaque with gtype propName)

newAttrFromBoxedStorableProperty :: (GObjectClass gobj, Storable boxed) => String -> GType -> Attr gobj boxed
newAttrFromBoxedStorableProperty propName gtype =
  newAttr (objectGetPropertyBoxedStorable gtype propName) (objectSetPropertyBoxedStorable gtype propName)

newAttrFromObjectProperty :: (GObjectClass gobj, GObjectClass gobj', GObjectClass gobj'') => String -> GType -> ReadWriteAttr gobj gobj' gobj''
newAttrFromObjectProperty propName gtype =
  newAttr (objectGetPropertyGObject gtype propName) (objectSetPropertyGObject gtype propName)

writeAttrFromObjectProperty :: (GObjectClass gobj, GObjectClass gobj') => String -> GType -> WriteAttr gobj gobj'
writeAttrFromObjectProperty propName gtype =
  writeAttr (objectSetPropertyGObject gtype propName)

-- -*-haskell-*-
--  GIMP Toolkit (GTK) GObject Properties
--
--  Author : Duncan Coutts
--
--  Created: 16 April 2005
--
--  Version $Revision: 1.8 $ from $Date: 2005/08/29 11:15:58 $
--
--  Copyright (C) 2005 Duncan Coutts
--
--  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)
--
-- Functions for getting and setting GObject properties
--
module System.Glib.Properties (
  -- * per-type functions for getting and setting GObject properties
  objectSetPropertyInt,
  objectGetPropertyInt,
  objectSetPropertyUInt,
  objectGetPropertyUInt,
  objectSetPropertyBool,
  objectGetPropertyBool,
  objectSetPropertyEnum,
  objectGetPropertyEnum,
  objectSetPropertyFlags,
  objectGetPropertyFlags,
  objectSetPropertyFloat,
  objectGetPropertyFloat,
  objectSetPropertyDouble,
  objectGetPropertyDouble,
  objectSetPropertyString,
  objectGetPropertyString,
  objectSetPropertyMaybeString,
  objectGetPropertyMaybeString,
  objectSetPropertyBoxedOpaque,
  objectGetPropertyBoxedOpaque,
  objectSetPropertyBoxedStorable,
  objectGetPropertyBoxedStorable,
  objectSetPropertyGObject,
  objectGetPropertyGObject,

  -- * constructors for attributes backed by GObject properties
  newAttrFromIntProperty,
  readAttrFromIntProperty,
  newAttrFromUIntProperty,
  writeAttrFromUIntProperty,
  newAttrFromBoolProperty,
  newAttrFromFloatProperty,
  newAttrFromDoubleProperty,
  newAttrFromEnumProperty,
  readAttrFromEnumProperty,
  newAttrFromFlagsProperty,
  newAttrFromStringProperty,
  readAttrFromStringProperty,
  writeAttrFromStringProperty,
  writeAttrFromMaybeStringProperty,
  newAttrFromMaybeStringProperty,
  newAttrFromBoxedOpaqueProperty,
  writeAttrFromBoxedOpaqueProperty,
  newAttrFromBoxedStorableProperty,
  newAttrFromObjectProperty,
  writeAttrFromObjectProperty,
  ) where

import Monad (liftM)

import System.Glib.FFI
import System.Glib.Flags	(Flags, fromFlags, toFlags)
import System.Glib.UTFString
{#import System.Glib.Types#}
{#import System.Glib.GValue#}	(GValue(GValue), valueInit, allocaGValue)
import System.Glib.GObject	(makeNewGObject)
import qualified System.Glib.GTypeConstants as GType
import System.Glib.GType
import System.Glib.GValueTypes
import System.Glib.Attributes	(Attr, ReadAttr, WriteAttr, ReadWriteAttr,
				newAttr, readAttr, writeAttr)

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

objectSetPropertyInternal :: GObjectClass gobj => GType -> (GValue -> a -> IO ()) -> String -> gobj -> a -> IO ()
objectSetPropertyInternal gtype valueSet prop obj val =
  withCString prop $ \propPtr ->
  allocaGValue $ \gvalue -> do
  valueInit gvalue gtype
  valueSet gvalue val
  {# call g_object_set_property #}
    (toGObject obj)
    propPtr
    gvalue

objectGetPropertyInternal :: GObjectClass gobj => GType -> (GValue -> IO a) -> String -> gobj -> IO a
objectGetPropertyInternal gtype valueGet prop obj =
  withCString prop $ \propPtr ->
  allocaGValue $ \gvalue -> do
  valueInit gvalue gtype
  {# call unsafe g_object_get_property #}
    (toGObject obj)
    propPtr
    gvalue
  valueGet gvalue

objectSetPropertyInt :: GObjectClass gobj => String -> gobj -> Int -> IO ()
objectSetPropertyInt = objectSetPropertyInternal GType.int valueSetInt

objectGetPropertyInt :: GObjectClass gobj => String -> gobj -> IO Int
objectGetPropertyInt = objectGetPropertyInternal GType.int valueGetInt

objectSetPropertyUInt :: GObjectClass gobj => String -> gobj -> Int -> IO ()
objectSetPropertyUInt = objectSetPropertyInternal GType.uint (\gv v -> valueSetUInt gv (fromIntegral v))

objectGetPropertyUInt :: GObjectClass gobj => String -> gobj -> IO Int
objectGetPropertyUInt = objectGetPropertyInternal GType.uint (\gv -> liftM fromIntegral $ valueGetUInt gv)

objectSetPropertyBool :: GObjectClass gobj => String -> gobj -> Bool -> IO ()
objectSetPropertyBool = objectSetPropertyInternal GType.bool valueSetBool

objectGetPropertyBool :: GObjectClass gobj => String -> gobj -> IO Bool
objectGetPropertyBool = objectGetPropertyInternal GType.bool valueGetBool

objectSetPropertyEnum :: (GObjectClass gobj, Enum enum) => GType -> String -> gobj -> enum -> IO ()
objectSetPropertyEnum gtype = objectSetPropertyInternal gtype valueSetEnum

objectGetPropertyEnum :: (GObjectClass gobj, Enum enum) => GType -> String -> gobj -> IO enum
objectGetPropertyEnum gtype = objectGetPropertyInternal gtype valueGetEnum

objectSetPropertyFlags :: (GObjectClass gobj, Flags flag) => String -> gobj -> [flag] -> IO ()
objectSetPropertyFlags = objectSetPropertyInternal GType.flags valueSetFlags

objectGetPropertyFlags :: (GObjectClass gobj, Flags flag) => String -> gobj -> IO [flag]
objectGetPropertyFlags = objectGetPropertyInternal GType.flags valueGetFlags

objectSetPropertyFloat :: GObjectClass gobj => String -> gobj -> Float -> IO ()
objectSetPropertyFloat = objectSetPropertyInternal GType.float valueSetFloat

objectGetPropertyFloat :: GObjectClass gobj => String -> gobj -> IO Float
objectGetPropertyFloat = objectGetPropertyInternal GType.float valueGetFloat

objectSetPropertyDouble :: GObjectClass gobj => String -> gobj -> Double -> IO ()
objectSetPropertyDouble = objectSetPropertyInternal GType.double valueSetDouble

objectGetPropertyDouble :: GObjectClass gobj => String -> gobj -> IO Double
objectGetPropertyDouble = objectGetPropertyInternal GType.double valueGetDouble

objectSetPropertyString :: GObjectClass gobj => String -> gobj -> String -> IO ()
objectSetPropertyString = objectSetPropertyInternal GType.string valueSetString

objectGetPropertyString :: GObjectClass gobj => String -> gobj -> IO String
objectGetPropertyString = objectGetPropertyInternal GType.string valueGetString

objectSetPropertyMaybeString :: GObjectClass gobj => String -> gobj -> Maybe String -> IO ()
objectSetPropertyMaybeString = objectSetPropertyInternal GType.string valueSetMaybeString

objectGetPropertyMaybeString :: GObjectClass gobj => String -> gobj -> IO (Maybe String)
objectGetPropertyMaybeString = objectGetPropertyInternal GType.string valueGetMaybeString

objectSetPropertyBoxedOpaque :: GObjectClass gobj => (boxed -> (Ptr boxed -> IO ()) -> IO ()) -> GType -> String -> gobj -> boxed -> IO ()
objectSetPropertyBoxedOpaque with gtype = objectSetPropertyInternal gtype (valueSetBoxed with)

objectGetPropertyBoxedOpaque :: GObjectClass gobj => (Ptr boxed -> IO boxed) -> GType -> String -> gobj -> IO boxed
objectGetPropertyBoxedOpaque peek gtype = objectGetPropertyInternal gtype (valueGetBoxed peek)

objectSetPropertyBoxedStorable :: (GObjectClass gobj, Storable boxed) => GType -> String -> gobj -> boxed -> IO ()
objectSetPropertyBoxedStorable = objectSetPropertyBoxedOpaque with

objectGetPropertyBoxedStorable :: (GObjectClass gobj, Storable boxed) => GType -> String -> gobj -> IO boxed
objectGetPropertyBoxedStorable = objectGetPropertyBoxedOpaque peek

objectSetPropertyGObject :: (GObjectClass gobj, GObjectClass gobj') => GType -> String -> gobj -> gobj' -> IO ()
objectSetPropertyGObject gtype = objectSetPropertyInternal gtype valueSetGObject

objectGetPropertyGObject :: (GObjectClass gobj, GObjectClass gobj') => GType -> String -> gobj -> IO gobj'
objectGetPropertyGObject gtype = objectGetPropertyInternal gtype valueGetGObject

-- Convenience functions to make attribute implementations in the other modules
-- shorter and more easily extensible.
--

newAttrFromIntProperty :: GObjectClass gobj => String -> Attr gobj Int
newAttrFromIntProperty propName =
  newAttr (objectGetPropertyInt propName) (objectSetPropertyInt propName)

readAttrFromIntProperty :: GObjectClass gobj => String -> ReadAttr gobj Int
readAttrFromIntProperty propName =
  readAttr (objectGetPropertyInt propName)

newAttrFromUIntProperty :: GObjectClass gobj => String -> Attr gobj Int
newAttrFromUIntProperty propName =
  newAttr (objectGetPropertyUInt propName) (objectSetPropertyUInt propName)

writeAttrFromUIntProperty :: GObjectClass gobj => String -> WriteAttr gobj Int
writeAttrFromUIntProperty propName =
  writeAttr (objectSetPropertyUInt propName)

newAttrFromBoolProperty :: GObjectClass gobj => String -> Attr gobj Bool
newAttrFromBoolProperty propName =
  newAttr (objectGetPropertyBool propName) (objectSetPropertyBool propName)

newAttrFromFloatProperty :: GObjectClass gobj => String -> Attr gobj Float
newAttrFromFloatProperty propName =
  newAttr (objectGetPropertyFloat propName) (objectSetPropertyFloat propName)

newAttrFromDoubleProperty :: GObjectClass gobj => String -> Attr gobj Double
newAttrFromDoubleProperty propName =
  newAttr (objectGetPropertyDouble propName) (objectSetPropertyDouble propName)

newAttrFromEnumProperty :: (GObjectClass gobj, Enum enum) => String -> GType -> Attr gobj enum
newAttrFromEnumProperty propName gtype =
  newAttr (objectGetPropertyEnum gtype propName) (objectSetPropertyEnum gtype propName)

readAttrFromEnumProperty :: (GObjectClass gobj, Enum enum) => String -> GType -> ReadAttr gobj enum
readAttrFromEnumProperty propName gtype =
  readAttr (objectGetPropertyEnum gtype propName)

newAttrFromFlagsProperty :: (GObjectClass gobj, Flags flag) => String -> Attr gobj [flag]
newAttrFromFlagsProperty propName =
  newAttr (objectGetPropertyFlags propName) (objectSetPropertyFlags propName)

newAttrFromStringProperty :: GObjectClass gobj => String -> Attr gobj String
newAttrFromStringProperty propName =
  newAttr (objectGetPropertyString propName) (objectSetPropertyString propName)

readAttrFromStringProperty :: GObjectClass gobj => String -> ReadAttr gobj String
readAttrFromStringProperty propName =
  readAttr (objectGetPropertyString propName)

writeAttrFromStringProperty :: GObjectClass gobj => String -> WriteAttr gobj String
writeAttrFromStringProperty propName =
  writeAttr (objectSetPropertyString propName)

writeAttrFromMaybeStringProperty :: GObjectClass gobj => String -> WriteAttr gobj (Maybe String)
writeAttrFromMaybeStringProperty propName =
  writeAttr (objectSetPropertyMaybeString propName)

newAttrFromMaybeStringProperty :: GObjectClass gobj => String -> Attr gobj (Maybe String)
newAttrFromMaybeStringProperty propName =
  newAttr (objectGetPropertyMaybeString propName) (objectSetPropertyMaybeString propName)

newAttrFromBoxedOpaqueProperty :: GObjectClass gobj => (Ptr boxed -> IO boxed) -> (boxed -> (Ptr boxed -> IO ()) -> IO ()) -> String -> GType -> Attr gobj boxed
newAttrFromBoxedOpaqueProperty peek with propName gtype =
  newAttr (objectGetPropertyBoxedOpaque peek gtype propName) (objectSetPropertyBoxedOpaque with gtype propName)

writeAttrFromBoxedOpaqueProperty :: GObjectClass gobj => (boxed -> (Ptr boxed -> IO ()) -> IO ()) -> String -> GType -> WriteAttr gobj boxed
writeAttrFromBoxedOpaqueProperty with propName gtype =
  writeAttr (objectSetPropertyBoxedOpaque with gtype propName)

newAttrFromBoxedStorableProperty :: (GObjectClass gobj, Storable boxed) => String -> GType -> Attr gobj boxed
newAttrFromBoxedStorableProperty propName gtype =
  newAttr (objectGetPropertyBoxedStorable gtype propName) (objectSetPropertyBoxedStorable gtype propName)

newAttrFromObjectProperty :: (GObjectClass gobj, GObjectClass gobj', GObjectClass gobj'') => String -> GType -> ReadWriteAttr gobj gobj' gobj''
newAttrFromObjectProperty propName gtype =
  newAttr (objectGetPropertyGObject gtype propName) (objectSetPropertyGObject gtype propName)

writeAttrFromObjectProperty :: (GObjectClass gobj, GObjectClass gobj') => String -> GType -> WriteAttr gobj gobj'
writeAttrFromObjectProperty propName gtype =
  writeAttr (objectSetPropertyGObject gtype propName)


Remove Gtk.Signals from GtkInternals.chs

{-# OPTIONS_HADDOCK hide #-}
-- -*-haskell-*-
--  Internal functions for the GIMP Toolkit (GTK) Binding for Haskell
--
--  Author : Axel Simon
--
--  Copyright (C) 2010 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.
--
-- #hide

-- |
-- Maintainer  : gtk2hs-users@lists.sourceforge.net
-- Stability   : provisional
-- Portability : portable (depends on GHC)
--
-- This file contains functions that are needed by other library wrappers that build
-- on Gtk2Hs. An application should not need this function nor include this file.
--
module Graphics.UI.GtkInternals (
  module Graphics.UI.Gtk.Types,
  module Graphics.UI.Gtk.General.DNDTypes,
  module Graphics.UI.Gtk.Multiline.Types,
  ) where

{#import Graphics.UI.Gtk.Types#}
{#import Graphics.UI.Gtk.General.DNDTypes#} (mkTargetList)
{#import Graphics.UI.Gtk.Multiline.Types#}

{-# OPTIONS_HADDOCK hide #-}
-- -*-haskell-*-
--  Internal functions for the GIMP Toolkit (GTK) Binding for Haskell
--
--  Author : Axel Simon
--
--  Copyright (C) 2010 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.
--
-- #hide

-- |
-- Maintainer  : gtk2hs-users@lists.sourceforge.net
-- Stability   : provisional
-- Portability : portable (depends on GHC)
--
-- This file contains functions that are needed by other library wrappers that build
-- on Gtk2Hs. An application should not need this function nor include this file.
--
module Graphics.UI.GtkInternals (
  module Graphics.UI.Gtk.Types,
  module Graphics.UI.Gtk.General.DNDTypes,
  module Graphics.UI.Gtk.Multiline.Types,
  module Graphics.UI.Gtk.Signals,
  ) where

{#import Graphics.UI.Gtk.Types#}
{#import Graphics.UI.Gtk.General.DNDTypes#} (mkTargetList)
{#import Graphics.UI.Gtk.Multiline.Types#}
{#import Graphics.UI.Gtk.Signals#}


Make the setting of handlers more efficient in IO.parse

Ignore-this: d1cf0752eb1ca9e028ee6253c6163c5d

darcs-hash:20090306112543-ed7c9-8795c33e97ce02a620f50e3c40ebb97007e737b0.gz

-- hexpat, a Haskell wrapper for expat
-- Copyright (C) 2008 Evan Martin <martine@danga.com>

-- |This module wraps the Expat API directly with IO operations
-- everywhere.  Basic usage is:
--
-- (1) Make a new parser: 'newParser'.
--
-- (2) Set up callbacks on the parser: 'setStartElementHandler', etc.
--
-- (3) Feed data into the parser: 'parse' or 'parseChunk'.

module Text.XML.Expat.IO (
  -- ** Parser Setup
  Parser, newParser,

  -- ** Parsing
  parse, Encoding(..),

  -- ** Parser Callbacks
  StartElementHandler, EndElementHandler, CharacterDataHandler,
  setStartElementHandler, setEndElementHandler, setCharacterDataHandler,

  -- ** Lower-level Parsing Interface
  parseChunk,

  -- ** Helpers
  encodingToString
) where

import Control.Exception (bracket)
import C2HS
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BSL
import qualified Data.ByteString.Internal as BSI
import Data.IORef

#include <expat.h>

-- Expat functions start with "XML", but C2HS appears to ignore our "as"
-- definitions if they only differ from the symbol in case.  So we write out
-- XML_* in most cases anyway...  :(
{#context lib = "expat" prefix = "XML"#}

-- |Opaque parser type.
type ParserPtr = Ptr ()
data Parser = Parser
    (ForeignPtr ())
    (IORef CStartElementHandler)
    (IORef CEndElementHandler)
    (IORef CCharacterDataHandler)

withParser :: Parser -> (ParserPtr -> IO a) -> IO a
withParser (Parser fp _ _ _) = withForeignPtr fp

-- |Encoding types available for the document encoding.
data Encoding = ASCII | UTF8 | UTF16 | ISO88591
encodingToString :: Encoding -> String
encodingToString ASCII    = "US-ASCII"
encodingToString UTF8     = "UTF-8"
encodingToString UTF16    = "UTF-16"
encodingToString ISO88591 = "ISO-8859-1"

withOptEncoding :: Maybe Encoding -> (CString -> IO a) -> IO a
withOptEncoding Nothing    f = f nullPtr
withOptEncoding (Just enc) f = withCString (encodingToString enc) f

{#fun unsafe XML_ParserCreate as parserCreate
    {withOptEncoding* `Maybe Encoding'} -> `ParserPtr' id#}
foreign import ccall "&XML_ParserFree" parserFree :: FunPtr (ParserPtr -> IO ())

-- |Create a 'Parser'.  The encoding parameter, if provided, overrides the
-- document's encoding declaration.
newParser :: Maybe Encoding -> IO Parser
newParser enc = do
  ptr <- parserCreate enc
  fptr <- newForeignPtr parserFree ptr
  nullStartH <- newIORef nullCStartElementHandler
  nullEndH <- newIORef nullCEndElementHandler
  nullCharH <- newIORef nullCCharacterDataHandler
  return $ Parser fptr nullStartH nullEndH nullCharH

-- ByteString.useAsCStringLen is almost what we need, but C2HS wants a CInt
-- instead of an Int.
withBStringLen :: BS.ByteString -> ((CString, CInt) -> IO a) -> IO a
withBStringLen bs f = do
  BS.useAsCStringLen bs $ \(str, len) -> f (str, fromIntegral len)

unStatus :: CInt -> Bool
unStatus 0 = False
unStatus 1 = True
-- |@parseChunk data False@ feeds /strict/ ByteString data into a
-- 'Parser'.  The end of the data is indicated by passing @True@ for the
-- final parameter.  @parse@ returns @False@ on a parse error.
parseChunk :: Parser
           -> BS.ByteString
           -> Bool
           -> IO Bool
parseChunk parser xml final = do
    withHandlers parser $ doParseChunk parser xml final

withHandlers :: Parser -> IO a -> IO a
withHandlers parser@(Parser fp startRef endRef charRef) code = do
    bracket
        (do
            cStartH <- mkCStartElementHandler =<< readIORef startRef
            cEndH   <- mkCEndElementHandler =<< readIORef endRef
            cCharH  <- mkCCharacterDataHandler =<< readIORef charRef
            withParser parser $ \p -> do
                {#call unsafe XML_SetStartElementHandler as ^#}  p cStartH
                {#call unsafe XML_SetEndElementHandler as ^#}    p cEndH
                {#call unsafe XML_SetCharacterDataHandler as ^#} p cCharH
            return (cStartH, cEndH, cCharH))
        (\(cStartH, cEndH, cCharH) -> do
            freeHaskellFunPtr cStartH
            freeHaskellFunPtr cEndH
            freeHaskellFunPtr cCharH)
        (\_ -> code)

{#fun XML_Parse as doParseChunk
    {withParser* `Parser', withBStringLen* `BS.ByteString' &, `Bool'}
    -> `Bool' unStatus#}

-- |@parse data@ feeds /lazy/ bytestring data into a parser and returns
-- @True@ if there was no parse error.
parse :: Parser -> BSL.ByteString -> IO Bool
parse parser bs = withHandlers parser $ feedChunk (BSL.toChunks bs)
  where
    feedChunk []      = return True
    feedChunk [chunk] = parseChunk parser chunk True
    feedChunk (c:cs)  = do ok <- doParseChunk parser c False
                           if ok then feedChunk cs
                                 else return False

-- |The type of the \"element started\" callback.  The first parameter is
-- the element name; the second are the (attribute, value) pairs.
type StartElementHandler  = BS.ByteString -> [(BS.ByteString,BS.ByteString)] -> IO ()
-- |The type of the \"element ended\" callback.  The parameter is
-- the element name.
type EndElementHandler    = BS.ByteString -> IO ()
-- |The type of the \"character data\" callback.  The parameter is
-- the character data processed.  This callback may be called more than once
-- while processing a single conceptual block of text.
type CharacterDataHandler = BS.ByteString -> IO ()

type CStartElementHandler = Ptr () -> CString -> Ptr CString -> IO ()
nullCStartElementHandler _ _ _ = return ()

foreign import ccall "wrapper"
  mkCStartElementHandler :: CStartElementHandler
                         -> IO (FunPtr CStartElementHandler)
wrapStartElementHandler :: StartElementHandler -> CStartElementHandler
wrapStartElementHandler handler = h where
  h ptr cname cattrs = do
    name <- peekByteString cname
    cattrlist <- peekArray0 nullPtr cattrs
    attrlist <- mapM peekByteString cattrlist
    handler name (pairwise attrlist)
-- |Attach a StartElementHandler to a Parser.
setStartElementHandler :: Parser -> StartElementHandler -> IO ()
setStartElementHandler parser@(Parser _ startRef _ _) handler = do
  withParser parser $ \p -> do
  writeIORef startRef $ wrapStartElementHandler handler

type CEndElementHandler = Ptr () -> CString -> IO ()
nullCEndElementHandler _ _ = return ()

foreign import ccall "wrapper"
  mkCEndElementHandler :: CEndElementHandler
                       -> IO (FunPtr CEndElementHandler)
wrapEndElementHandler :: EndElementHandler -> CEndElementHandler
wrapEndElementHandler handler = h where
  h ptr cname = do
    name <- peekByteString cname
    handler name

-- |Attach an EndElementHandler to a Parser.
setEndElementHandler :: Parser -> EndElementHandler -> IO ()
setEndElementHandler parser@(Parser _ _ endRef _) handler = do
  withParser parser $ \p -> do
  writeIORef endRef $ wrapEndElementHandler handler

type CCharacterDataHandler = Ptr () -> CString -> CInt -> IO ()
nullCCharacterDataHandler _ _ _ = return ()

foreign import ccall "wrapper"
  mkCCharacterDataHandler :: CCharacterDataHandler
                          -> IO (FunPtr CCharacterDataHandler)
wrapCharacterDataHandler :: CharacterDataHandler -> CCharacterDataHandler
wrapCharacterDataHandler handler = h where
  h ptr cdata len = do
    data_ <- peekByteStringLen (cdata, fromIntegral len)
    handler data_

-- |Attach an CharacterDataHandler to a Parser.
setCharacterDataHandler :: Parser -> CharacterDataHandler -> IO ()
setCharacterDataHandler parser@(Parser _ _ _ charRef) handler = do
  withParser parser $ \p -> do
  writeIORef charRef $ wrapCharacterDataHandler handler

pairwise (x1:x2:xs) = (x1,x2) : pairwise xs
pairwise []         = []

peekByteString :: CString -> IO BS.ByteString
{-# INLINE peekByteString #-}
peekByteString cstr = do
    len <- BSI.c_strlen cstr
    peekByteStringLen (castPtr cstr, len)

peekByteStringLen :: (CString, CSize) -> IO BS.ByteString
{-# INLINE peekByteStringLen #-}
peekByteStringLen (cstr, len) =
    BSI.create (fromIntegral len) $ \ptr ->
        BSI.memcpy ptr (castPtr cstr) len

-- hexpat, a Haskell wrapper for expat
-- Copyright (C) 2008 Evan Martin <martine@danga.com>

-- |This module wraps the Expat API directly with IO operations
-- everywhere.  Basic usage is:
--
-- (1) Make a new parser: 'newParser'.
--
-- (2) Set up callbacks on the parser: 'setStartElementHandler', etc.
--
-- (3) Feed data into the parser: 'parse' or 'parseChunk'.

module Text.XML.Expat.IO (
  -- ** Parser Setup
  Parser, newParser,

  -- ** Parsing
  parse, Encoding(..),

  -- ** Parser Callbacks
  StartElementHandler, EndElementHandler, CharacterDataHandler,
  setStartElementHandler, setEndElementHandler, setCharacterDataHandler,

  -- ** Lower-level Parsing Interface
  parseChunk,

  -- ** Helpers
  encodingToString
) where

import Control.Exception (bracket)
import C2HS
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BSL
import qualified Data.ByteString.Internal as BSI
import Data.IORef

#include <expat.h>

-- Expat functions start with "XML", but C2HS appears to ignore our "as"
-- definitions if they only differ from the symbol in case.  So we write out
-- XML_* in most cases anyway...  :(
{#context lib = "expat" prefix = "XML"#}

-- |Opaque parser type.
type ParserPtr = Ptr ()
data Parser = Parser
    (ForeignPtr ())
    (IORef CStartElementHandler)
    (IORef CEndElementHandler)
    (IORef CCharacterDataHandler)

withParser :: Parser -> (ParserPtr -> IO a) -> IO a
withParser (Parser fp _ _ _) = withForeignPtr fp

-- |Encoding types available for the document encoding.
data Encoding = ASCII | UTF8 | UTF16 | ISO88591
encodingToString :: Encoding -> String
encodingToString ASCII    = "US-ASCII"
encodingToString UTF8     = "UTF-8"
encodingToString UTF16    = "UTF-16"
encodingToString ISO88591 = "ISO-8859-1"

withOptEncoding :: Maybe Encoding -> (CString -> IO a) -> IO a
withOptEncoding Nothing    f = f nullPtr
withOptEncoding (Just enc) f = withCString (encodingToString enc) f

{#fun unsafe XML_ParserCreate as parserCreate
    {withOptEncoding* `Maybe Encoding'} -> `ParserPtr' id#}
foreign import ccall "&XML_ParserFree" parserFree :: FunPtr (ParserPtr -> IO ())

-- |Create a 'Parser'.  The encoding parameter, if provided, overrides the
-- document's encoding declaration.
newParser :: Maybe Encoding -> IO Parser
newParser enc = do
  ptr <- parserCreate enc
  fptr <- newForeignPtr parserFree ptr
  nullStartH <- newIORef nullCStartElementHandler
  nullEndH <- newIORef nullCEndElementHandler
  nullCharH <- newIORef nullCCharacterDataHandler
  return $ Parser fptr nullStartH nullEndH nullCharH

-- ByteString.useAsCStringLen is almost what we need, but C2HS wants a CInt
-- instead of an Int.
withBStringLen :: BS.ByteString -> ((CString, CInt) -> IO a) -> IO a
withBStringLen bs f = do
  BS.useAsCStringLen bs $ \(str, len) -> f (str, fromIntegral len)

unStatus :: CInt -> Bool
unStatus 0 = False
unStatus 1 = True
-- |@parseChunk data False@ feeds /strict/ ByteString data into a
-- 'Parser'.  The end of the data is indicated by passing @True@ for the
-- final parameter.  @parse@ returns @False@ on a parse error.
parseChunk :: Parser
              -> BS.ByteString
              -> Bool
              -> IO Bool
parseChunk parser@(Parser fp startRef endRef charRef) xml final = do
    bracket
        (do
            cStartH <- mkCStartElementHandler =<< readIORef startRef
            cEndH   <- mkCEndElementHandler =<< readIORef endRef
            cCharH  <- mkCCharacterDataHandler =<< readIORef charRef
            withParser parser $ \p -> do
                {#call unsafe XML_SetStartElementHandler as ^#}  p cStartH
                {#call unsafe XML_SetEndElementHandler as ^#}    p cEndH
                {#call unsafe XML_SetCharacterDataHandler as ^#} p cCharH
            return (cStartH, cEndH, cCharH))
        (\(cStartH, cEndH, cCharH) -> do
            freeHaskellFunPtr cStartH
            freeHaskellFunPtr cEndH
            freeHaskellFunPtr cCharH)
        (\_ -> doParseChunk parser xml final)

{#fun XML_Parse as doParseChunk
    {withParser* `Parser', withBStringLen* `BS.ByteString' &, `Bool'}
    -> `Bool' unStatus#}

-- |@parse data@ feeds /lazy/ bytestring data into a parser and returns
-- @True@ if there was no parse error.
parse :: Parser -> BSL.ByteString -> IO Bool
parse parser bs = feedChunk (BSL.toChunks bs) where
  feedChunk []      = return True
  feedChunk [chunk] = parseChunk parser chunk True
  feedChunk (c:cs)  = do ok <- parseChunk parser c False
                         if ok then feedChunk cs
                               else return False

-- |The type of the \"element started\" callback.  The first parameter is
-- the element name; the second are the (attribute, value) pairs.
type StartElementHandler  = BS.ByteString -> [(BS.ByteString,BS.ByteString)] -> IO ()
-- |The type of the \"element ended\" callback.  The parameter is
-- the element name.
type EndElementHandler    = BS.ByteString -> IO ()
-- |The type of the \"character data\" callback.  The parameter is
-- the character data processed.  This callback may be called more than once
-- while processing a single conceptual block of text.
type CharacterDataHandler = BS.ByteString -> IO ()

type CStartElementHandler = Ptr () -> CString -> Ptr CString -> IO ()
nullCStartElementHandler _ _ _ = return ()

foreign import ccall "wrapper"
  mkCStartElementHandler :: CStartElementHandler
                         -> IO (FunPtr CStartElementHandler)
wrapStartElementHandler :: StartElementHandler -> CStartElementHandler
wrapStartElementHandler handler = h where
  h ptr cname cattrs = do
    name <- peekByteString cname
    cattrlist <- peekArray0 nullPtr cattrs
    attrlist <- mapM peekByteString cattrlist
    handler name (pairwise attrlist)
-- |Attach a StartElementHandler to a Parser.
setStartElementHandler :: Parser -> StartElementHandler -> IO ()
setStartElementHandler parser@(Parser _ startRef _ _) handler = do
  withParser parser $ \p -> do
  writeIORef startRef $ wrapStartElementHandler handler

type CEndElementHandler = Ptr () -> CString -> IO ()
nullCEndElementHandler _ _ = return ()

foreign import ccall "wrapper"
  mkCEndElementHandler :: CEndElementHandler
                       -> IO (FunPtr CEndElementHandler)
wrapEndElementHandler :: EndElementHandler -> CEndElementHandler
wrapEndElementHandler handler = h where
  h ptr cname = do
    name <- peekByteString cname
    handler name

-- |Attach an EndElementHandler to a Parser.
setEndElementHandler :: Parser -> EndElementHandler -> IO ()
setEndElementHandler parser@(Parser _ _ endRef _) handler = do
  withParser parser $ \p -> do
  writeIORef endRef $ wrapEndElementHandler handler

type CCharacterDataHandler = Ptr () -> CString -> CInt -> IO ()
nullCCharacterDataHandler _ _ _ = return ()

foreign import ccall "wrapper"
  mkCCharacterDataHandler :: CCharacterDataHandler
                          -> IO (FunPtr CCharacterDataHandler)
wrapCharacterDataHandler :: CharacterDataHandler -> CCharacterDataHandler
wrapCharacterDataHandler handler = h where
  h ptr cdata len = do
    data_ <- peekByteStringLen (cdata, fromIntegral len)
    handler data_

-- |Attach an CharacterDataHandler to a Parser.
setCharacterDataHandler :: Parser -> CharacterDataHandler -> IO ()
setCharacterDataHandler parser@(Parser _ _ _ charRef) handler = do
  withParser parser $ \p -> do
  writeIORef charRef $ wrapCharacterDataHandler handler

pairwise (x1:x2:xs) = (x1,x2) : pairwise xs
pairwise []         = []

peekByteString :: CString -> IO BS.ByteString
{-# INLINE peekByteString #-}
peekByteString cstr = do
    len <- BSI.c_strlen cstr
    peekByteStringLen (castPtr cstr, len)

peekByteStringLen :: (CString, CSize) -> IO BS.ByteString
{-# INLINE peekByteStringLen #-}
peekByteStringLen (cstr, len) =
    BSI.create (fromIntegral len) $ \ptr ->
        BSI.memcpy ptr (castPtr cstr) len


export functions

export functions

module CuddExplicitDeref (
    bzero,
    bone,
    bvar,
    band,
    bor,
    bnand,
    bnor,
    bxor,
    bxnor,
    bnot,
    bite,
    bexists,
    bforall,
    deref,
    setVarMap,
    mapVars,
    DDNode,
    STDdManager,
    leq,
    CuddExplicitDeref.shift,
    ref,
    largestCube,
    makePrime,
    supportIndices,
    indicesToCube,
    computeCube,
    nodesToCube,
    readSize,
    satCube,
    compose,
    andAbstract,
    xorExistAbstract,
    leqUnless,
    equivDC,
    xeqy,
    debugCheck,
    checkKeys
    ) where

import Foreign hiding (void)
import Foreign.Ptr
import Foreign.C.Types
import Control.Monad.ST.Lazy
import Control.Monad

import CuddC
import CuddInternal hiding (deref)

newtype DDNode s u = DDNode {unDDNode :: Ptr CDdNode} deriving (Ord, Eq, Show)

arg0 :: (Ptr CDdManager -> IO (Ptr CDdNode)) -> STDdManager s u -> ST s (DDNode s u)
arg0 f (STDdManager m) = liftM DDNode $ unsafeIOToST $ f m

arg1 :: (Ptr CDdManager -> Ptr CDdNode -> IO (Ptr CDdNode)) -> STDdManager s u -> DDNode s u -> ST s (DDNode s u)
arg1 f (STDdManager m) (DDNode x) = liftM DDNode $ unsafeIOToST $ f m x

arg2 :: (Ptr CDdManager -> Ptr CDdNode -> Ptr CDdNode -> IO (Ptr CDdNode)) -> STDdManager s u -> DDNode s u -> DDNode s u -> ST s (DDNode s u)
arg2 f (STDdManager m) (DDNode x) (DDNode y) = liftM DDNode $ unsafeIOToST $ f m x y

arg3 :: (Ptr CDdManager -> Ptr CDdNode -> Ptr CDdNode -> Ptr CDdNode -> IO (Ptr CDdNode)) -> STDdManager s u -> DDNode s u -> DDNode s u -> DDNode s u  -> ST s (DDNode s u)
arg3 f (STDdManager m) (DDNode x) (DDNode y) (DDNode z) = liftM DDNode $ unsafeIOToST $ f m x y z

bzero (STDdManager m) = DDNode $ unsafePerformIO $ c_cuddReadLogicZero m
bone  (STDdManager m) = DDNode $ unsafePerformIO $ c_cuddReadOne m

band    = arg2 c_cuddBddAnd
bor     = arg2 c_cuddBddOr
bnand   = arg2 c_cuddBddNand
bnor    = arg2 c_cuddBddNor
bxor    = arg2 c_cuddBddXor
bxnor   = arg2 c_cuddBddXnor
bite    = arg3 c_cuddBddIte
bexists = arg2 c_cuddBddExistAbstract
bforall = arg2 c_cuddBddUnivAbstract

andAbstract      = arg3 c_cuddBddAndAbstract
xorExistAbstract = arg3 c_cuddBddXorExistAbstract

bnot (DDNode x) = DDNode $ unsafePerformIO $ c_cuddNot x
bvar (STDdManager m) i = liftM DDNode $ unsafeIOToST $ c_cuddBddIthVar m (fromIntegral i)

deref :: STDdManager s u -> DDNode s u -> ST s ()
deref (STDdManager m) (DDNode x) = unsafeIOToST $ c_cuddIterDerefBdd m x

setVarMap :: STDdManager s u -> [DDNode s u] -> [DDNode s u] -> ST s ()
setVarMap (STDdManager m) xs ys = unsafeIOToST $
    withArrayLen (map unDDNode xs) $ \xl xp ->
    withArrayLen (map unDDNode ys) $ \yl yp -> do
    when (xl /= yl) (error "setVarMap: lengths not equal")
    void $ c_cuddSetVarMap m xp yp (fromIntegral xl)

mapVars :: STDdManager s u -> DDNode s u -> ST s (DDNode s u)
mapVars (STDdManager m) (DDNode x) = liftM DDNode $ unsafeIOToST $ c_cuddBddVarMap m x

leq :: STDdManager s u -> DDNode s u -> DDNode s u -> ST s Bool
leq (STDdManager m) (DDNode x) (DDNode y) = liftM (==1) $ unsafeIOToST $ c_cuddBddLeq m x y

shift :: STDdManager s u -> [DDNode s u] -> [DDNode s u] -> DDNode s u -> ST s (DDNode s u)
shift (STDdManager m) nodesx nodesy (DDNode x) = unsafeIOToST $
    withArrayLen (map unDDNode nodesx) $ \lx xp ->
    withArrayLen (map unDDNode nodesy) $ \ly yp -> do
    when (lx /= ly) $ error "CuddExplicitDeref: shift: lengths not equal"
    res <- c_cuddBddSwapVariables m x xp yp (fromIntegral lx)
    return $ DDNode res

ref :: DDNode s u -> ST s ()
ref (DDNode x) = unsafeIOToST $ cuddRef x

largestCube :: STDdManager s u -> DDNode s u -> ST s (DDNode s u, Int)
largestCube (STDdManager m) (DDNode x) = unsafeIOToST $
    alloca $ \lp -> do
    res <- c_cuddLargestCube m x lp
    l <- peek lp
    return (DDNode res, fromIntegral l)

makePrime :: STDdManager s u -> DDNode s u -> DDNode s u -> ST s (DDNode s u)
makePrime = arg2 c_cuddBddMakePrime

supportIndices :: STDdManager s u -> DDNode s u -> ST s [Int]
supportIndices (STDdManager m) (DDNode x) = unsafeIOToST $
    alloca $ \arrp -> do
    sz <- c_cuddSupportIndices m x arrp
    aaddr <- peek arrp
    res <- peekArray (fromIntegral sz) aaddr
    return $ map fromIntegral res

indicesToCube :: STDdManager s u -> [Int] -> ST s (DDNode s u)
indicesToCube (STDdManager m) indices = unsafeIOToST $
    withArrayLen (map fromIntegral indices) $ \sz pt -> do
    res <- c_cuddIndicesToCube m pt (fromIntegral sz)
    return $ DDNode res

computeCube :: STDdManager s u -> [DDNode s u] -> [Bool] -> ST s (DDNode s u)
computeCube (STDdManager m) nodes phases = unsafeIOToST $
    withArrayLen (map unDDNode nodes) $ \szn ptn ->
    withArrayLen (map (fromIntegral . fromBool) phases) $ \szp ptp -> do
    when (szn /= szp) $ error "computeCube: lists are different lengths"
    res <- c_cuddBddComputeCube m ptn ptp (fromIntegral szn)
    return $ DDNode res

nodesToCube :: STDdManager s u -> [DDNode s u] -> ST s (DDNode s u)
nodesToCube (STDdManager m) nodes = unsafeIOToST $
    withArrayLen (map unDDNode nodes) $ \sz pt -> do
    res <- c_cuddBddComputeCube m pt nullPtr (fromIntegral sz)
    return $ DDNode res

readSize :: STDdManager s u -> ST s Int
readSize (STDdManager m) = liftM fromIntegral $ unsafeIOToST $ c_cuddReadSize m

satCube :: STDdManager s u -> DDNode s u -> ST s [Int]
satCube ma@(STDdManager m) (DDNode x) = unsafeIOToST $ do
    size <- liftM fromIntegral $ c_cuddReadSize m
    allocaArray size $ \resptr -> do
    c_cuddBddToCubeArray m x resptr
    res <- peekArray size resptr
    return $ map fromIntegral res

compose :: STDdManager s u -> DDNode s u -> DDNode s u -> Int -> ST s (DDNode s u)
compose (STDdManager m) (DDNode f) (DDNode g) v = liftM DDNode $ unsafeIOToST $ c_cuddBddCompose m f g (fromIntegral v)

arg3Bool :: (Ptr CDdManager -> Ptr CDdNode -> Ptr CDdNode -> Ptr CDdNode -> IO CInt) -> STDdManager s u -> DDNode s u -> DDNode s u -> DDNode s u  -> ST s Bool
arg3Bool f (STDdManager m) (DDNode x) (DDNode y) (DDNode z) = liftM (==1) $ unsafeIOToST $ f m x y z

leqUnless, equivDC :: STDdManager s u -> DDNode s u -> DDNode s u -> DDNode s u -> ST s Bool
leqUnless = arg3Bool c_cuddBddLeqUnless
equivDC   = arg3Bool c_cuddEquivDC

xeqy :: STDdManager s u -> [DDNode s u] -> [DDNode s u] -> ST s (DDNode s u)
xeqy (STDdManager m) xs ys = unsafeIOToST $
    withArrayLen (map unDDNode xs) $ \xl xp ->
    withArrayLen (map unDDNode ys) $ \yl yp -> do
    when (xl /= yl) (error "xeqy: lengths not equal")
    res <- c_cuddXeqy m (fromIntegral xl) xp yp
    return $ DDNode res

debugCheck :: STDdManager s u -> ST s ()
debugCheck (STDdManager m) = unsafeIOToST $ c_cuddDebugCheck m

checkKeys :: STDdManager s u -> ST s ()
checkKeys (STDdManager m) = unsafeIOToST $ c_cuddCheckKeys m

{-
refCount :: STDdManager s u -> STDdNode s u -> ST s (DdNode s u)

unRefCount :: STDdManager s u -> DdNode s u -> ST s (STDdNode s u)
-}

module CuddExplicitDeref (
    bzero,
    bone,
    bvar,
    band,
    bor,
    bnand,
    bnor,
    bxor,
    bxnor,
    bnot,
    bite,
    bexists,
    bforall,
    deref,
    setVarMap,
    mapVars,
    DDNode,
    STDdManager,
    leq,
    CuddExplicitDeref.shift,
    ref,
    largestCube,
    makePrime,
    supportIndices,
    indicesToCube,
    computeCube,
    nodesToCube,
    readSize,
    satCube,
    compose,
    andAbstract,
    xorExistAbstract,
    leqUnless,
    equivDC,
    xeqy
    ) where

import Foreign hiding (void)
import Foreign.Ptr
import Foreign.C.Types
import Control.Monad.ST.Lazy
import Control.Monad

import CuddC
import CuddInternal hiding (deref)

newtype DDNode s u = DDNode {unDDNode :: Ptr CDdNode} deriving (Ord, Eq, Show)

arg0 :: (Ptr CDdManager -> IO (Ptr CDdNode)) -> STDdManager s u -> ST s (DDNode s u)
arg0 f (STDdManager m) = liftM DDNode $ unsafeIOToST $ f m

arg1 :: (Ptr CDdManager -> Ptr CDdNode -> IO (Ptr CDdNode)) -> STDdManager s u -> DDNode s u -> ST s (DDNode s u)
arg1 f (STDdManager m) (DDNode x) = liftM DDNode $ unsafeIOToST $ f m x

arg2 :: (Ptr CDdManager -> Ptr CDdNode -> Ptr CDdNode -> IO (Ptr CDdNode)) -> STDdManager s u -> DDNode s u -> DDNode s u -> ST s (DDNode s u)
arg2 f (STDdManager m) (DDNode x) (DDNode y) = liftM DDNode $ unsafeIOToST $ f m x y

arg3 :: (Ptr CDdManager -> Ptr CDdNode -> Ptr CDdNode -> Ptr CDdNode -> IO (Ptr CDdNode)) -> STDdManager s u -> DDNode s u -> DDNode s u -> DDNode s u  -> ST s (DDNode s u)
arg3 f (STDdManager m) (DDNode x) (DDNode y) (DDNode z) = liftM DDNode $ unsafeIOToST $ f m x y z

bzero (STDdManager m) = DDNode $ unsafePerformIO $ c_cuddReadLogicZero m
bone  (STDdManager m) = DDNode $ unsafePerformIO $ c_cuddReadOne m

band    = arg2 c_cuddBddAnd
bor     = arg2 c_cuddBddOr
bnand   = arg2 c_cuddBddNand
bnor    = arg2 c_cuddBddNor
bxor    = arg2 c_cuddBddXor
bxnor   = arg2 c_cuddBddXnor
bite    = arg3 c_cuddBddIte
bexists = arg2 c_cuddBddExistAbstract
bforall = arg2 c_cuddBddUnivAbstract

andAbstract      = arg3 c_cuddBddAndAbstract
xorExistAbstract = arg3 c_cuddBddXorExistAbstract

bnot (DDNode x) = DDNode $ unsafePerformIO $ c_cuddNot x
bvar (STDdManager m) i = liftM DDNode $ unsafeIOToST $ c_cuddBddIthVar m (fromIntegral i)

deref :: STDdManager s u -> DDNode s u -> ST s ()
deref (STDdManager m) (DDNode x) = unsafeIOToST $ c_cuddIterDerefBdd m x

setVarMap :: STDdManager s u -> [DDNode s u] -> [DDNode s u] -> ST s ()
setVarMap (STDdManager m) xs ys = unsafeIOToST $
    withArrayLen (map unDDNode xs) $ \xl xp ->
    withArrayLen (map unDDNode ys) $ \yl yp -> do
    when (xl /= yl) (error "setVarMap: lengths not equal")
    void $ c_cuddSetVarMap m xp yp (fromIntegral xl)

mapVars :: STDdManager s u -> DDNode s u -> ST s (DDNode s u)
mapVars (STDdManager m) (DDNode x) = liftM DDNode $ unsafeIOToST $ c_cuddBddVarMap m x

leq :: STDdManager s u -> DDNode s u -> DDNode s u -> ST s Bool
leq (STDdManager m) (DDNode x) (DDNode y) = liftM (==1) $ unsafeIOToST $ c_cuddBddLeq m x y

shift :: STDdManager s u -> [DDNode s u] -> [DDNode s u] -> DDNode s u -> ST s (DDNode s u)
shift (STDdManager m) nodesx nodesy (DDNode x) = unsafeIOToST $
    withArrayLen (map unDDNode nodesx) $ \lx xp ->
    withArrayLen (map unDDNode nodesy) $ \ly yp -> do
    when (lx /= ly) $ error "CuddExplicitDeref: shift: lengths not equal"
    res <- c_cuddBddSwapVariables m x xp yp (fromIntegral lx)
    return $ DDNode res

ref :: DDNode s u -> ST s ()
ref (DDNode x) = unsafeIOToST $ cuddRef x

largestCube :: STDdManager s u -> DDNode s u -> ST s (DDNode s u, Int)
largestCube (STDdManager m) (DDNode x) = unsafeIOToST $
    alloca $ \lp -> do
    res <- c_cuddLargestCube m x lp
    l <- peek lp
    return (DDNode res, fromIntegral l)

makePrime :: STDdManager s u -> DDNode s u -> DDNode s u -> ST s (DDNode s u)
makePrime = arg2 c_cuddBddMakePrime

supportIndices :: STDdManager s u -> DDNode s u -> ST s [Int]
supportIndices (STDdManager m) (DDNode x) = unsafeIOToST $
    alloca $ \arrp -> do
    sz <- c_cuddSupportIndices m x arrp
    aaddr <- peek arrp
    res <- peekArray (fromIntegral sz) aaddr
    return $ map fromIntegral res

indicesToCube :: STDdManager s u -> [Int] -> ST s (DDNode s u)
indicesToCube (STDdManager m) indices = unsafeIOToST $
    withArrayLen (map fromIntegral indices) $ \sz pt -> do
    res <- c_cuddIndicesToCube m pt (fromIntegral sz)
    return $ DDNode res

computeCube :: STDdManager s u -> [DDNode s u] -> [Bool] -> ST s (DDNode s u)
computeCube (STDdManager m) nodes phases = unsafeIOToST $
    withArrayLen (map unDDNode nodes) $ \szn ptn ->
    withArrayLen (map (fromIntegral . fromBool) phases) $ \szp ptp -> do
    when (szn /= szp) $ error "computeCube: lists are different lengths"
    res <- c_cuddBddComputeCube m ptn ptp (fromIntegral szn)
    return $ DDNode res

nodesToCube :: STDdManager s u -> [DDNode s u] -> ST s (DDNode s u)
nodesToCube (STDdManager m) nodes = unsafeIOToST $
    withArrayLen (map unDDNode nodes) $ \sz pt -> do
    res <- c_cuddBddComputeCube m pt nullPtr (fromIntegral sz)
    return $ DDNode res

readSize :: STDdManager s u -> ST s Int
readSize (STDdManager m) = liftM fromIntegral $ unsafeIOToST $ c_cuddReadSize m

satCube :: STDdManager s u -> DDNode s u -> ST s [Int]
satCube ma@(STDdManager m) (DDNode x) = unsafeIOToST $ do
    size <- liftM fromIntegral $ c_cuddReadSize m
    allocaArray size $ \resptr -> do
    c_cuddBddToCubeArray m x resptr
    res <- peekArray size resptr
    return $ map fromIntegral res

compose :: STDdManager s u -> DDNode s u -> DDNode s u -> Int -> ST s (DDNode s u)
compose (STDdManager m) (DDNode f) (DDNode g) v = liftM DDNode $ unsafeIOToST $ c_cuddBddCompose m f g (fromIntegral v)

arg3Bool :: (Ptr CDdManager -> Ptr CDdNode -> Ptr CDdNode -> Ptr CDdNode -> IO CInt) -> STDdManager s u -> DDNode s u -> DDNode s u -> DDNode s u  -> ST s Bool
arg3Bool f (STDdManager m) (DDNode x) (DDNode y) (DDNode z) = liftM (==1) $ unsafeIOToST $ f m x y z

leqUnless, equivDC :: STDdManager s u -> DDNode s u -> DDNode s u -> DDNode s u -> ST s Bool
leqUnless = arg3Bool c_cuddBddLeqUnless
equivDC   = arg3Bool c_cuddEquivDC

xeqy :: STDdManager s u -> [DDNode s u] -> [DDNode s u] -> ST s (DDNode s u)
xeqy (STDdManager m) xs ys = unsafeIOToST $
    withArrayLen (map unDDNode xs) $ \xl xp ->
    withArrayLen (map unDDNode ys) $ \yl yp -> do
    when (xl /= yl) (error "xeqy: lengths not equal")
    res <- c_cuddXeqy m (fromIntegral xl) xp yp
    return $ DDNode res

debugCheck :: STDdManager s u -> ST s ()
debugCheck (STDdManager m) = unsafeIOToST $ c_cuddDebugCheck m

checkKeys :: STDdManager s u -> ST s ()
checkKeys (STDdManager m) = unsafeIOToST $ c_cuddCheckKeys m

{-
refCount :: STDdManager s u -> STDdNode s u -> ST s (DdNode s u)

unRefCount :: STDdManager s u -> DdNode s u -> ST s (STDdNode s u)
-}