gio: S.G.File: specify module exports

gio: S.G.File: specify module exports

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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


fixed import

fixed import

{-# 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

{-# 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


Image Format struct

Image Format struct

-- -----------------------------------------------------------------------------
-- This file is part of Haskell-Opencl.

-- Haskell-Opencl is free software: you can redistribute it and/or modify
-- it under the terms of the GNU General Public License as published by
-- the Free Software Foundation, either version 3 of the License, or
-- (at your option) any later version.

-- Haskell-Opencl is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-- GNU General Public License for more details.

-- You should have received a copy of the GNU General Public License
-- along with Haskell-Opencl.  If not, see <http://www.gnu.org/licenses/>.
-- -----------------------------------------------------------------------------
module System.GPU.OpenCL.Types(
  ErrorCode(..), CLbool, CLint, CLuint, CLulong, CLPlatformInfo_, CLMem,
  CLProgram, CLEvent,
  CLDeviceType_, CLDeviceInfo_, CLContextInfo_, CLDeviceFPConfig(..),
  CLDeviceMemCacheType(..), CLDeviceExecCapability(..), CLDeviceLocalMemType(..),
  CLPlatformID, CLDeviceID, CLContext, CLCommandQueue, CLContextProperty_,
  CLDeviceType(..), CLCommandQueueProperty(..), CLCommandQueueInfo_,
  CLEventInfo_, CLProfilingInfo_, CLCommandType(..), CLCommandType_,
  CLCommandExecutionStatus(..), CLProfilingInfo(..), getProfilingInfoValue,
  CLCommandQueueProperty_, CLMemFlags_, CLImageFormat_p, CLMemObjectType_,
  CLMemInfo_, CLImageInfo_, CLImageFormat(..), getImageFormat, getDeviceTypeValue,
  getDeviceLocalMemType, getDeviceMemCacheType, getCommandType,
  getCommandExecutionStatus, bitmaskToDeviceTypes, bitmaskFromDeviceTypes,
  bitmaskToCommandQueueProperties, bitmaskFromCommandQueueProperties,
  bitmaskToFPConfig, bitmaskToExecCapability )
       where

-- -----------------------------------------------------------------------------
import Foreign
import Foreign.C.Types
import Data.List( foldl' )

#include <CL/cl.h>

-- -----------------------------------------------------------------------------

type CLPlatformID = {#type cl_platform_id#}
type CLDeviceID = {#type cl_device_id#}
type CLContext = {#type cl_context#}
type CLCommandQueue = {#type cl_command_queue#}
type CLMem = {#type cl_mem#}
type CLEvent = {#type cl_event#}
type CLProgram = {#type cl_program#}

type CLint = {#type cl_int#}
type CLuint = {#type cl_uint#}
type CLulong = {#type cl_ulong#}
type CLbool = {#type cl_bool#}

type CLPlatformInfo_ = {#type cl_platform_info#}
type CLDeviceType_ = {#type cl_device_type#}
type CLDeviceInfo_ = {#type cl_device_info#}
type CLDeviceFPConfig_ = {#type cl_device_fp_config#}
type CLDeviceMemCacheType_ = {#type cl_device_mem_cache_type#}
type CLDeviceLocalMemType_ = {#type cl_device_local_mem_type#}
type CLDeviceExecCapability_ = {#type cl_device_exec_capabilities#}
type CLContextInfo_ = {#type cl_context_info#}
type CLContextProperty_ = {#type cl_context_properties#}
type CLCommandQueueInfo_ = {#type cl_command_queue_info#}
type CLCommandQueueProperty_ = {#type cl_command_queue_properties#}
type CLEventInfo_ = {#type cl_event_info#}
type CLProfilingInfo_ = {#type cl_profiling_info#}
type CLCommandType_ = {#type cl_command_type#}
type CLMemFlags_ = {#type cl_mem_flags#}
type CLMemObjectType_ = {#type cl_mem_object_type#}
type CLMemInfo_ = {#type cl_mem_info#}
type CLImageInfo_ = {#type cl_image_info#}
{#pointer *cl_image_format as CLImageFormat_p#}

type CLImageChannelOrder_ = {#type cl_channel_order#}
type CLImageChannelDataType_ = {#type cl_channel_type#}

newtype ErrorCode = ErrorCode CInt deriving( Eq )

-- -----------------------------------------------------------------------------
#c
enum CLDeviceType {
CLDEVICE_TYPE_CPU=CL_DEVICE_TYPE_CPU,
CLDEVICE_TYPE_GPU=CL_DEVICE_TYPE_GPU,
CLDEVICE_TYPE_ACCELERATOR=CL_DEVICE_TYPE_ACCELERATOR,
CLDEVICE_TYPE_DEFAULT=CL_DEVICE_TYPE_DEFAULT,
CLDEVICE_TYPE_ALL=CL_DEVICE_TYPE_ALL
  };
#endc

{-|
 * 'CLDEVICE_TYPE_CPU', An OpenCL device that is the host processor. The host processor runs the OpenCL implementations and is a single or multi-core CPU.

 * 'CLDEVICE_TYPE_GPU', An OpenCL device that is a GPU. By this we mean that the device can also be used to accelerate a 3D API such as OpenGL or DirectX.

 * 'CLDEVICE_TYPE_ACCELERATOR', Dedicated OpenCL accelerators (for example the IBM CELL Blade). These devices communicate with the host processor using a peripheral interconnect such as PCIe.

 * 'CLDEVICE_TYPE_DEFAULT', The default OpenCL device in the system.

 * 'CLDEVICE_TYPE_ALL', All OpenCL devices available in the system.
-}
{#enum CLDeviceType {} deriving( Show ) #}

getDeviceTypeValue :: CLDeviceType -> CLDeviceType_
getDeviceTypeValue = fromIntegral . fromEnum

#c
enum CLCommandQueueProperty {
  CLQUEUE_OUT_OF_ORDER_EXEC_MODE_ENABLE=CL_QUEUE_OUT_OF_ORDER_EXEC_MODE_ENABLE,
  CLQUEUE_PROFILING_ENABLE=CL_QUEUE_PROFILING_ENABLE
  };
#endc

{-|
 * 'CLQUEUE_OUT_OF_ORDER_EXEC_MODE_ENABLE', Determines whether the commands
queued in the command-queue are executed in-order or out-of-order. If set, the
commands in the command-queue are executed out-of-order. Otherwise, commands are
executed in-order.

 * 'CLQUEUE_PROFILING_ENABLE', Enable or disable profiling of commands in the
command-queue. If set, the profiling of commands is enabled. Otherwise profiling
of commands is disabled. See 'clGetEventProfilingInfo' for more information.
-}
{#enum CLCommandQueueProperty {} deriving( Show, Bounded, Eq, Ord ) #}

#c
enum CLDeviceFPConfig {
  CLFP_DENORM=CL_FP_DENORM, CLFP_INF_NAN=CL_FP_INF_NAN,
  CLFP_ROUND_TO_NEAREST=CL_FP_ROUND_TO_NEAREST,
  CLFP_ROUND_TO_ZERO=CL_FP_ROUND_TO_ZERO,
  CLFP_ROUND_TO_INF=CL_FP_ROUND_TO_INF, CLFP_FMA=CL_FP_FMA,
  };
#endc

{-|
 * 'CLFP_DENORM', denorms are supported.

 * 'CLFP_INF_NAN', INF and NaNs are supported.

 * 'CLFP_ROUND_TO_NEAREST', round to nearest even rounding mode supported.

 * 'CLFP_ROUND_TO_ZERO', round to zero rounding mode supported.

 * 'CLFP_ROUND_TO_INF', round to +ve and -ve infinity rounding modes supported.

 * 'CLFP_FMA', IEEE754-2008 fused multiply-add is supported.
-}
{#enum CLDeviceFPConfig {} deriving( Show, Bounded, Eq, Ord ) #}

#c
enum CLDeviceExecCapability {
  CLEXEC_KERNEL=CL_EXEC_KERNEL,
  CLEXEC_NATIVE_KERNEL=CL_EXEC_NATIVE_KERNEL
  };
#endc

{-|
 * 'CLEXEC_KERNEL', The OpenCL device can execute OpenCL kernels.

 * 'CLEXEC_NATIVE_KERNEL', The OpenCL device can execute native kernels.
-}
{#enum CLDeviceExecCapability {} deriving( Show, Bounded, Eq, Ord ) #}

#c
enum CLDeviceMemCacheType {
  CLNONE=CL_NONE,CLREAD_ONLY_CACHE=CL_READ_ONLY_CACHE,
  CLREAD_WRITE_CACHE=CL_READ_WRITE_CACHE
  };
#endc

{#enum CLDeviceMemCacheType {} deriving( Show ) #}

getDeviceMemCacheType :: CLDeviceMemCacheType_ -> Maybe CLDeviceMemCacheType
getDeviceMemCacheType = Just . toEnum . fromIntegral

#c
enum CLDeviceLocalMemType {
  CLLOCAL=CL_LOCAL, CLGLOBAL=CL_GLOBAL
  };
#endc

{#enum CLDeviceLocalMemType {} deriving( Show ) #}

getDeviceLocalMemType :: CLDeviceLocalMemType_ -> Maybe CLDeviceLocalMemType
getDeviceLocalMemType = Just . toEnum . fromIntegral

#c
enum CLCommandType {
  CLCOMMAND_NDRANGE_KERNEL=CL_COMMAND_NDRANGE_KERNEL,
  CLCOMMAND_TASK=CL_COMMAND_TASK ,
  CLCOMMAND_NATIVE_KERNEL=CL_COMMAND_NATIVE_KERNEL,
  CLCOMMAND_READ_BUFFER=CL_COMMAND_READ_BUFFER,
  CLCOMMAND_WRITE_BUFFER=CL_COMMAND_WRITE_BUFFER,
  CLCOMMAND_COPY_BUFFER=CL_COMMAND_COPY_BUFFER,
  CLCOMMAND_READ_IMAGE=CL_COMMAND_READ_IMAGE,
  CLCOMMAND_WRITE_IMAGE=CL_COMMAND_WRITE_IMAGE,
  CLCOMMAND_COPY_IMAGE=CL_COMMAND_COPY_IMAGE,
  CLCOMMAND_COPY_BUFFER_TO_IMAGE=CL_COMMAND_COPY_BUFFER_TO_IMAGE,
  CLCOMMAND_COPY_IMAGE_TO_BUFFER=CL_COMMAND_COPY_IMAGE_TO_BUFFER,
  CLCOMMAND_MAP_BUFFER=CL_COMMAND_MAP_BUFFER,
  CLCOMMAND_MAP_IMAGE=CL_COMMAND_MAP_IMAGE,
  CLCOMMAND_UNMAP_MEM_OBJECT=CL_COMMAND_UNMAP_MEM_OBJECT,
  CLCOMMAND_MARKER=CL_COMMAND_MARKER,
  CLCOMMAND_ACQUIRE_GL_OBJECTS=CL_COMMAND_ACQUIRE_GL_OBJECTS,
  CLCOMMAND_RELEASE_GL_OBJECTS=CL_COMMAND_RELEASE_GL_OBJECTS
  };
#endc

-- | Command associated with an event.
{#enum CLCommandType {} deriving( Show ) #}

getCommandType :: CLCommandType_ -> Maybe CLCommandType
getCommandType = Just . toEnum . fromIntegral

#c
enum CLCommandExecutionStatus {
  CLQUEUED=CL_QUEUED, CLSUBMITTED=CL_SUBMITTED, CLRUNNING=CL_RUNNING,
  CLCOMPLETE=CL_COMPLETE, CLEXEC_ERROR= -1
  };
#endc

{-|
 * 'CLQUEUED', command has been enqueued in the command-queue.

 * 'CLSUBMITTED', enqueued command has been submitted by the host to the
device associated with the command-queue.

 * 'CLRUNNING', device is currently executing this command.

 * 'CLCOMPLETE', the command has completed.

 * 'CLEXEC_ERROR', command was abnormally terminated.
-}
{#enum CLCommandExecutionStatus {} deriving( Show ) #}

getCommandExecutionStatus :: CLint -> Maybe CLCommandExecutionStatus
getCommandExecutionStatus n
  | n < 0 = Just CLEXEC_ERROR
  | otherwise = Just . toEnum . fromIntegral $ n

#c
enum CLProfilingInfo {
  CLPROFILING_COMMAND_QUEUED=CL_PROFILING_COMMAND_QUEUED,
  CLPROFILING_COMMAND_SUBMIT=CL_PROFILING_COMMAND_SUBMIT,
  CLPROFILING_COMMAND_START=CL_PROFILING_COMMAND_START,
  CLPROFILING_COMMAND_END=CL_PROFILING_COMMAND_END
  };
#endc

{-| Specifies the profiling data.

 * 'CLPROFILING_COMMAND_QUEUED', A 64-bit value that describes the current
device time counter in nanoseconds when the command identified by event is
enqueued in a command-queue by the host.

 * 'CLPROFILING_COMMAND_SUBMIT', A 64-bit value that describes the current
device time counter in nanoseconds when the command identified by event that has
been enqueued is submitted by the host to the device associated with the
commandqueue.

 * 'CLPROFILING_COMMAND_START',	 A 64-bit value that describes the current
device time counter in nanoseconds when the command identified by event starts
execution on the device.

 * 'CLPROFILING_COMMAND_END', A 64-bit value that describes the current device
time counter in nanoseconds when the command identified by event has finished
execution on the device.
-}
{#enum CLProfilingInfo {} deriving( Show ) #}

getProfilingInfoValue :: CLProfilingInfo -> CLProfilingInfo_
getProfilingInfoValue = fromIntegral . fromEnum

-- -----------------------------------------------------------------------------
getImageChannelOrder :: CLImageFormat_p -> IO CLImageChannelOrder_
getImageChannelOrder = {#get cl_image_format->image_channel_order#}

getImageChannelDataType :: CLImageFormat_p -> IO CLImageChannelDataType_
getImageChannelDataType = {#get cl_image_format->image_channel_data_type#}

data CLImageFormat = CLImageFormat {
  image_channel_order :: CLImageChannelOrder_,
  image_channel_data_type :: CLImageChannelDataType_
  } deriving( Show )

getImageFormat :: CLImageFormat_p -> IO CLImageFormat
getImageFormat p = do
  order <- getImageChannelOrder p
  datatype <- getImageChannelDataType p
  return $ CLImageFormat order datatype

-- -----------------------------------------------------------------------------
binaryFlags :: (Ord b, Enum b, Bounded b) => b -> [b]
binaryFlags m = map toEnum . takeWhile (<= (fromEnum m)) $ [1 `shiftL` n | n <- [0..]]

testMask :: Bits b => b -> b -> Bool
testMask mask v = (v .&. mask) == v

bitmaskToDeviceTypes :: CLDeviceType_ -> [CLDeviceType]
bitmaskToDeviceTypes mask = filter (testMask mask . fromIntegral . fromEnum) $ [CLDEVICE_TYPE_CPU,CLDEVICE_TYPE_GPU,CLDEVICE_TYPE_ACCELERATOR,CLDEVICE_TYPE_DEFAULT,CLDEVICE_TYPE_ALL]

bitmaskFromDeviceTypes :: [CLDeviceType] -> CLDeviceType_
bitmaskFromDeviceTypes = foldl' (.|.) 0 . map (fromIntegral . fromEnum)

bitmaskToCommandQueueProperties :: CLCommandQueueProperty_ -> [CLCommandQueueProperty]
bitmaskToCommandQueueProperties mask = filter (testMask mask . fromIntegral . fromEnum) $ binaryFlags maxBound

bitmaskFromCommandQueueProperties :: [CLCommandQueueProperty] -> CLCommandQueueProperty_
bitmaskFromCommandQueueProperties = foldl' (.|.) 0 . map (fromIntegral.fromEnum)

bitmaskToFPConfig :: CLDeviceFPConfig_ -> [CLDeviceFPConfig]
bitmaskToFPConfig mask = filter (testMask mask . fromIntegral . fromEnum) $ binaryFlags maxBound

bitmaskToExecCapability :: CLDeviceExecCapability_ -> [CLDeviceExecCapability]
bitmaskToExecCapability mask = filter (testMask mask . fromIntegral . fromEnum) $ binaryFlags maxBound

-- -----------------------------------------------------------------------------

-- -----------------------------------------------------------------------------
-- This file is part of Haskell-Opencl.

-- Haskell-Opencl is free software: you can redistribute it and/or modify
-- it under the terms of the GNU General Public License as published by
-- the Free Software Foundation, either version 3 of the License, or
-- (at your option) any later version.

-- Haskell-Opencl is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-- GNU General Public License for more details.

-- You should have received a copy of the GNU General Public License
-- along with Haskell-Opencl.  If not, see <http://www.gnu.org/licenses/>.
-- -----------------------------------------------------------------------------
module System.GPU.OpenCL.Types(
  ErrorCode(..), CLbool, CLint, CLuint, CLulong, CLPlatformInfo_, CLMem,
  CLProgram, CLEvent,
  CLDeviceType_, CLDeviceInfo_, CLContextInfo_, CLDeviceFPConfig(..),
  CLDeviceMemCacheType(..), CLDeviceExecCapability(..), CLDeviceLocalMemType(..),
  CLPlatformID, CLDeviceID, CLContext, CLCommandQueue, CLContextProperty_,
  CLDeviceType(..), CLCommandQueueProperty(..), CLCommandQueueInfo_,
  CLEventInfo_, CLProfilingInfo_, CLCommandType(..), CLCommandType_,
  CLCommandExecutionStatus(..), CLProfilingInfo(..), getProfilingInfoValue,
  CLCommandQueueProperty_, CLMemFlags_, CLImageFormat_p, CLMemObjectType_,
  CLMemInfo_, CLImageInfo_, getDeviceTypeValue, getDeviceLocalMemType,
  getDeviceMemCacheType, getCommandType, getCommandExecutionStatus,
  bitmaskToDeviceTypes, bitmaskFromDeviceTypes, bitmaskToCommandQueueProperties,
  bitmaskFromCommandQueueProperties, bitmaskToFPConfig, bitmaskToExecCapability )
       where

-- -----------------------------------------------------------------------------
import Foreign( Ptr )
import Foreign.C.Types
import Data.List( foldl' )
import Data.Bits( Bits, shiftL, (.|.), (.&.) )

#include <CL/cl.h>

-- -----------------------------------------------------------------------------

type CLPlatformID = {#type cl_platform_id#}
type CLDeviceID = {#type cl_device_id#}
type CLContext = {#type cl_context#}
type CLCommandQueue = {#type cl_command_queue#}
type CLMem = {#type cl_mem#}
type CLEvent = {#type cl_event#}
type CLProgram = {#type cl_program#}

type CLint = {#type cl_int#}
type CLuint = {#type cl_uint#}
type CLulong = {#type cl_ulong#}
type CLbool = {#type cl_bool#}

type CLPlatformInfo_ = {#type cl_platform_info#}
type CLDeviceType_ = {#type cl_device_type#}
type CLDeviceInfo_ = {#type cl_device_info#}
type CLDeviceFPConfig_ = {#type cl_device_fp_config#}
type CLDeviceMemCacheType_ = {#type cl_device_mem_cache_type#}
type CLDeviceLocalMemType_ = {#type cl_device_local_mem_type#}
type CLDeviceExecCapability_ = {#type cl_device_exec_capabilities#}
type CLContextInfo_ = {#type cl_context_info#}
type CLContextProperty_ = {#type cl_context_properties#}
type CLCommandQueueInfo_ = {#type cl_command_queue_info#}
type CLCommandQueueProperty_ = {#type cl_command_queue_properties#}
type CLEventInfo_ = {#type cl_event_info#}
type CLProfilingInfo_ = {#type cl_profiling_info#}
type CLCommandType_ = {#type cl_command_type#}
type CLMemFlags_ = {#type cl_mem_flags#}
type CLMemObjectType_ = {#type cl_mem_object_type#}
type CLMemInfo_ = {#type cl_mem_info#}
type CLImageInfo_ = {#type cl_image_info#}
{#pointer *cl_image_format as CLImageFormat_p#}

type CLImageChannelOrder_ = {#type cl_channel_order#}
type CLImageChannelDataType_ = {#type cl_channel_type#}

newtype ErrorCode = ErrorCode CInt deriving( Eq )

-- -----------------------------------------------------------------------------
#c
enum CLDeviceType {
CLDEVICE_TYPE_CPU=CL_DEVICE_TYPE_CPU,
CLDEVICE_TYPE_GPU=CL_DEVICE_TYPE_GPU,
CLDEVICE_TYPE_ACCELERATOR=CL_DEVICE_TYPE_ACCELERATOR,
CLDEVICE_TYPE_DEFAULT=CL_DEVICE_TYPE_DEFAULT,
CLDEVICE_TYPE_ALL=CL_DEVICE_TYPE_ALL
  };
#endc

{-|
 * 'CLDEVICE_TYPE_CPU', An OpenCL device that is the host processor. The host processor runs the OpenCL implementations and is a single or multi-core CPU.

 * 'CLDEVICE_TYPE_GPU', An OpenCL device that is a GPU. By this we mean that the device can also be used to accelerate a 3D API such as OpenGL or DirectX.

 * 'CLDEVICE_TYPE_ACCELERATOR', Dedicated OpenCL accelerators (for example the IBM CELL Blade). These devices communicate with the host processor using a peripheral interconnect such as PCIe.

 * 'CLDEVICE_TYPE_DEFAULT', The default OpenCL device in the system.

 * 'CLDEVICE_TYPE_ALL', All OpenCL devices available in the system.
-}
{#enum CLDeviceType {} deriving( Show ) #}

getDeviceTypeValue :: CLDeviceType -> CLDeviceType_
getDeviceTypeValue = fromIntegral . fromEnum

#c
enum CLCommandQueueProperty {
  CLQUEUE_OUT_OF_ORDER_EXEC_MODE_ENABLE=CL_QUEUE_OUT_OF_ORDER_EXEC_MODE_ENABLE,
  CLQUEUE_PROFILING_ENABLE=CL_QUEUE_PROFILING_ENABLE
  };
#endc

{-|
 * 'CLQUEUE_OUT_OF_ORDER_EXEC_MODE_ENABLE', Determines whether the commands
queued in the command-queue are executed in-order or out-of-order. If set, the
commands in the command-queue are executed out-of-order. Otherwise, commands are
executed in-order.

 * 'CLQUEUE_PROFILING_ENABLE', Enable or disable profiling of commands in the
command-queue. If set, the profiling of commands is enabled. Otherwise profiling
of commands is disabled. See 'clGetEventProfilingInfo' for more information.
-}
{#enum CLCommandQueueProperty {} deriving( Show, Bounded, Eq, Ord ) #}

#c
enum CLDeviceFPConfig {
  CLFP_DENORM=CL_FP_DENORM, CLFP_INF_NAN=CL_FP_INF_NAN,
  CLFP_ROUND_TO_NEAREST=CL_FP_ROUND_TO_NEAREST,
  CLFP_ROUND_TO_ZERO=CL_FP_ROUND_TO_ZERO,
  CLFP_ROUND_TO_INF=CL_FP_ROUND_TO_INF, CLFP_FMA=CL_FP_FMA,
  };
#endc

{-|
 * 'CLFP_DENORM', denorms are supported.

 * 'CLFP_INF_NAN', INF and NaNs are supported.

 * 'CLFP_ROUND_TO_NEAREST', round to nearest even rounding mode supported.

 * 'CLFP_ROUND_TO_ZERO', round to zero rounding mode supported.

 * 'CLFP_ROUND_TO_INF', round to +ve and -ve infinity rounding modes supported.

 * 'CLFP_FMA', IEEE754-2008 fused multiply-add is supported.
-}
{#enum CLDeviceFPConfig {} deriving( Show, Bounded, Eq, Ord ) #}

#c
enum CLDeviceExecCapability {
  CLEXEC_KERNEL=CL_EXEC_KERNEL,
  CLEXEC_NATIVE_KERNEL=CL_EXEC_NATIVE_KERNEL
  };
#endc

{-|
 * 'CLEXEC_KERNEL', The OpenCL device can execute OpenCL kernels.

 * 'CLEXEC_NATIVE_KERNEL', The OpenCL device can execute native kernels.
-}
{#enum CLDeviceExecCapability {} deriving( Show, Bounded, Eq, Ord ) #}

#c
enum CLDeviceMemCacheType {
  CLNONE=CL_NONE,CLREAD_ONLY_CACHE=CL_READ_ONLY_CACHE,
  CLREAD_WRITE_CACHE=CL_READ_WRITE_CACHE
  };
#endc

{#enum CLDeviceMemCacheType {} deriving( Show ) #}

getDeviceMemCacheType :: CLDeviceMemCacheType_ -> Maybe CLDeviceMemCacheType
getDeviceMemCacheType = Just . toEnum . fromIntegral

#c
enum CLDeviceLocalMemType {
  CLLOCAL=CL_LOCAL, CLGLOBAL=CL_GLOBAL
  };
#endc

{#enum CLDeviceLocalMemType {} deriving( Show ) #}

getDeviceLocalMemType :: CLDeviceLocalMemType_ -> Maybe CLDeviceLocalMemType
getDeviceLocalMemType = Just . toEnum . fromIntegral

#c
enum CLCommandType {
  CLCOMMAND_NDRANGE_KERNEL=CL_COMMAND_NDRANGE_KERNEL,
  CLCOMMAND_TASK=CL_COMMAND_TASK ,
  CLCOMMAND_NATIVE_KERNEL=CL_COMMAND_NATIVE_KERNEL,
  CLCOMMAND_READ_BUFFER=CL_COMMAND_READ_BUFFER,
  CLCOMMAND_WRITE_BUFFER=CL_COMMAND_WRITE_BUFFER,
  CLCOMMAND_COPY_BUFFER=CL_COMMAND_COPY_BUFFER,
  CLCOMMAND_READ_IMAGE=CL_COMMAND_READ_IMAGE,
  CLCOMMAND_WRITE_IMAGE=CL_COMMAND_WRITE_IMAGE,
  CLCOMMAND_COPY_IMAGE=CL_COMMAND_COPY_IMAGE,
  CLCOMMAND_COPY_BUFFER_TO_IMAGE=CL_COMMAND_COPY_BUFFER_TO_IMAGE,
  CLCOMMAND_COPY_IMAGE_TO_BUFFER=CL_COMMAND_COPY_IMAGE_TO_BUFFER,
  CLCOMMAND_MAP_BUFFER=CL_COMMAND_MAP_BUFFER,
  CLCOMMAND_MAP_IMAGE=CL_COMMAND_MAP_IMAGE,
  CLCOMMAND_UNMAP_MEM_OBJECT=CL_COMMAND_UNMAP_MEM_OBJECT,
  CLCOMMAND_MARKER=CL_COMMAND_MARKER,
  CLCOMMAND_ACQUIRE_GL_OBJECTS=CL_COMMAND_ACQUIRE_GL_OBJECTS,
  CLCOMMAND_RELEASE_GL_OBJECTS=CL_COMMAND_RELEASE_GL_OBJECTS
  };
#endc

-- | Command associated with an event.
{#enum CLCommandType {} deriving( Show ) #}

getCommandType :: CLCommandType_ -> Maybe CLCommandType
getCommandType = Just . toEnum . fromIntegral

#c
enum CLCommandExecutionStatus {
  CLQUEUED=CL_QUEUED, CLSUBMITTED=CL_SUBMITTED, CLRUNNING=CL_RUNNING,
  CLCOMPLETE=CL_COMPLETE, CLEXEC_ERROR= -1
  };
#endc

{-|
 * 'CLQUEUED', command has been enqueued in the command-queue.

 * 'CLSUBMITTED', enqueued command has been submitted by the host to the
device associated with the command-queue.

 * 'CLRUNNING', device is currently executing this command.

 * 'CLCOMPLETE', the command has completed.

 * 'CLEXEC_ERROR', command was abnormally terminated.
-}
{#enum CLCommandExecutionStatus {} deriving( Show ) #}

getCommandExecutionStatus :: CLint -> Maybe CLCommandExecutionStatus
getCommandExecutionStatus n
  | n < 0 = Just CLEXEC_ERROR
  | otherwise = Just . toEnum . fromIntegral $ n

#c
enum CLProfilingInfo {
  CLPROFILING_COMMAND_QUEUED=CL_PROFILING_COMMAND_QUEUED,
  CLPROFILING_COMMAND_SUBMIT=CL_PROFILING_COMMAND_SUBMIT,
  CLPROFILING_COMMAND_START=CL_PROFILING_COMMAND_START,
  CLPROFILING_COMMAND_END=CL_PROFILING_COMMAND_END
  };
#endc

{-| Specifies the profiling data.

 * 'CLPROFILING_COMMAND_QUEUED', A 64-bit value that describes the current
device time counter in nanoseconds when the command identified by event is
enqueued in a command-queue by the host.

 * 'CLPROFILING_COMMAND_SUBMIT', A 64-bit value that describes the current
device time counter in nanoseconds when the command identified by event that has
been enqueued is submitted by the host to the device associated with the
commandqueue.

 * 'CLPROFILING_COMMAND_START',	 A 64-bit value that describes the current
device time counter in nanoseconds when the command identified by event starts
execution on the device.

 * 'CLPROFILING_COMMAND_END', A 64-bit value that describes the current device
time counter in nanoseconds when the command identified by event has finished
execution on the device.
-}
{#enum CLProfilingInfo {} deriving( Show ) #}

getProfilingInfoValue :: CLProfilingInfo -> CLProfilingInfo_
getProfilingInfoValue = fromIntegral . fromEnum

-- -----------------------------------------------------------------------------
binaryFlags :: (Ord b, Enum b, Bounded b) => b -> [b]
binaryFlags m = map toEnum . takeWhile (<= (fromEnum m)) $ [1 `shiftL` n | n <- [0..]]

testMask :: Bits b => b -> b -> Bool
testMask mask v = (v .&. mask) == v

bitmaskToDeviceTypes :: CLDeviceType_ -> [CLDeviceType]
bitmaskToDeviceTypes mask = filter (testMask mask . fromIntegral . fromEnum) $ [CLDEVICE_TYPE_CPU,CLDEVICE_TYPE_GPU,CLDEVICE_TYPE_ACCELERATOR,CLDEVICE_TYPE_DEFAULT,CLDEVICE_TYPE_ALL]

bitmaskFromDeviceTypes :: [CLDeviceType] -> CLDeviceType_
bitmaskFromDeviceTypes = foldl' (.|.) 0 . map (fromIntegral . fromEnum)

bitmaskToCommandQueueProperties :: CLCommandQueueProperty_ -> [CLCommandQueueProperty]
bitmaskToCommandQueueProperties mask = filter (testMask mask . fromIntegral . fromEnum) $ binaryFlags maxBound

bitmaskFromCommandQueueProperties :: [CLCommandQueueProperty] -> CLCommandQueueProperty_
bitmaskFromCommandQueueProperties = foldl' (.|.) 0 . map (fromIntegral.fromEnum)

bitmaskToFPConfig :: CLDeviceFPConfig_ -> [CLDeviceFPConfig]
bitmaskToFPConfig mask = filter (testMask mask . fromIntegral . fromEnum) $ binaryFlags maxBound

bitmaskToExecCapability :: CLDeviceExecCapability_ -> [CLDeviceExecCapability]
bitmaskToExecCapability mask = filter (testMask mask . fromIntegral . fromEnum) $ binaryFlags maxBound

-- -----------------------------------------------------------------------------