[project @ 2002-07-17 15:59:19 by juhp]

[project @ 2002-07-17 15:59:19 by juhp]

(treeViewColumnNewWithAttributes): Haskell implementation to
avoid binding to original variad function.
(treeViewColumnAddAttributes): New convenience function.
(treeViewColumnSetAttributes): Haskell implementation to
avoid binding to original variad function.
(treeViewColumnClearAttributes): Add binding.

darcs-hash:20020717155919-f332a-a89d58aed845a5c401649ab842f685953b622f4b.gz

-- -*-haskell-*-
--  GIMP Toolkit (GTK) @entry Widget TreeViewColumn@
--
--  Author : Axel Simon
--
--  Created: 9 May 2001
--
--  Version $Revision: 1.4 $ from $Date: 2002/07/17 15:59:19 $
--
--  Copyright (c) 2001 Axel Simon
--
--  This file is free software; you can redistribute it and/or modify
--  it under the terms of the GNU General Public License as published by
--  the Free Software Foundation; either version 2 of the License, or
--  (at your option) any later version.
--
--  This file is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
--  GNU General Public License for more details.
--
-- @description@ --------------------------------------------------------------
--
--
-- @documentation@ ------------------------------------------------------------
--
-- * tree_view_column_new_with_attributes and tree_view_column_set_attributes
--   are variadic and the funcitonality can be achieved through other
--   functions.
--
-- * tree_view_column_set_cell_data and tree_view_column_cell_get_size are not
--   bound because I am not sure what they do and when they are useful
--
-- @todo@ ---------------------------------------------------------------------
--
-- * treeViewColumnSetCellData is not bound. With this function the user has
--   control over how data in the store is mapped to the attributes of a
--   cell renderer. This functin should be bound in the future to allow the
--   user to insert Haskell data types into the store and convert these
--   values to attributes of cell renderers.
--
module TreeViewColumn(
  TreeViewColumn,
  TreeViewColumnClass,
  castToTreeViewColumn,
  treeViewColumnNew,
  treeViewColumnNewWithAttributes,
  treeViewColumnPackStart,
  treeViewColumnPackEnd,
  treeViewColumnClear,
  treeViewColumnGetCellRenderers,
  treeViewColumnAddAttribute,
  treeViewColumnAddAttributes,
  treeViewColumnSetAttributes,
  treeViewColumnClearAttributes,
  treeViewColumnSetSpacing,
  treeViewColumnGetSpacing,
  treeViewColumnSetVisible,
  treeViewColumnGetVisible,
  treeViewColumnSetResizable,
  treeViewColumnGetResizable,
  TreeViewColumnSizing(..),
  treeViewColumnSetSizing,
  treeViewColumnGetSizing,
  treeViewColumnGetWidth,
  treeViewColumnSetFixedWidth,
  treeViewColumnSetMinWidth,
  treeViewColumnGetMinWidth,
  treeViewColumnSetMaxWidth,
  treeViewColumnGetMaxWidth,
  treeViewColumnClicked,
  treeViewColumnSetTitle,
  treeViewColumnGetTitle,
  treeViewColumnSetClickable,
  treeViewColumnSetWidget,
  treeViewColumnGetWidget,
  treeViewColumnSetAlignment,
  treeViewColumnGetAlignment,
  treeViewColumnSetReorderable,
  treeViewColumnGetReorderable,
  treeViewColumnSetSortColumnId,
  treeViewColumnGetSortColumnId,
  treeViewColumnSetSortIndicator,
  treeViewColumnGetSortIndicator,
  treeViewColumnSetSortOrder,
  treeViewColumnGetSortOrder,
  SortType(..),
  onColClicked,
  afterColClicked
  ) where

import Monad	(liftM)
import Foreign
import UTFCForeign
import Object	(makeNewObject)
{#import Hierarchy#}
{#import Signal#}
import Enums	(TreeViewColumnSizing(..), SortType(..))
{#import TreeModel#}
import CellRenderer (Attribute(..))
{#import GList#}

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

-- TreeViewColumn type declaration

-- methods

-- @constructor treeViewColumnNew@ Generate a new TreeViewColumn widget.
--
treeViewColumnNew :: IO TreeViewColumn
treeViewColumnNew  = makeNewObject mkTreeViewColumn
  {#call tree_view_column_new#}

-- @method treeViewColumnNewWithAttributes@ Returns a new TreeViewColumn with
-- title @ref arg title@, cell renderer @ref arg cr@, and attributes
-- @ref arg attribs@.
--
treeViewColumnNewWithAttributes :: CellRendererClass cr => String -> cr ->
				   [(String, Int)] -> IO TreeViewColumn
treeViewColumnNewWithAttributes title cr attribs =
    do
    tvc <- treeViewColumnNew
    treeViewColumnSetTitle tvc title
    treeViewColumnPackStart tvc  cr True
    treeViewColumnAddAttributes tvc cr attribs
    return tvc

-- @method treeViewColumnPackStart@ Add a cell renderer at the beginning of
-- a column.
--
-- * Excess space is divided equally among all renderers which have
--   @arg expand@ set to True.
--
treeViewColumnPackStart :: (TreeViewColumnClass tvc, CellRendererClass cr) =>
			   tvc -> cr -> Bool -> IO ()
treeViewColumnPackStart tvc cr expand =
  {#call unsafe tree_view_column_pack_start#} (toTreeViewColumn tvc)
  (toCellRenderer cr) (fromBool expand)

-- @method treeViewColumnPackEnd@ Add a cell renderer at the end of a column.
--
-- * Excess space is divided equally among all renderers which have
--   @arg expand@ set to True.
--
treeViewColumnPackEnd :: (TreeViewColumnClass tvc, CellRendererClass cr) =>
			 tvc -> cr -> Bool -> IO ()
treeViewColumnPackEnd tvc cr expand =
  {#call unsafe tree_view_column_pack_end#} (toTreeViewColumn tvc)
  (toCellRenderer cr) (fromBool expand)

-- @method treeViewColumnClear@ Remove the associations of attributes
-- to a store for all @ref type CellRenderers@.
--
treeViewColumnClear :: TreeViewColumnClass tvc => tvc -> IO ()
treeViewColumnClear tvc =
  {#call tree_view_column_clear#} (toTreeViewColumn tvc)

-- @method treeViewColumnGetCellRenderers@ Retrieve all
-- @ref type CellRenderer@s that are contained in this column.
--
treeViewColumnGetCellRenderers :: TreeViewColumnClass tvc =>
				  tvc -> IO [CellRenderer]
treeViewColumnGetCellRenderers tvc = do
  glist <- {#call unsafe tree_view_column_get_cell_renderers#}
	   (toTreeViewColumn tvc)
  crs <- fromGList glist
  mapM (makeNewObject mkCellRenderer) (map return crs)

-- @method treeViewColumnAddAttribute@ Insert an attribute to change the
-- behaviour of the column's cell renderer.
--
-- * The @ref type CellRenderer@ @ref arg cr@ must already be in
--   @ref type TreeViewColumn@.
--
treeViewColumnAddAttribute :: (TreeViewColumnClass tvc, CellRendererClass cr)
			      => tvc -> cr -> String -> Int -> IO ()
treeViewColumnAddAttribute tvc cr attr col =
  withCString attr $ \cstr ->  {#call unsafe tree_view_column_add_attribute#}
    (toTreeViewColumn tvc) (toCellRenderer cr) cstr (fromIntegral col)

-- @method treeViewColumnAddAttributes@ Insert attributes @ref arg attribs@
-- to change the behaviour of column @ref arg tvc@'s cell renderer
-- @ref arg cr@.
--
treeViewColumnAddAttributes ::
  (TreeViewColumnClass tvc, CellRendererClass cr) =>
  tvc -> cr -> [(String,Int)] -> IO ()
treeViewColumnAddAttributes tvc cr attribs =
    mapM_ (\ (attr, col) -> treeViewColumnAddAttribute tvc cr attr col) attribs

-- @method treeViewColumnSetAttributes@ Set the attributes of
-- the cell renderer @ref arg cr@ in the tree column @ref arg tvc@
-- be  @red arg attribs@.
-- The attributes are given as a list of attribute/column pairs.
-- All existing attributes are removed, and replaced with the new attributes.
--
treeViewColumnSetAttributes ::
    (TreeViewColumnClass tvc, CellRendererClass cr)  =>
    tvc -> cr -> [(String, Int)] -> IO ()
treeViewColumnSetAttributes tvc cr attribs =
    do
    treeViewColumnClearAttributes tvc cr
    treeViewColumnAddAttributes tvc cr attribs

-- @method treeViewColumnClearAttributes@ Clears all existing attributes
-- of the column @ref arg tvc@.
--
treeViewColumnClearAttributes ::
    (TreeViewColumnClass tvc, CellRendererClass cr) =>
    tvc -> cr -> IO ()
treeViewColumnClearAttributes tvc cr =
  {#call tree_view_column_clear_attributes#} (toTreeViewColumn tvc)
    (toCellRenderer cr)

-- @method treeViewColumnSetSpacing@ Set the number of pixels between two
-- cell renderers.
--
treeViewColumnSetSpacing :: TreeViewColumnClass tvc => tvc -> Int -> IO ()
treeViewColumnSetSpacing tvc vis =
  {#call tree_view_column_set_spacing#} (toTreeViewColumn tvc)
    (fromIntegral vis)

-- @method treeViewColumnGetSpacing@ Get the number of pixels between two
-- cell renderers.
--
treeViewColumnGetSpacing :: TreeViewColumnClass tvc => tvc -> IO Int
treeViewColumnGetSpacing tvc = liftM fromIntegral $
  {#call unsafe tree_view_column_get_spacing#} (toTreeViewColumn tvc)

-- @method treeViewColumnSetVisible@ Set the visibility of a given column.
--
treeViewColumnSetVisible :: TreeViewColumnClass tvc => tvc -> Bool -> IO ()
treeViewColumnSetVisible tvc vis =
  {#call tree_view_column_set_visible#} (toTreeViewColumn tvc)
    (fromBool vis)

-- @method treeViewColumnGetVisible@ Get the visibility of a given column.
--
treeViewColumnGetVisible :: TreeViewColumnClass tvc => tvc -> IO Bool
treeViewColumnGetVisible tvc = liftM toBool $
  {#call unsafe tree_view_column_get_visible#} (toTreeViewColumn tvc)

-- @method treeViewColumnSetResizable@ Set if a given column is resizable
-- by the user.
--
treeViewColumnSetResizable :: TreeViewColumnClass tvc => tvc -> Bool -> IO ()
treeViewColumnSetResizable tvc vis =
  {#call tree_view_column_set_resizable#} (toTreeViewColumn tvc)
    (fromBool vis)

-- @method treeViewColumnGetResizable@ Get if a given column is resizable
-- by the user.
--
treeViewColumnGetResizable :: TreeViewColumnClass tvc => tvc -> IO Bool
treeViewColumnGetResizable tvc = liftM toBool $
  {#call unsafe tree_view_column_get_resizable#} (toTreeViewColumn tvc)

-- @method treeViewColumnSetSizing@ Set wether the column can be resized.
--
treeViewColumnSetSizing :: TreeViewColumnClass tvc => tvc ->
                           TreeViewColumnSizing -> IO ()
treeViewColumnSetSizing tvc size = {#call tree_view_column_set_sizing#}
  (toTreeViewColumn tvc) ((fromIntegral.fromEnum) size)

-- @method treeViewColumnGetSizing@ Return the resizing type of the column.
--
treeViewColumnGetSizing :: TreeViewColumnClass tvc => tvc ->
                           IO TreeViewColumnSizing
treeViewColumnGetSizing tvc = liftM (toEnum.fromIntegral) $
  {#call unsafe tree_view_column_get_sizing#} (toTreeViewColumn tvc)

-- @method treeViewColumnGetWidth@ Query the current width of the column.
--
treeViewColumnGetWidth :: TreeViewColumnClass tvc => tvc -> IO Int
treeViewColumnGetWidth tvc = liftM fromIntegral $
  {#call unsafe tree_view_column_get_width#} (toTreeViewColumn tvc)

-- @method treeViewColumnSetFixedWidth@ Set the width of the column.
--
-- * This is meaningful only if the sizing type is
--   @ref type TreeViewColumnFixed@.
--
treeViewColumnSetFixedWidth :: TreeViewColumnClass tvc => Int -> tvc -> IO ()
treeViewColumnSetFixedWidth width tvc =
  {#call tree_view_column_set_fixed_width#}
  (toTreeViewColumn tvc) (fromIntegral width)

-- @method treeViewColumnSetMinWidth@ Set minimum width of the column.
--
treeViewColumnSetMinWidth :: TreeViewColumnClass tvc => tvc -> Int -> IO ()
treeViewColumnSetMinWidth tvc width = {#call tree_view_column_set_min_width#}
  (toTreeViewColumn tvc) (fromIntegral width)

-- @method treeViewColumnGetMinWidth@ Get the minimum width of a column.
-- Returns -1 if this width was not set.
--
treeViewColumnGetMinWidth :: TreeViewColumnClass tvc => tvc -> IO Int
treeViewColumnGetMinWidth tvc = liftM fromIntegral $
  {#call unsafe tree_view_column_get_min_width#} (toTreeViewColumn tvc)

-- @method treeViewColumnSetMaxWidth@ Set maximum width of the column.
--
treeViewColumnSetMaxWidth :: TreeViewColumnClass tvc => tvc -> Int -> IO ()
treeViewColumnSetMaxWidth tvc width = {#call tree_view_column_set_max_width#}
  (toTreeViewColumn tvc) (fromIntegral width)

-- @method treeViewColumnGetMaxWidth@ Get the maximum width of a column.
-- Returns -1 if this width was not set.
--
treeViewColumnGetMaxWidth :: TreeViewColumnClass tvc => tvc -> IO Int
treeViewColumnGetMaxWidth tvc = liftM fromIntegral $
  {#call unsafe tree_view_column_get_max_width#} (toTreeViewColumn tvc)

-- @method treeViewColumnClicked@ Emit the @ref arg clicked@ signal on the
-- column.
--
treeViewColumnClicked :: TreeViewColumnClass tvc => tvc -> IO ()
treeViewColumnClicked tvc =
  {#call tree_view_column_clicked#} (toTreeViewColumn tvc)

-- @method treeViewColumnSetTitle@ Set the widget's title if a custom widget
-- has not been set.
--
treeViewColumnSetTitle :: TreeViewColumnClass tvc => tvc -> String -> IO ()
treeViewColumnSetTitle tvc title = withCString title $
  {#call tree_view_column_set_title#} (toTreeViewColumn tvc)

-- @method treeViewColumnGetTitle@ Get the widget's title.
--
treeViewColumnGetTitle :: TreeViewColumnClass tvc => tvc -> IO (Maybe String)
treeViewColumnGetTitle tvc = do
  strPtr <- {#call unsafe tree_view_column_get_title#} (toTreeViewColumn tvc)
  if strPtr==nullPtr then return Nothing else liftM Just $ peekCString strPtr

-- @method treeViewColumnSetClickable@ Set if the column should be sensitive
-- to mouse clicks.
--
treeViewColumnSetClickable :: TreeViewColumnClass tvc => tvc -> Bool -> IO ()
treeViewColumnSetClickable tvc click = {#call tree_view_column_set_clickable#}
  (toTreeViewColumn tvc) (fromBool click)

-- @method treeViewColumnSetWidget@ Set the column's title to this widget.
--
treeViewColumnSetWidget :: (TreeViewColumnClass tvc, WidgetClass w) => tvc ->
                           w -> IO ()
treeViewColumnSetWidget tvc w =
  {#call tree_view_column_set_widget#} (toTreeViewColumn tvc) (toWidget w)

-- @method treeViewColumnGetWidget@ Retrieve the widget responsible for
-- showing the column title. In case only a text title was set this will be a
-- @ref arg Alignment@ widget with a @ref arg Label@ inside.
--
treeViewColumnGetWidget :: TreeViewColumnClass tvc => tvc -> IO Widget
treeViewColumnGetWidget tvc = makeNewObject mkWidget $
  {#call unsafe tree_view_column_get_widget#} (toTreeViewColumn tvc)

-- @method treeViewColumnSetAlignment@ Set the alignment of the title.
--
treeViewColumnSetAlignment :: TreeViewColumnClass tvc => tvc -> Float -> IO ()
treeViewColumnSetAlignment tvc align = {#call tree_view_column_set_alignment#}
  (toTreeViewColumn tvc) (realToFrac align)

-- @method treeViewColumnGetAlignment@ Get the alignment of the titlte.
--
treeViewColumnGetAlignment :: TreeViewColumnClass tvc => tvc -> IO Float
treeViewColumnGetAlignment tvc = liftM realToFrac $
  {#call unsafe tree_view_column_get_alignment#} (toTreeViewColumn tvc)

-- @method treeViewColumnSetReorderable@ Set if a given column is reorderable
-- by the user.
--
treeViewColumnSetReorderable :: TreeViewColumnClass tvc => tvc -> Bool -> IO ()
treeViewColumnSetReorderable tvc vis =
  {#call tree_view_column_set_reorderable#} (toTreeViewColumn tvc)
    (fromBool vis)

-- @method treeViewColumnGetReorderable@ Get if a given column is reorderable
-- by the user.
--
treeViewColumnGetReorderable :: TreeViewColumnClass tvc => tvc -> IO Bool
treeViewColumnGetReorderable tvc = liftM toBool $
  {#call unsafe tree_view_column_get_reorderable#} (toTreeViewColumn tvc)

-- @method treeViewColumnSetSortColumnId@ Set the column by which to sort.
--
-- * Sets the logical @ref arg columnId@ that this column sorts on when
--   this column is selected for sorting. The selected column's header
--   will be clickable after this call. Logical refers to the column in
--   the @ref type TreeModel@.
--
treeViewColumnSetSortColumnId :: TreeViewColumnClass tvc =>
				 tvc -> Int -> IO ()
treeViewColumnSetSortColumnId tvc columnId =
  {#call tree_view_column_set_sort_column_id#}
  (toTreeViewColumn tvc) (fromIntegral columnId)

-- @method treeViewColumnGetSortColumnId@ Get the column by which to sort.
--
-- * Retrieves the logical @ref arg columnId@ that the model sorts on when
--   this column is selected for sorting.
--
-- * Returns -1 if this column can't be used for sorting.
--
treeViewColumnGetSortColumnId :: TreeViewColumnClass tvc => tvc -> IO Int
treeViewColumnGetSortColumnId tvc = liftM fromIntegral $
  {#call unsafe tree_view_column_get_sort_column_id#} (toTreeViewColumn tvc)

-- @method treeViewColumnSetSortIndicator@ Set if a given column has
-- sorting arrows in its heading.
--
treeViewColumnSetSortIndicator :: TreeViewColumnClass tvc =>
				  tvc -> Bool -> IO ()
treeViewColumnSetSortIndicator tvc sort =
  {#call tree_view_column_set_sort_indicator#} (toTreeViewColumn tvc)
    (fromBool sort)

-- @method treeViewColumnGetSortIndicator@ Query if a given column has
-- sorting arrows in its heading.
--
treeViewColumnGetSortIndicator :: TreeViewColumnClass tvc => tvc -> IO Bool
treeViewColumnGetSortIndicator tvc = liftM toBool $
  {#call unsafe tree_view_column_get_sort_indicator#} (toTreeViewColumn tvc)

-- @method treeViewColumnSetSortOrder@ Set if a given column is sorted
-- in ascending or descending order.
--
-- * In order for sorting to work, it is necessary to either use automatic
--   sorting via @ref method treeViewColumnSetSortColumnId@ or to use a
--   user defined sorting on the elements in a @ref type TreeModel@.
--
treeViewColumnSetSortOrder :: TreeViewColumnClass tvc =>
			      tvc -> SortType -> IO ()
treeViewColumnSetSortOrder tvc sort =
  {#call tree_view_column_set_sort_order#} (toTreeViewColumn tvc)
    ((fromIntegral.fromEnum) sort)

-- @method treeViewColumnGetSortOrder@ Query if a given column is sorted
-- in ascending or descending order.
--
treeViewColumnGetSortOrder :: TreeViewColumnClass tvc => tvc -> IO SortType
treeViewColumnGetSortOrder tvc = liftM (toEnum.fromIntegral) $
  {#call unsafe tree_view_column_get_sort_order#} (toTreeViewColumn tvc)

-- @signal colClicked@ Emitted when the header of this column has been
-- clicked on.
--
onColClicked, afterColClicked :: TreeViewColumnClass tvc => tvc -> IO () ->
							    IO (ConnectId tvc)
onColClicked = connect_NONE__NONE "clicked" False
afterColClicked = connect_NONE__NONE "clicked" True

-- -*-haskell-*-
--  GIMP Toolkit (GTK) @entry Widget TreeViewColumn@
--
--  Author : Axel Simon
--
--  Created: 9 May 2001
--
--  Version $Revision: 1.3 $ from $Date: 2002/07/08 09:15:09 $
--
--  Copyright (c) 2001 Axel Simon
--
--  This file is free software; you can redistribute it and/or modify
--  it under the terms of the GNU General Public License as published by
--  the Free Software Foundation; either version 2 of the License, or
--  (at your option) any later version.
--
--  This file is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
--  GNU General Public License for more details.
--
-- @description@ --------------------------------------------------------------
--
--
-- @documentation@ ------------------------------------------------------------
--
-- * tree_view_column_new_with_attributes and tree_view_column_set_attributes
--   are variadic and the funcitonality can be achieved through other
--   functions.
--
-- * tree_view_column_set_cell_data and tree_view_column_cell_get_size are not
--   bound because I am not sure what they do and when they are useful
--
-- @todo@ ---------------------------------------------------------------------
--
-- * treeViewColumnSetCellData is not bound. With this function the user has
--   control over how data in the store is mapped to the attributes of a
--   cell renderer. This functin should be bound in the future to allow the
--   user to insert Haskell data types into the store and convert these
--   values to attributes of cell renderers.
--
module TreeViewColumn(
  TreeViewColumn,
  TreeViewColumnClass,
  castToTreeViewColumn,
  treeViewColumnNew,
  treeViewColumnPackStart,
  treeViewColumnPackEnd,
  treeViewColumnClear,
  treeViewColumnGetCellRenderers,
  treeViewColumnAddAttribute,
  treeViewColumnSetSpacing,
  treeViewColumnGetSpacing,
  treeViewColumnSetVisible,
  treeViewColumnGetVisible,
  treeViewColumnSetResizable,
  treeViewColumnGetResizable,
  TreeViewColumnSizing(..),
  treeViewColumnSetSizing,
  treeViewColumnGetSizing,
  treeViewColumnGetWidth,
  treeViewColumnSetFixedWidth,
  treeViewColumnSetMinWidth,
  treeViewColumnGetMinWidth,
  treeViewColumnSetMaxWidth,
  treeViewColumnGetMaxWidth,
  treeViewColumnClicked,
  treeViewColumnSetTitle,
  treeViewColumnGetTitle,
  treeViewColumnSetClickable,
  treeViewColumnSetWidget,
  treeViewColumnGetWidget,
  treeViewColumnSetAlignment,
  treeViewColumnGetAlignment,
  treeViewColumnSetReorderable,
  treeViewColumnGetReorderable,
  treeViewColumnSetSortColumnId,
  treeViewColumnGetSortColumnId,
  treeViewColumnSetSortIndicator,
  treeViewColumnGetSortIndicator,
  treeViewColumnSetSortOrder,
  treeViewColumnGetSortOrder,
  SortType(..),
  onColClicked,
  afterColClicked
  ) where

import Monad	(liftM)
import Foreign
import UTFCForeign
import Object	(makeNewObject)
{#import Hierarchy#}
{#import Signal#}
import Enums	(TreeViewColumnSizing(..), SortType(..))
{#import TreeModel#}
import CellRenderer (Attribute(..))
{#import GList#}

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

-- TreeViewColumn type declaration

-- methods

-- @constructor treeViewColumnNew@ Generate a new TreeViewColumn widget.
--
treeViewColumnNew :: IO TreeViewColumn
treeViewColumnNew  = makeNewObject mkTreeViewColumn
  {#call tree_view_column_new#}

-- @method treeViewColumnPackStart@ Add a cell renderer at the beginning of
-- a column.
--
-- * Excess space is divided equally among all renderers which have
--   @arg expand@ set to True.
--
treeViewColumnPackStart :: (TreeViewColumnClass tvc, CellRendererClass cr) =>
			   tvc -> cr -> Bool -> IO ()
treeViewColumnPackStart tvc cr expand =
  {#call unsafe tree_view_column_pack_start#} (toTreeViewColumn tvc)
  (toCellRenderer cr) (fromBool expand)

-- @method treeViewColumnPackEnd@ Add a cell renderer at the end of a column.
--
-- * Excess space is divided equally among all renderers which have
--   @arg expand@ set to True.
--
treeViewColumnPackEnd :: (TreeViewColumnClass tvc, CellRendererClass cr) =>
			 tvc -> cr -> Bool -> IO ()
treeViewColumnPackEnd tvc cr expand =
  {#call unsafe tree_view_column_pack_end#} (toTreeViewColumn tvc)
  (toCellRenderer cr) (fromBool expand)

-- @method treeViewColumnClear@ Remove the associations of attributes
-- to a store for all @ref type CellRenderers@.
--
treeViewColumnClear :: TreeViewColumnClass tvc => tvc -> IO ()
treeViewColumnClear tvc =
  {#call tree_view_column_clear#} (toTreeViewColumn tvc)

-- @method treeViewColumnGetCellRenderers@ Retrieve all
-- @ref type CellRenderer@s that are contained in this column.
--
treeViewColumnGetCellRenderers :: TreeViewColumnClass tvc =>
				  tvc -> IO [CellRenderer]
treeViewColumnGetCellRenderers tvc = do
  glist <- {#call unsafe tree_view_column_get_cell_renderers#}
	   (toTreeViewColumn tvc)
  crs <- fromGList glist
  mapM (makeNewObject mkCellRenderer) (map return crs)

-- @method treeViewColumnAddAttribute@ Insert an attribute to change the
-- behaviour of the column's cell renderer.
--
-- * The @ref type CellRenderer@ @ref arg cr@ must already be in
--   @ref type TreeViewColumn@.
--
treeViewColumnAddAttribute :: (TreeViewColumnClass tvc, CellRendererClass cr)
			      => tvc -> cr -> String -> Int -> IO ()
treeViewColumnAddAttribute tvc cr attr col =
  withCString attr $ \cstr ->  {#call unsafe tree_view_column_add_attribute#}
    (toTreeViewColumn tvc) (toCellRenderer cr) cstr (fromIntegral col)

-- @method treeViewColumnSetSpacing@ Set the number of pixels between two
-- cell renderers.
--
treeViewColumnSetSpacing :: TreeViewColumnClass tvc => tvc -> Int -> IO ()
treeViewColumnSetSpacing tvc vis =
  {#call tree_view_column_set_spacing#} (toTreeViewColumn tvc)
    (fromIntegral vis)

-- @method treeViewColumnGetSpacing@ Get the number of pixels between two
-- cell renderers.
--
treeViewColumnGetSpacing :: TreeViewColumnClass tvc => tvc -> IO Int
treeViewColumnGetSpacing tvc = liftM fromIntegral $
  {#call unsafe tree_view_column_get_spacing#} (toTreeViewColumn tvc)

-- @method treeViewColumnSetVisible@ Set the visibility of a given column.
--
treeViewColumnSetVisible :: TreeViewColumnClass tvc => tvc -> Bool -> IO ()
treeViewColumnSetVisible tvc vis =
  {#call tree_view_column_set_visible#} (toTreeViewColumn tvc)
    (fromBool vis)

-- @method treeViewColumnGetVisible@ Get the visibility of a given column.
--
treeViewColumnGetVisible :: TreeViewColumnClass tvc => tvc -> IO Bool
treeViewColumnGetVisible tvc = liftM toBool $
  {#call unsafe tree_view_column_get_visible#} (toTreeViewColumn tvc)

-- @method treeViewColumnSetResizable@ Set if a given column is resizable
-- by the user.
--
treeViewColumnSetResizable :: TreeViewColumnClass tvc => tvc -> Bool -> IO ()
treeViewColumnSetResizable tvc vis =
  {#call tree_view_column_set_resizable#} (toTreeViewColumn tvc)
    (fromBool vis)

-- @method treeViewColumnGetResizable@ Get if a given column is resizable
-- by the user.
--
treeViewColumnGetResizable :: TreeViewColumnClass tvc => tvc -> IO Bool
treeViewColumnGetResizable tvc = liftM toBool $
  {#call unsafe tree_view_column_get_resizable#} (toTreeViewColumn tvc)

-- @method treeViewColumnSetSizing@ Set wether the column can be resized.
--
treeViewColumnSetSizing :: TreeViewColumnClass tvc => tvc ->
                           TreeViewColumnSizing -> IO ()
treeViewColumnSetSizing tvc size = {#call tree_view_column_set_sizing#}
  (toTreeViewColumn tvc) ((fromIntegral.fromEnum) size)

-- @method treeViewColumnGetSizing@ Return the resizing type of the column.
--
treeViewColumnGetSizing :: TreeViewColumnClass tvc => tvc ->
                           IO TreeViewColumnSizing
treeViewColumnGetSizing tvc = liftM (toEnum.fromIntegral) $
  {#call unsafe tree_view_column_get_sizing#} (toTreeViewColumn tvc)

-- @method treeViewColumnGetWidth@ Query the current width of the column.
--
treeViewColumnGetWidth :: TreeViewColumnClass tvc => tvc -> IO Int
treeViewColumnGetWidth tvc = liftM fromIntegral $
  {#call unsafe tree_view_column_get_width#} (toTreeViewColumn tvc)

-- @method treeViewColumnSetFixedWidth@ Set the width of the column.
--
-- * This is meaningful only if the sizing type is
--   @ref type TreeViewColumnFixed@.
--
treeViewColumnSetFixedWidth :: TreeViewColumnClass tvc => Int -> tvc -> IO ()
treeViewColumnSetFixedWidth width tvc =
  {#call tree_view_column_set_fixed_width#}
  (toTreeViewColumn tvc) (fromIntegral width)

-- @method treeViewColumnSetMinWidth@ Set minimum width of the column.
--
treeViewColumnSetMinWidth :: TreeViewColumnClass tvc => tvc -> Int -> IO ()
treeViewColumnSetMinWidth tvc width = {#call tree_view_column_set_min_width#}
  (toTreeViewColumn tvc) (fromIntegral width)

-- @method treeViewColumnGetMinWidth@ Get the minimum width of a column.
-- Returns -1 if this width was not set.
--
treeViewColumnGetMinWidth :: TreeViewColumnClass tvc => tvc -> IO Int
treeViewColumnGetMinWidth tvc = liftM fromIntegral $
  {#call unsafe tree_view_column_get_min_width#} (toTreeViewColumn tvc)

-- @method treeViewColumnSetMaxWidth@ Set maximum width of the column.
--
treeViewColumnSetMaxWidth :: TreeViewColumnClass tvc => tvc -> Int -> IO ()
treeViewColumnSetMaxWidth tvc width = {#call tree_view_column_set_max_width#}
  (toTreeViewColumn tvc) (fromIntegral width)

-- @method treeViewColumnGetMaxWidth@ Get the maximum width of a column.
-- Returns -1 if this width was not set.
--
treeViewColumnGetMaxWidth :: TreeViewColumnClass tvc => tvc -> IO Int
treeViewColumnGetMaxWidth tvc = liftM fromIntegral $
  {#call unsafe tree_view_column_get_max_width#} (toTreeViewColumn tvc)

-- @method treeViewColumnClicked@ Emit the @ref arg clicked@ signal on the
-- column.
--
treeViewColumnClicked :: TreeViewColumnClass tvc => tvc -> IO ()
treeViewColumnClicked tvc =
  {#call tree_view_column_clicked#} (toTreeViewColumn tvc)

-- @method treeViewColumnSetTitle@ Set the widget's title if a custom widget
-- has not been set.
--
treeViewColumnSetTitle :: TreeViewColumnClass tvc => tvc -> String -> IO ()
treeViewColumnSetTitle tvc title = withCString title $
  {#call tree_view_column_set_title#} (toTreeViewColumn tvc)

-- @method treeViewColumnGetTitle@ Get the widget's title.
--
treeViewColumnGetTitle :: TreeViewColumnClass tvc => tvc -> IO (Maybe String)
treeViewColumnGetTitle tvc = do
  strPtr <- {#call unsafe tree_view_column_get_title#} (toTreeViewColumn tvc)
  if strPtr==nullPtr then return Nothing else liftM Just $ peekCString strPtr

-- @method treeViewColumnSetClickable@ Set if the column should be sensitive
-- to mouse clicks.
--
treeViewColumnSetClickable :: TreeViewColumnClass tvc => tvc -> Bool -> IO ()
treeViewColumnSetClickable tvc click = {#call tree_view_column_set_clickable#}
  (toTreeViewColumn tvc) (fromBool click)

-- @method treeViewColumnSetWidget@ Set the column's title to this widget.
--
treeViewColumnSetWidget :: (TreeViewColumnClass tvc, WidgetClass w) => tvc ->
                           w -> IO ()
treeViewColumnSetWidget tvc w =
  {#call tree_view_column_set_widget#} (toTreeViewColumn tvc) (toWidget w)

-- @method treeViewColumnGetWidget@ Retrieve the widget responsible for
-- showing the column title. In case only a text title was set this will be a
-- @ref arg Alignment@ widget with a @ref arg Label@ inside.
--
treeViewColumnGetWidget :: TreeViewColumnClass tvc => tvc -> IO Widget
treeViewColumnGetWidget tvc = makeNewObject mkWidget $
  {#call unsafe tree_view_column_get_widget#} (toTreeViewColumn tvc)

-- @method treeViewColumnSetAlignment@ Set the alignment of the title.
--
treeViewColumnSetAlignment :: TreeViewColumnClass tvc => tvc -> Float -> IO ()
treeViewColumnSetAlignment tvc align = {#call tree_view_column_set_alignment#}
  (toTreeViewColumn tvc) (realToFrac align)

-- @method treeViewColumnGetAlignment@ Get the alignment of the titlte.
--
treeViewColumnGetAlignment :: TreeViewColumnClass tvc => tvc -> IO Float
treeViewColumnGetAlignment tvc = liftM realToFrac $
  {#call unsafe tree_view_column_get_alignment#} (toTreeViewColumn tvc)

-- @method treeViewColumnSetReorderable@ Set if a given column is reorderable
-- by the user.
--
treeViewColumnSetReorderable :: TreeViewColumnClass tvc => tvc -> Bool -> IO ()
treeViewColumnSetReorderable tvc vis =
  {#call tree_view_column_set_reorderable#} (toTreeViewColumn tvc)
    (fromBool vis)

-- @method treeViewColumnGetReorderable@ Get if a given column is reorderable
-- by the user.
--
treeViewColumnGetReorderable :: TreeViewColumnClass tvc => tvc -> IO Bool
treeViewColumnGetReorderable tvc = liftM toBool $
  {#call unsafe tree_view_column_get_reorderable#} (toTreeViewColumn tvc)

-- @method treeViewColumnSetSortColumnId@ Set the column by which to sort.
--
-- * Sets the logical @ref arg columnId@ that this column sorts on when
--   this column is selected for sorting. The selected column's header
--   will be clickable after this call. Logical refers to the column in
--   the @ref type TreeModel@.
--
treeViewColumnSetSortColumnId :: TreeViewColumnClass tvc =>
				 tvc -> Int -> IO ()
treeViewColumnSetSortColumnId tvc columnId =
  {#call tree_view_column_set_sort_column_id#}
  (toTreeViewColumn tvc) (fromIntegral columnId)

-- @method treeViewColumnGetSortColumnId@ Get the column by which to sort.
--
-- * Retrieves the logical @ref arg columnId@ that the model sorts on when
--   this column is selected for sorting.
--
-- * Returns -1 if this column can't be used for sorting.
--
treeViewColumnGetSortColumnId :: TreeViewColumnClass tvc => tvc -> IO Int
treeViewColumnGetSortColumnId tvc = liftM fromIntegral $
  {#call unsafe tree_view_column_get_sort_column_id#} (toTreeViewColumn tvc)

-- @method treeViewColumnSetSortIndicator@ Set if a given column has
-- sorting arrows in its heading.
--
treeViewColumnSetSortIndicator :: TreeViewColumnClass tvc =>
				  tvc -> Bool -> IO ()
treeViewColumnSetSortIndicator tvc sort =
  {#call tree_view_column_set_sort_indicator#} (toTreeViewColumn tvc)
    (fromBool sort)

-- @method treeViewColumnGetSortIndicator@ Query if a given column has
-- sorting arrows in its heading.
--
treeViewColumnGetSortIndicator :: TreeViewColumnClass tvc => tvc -> IO Bool
treeViewColumnGetSortIndicator tvc = liftM toBool $
  {#call unsafe tree_view_column_get_sort_indicator#} (toTreeViewColumn tvc)

-- @method treeViewColumnSetSortOrder@ Set if a given column is sorted
-- in ascending or descending order.
--
-- * In order for sorting to work, it is necessary to either use automatic
--   sorting via @ref method treeViewColumnSetSortColumnId@ or to use a
--   user defined sorting on the elements in a @ref type TreeModel@.
--
treeViewColumnSetSortOrder :: TreeViewColumnClass tvc =>
			      tvc -> SortType -> IO ()
treeViewColumnSetSortOrder tvc sort =
  {#call tree_view_column_set_sort_order#} (toTreeViewColumn tvc)
    ((fromIntegral.fromEnum) sort)

-- @method treeViewColumnGetSortOrder@ Query if a given column is sorted
-- in ascending or descending order.
--
treeViewColumnGetSortOrder :: TreeViewColumnClass tvc => tvc -> IO SortType
treeViewColumnGetSortOrder tvc = liftM (toEnum.fromIntegral) $
  {#call unsafe tree_view_column_get_sort_order#} (toTreeViewColumn tvc)

-- @signal colClicked@ Emitted when the header of this column has been
-- clicked on.
--
onColClicked, afterColClicked :: TreeViewColumnClass tvc => tvc -> IO () ->
							    IO (ConnectId tvc)
onColClicked = connect_NONE__NONE "clicked" False
afterColClicked = connect_NONE__NONE "clicked" True


fix for gdal < 1.11

fix for gdal < 1.11

{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}

#include "bindings.h"

module GDAL.Internal.OGR (
    DataSource
  , DataSourceH
  , SQLDialect (..)
  , ApproxOK (..)
  , Layer
  , LayerH (..)
  , RODataSource
  , RWDataSource
  , ROLayer
  , RWLayer
  , Driver

  , openReadOnly
  , openReadWrite
  , create
  , createMem
  , canCreateMultipleGeometryFields

  , datasourceName
  , executeSQL

  , createLayer
  , getLayer
  , getLayerByName

  , getSpatialFilter
  , setSpatialFilter

  , layerCount
  , layerName
  , layerFeatureDef

  , registerAll
  , cleanupAll

  , withLockedLayerPtr
  , withLockedLayerPtrs
  , unDataSource
  , unLayer
  , withLockedDataSourcePtr
) where

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

import Data.Text (Text)
import qualified Data.Vector as V

import Control.Applicative ((<$>))
import Control.Monad (liftM, when, void, forM_, (<=<))
import Control.Monad.Catch(throwM, catch, catchJust)
import Control.Monad.IO.Class (MonadIO(liftIO))

import Foreign.C.String (CString, peekCString, withCString)
import Foreign.C.Types (CInt(..), CChar(..))
import Foreign.Ptr (Ptr, nullPtr)
import Foreign.Marshal.Utils (toBool)

import Foreign.Storable (Storable)

import System.IO.Unsafe (unsafePerformIO)

{#import GDAL.Internal.OSR#}
{#import GDAL.Internal.OGRGeometry#}
{#import GDAL.Internal.OGRFeature#}
{#import GDAL.Internal.OGRError#}
{#import GDAL.Internal.CPLString#}
import GDAL.Internal.CPLError hiding (None)
import GDAL.Internal.CPLConv (cplFree)
import GDAL.Internal.Util
import GDAL.Internal.Types

#include "ogr_api.h"

{#fun RegisterAll as ^ {} -> `()'  #}
{#fun CleanupAll  as ^ {} -> `()'  #}

{#pointer OGRSFDriverH as DriverH newtype#}
deriving instance Eq DriverH

nullDriverH :: DriverH
nullDriverH = DriverH nullPtr

{#pointer DataSourceH newtype#}
newtype DataSource s (t::AccessMode) = DataSource (Mutex, DataSourceH)

deriving instance Eq DataSourceH

nullDataSourceH :: DataSourceH
nullDataSourceH = DataSourceH nullPtr

unDataSource :: DataSource s t -> DataSourceH
unDataSource (DataSource (_,p)) = p

type RODataSource s = DataSource s ReadOnly
type RWDataSource s = DataSource s ReadWrite

withLockedDataSourcePtr
  :: DataSource s t -> (DataSourceH -> IO b) -> IO b
withLockedDataSourcePtr (DataSource (m,p)) f = withMutex m (f p)

{#pointer LayerH newtype#}

deriving instance Storable LayerH
deriving instance Eq LayerH

nullLayerH :: LayerH
nullLayerH = LayerH nullPtr

newtype (Layer s (t::AccessMode) a) = Layer (Mutex, LayerH)

unLayer :: Layer s t a -> LayerH
unLayer (Layer (_,p)) = p

lMutex :: Layer s t a -> Mutex
lMutex (Layer (m,_)) = m

withLockedLayerPtr
  :: Layer s t a -> (LayerH -> IO b) -> IO b
withLockedLayerPtr (Layer (m,p)) f = withMutex m $ f p

withLockedLayerPtrs
  :: [Layer s t a] -> ([LayerH] -> IO b) -> IO b
withLockedLayerPtrs ls f
  = withMutexes (map lMutex ls) (f (map unLayer ls))

type ROLayer s = Layer s ReadOnly
type RWLayer s = Layer s ReadWrite

{#enum define OGRAccess
  { FALSE  as OGR_ReadOnly
  , TRUE   as OGR_Update
  } deriving (Eq, Show) #}

openReadOnly :: String -> GDAL s (RODataSource s)
openReadOnly p = openWithMode OGR_ReadOnly p

openReadWrite :: String -> GDAL s (RWDataSource s)
openReadWrite p = openWithMode OGR_Update p

openWithMode :: OGRAccess -> String -> GDAL s (DataSource s t)
openWithMode m p = do
  ptr <- liftIO $ withCString p $ \p' ->
           throwIfError "open" ({#call OGROpen as ^#} p' (fromEnumC m) nullPtr)
  newDataSourceHandle ptr `catch` (\NullDataSource ->
    throwM (GDALException CE_Failure OpenFailed "OGROpen returned a NULL ptr"))

newDataSourceHandle :: DataSourceH -> GDAL s (DataSource s t)
newDataSourceHandle p
  | p==nullDataSourceH = throwBindingException NullDataSource
  | otherwise          = do
      registerFinalizer (void ({#call unsafe ReleaseDataSource as ^#} p))
      m <- liftIO newMutex
      return $ DataSource (m,p)

type Driver = String

create :: Driver -> String -> OptionList -> GDAL s (RWDataSource s)
create driverName name options = newDataSourceHandle <=<
  liftIO $ throwIfError "create" $ do
    pDr <- driverByName driverName
    withCString name $ \pName ->
      withOptionList options $ {#call OGR_Dr_CreateDataSource as ^#} pDr pName

createMem :: OptionList -> GDAL s (RWDataSource s)
createMem = create "Memory" ""

driverByName :: String -> IO DriverH
driverByName name = withCString name $ \pName -> do
  drv <- {#call unsafe GetDriverByName as ^#} pName
  if drv == nullDriverH
    then throwBindingException (UnknownDriver name)
    else return drv

{#enum define ApproxOK
  { TRUE as ApproxOK
  , FALSE as StrictOK
  } deriving (Eq, Show) #}

createLayer
  :: RWDataSource s -> FeatureDef -> ApproxOK -> OptionList
  -> GDAL s (RWLayer s a)
createLayer ds FeatureDef{..} approxOk options = liftIO $
  useAsEncodedCString fdName $ \pName ->
  withMaybeSpatialReference (gfdSrs fdGeom) $ \pSrs ->
  withOptionList extendedOptions $ \pOpts ->
  throwIfError "createLayer" $ do
    fpL <- {#call OGR_DS_CreateLayer as ^#} pDs pName pSrs gType pOpts >>=
              newLayerHandle ds NullLayer
    withLockedLayerPtr fpL $ \pL -> do
      V.forM_ fdFields $ \f -> withFieldDefnH f $ \pFld ->
        {#call unsafe OGR_L_CreateField as ^#} pL pFld iApproxOk
      when (not (V.null fdGeoms)) $
        if supportsMultiGeomFields pL
          then
#if MULTI_GEOM_FIELDS
            V.forM_ fdGeoms $ \f -> withGeomFieldDefnH f $ \pGFld ->
              {#call OGR_L_CreateGeomField as ^#} pL pGFld iApproxOk
#else
            error "should never reach here"
#endif
          else throwBindingException CantCreateMultipleGeomFields
      return fpL
  where
    supportsMultiGeomFields pL =
      layerHasCapability pL CreateGeomField &&
      dataSourceHasCapability pDs CreateGeomFieldAfterCreateLayer
    iApproxOk = fromEnumC approxOk
    pDs   = unDataSource ds
    gType = fromEnumC (gfdType fdGeom)
    extendedOptions
      | gfdName fdGeom /= "" = ("GEOMETRY_NAME", gfdName fdGeom):options
      | otherwise            = options

canCreateMultipleGeometryFields :: Bool
canCreateMultipleGeometryFields =
#if MULTI_GEOM_FIELDS
  True
#else
  False
#endif

getLayer :: Int -> DataSource s t -> GDAL s (Layer s t a)
getLayer layer ds = liftIO $
  newLayerHandle ds (InvalidLayerIndex layer) <=<
    throwIfError "getLayer" $ {#call OGR_DS_GetLayer as ^#} dsH lyr
  where
    dsH = unDataSource ds
    lyr = fromIntegral layer

getLayerByName :: Text -> DataSource s t -> GDAL s (Layer s t a)
getLayerByName layer ds = liftIO $ useAsEncodedCString layer $
  newLayerHandle ds (InvalidLayerName layer) <=<
    throwIfError "getLayerByName" .
      {#call OGR_DS_GetLayerByName as ^#} (unDataSource ds)

-- | GDAL < 1.11 only supports 1 geometry field and associates it the layer
layerGeomFieldDef :: LayerH -> IO GeomFieldDef
layerGeomFieldDef p =
  GeomFieldDef
    <$> ({#call unsafe OGR_L_GetGeometryColumn as ^#} p >>= peekEncodedCString)
    <*> liftM toEnumC ({#call unsafe OGR_L_GetGeomType	as ^#} p)
    <*> ({#call unsafe OGR_L_GetSpatialRef as ^#} p >>=
          maybeNewSpatialRefBorrowedHandle)

newLayerHandle
  :: DataSource s t -> OGRException -> LayerH -> IO (Layer s t a)
newLayerHandle (DataSource (m,_)) exc p
  | p==nullLayerH = throwBindingException exc
  | otherwise     = return (Layer (m,p))

layerCount :: DataSource s t -> GDAL s Int
layerCount = liftM fromIntegral
           . liftIO . {#call unsafe OGR_DS_GetLayerCount as ^#} . unDataSource

datasourceName :: DataSource s t -> GDAL s String
datasourceName =
  liftIO . (peekCString <=< {#call unsafe OGR_DS_GetName as ^#} . unDataSource)

data SQLDialect
  = DefaultDialect
  | SqliteDialect
  | OGRDialect
  deriving (Eq, Show, Enum)

withSQLDialect :: SQLDialect -> (CString -> IO a) -> IO a
withSQLDialect DefaultDialect = ($ nullPtr)
withSQLDialect SqliteDialect  = withCString "SQLITE"
withSQLDialect OGRDialect     = withCString "OGRSQL"

executeSQL
  :: SQLDialect -> Text -> Maybe Geometry -> RODataSource s
  -> GDAL s (ROLayer s a)
executeSQL dialect query mSpatialFilter ds@(DataSource (m,dsP)) = do
  p <- catchJust selectExc execute (throwBindingException . SQLQueryError)
  when (p==nullLayerH) $ throwBindingException NullLayer
  registerFinalizer ({#call unsafe OGR_DS_ReleaseResultSet as ^#} dsP p)
  return (Layer (m, p))
  where
    selectExc GDALException{..} | gdalErrNum==AppDefined = Just gdalErrMsg
    selectExc _                                          = Nothing
    execute = liftIO $
      throwIfError "executeSQL" $
      withLockedDataSourcePtr ds $ \dsPtr ->
      withMaybeGeometry mSpatialFilter $ \sFilter ->
      withSQLDialect dialect $ \sDialect ->
      useAsEncodedCString query $ \sQuery ->
        {#call OGR_DS_ExecuteSQL as ^#} dsPtr sQuery sFilter sDialect

layerName :: Layer s t a -> GDAL s Text
layerName =
  liftIO . (peekEncodedCString <=< {#call unsafe OGR_L_GetName as ^#} . unLayer)

layerFeatureDef :: Layer s t a -> GDAL s FeatureDef
layerFeatureDef l = liftIO $ do
  let pL = unLayer l
  gfd <- layerGeomFieldDef pL
  featureDefFromHandle gfd =<< {#call unsafe OGR_L_GetLayerDefn as ^#} pL

getSpatialFilter :: Layer s t a -> GDAL s (Maybe Geometry)
getSpatialFilter l = liftIO $ withLockedLayerPtr l $ \lPtr -> do
  p <- {#call unsafe OGR_L_GetSpatialFilter as ^#} lPtr
  if p == nullPtr
    then return Nothing
    else liftM Just (cloneGeometry p)

setSpatialFilter :: Layer s t a -> Geometry -> GDAL s ()
setSpatialFilter l g = liftIO $
  withLockedLayerPtr l $ \lPtr -> withGeometry g$ \gPtr ->
    {#call unsafe OGR_L_SetSpatialFilter as ^#} lPtr gPtr

data LayerCapability
  = RandomRead
  | SequentialWrite
  | RandomWrite
  | FastSpatialFilter
  | FastFeatureCount
  | FastGetExtent
  | CreateField
  | DeleteField
  | ReorderFields
  | AlterFieldDefn
  | Transactions
  | DeleteFeature
  | FastSetNextByIndex
  | StringsAsUTF8
  | IgnoreFields
  | CreateGeomField
  deriving (Eq, Show, Enum, Bounded)

layerHasCapability :: LayerH -> LayerCapability -> Bool
layerHasCapability l c = unsafePerformIO $ do
  withCString (show c)
    (liftM toBool . {#call unsafe OGR_L_TestCapability as ^#} l)

data DataSourceCapability
  = CreateLayer
  | DeleteLayer
  | CreateGeomFieldAfterCreateLayer
  deriving (Eq, Show, Enum, Bounded)

dataSourceHasCapability :: DataSourceH -> DataSourceCapability -> Bool
dataSourceHasCapability d c = unsafePerformIO $ do
  withCString (show c)
    (liftM toBool . {#call unsafe OGR_DS_TestCapability as ^#} d)

data DriverCapability
  = CreateDataSource
  | DeleteDataSource
  deriving (Eq, Show, Enum, Bounded)

driverHasCapability :: DriverH -> DriverCapability -> Bool
driverHasCapability d c = unsafePerformIO $ do
  withCString (show c)
    (liftM toBool . {#call unsafe OGR_Dr_TestCapability as ^#} d)

{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}

#include "bindings.h"

module GDAL.Internal.OGR (
    DataSource
  , DataSourceH
  , SQLDialect (..)
  , ApproxOK (..)
  , Layer
  , LayerH (..)
  , RODataSource
  , RWDataSource
  , ROLayer
  , RWLayer
  , Driver

  , openReadOnly
  , openReadWrite
  , create
  , createMem
  , canCreateMultipleGeometryFields

  , datasourceName
  , executeSQL

  , createLayer
  , getLayer
  , getLayerByName

  , getSpatialFilter
  , setSpatialFilter

  , layerCount
  , layerName
  , layerFeatureDef

  , registerAll
  , cleanupAll

  , withLockedLayerPtr
  , withLockedLayerPtrs
  , unDataSource
  , unLayer
  , withLockedDataSourcePtr
) where

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

import Data.Text (Text)
import qualified Data.Vector as V

import Control.Applicative ((<$>))
import Control.Monad (liftM, when, void, forM_, (<=<))
import Control.Monad.Catch(throwM, catch, catchJust)
import Control.Monad.IO.Class (MonadIO(liftIO))

import Foreign.C.String (CString, peekCString, withCString)
import Foreign.C.Types (CInt(..), CChar(..))
import Foreign.Ptr (Ptr, nullPtr)
import Foreign.Marshal.Utils (toBool)

import Foreign.Storable (Storable)

import System.IO.Unsafe (unsafePerformIO)

{#import GDAL.Internal.OSR#}
{#import GDAL.Internal.OGRGeometry#}
{#import GDAL.Internal.OGRFeature#}
{#import GDAL.Internal.OGRError#}
{#import GDAL.Internal.CPLString#}
import GDAL.Internal.CPLError hiding (None)
import GDAL.Internal.CPLConv (cplFree)
import GDAL.Internal.Util
import GDAL.Internal.Types

#include "ogr_api.h"

{#fun RegisterAll as ^ {} -> `()'  #}
{#fun CleanupAll  as ^ {} -> `()'  #}

{#pointer OGRSFDriverH as DriverH newtype#}
deriving instance Eq DriverH

nullDriverH :: DriverH
nullDriverH = DriverH nullPtr

{#pointer DataSourceH newtype#}
newtype DataSource s (t::AccessMode) = DataSource (Mutex, DataSourceH)

deriving instance Eq DataSourceH

nullDataSourceH :: DataSourceH
nullDataSourceH = DataSourceH nullPtr

unDataSource :: DataSource s t -> DataSourceH
unDataSource (DataSource (_,p)) = p

type RODataSource s = DataSource s ReadOnly
type RWDataSource s = DataSource s ReadWrite

withLockedDataSourcePtr
  :: DataSource s t -> (DataSourceH -> IO b) -> IO b
withLockedDataSourcePtr (DataSource (m,p)) f = withMutex m (f p)

{#pointer LayerH newtype#}

deriving instance Storable LayerH
deriving instance Eq LayerH

nullLayerH :: LayerH
nullLayerH = LayerH nullPtr

newtype (Layer s (t::AccessMode) a) = Layer (Mutex, LayerH)

unLayer :: Layer s t a -> LayerH
unLayer (Layer (_,p)) = p

lMutex :: Layer s t a -> Mutex
lMutex (Layer (m,_)) = m

withLockedLayerPtr
  :: Layer s t a -> (LayerH -> IO b) -> IO b
withLockedLayerPtr (Layer (m,p)) f = withMutex m $ f p

withLockedLayerPtrs
  :: [Layer s t a] -> ([LayerH] -> IO b) -> IO b
withLockedLayerPtrs ls f
  = withMutexes (map lMutex ls) (f (map unLayer ls))

type ROLayer s = Layer s ReadOnly
type RWLayer s = Layer s ReadWrite

{#enum define OGRAccess
  { FALSE  as OGR_ReadOnly
  , TRUE   as OGR_Update
  } deriving (Eq, Show) #}

openReadOnly :: String -> GDAL s (RODataSource s)
openReadOnly p = openWithMode OGR_ReadOnly p

openReadWrite :: String -> GDAL s (RWDataSource s)
openReadWrite p = openWithMode OGR_Update p

openWithMode :: OGRAccess -> String -> GDAL s (DataSource s t)
openWithMode m p = do
  ptr <- liftIO $ withCString p $ \p' ->
           throwIfError "open" ({#call OGROpen as ^#} p' (fromEnumC m) nullPtr)
  newDataSourceHandle ptr `catch` (\NullDataSource ->
    throwM (GDALException CE_Failure OpenFailed "OGROpen returned a NULL ptr"))

newDataSourceHandle :: DataSourceH -> GDAL s (DataSource s t)
newDataSourceHandle p
  | p==nullDataSourceH = throwBindingException NullDataSource
  | otherwise          = do
      registerFinalizer (void ({#call unsafe ReleaseDataSource as ^#} p))
      m <- liftIO newMutex
      return $ DataSource (m,p)

type Driver = String

create :: Driver -> String -> OptionList -> GDAL s (RWDataSource s)
create driverName name options = newDataSourceHandle <=<
  liftIO $ throwIfError "create" $ do
    pDr <- driverByName driverName
    withCString name $ \pName ->
      withOptionList options $ {#call OGR_Dr_CreateDataSource as ^#} pDr pName

createMem :: OptionList -> GDAL s (RWDataSource s)
createMem = create "Memory" ""

driverByName :: String -> IO DriverH
driverByName name = withCString name $ \pName -> do
  drv <- {#call unsafe GetDriverByName as ^#} pName
  if drv == nullDriverH
    then throwBindingException (UnknownDriver name)
    else return drv

{#enum define ApproxOK
  { TRUE as ApproxOK
  , FALSE as StrictOK
  } deriving (Eq, Show) #}

createLayer
  :: RWDataSource s -> FeatureDef -> ApproxOK -> OptionList
  -> GDAL s (RWLayer s a)
createLayer ds FeatureDef{..} approxOk options = liftIO $
  useAsEncodedCString fdName $ \pName ->
  withMaybeSpatialReference (gfdSrs fdGeom) $ \pSrs ->
  withOptionList extendedOptions $ \pOpts ->
  throwIfError "createLayer" $ do
    fpL <- {#call OGR_DS_CreateLayer as ^#} pDs pName pSrs gType pOpts >>=
              newLayerHandle ds NullLayer
    withLockedLayerPtr fpL $ \pL -> do
      V.forM_ fdFields $ \f -> withFieldDefnH f $ \pFld ->
        {#call unsafe OGR_L_CreateField as ^#} pL pFld iApproxOk
      when (not (V.null fdGeoms)) $
        if supportsMultiGeomFields pL
          then
#if MULTI_GEOM_FIELDS
            V.forM_ fdGeoms $ \f -> withGeomFieldDefnH f $ \pGFld ->
              {#call OGR_L_CreateGeomField as ^#} pL pGFld iApproxOk
#endif
          else throwBindingException CantCreateMultipleGeomFields
      return fpL
  where
    supportsMultiGeomFields pL =
      layerHasCapability pL CreateGeomField &&
      dataSourceHasCapability pDs CreateGeomFieldAfterCreateLayer
    iApproxOk = fromEnumC approxOk
    pDs   = unDataSource ds
    gType = fromEnumC (gfdType fdGeom)
    extendedOptions
      | gfdName fdGeom /= "" = ("GEOMETRY_NAME", gfdName fdGeom):options
      | otherwise            = options

canCreateMultipleGeometryFields :: Bool
canCreateMultipleGeometryFields =
#if MULTI_GEOM_FIELDS
  True
#else
  False
#endif

getLayer :: Int -> DataSource s t -> GDAL s (Layer s t a)
getLayer layer ds = liftIO $
  newLayerHandle ds (InvalidLayerIndex layer) <=<
    throwIfError "getLayer" $ {#call OGR_DS_GetLayer as ^#} dsH lyr
  where
    dsH = unDataSource ds
    lyr = fromIntegral layer

getLayerByName :: Text -> DataSource s t -> GDAL s (Layer s t a)
getLayerByName layer ds = liftIO $ useAsEncodedCString layer $
  newLayerHandle ds (InvalidLayerName layer) <=<
    throwIfError "getLayerByName" .
      {#call OGR_DS_GetLayerByName as ^#} (unDataSource ds)

-- | GDAL < 1.11 only supports 1 geometry field and associates it the layer
layerGeomFieldDef :: LayerH -> IO GeomFieldDef
layerGeomFieldDef p =
  GeomFieldDef
    <$> ({#call unsafe OGR_L_GetGeometryColumn as ^#} p >>= peekEncodedCString)
    <*> liftM toEnumC ({#call unsafe OGR_L_GetGeomType	as ^#} p)
    <*> ({#call unsafe OGR_L_GetSpatialRef as ^#} p >>=
          maybeNewSpatialRefBorrowedHandle)

newLayerHandle
  :: DataSource s t -> OGRException -> LayerH -> IO (Layer s t a)
newLayerHandle (DataSource (m,_)) exc p
  | p==nullLayerH = throwBindingException exc
  | otherwise     = return (Layer (m,p))

layerCount :: DataSource s t -> GDAL s Int
layerCount = liftM fromIntegral
           . liftIO . {#call unsafe OGR_DS_GetLayerCount as ^#} . unDataSource

datasourceName :: DataSource s t -> GDAL s String
datasourceName =
  liftIO . (peekCString <=< {#call unsafe OGR_DS_GetName as ^#} . unDataSource)

data SQLDialect
  = DefaultDialect
  | SqliteDialect
  | OGRDialect
  deriving (Eq, Show, Enum)

withSQLDialect :: SQLDialect -> (CString -> IO a) -> IO a
withSQLDialect DefaultDialect = ($ nullPtr)
withSQLDialect SqliteDialect  = withCString "SQLITE"
withSQLDialect OGRDialect     = withCString "OGRSQL"

executeSQL
  :: SQLDialect -> Text -> Maybe Geometry -> RODataSource s
  -> GDAL s (ROLayer s a)
executeSQL dialect query mSpatialFilter ds@(DataSource (m,dsP)) = do
  p <- catchJust selectExc execute (throwBindingException . SQLQueryError)
  when (p==nullLayerH) $ throwBindingException NullLayer
  registerFinalizer ({#call unsafe OGR_DS_ReleaseResultSet as ^#} dsP p)
  return (Layer (m, p))
  where
    selectExc GDALException{..} | gdalErrNum==AppDefined = Just gdalErrMsg
    selectExc _                                          = Nothing
    execute = liftIO $
      throwIfError "executeSQL" $
      withLockedDataSourcePtr ds $ \dsPtr ->
      withMaybeGeometry mSpatialFilter $ \sFilter ->
      withSQLDialect dialect $ \sDialect ->
      useAsEncodedCString query $ \sQuery ->
        {#call OGR_DS_ExecuteSQL as ^#} dsPtr sQuery sFilter sDialect

layerName :: Layer s t a -> GDAL s Text
layerName =
  liftIO . (peekEncodedCString <=< {#call unsafe OGR_L_GetName as ^#} . unLayer)

layerFeatureDef :: Layer s t a -> GDAL s FeatureDef
layerFeatureDef l = liftIO $ do
  let pL = unLayer l
  gfd <- layerGeomFieldDef pL
  featureDefFromHandle gfd =<< {#call unsafe OGR_L_GetLayerDefn as ^#} pL

getSpatialFilter :: Layer s t a -> GDAL s (Maybe Geometry)
getSpatialFilter l = liftIO $ withLockedLayerPtr l $ \lPtr -> do
  p <- {#call unsafe OGR_L_GetSpatialFilter as ^#} lPtr
  if p == nullPtr
    then return Nothing
    else liftM Just (cloneGeometry p)

setSpatialFilter :: Layer s t a -> Geometry -> GDAL s ()
setSpatialFilter l g = liftIO $
  withLockedLayerPtr l $ \lPtr -> withGeometry g$ \gPtr ->
    {#call unsafe OGR_L_SetSpatialFilter as ^#} lPtr gPtr

data LayerCapability
  = RandomRead
  | SequentialWrite
  | RandomWrite
  | FastSpatialFilter
  | FastFeatureCount
  | FastGetExtent
  | CreateField
  | DeleteField
  | ReorderFields
  | AlterFieldDefn
  | Transactions
  | DeleteFeature
  | FastSetNextByIndex
  | StringsAsUTF8
  | IgnoreFields
  | CreateGeomField
  deriving (Eq, Show, Enum, Bounded)

layerHasCapability :: LayerH -> LayerCapability -> Bool
layerHasCapability l c = unsafePerformIO $ do
  withCString (show c)
    (liftM toBool . {#call unsafe OGR_L_TestCapability as ^#} l)

data DataSourceCapability
  = CreateLayer
  | DeleteLayer
  | CreateGeomFieldAfterCreateLayer
  deriving (Eq, Show, Enum, Bounded)

dataSourceHasCapability :: DataSourceH -> DataSourceCapability -> Bool
dataSourceHasCapability d c = unsafePerformIO $ do
  withCString (show c)
    (liftM toBool . {#call unsafe OGR_DS_TestCapability as ^#} d)

data DriverCapability
  = CreateDataSource
  | DeleteDataSource
  deriving (Eq, Show, Enum, Bounded)

driverHasCapability :: DriverH -> DriverCapability -> Bool
driverHasCapability d c = unsafePerformIO $ do
  withCString (show c)
    (liftM toBool . {#call unsafe OGR_Dr_TestCapability as ^#} d)


free sockaddr_storage after reading candidate addresses

{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Network.Ice.NiceCandidate where

import Network.Socket
import Network.Socket.Internal (peekSockAddr, withSockAddr)
import Foreign.Marshal.Alloc
import Foreign.Ptr
import Foreign.Storable
import Control.Applicative
import Control.Monad
import Foreign.C

#include <nice/agent.h>
#include <marshal.h>

{#context lib="libnice" prefix="nice" #}

{# enum NiceCandidateType as NiceCandidateType {underscoreToCase}
    deriving (Eq, Show, Read, Bounded) #}

{# enum NiceCandidateTransport {underscoreToCase}
    deriving (Eq, Show, Read, Bounded) #}

type NiceAddress = SockAddr
type TurnServer = Ptr ()

data NiceCandidate = NiceCandidate
  { candidateType :: NiceCandidateType
  , candidateTransport :: NiceCandidateTransport
  , address :: SockAddr
  , baseAddress :: SockAddr
  , priority :: Integer
  , streamId :: Int
  , componentId :: Int
  , foundation :: String
  , username :: Maybe String
  , password :: Maybe String
  , turn :: TurnServer
  , sockPtr :: Ptr ()
  } deriving Show

enum :: (Monad m, Integral i, Enum e)  => m i -> m e
enum = liftM $ toEnum . fromIntegral

mbPeekCString p = do
    mbstr <- if p == nullPtr
                 then return Nothing
                 else Just `fmap` peekCString p
    free p
    return mbstr

mbNewCString Nothing = return nullPtr
mbNewCString (Just x) = newCString x

candidateAddress p = do
    addrPtr <- {# call get_candidate_addr #} (castPtr p)
    addr <- peekSockAddr $ castPtr addrPtr
    free addrPtr
    return addr

candidateBaseAddress p = do
    addrPtr <- {# call get_candidate_base_addr #} (castPtr p)
    addr <- peekSockAddr $ castPtr addrPtr
    free addrPtr
    return addr

instance Storable NiceCandidate where
    sizeOf _ = {# sizeof NiceCandidateType #}
    alignment _ = {# alignof NiceCandidateType #}
    peek p = NiceCandidate
               <$> enum ({# get NiceCandidate->type      #} p)
               <*> enum ({# get NiceCandidate->transport #} p)
               <*> candidateAddress p
               <*> candidateBaseAddress p
               <*> (fromIntegral <$> {# get NiceCandidate->priority #} p)
               <*> (fromIntegral <$> {# get NiceCandidate->stream_id #} p)
               <*> (fromIntegral <$> {# get NiceCandidate->component_id #} p)
               <*> (peekCString . castPtr $ p `plusPtr` 76)
               <*> (mbPeekCString =<< {# get NiceCandidate->username #} p)
               <*> (mbPeekCString =<< {# get NiceCandidate->password #} p)
               <*> {# get NiceCandidate->turn #} p
               <*> {# get NiceCandidate->sockptr #} p
    poke p NiceCandidate{..} = do
        {# set NiceCandidate->type #} p . fromIntegral . fromEnum $ candidateType
        {# set NiceCandidate->transport #} p . fromIntegral . fromEnum
            $ candidateTransport
        withSockAddr address $ \pa _ ->
            {# call set_candidate_addr #} (castPtr p) (castPtr pa)
        withSockAddr baseAddress $ \pa _ ->
            {# call set_candidate_base_addr #} (castPtr p) (castPtr pa)
        {# set NiceCandidate->priority #} p $ fromIntegral priority
        {# set NiceCandidate->stream_id #} p $ fromIntegral streamId
        {# set NiceCandidate->component_id #} p $ fromIntegral componentId
        withCString foundation $ \pa ->
            {#call set_foundation #} (castPtr p) (castPtr pa)
        {# set NiceCandidate->username #} p =<< mbNewCString username
        {# set NiceCandidate->password #} p =<< mbNewCString password
        {# set NiceCandidate->turn #} p turn
        {# set NiceCandidate->sockptr #} p sockPtr

{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Network.Ice.NiceCandidate where

import Network.Socket
import Network.Socket.Internal (peekSockAddr, withSockAddr)
import Foreign.Marshal.Alloc
import Foreign.Ptr
import Foreign.Storable
import Control.Applicative
import Control.Monad
import Foreign.C

#include <nice/agent.h>
#include <marshal.h>

{#context lib="libnice" prefix="nice" #}

{# enum NiceCandidateType as NiceCandidateType {underscoreToCase}
    deriving (Eq, Show, Read, Bounded) #}

{# enum NiceCandidateTransport {underscoreToCase}
    deriving (Eq, Show, Read, Bounded) #}

type NiceAddress = SockAddr
type TurnServer = Ptr ()

data NiceCandidate = NiceCandidate
  { candidateType :: NiceCandidateType
  , candidateTransport :: NiceCandidateTransport
  , address :: SockAddr
  , baseAddress :: SockAddr
  , priority :: Integer
  , streamId :: Int
  , componentId :: Int
  , foundation :: String
  , username :: Maybe String
  , password :: Maybe String
  , turn :: TurnServer
  , sockPtr :: Ptr ()
  } deriving Show

enum :: (Monad m, Integral i, Enum e)  => m i -> m e
enum = liftM $ toEnum . fromIntegral

mbPeekCString p = do
    mbstr <- if p == nullPtr
                 then return Nothing
                 else Just `fmap` peekCString p
    free p
    return mbstr

mbNewCString Nothing = return nullPtr
mbNewCString (Just x) = newCString x

instance Storable NiceCandidate where
    sizeOf _ = {# sizeof NiceCandidateType #}
    alignment _ = {# alignof NiceCandidateType #}
    peek p = NiceCandidate
               <$> enum ({# get NiceCandidate->type      #} p)
               <*> enum ({# get NiceCandidate->transport #} p)
               <*> (peekSockAddr . castPtr
                     =<< {# call get_candidate_addr #} (castPtr p))
               <*> (peekSockAddr . castPtr
                     =<< {# call get_candidate_base_addr #} (castPtr p))
               <*> (fromIntegral <$> {# get NiceCandidate->priority #} p)
               <*> (fromIntegral <$> {# get NiceCandidate->stream_id #} p)
               <*> (fromIntegral <$> {# get NiceCandidate->component_id #} p)
               <*> (peekCString . castPtr $ p `plusPtr` 76)
               <*> (mbPeekCString =<< {# get NiceCandidate->username #} p)
               <*> (mbPeekCString =<< {# get NiceCandidate->password #} p)
               <*> {# get NiceCandidate->turn #} p
               <*> {# get NiceCandidate->sockptr #} p
    poke p NiceCandidate{..} = do
        {# set NiceCandidate->type #} p . fromIntegral . fromEnum $ candidateType
        {# set NiceCandidate->transport #} p . fromIntegral . fromEnum
            $ candidateTransport
        withSockAddr address $ \pa _ ->
            {# call set_candidate_addr #} (castPtr p) (castPtr pa)
        withSockAddr baseAddress $ \pa _ ->
            {# call set_candidate_base_addr #} (castPtr p) (castPtr pa)
        {# set NiceCandidate->priority #} p $ fromIntegral priority
        {# set NiceCandidate->stream_id #} p $ fromIntegral streamId
        {# set NiceCandidate->component_id #} p $ fromIntegral componentId
        withCString foundation $ \pa ->
            {#call set_foundation #} (castPtr p) (castPtr pa)
        {# set NiceCandidate->username #} p =<< mbNewCString username
        {# set NiceCandidate->password #} p =<< mbNewCString password
        {# set NiceCandidate->turn #} p turn
        {# set NiceCandidate->sockptr #} p sockPtr


texture instances for 64-bit integral types

Ignore-this: 1e51f6e49dcad054e2864dac16aad7e7

darcs-hash:20100618092454-dcabc-2c5c554b7a5139926262aa46657b95628d90608c.gz

{-# LANGUAGE ForeignFunctionInterface #-}
--------------------------------------------------------------------------------
-- |
-- Module    : Foreign.CUDA.Driver.Texture
-- Copyright : (c) [2009..2010] Trevor L. McDonell
-- License   : BSD
--
-- Texture management for low-level driver interface
--
--------------------------------------------------------------------------------

module Foreign.CUDA.Driver.Texture
  (
    Texture(..), AddressMode(..), FilterMode(..), Format,
    create, destroy,
    getPtr, getAddressMode, getFilterMode,
    setPtr, setAddressMode, setFilterMode, setFormat,

    -- Internal
    peekTex
  )
  where

#include <cuda.h>
{# context lib="cuda" #}

-- Friends
import Foreign.CUDA.Ptr
import Foreign.CUDA.Driver.Error
import Foreign.CUDA.Driver.Marshal
import Foreign.CUDA.Internal.C2HS

-- System
import Foreign
import Foreign.C
import Control.Monad

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

-- |A texture reference
--
newtype Texture a = Texture { useTexture :: {# type CUtexref #}}

instance Storable (Texture a) where
  sizeOf _    = sizeOf    (undefined :: {# type CUtexref #})
  alignment _ = alignment (undefined :: {# type CUtexref #})
  peek p      = Texture `fmap` peek (castPtr p)
  poke p t    = poke (castPtr p) (useTexture t)

-- |Texture reference addressing modes
--
{# enum CUaddress_mode as AddressMode
  { underscoreToCase }
  with prefix="CU_TR_ADDRESS_MODE" deriving (Eq, Show) #}

-- |Texture reference filtering mode
--
{# enum CUfilter_mode as FilterMode
  { underscoreToCase }
  with prefix="CU_TR_FILTER_MODE" deriving (Eq, Show) #}

-- |Texture read mode options
--
#c
typedef enum CUtexture_flag_enum {
  CU_TEXTURE_FLAG_READ_AS_INTEGER        = CU_TRSF_READ_AS_INTEGER,
  CU_TEXTURE_FLAG_NORMALIZED_COORDINATES = CU_TRSF_NORMALIZED_COORDINATES
} CUtexture_flag;
#endc

{# enum CUtexture_flag as ReadMode
  { underscoreToCase }
  with prefix="CU_TEXTURE_FLAG" deriving (Eq, Show) #}

-- |Texture data formats
--
{# enum CUarray_format as TextureFormat
  { }
  with prefix="CU_AD_FORMAT" deriving (Eq, Show) #}

class Format a where
  tag      :: a -> Int
  channels :: a -> Int
  channels _ = 1

instance Format Word   where tag _ = fromEnum UNSIGNED_INT32
instance Format Word8  where tag _ = fromEnum UNSIGNED_INT8
instance Format Word16 where tag _ = fromEnum UNSIGNED_INT16
instance Format Word32 where tag _ = fromEnum UNSIGNED_INT32
instance Format Word64  where
  tag _      = fromEnum UNSIGNED_INT32
  channels _ = 2

instance Format Int    where tag _ = fromEnum SIGNED_INT32
instance Format Int8   where tag _ = fromEnum SIGNED_INT8
instance Format Int16  where tag _ = fromEnum SIGNED_INT16
instance Format Int32  where tag _ = fromEnum SIGNED_INT32
instance Format Int64  where
  tag _      = fromEnum SIGNED_INT32
  channels _ = 2

instance Format Float  where tag _ = fromEnum FLOAT
instance Format Double where
  tag _      = fromEnum SIGNED_INT32
  channels _ = 2
  -- __hiloint2double()

-- FIXME:
--  * half (16-bit float)
--  * vector types
--  * A Int or Word on the GPU is 32-bits, but this may not be the same bitwidth
--    as Haskell-side computations.
--

--------------------------------------------------------------------------------
-- Texture management
--------------------------------------------------------------------------------

-- |Create a new texture reference. Once created, the application must call
-- 'setPtr' to associate the reference with allocated memory. Other texture
-- reference functions are used to specify the format and interpretation to be
-- used when the memory is read through this reference.
--
create :: Format a => IO (Texture a)
create = do
  tex <- resultIfOk =<< cuTexRefCreate
  setFormat tex
  return tex

{# fun unsafe cuTexRefCreate
  { alloca- `Texture a' peekTex* } -> `Status' cToEnum #}

-- |Destroy a texture reference
--
destroy :: Texture a -> IO ()
destroy tex = nothingIfOk =<< cuTexRefDestroy tex

{# fun unsafe cuTexRefDestroy
  { useTexture `Texture a' } -> `Status' cToEnum #}

-- |Get the address associated with a texture reference
--
getPtr :: Texture a -> IO (DevicePtr a)
getPtr tex = resultIfOk =<< cuTexRefGetAddress tex

{# fun unsafe cuTexRefGetAddress
  { alloca-    `DevicePtr a' peekDevPtr*
  , useTexture `Texture a'               } -> `Status' cToEnum #}

-- |Get the addressing mode used by a texture reference, corresponding to the
-- given dimension (currently the only supported dimension values are 0 or 1).
--
getAddressMode :: Texture a -> Int -> IO AddressMode
getAddressMode tex dim = resultIfOk =<< cuTexRefGetAddressMode tex dim

{# fun unsafe cuTexRefGetAddressMode
  { alloca-    `AddressMode' peekEnum*
  , useTexture `Texture a'
  ,            `Int'                  } -> `Status' cToEnum #}

-- |Get the filtering mode used by a texture reference
--
getFilterMode :: Texture a -> IO FilterMode
getFilterMode tex = resultIfOk =<< cuTexRefGetFilterMode tex

{# fun unsafe cuTexRefGetFilterMode
  { alloca-    `FilterMode' peekEnum*
  , useTexture `Texture a'            } -> `Status' cToEnum #}

{-
-- |Get the data format and number of channel components of the bound texture
--
getFormat :: Texture a -> IO (Format, Int)
getFormat tex = do
  (status,fmt,dim) <- cuTexRefGetFormat tex
  resultIfOk (status,(fmt,dim))

{# fun unsafe cuTexRefGetFormat
  { alloca-    `Format'    peekEnum*
  , alloca-    `Int'       peekIntConv*
  , useTexture `Texture a'              } -> `Status' cToEnum #}
-}

-- |Bind a linear array address of the given size (bytes) as a texture
-- reference. Any previously bound references are unbound.
--
setPtr :: Texture a -> DevicePtr a -> Int -> IO ()
setPtr tex dptr bytes = nothingIfOk =<< cuTexRefSetAddress tex dptr bytes

{# fun unsafe cuTexRefSetAddress
  { alloca-         `Int'
  , useTexture      `Texture a'
  , useDeviceHandle `DevicePtr a'
  ,                 `Int'         } -> `Status' cToEnum #}

-- |Specify the addressing mode for the given dimension of a texture reference
--
setAddressMode :: Texture a -> Int -> AddressMode -> IO ()
setAddressMode tex dim mode = nothingIfOk =<< cuTexRefSetAddressMode tex dim mode

{# fun unsafe cuTexRefSetAddressMode
  { useTexture `Texture a'
  ,            `Int'
  , cFromEnum  `AddressMode' } -> `Status' cToEnum #}

-- |Specify the filtering mode to be used when reading memory through a texture
-- reference
--
setFilterMode :: Texture a -> FilterMode -> IO ()
setFilterMode tex mode = nothingIfOk =<< cuTexRefSetFilterMode tex mode

{# fun unsafe cuTexRefSetFilterMode
  { useTexture `Texture a'
  , cFromEnum  `FilterMode' } -> `Status' cToEnum #}

-- |Specify the format of the data to be read by the texture reference
--
setFormat :: Format a => Texture a -> IO ()
setFormat tex = doSet undefined tex
  where
    doSet :: Format b => b -> Texture b -> IO ()
    doSet fmt _ = nothingIfOk =<< cuTexRefSetFormat tex (tag fmt) (channels fmt)

{# fun unsafe cuTexRefSetFormat
  { useTexture `Texture a'
  ,            `Int'
  ,            `Int'       } -> `Status' cToEnum #}

--------------------------------------------------------------------------------
-- Internal
--------------------------------------------------------------------------------

peekTex :: Ptr {# type CUtexref #} -> IO (Texture a)
peekTex = liftM Texture . peek

{-# LANGUAGE ForeignFunctionInterface #-}
--------------------------------------------------------------------------------
-- |
-- Module    : Foreign.CUDA.Driver.Texture
-- Copyright : (c) [2009..2010] Trevor L. McDonell
-- License   : BSD
--
-- Texture management for low-level driver interface
--
--------------------------------------------------------------------------------

module Foreign.CUDA.Driver.Texture
  (
    Texture(..), AddressMode(..), FilterMode(..), Format,
    create, destroy,
    getPtr, getAddressMode, getFilterMode,
    setPtr, setAddressMode, setFilterMode, setFormat,

    -- Internal
    peekTex
  )
  where

#include <cuda.h>
{# context lib="cuda" #}

-- Friends
import Foreign.CUDA.Ptr
import Foreign.CUDA.Driver.Error
import Foreign.CUDA.Driver.Marshal
import Foreign.CUDA.Internal.C2HS

-- System
import Foreign
import Foreign.C
import Control.Monad

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

-- |A texture reference
--
newtype Texture a = Texture { useTexture :: {# type CUtexref #}}

instance Storable (Texture a) where
  sizeOf _    = sizeOf    (undefined :: {# type CUtexref #})
  alignment _ = alignment (undefined :: {# type CUtexref #})
  peek p      = Texture `fmap` peek (castPtr p)
  poke p t    = poke (castPtr p) (useTexture t)

-- |Texture reference addressing modes
--
{# enum CUaddress_mode as AddressMode
  { underscoreToCase }
  with prefix="CU_TR_ADDRESS_MODE" deriving (Eq, Show) #}

-- |Texture reference filtering mode
--
{# enum CUfilter_mode as FilterMode
  { underscoreToCase }
  with prefix="CU_TR_FILTER_MODE" deriving (Eq, Show) #}

-- |Texture read mode options
--
#c
typedef enum CUtexture_flag_enum {
  CU_TEXTURE_FLAG_READ_AS_INTEGER        = CU_TRSF_READ_AS_INTEGER,
  CU_TEXTURE_FLAG_NORMALIZED_COORDINATES = CU_TRSF_NORMALIZED_COORDINATES
} CUtexture_flag;
#endc

{# enum CUtexture_flag as ReadMode
  { underscoreToCase }
  with prefix="CU_TEXTURE_FLAG" deriving (Eq, Show) #}

-- |Texture data formats
--
{# enum CUarray_format as TextureFormat
  { }
  with prefix="CU_AD_FORMAT" deriving (Eq, Show) #}

class Format a where
  tag      :: a -> Int
  channels :: a -> Int
  channels _ = 1

instance Format Word   where tag _ = fromEnum UNSIGNED_INT32
instance Format Word8  where tag _ = fromEnum UNSIGNED_INT8
instance Format Word16 where tag _ = fromEnum UNSIGNED_INT16
instance Format Word32 where tag _ = fromEnum UNSIGNED_INT32

instance Format Int    where tag _ = fromEnum SIGNED_INT32
instance Format Int8   where tag _ = fromEnum SIGNED_INT8
instance Format Int16  where tag _ = fromEnum SIGNED_INT16
instance Format Int32  where tag _ = fromEnum SIGNED_INT32

instance Format Float  where tag _ = fromEnum FLOAT
instance Format Double where
  tag _      = fromEnum SIGNED_INT32
  channels _ = 2
  -- __hiloint2double()

-- FIXME:
--  * half (16-bit float)
--  * vector types
--  * A Int or Word on the GPU is 32-bits, but this may not be the same bitwidth
--    as Haskell-side computations.
--

--------------------------------------------------------------------------------
-- Texture management
--------------------------------------------------------------------------------

-- |Create a new texture reference. Once created, the application must call
-- 'setPtr' to associate the reference with allocated memory. Other texture
-- reference functions are used to specify the format and interpretation to be
-- used when the memory is read through this reference.
--
create :: Format a => IO (Texture a)
create = do
  tex <- resultIfOk =<< cuTexRefCreate
  setFormat tex
  return tex

{# fun unsafe cuTexRefCreate
  { alloca- `Texture a' peekTex* } -> `Status' cToEnum #}

-- |Destroy a texture reference
--
destroy :: Texture a -> IO ()
destroy tex = nothingIfOk =<< cuTexRefDestroy tex

{# fun unsafe cuTexRefDestroy
  { useTexture `Texture a' } -> `Status' cToEnum #}

-- |Get the address associated with a texture reference
--
getPtr :: Texture a -> IO (DevicePtr a)
getPtr tex = resultIfOk =<< cuTexRefGetAddress tex

{# fun unsafe cuTexRefGetAddress
  { alloca-    `DevicePtr a' peekDevPtr*
  , useTexture `Texture a'               } -> `Status' cToEnum #}

-- |Get the addressing mode used by a texture reference, corresponding to the
-- given dimension (currently the only supported dimension values are 0 or 1).
--
getAddressMode :: Texture a -> Int -> IO AddressMode
getAddressMode tex dim = resultIfOk =<< cuTexRefGetAddressMode tex dim

{# fun unsafe cuTexRefGetAddressMode
  { alloca-    `AddressMode' peekEnum*
  , useTexture `Texture a'
  ,            `Int'                  } -> `Status' cToEnum #}

-- |Get the filtering mode used by a texture reference
--
getFilterMode :: Texture a -> IO FilterMode
getFilterMode tex = resultIfOk =<< cuTexRefGetFilterMode tex

{# fun unsafe cuTexRefGetFilterMode
  { alloca-    `FilterMode' peekEnum*
  , useTexture `Texture a'            } -> `Status' cToEnum #}

{-
-- |Get the data format and number of channel components of the bound texture
--
getFormat :: Texture a -> IO (Format, Int)
getFormat tex = do
  (status,fmt,dim) <- cuTexRefGetFormat tex
  resultIfOk (status,(fmt,dim))

{# fun unsafe cuTexRefGetFormat
  { alloca-    `Format'    peekEnum*
  , alloca-    `Int'       peekIntConv*
  , useTexture `Texture a'              } -> `Status' cToEnum #}
-}

-- |Bind a linear array address of the given size (bytes) as a texture
-- reference. Any previously bound references are unbound.
--
setPtr :: Texture a -> DevicePtr a -> Int -> IO ()
setPtr tex dptr bytes = nothingIfOk =<< cuTexRefSetAddress tex dptr bytes

{# fun unsafe cuTexRefSetAddress
  { alloca-         `Int'
  , useTexture      `Texture a'
  , useDeviceHandle `DevicePtr a'
  ,                 `Int'         } -> `Status' cToEnum #}

-- |Specify the addressing mode for the given dimension of a texture reference
--
setAddressMode :: Texture a -> Int -> AddressMode -> IO ()
setAddressMode tex dim mode = nothingIfOk =<< cuTexRefSetAddressMode tex dim mode

{# fun unsafe cuTexRefSetAddressMode
  { useTexture `Texture a'
  ,            `Int'
  , cFromEnum  `AddressMode' } -> `Status' cToEnum #}

-- |Specify the filtering mode to be used when reading memory through a texture
-- reference
--
setFilterMode :: Texture a -> FilterMode -> IO ()
setFilterMode tex mode = nothingIfOk =<< cuTexRefSetFilterMode tex mode

{# fun unsafe cuTexRefSetFilterMode
  { useTexture `Texture a'
  , cFromEnum  `FilterMode' } -> `Status' cToEnum #}

-- |Specify the format of the data to be read by the texture reference
--
setFormat :: Format a => Texture a -> IO ()
setFormat tex = doSet undefined tex
  where
    doSet :: Format b => b -> Texture b -> IO ()
    doSet fmt _ = nothingIfOk =<< cuTexRefSetFormat tex (tag fmt) (channels fmt)

{# fun unsafe cuTexRefSetFormat
  { useTexture `Texture a'
  ,            `Int'
  ,            `Int'       } -> `Status' cToEnum #}

--------------------------------------------------------------------------------
-- Internal
--------------------------------------------------------------------------------

peekTex :: Ptr {# type CUtexref #} -> IO (Texture a)
peekTex = liftM Texture . peek


glade: remove glade/Glade.chs (not sure why this file is here...)

darcs-hash:20090114053423-21862-4b938fd1fcc321c96d6d0da26f13f309bc4badc8.gz

-- GIMP Toolkit (GTK) Binding for Haskell: binding to Libglade   -*-haskell-*-
--    for loading XML widget specifications
--
--  Author : Manuel M T Chakravarty
--  Created: 13 March 2002
--
--  Copyright (c) 2002 Manuel M T Chakravarty
--  Modified 2003 by Duncan Coutts (gtk2hs port)
--
--  This library is free software; you can redistribute it and/or
--  modify it under the terms of the GNU Library General Public
--  License as published by the Free Software Foundation; either
--  version 2 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
--  Library General Public License for more details.
--
-- |
--
--  Libglade facilitates loading of XML specifications of whole widget trees
--  that have been interactively designed with the GUI builder Glade.  The
--  present module exports operations for manipulating 'GladeXML' objects.
--
--  @glade_xml_signal_autoconnect()@ is not supported. The C variant is not
--  suitable for Haskell as @-rdynamic@ leads to huge executable and we
--  usually don't want to connect staticly named functions, but closures.
--
-- * @glade_xml_construct()@ is not bound, as it doesn't seem to be useful
--   in Haskell.  As usual, the @signal_connect_data@ variant for
--   registering signal handlers isn't bound either.  Moreover, the
--   @connect_full@ functions are not bound.
--
-- * This binding does not support Libglade functionality that is
--   exclusively meant for extending Libglade with new widgets.  Like new
--   widgets, such functionality is currently expected to be implemented in
--   C.
--

module Glade (

  -- * Data types
  --
  GladeXMLClass, GladeXML,

  -- * Creation operations
  --
  xmlNew, xmlNewWithRootAndDomain,

  -- * Obtaining widget handles
  --
  xmlGetWidget, xmlGetWidgetRaw

) where

import Monad	(liftM)
import FFI
import GType
import Object   (makeNewObject)
import GObject  (makeNewGObject)
{#import Hierarchy#}
{#import GladeType#}
import GList

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

-- | Create a new XML object (and the corresponding
-- widgets) from the given XML file; corresponds to
-- 'xmlNewWithRootAndDomain', but without the ability to specify a root
-- widget or translation domain.
--
xmlNew :: FilePath -> IO (Maybe GladeXML)
xmlNew file =
  withCString file                $ \strPtr1 -> do
  xmlPtr <- {#call unsafe xml_new#} strPtr1 nullPtr nullPtr
  if xmlPtr==nullPtr then return Nothing
                     else liftM Just $ makeNewGObject mkGladeXML (return xmlPtr)

-- | Create a new GladeXML object (and
-- the corresponding widgets) from the given XML file with an optional
-- root widget and translation domain.
--
-- * If the second argument is not @Nothing@, the interface will only be built
--   from the widget whose name is given.  This feature is useful if you only
--   want to build say a toolbar or menu from the XML file, but not the window
--   it is embedded in.  Note also that the XML parse tree is cached to speed
--   up creating another \'XML\' object for the same file.
--
xmlNewWithRootAndDomain :: FilePath -> Maybe String -> Maybe String -> IO (Maybe GladeXML)
xmlNewWithRootAndDomain file rootWidgetName domain =
  withCString file                $ \strPtr1 ->
  withMaybeCString rootWidgetName $ \strPtr2 ->
  withMaybeCString domain         $ \strPtr3 -> do
  xmlPtr <- {#call unsafe xml_new#} strPtr1 strPtr2 strPtr3
  if xmlPtr==nullPtr then return Nothing
                     else liftM Just $ makeNewGObject mkGladeXML (return xmlPtr)

-- | Get the widget that has the given name in
-- the interface description. If the named widget cannot be found
-- or is of the wrong type the result is an error.
--
-- * the second parameter should be a dynamic cast function that
--   returns the type of object that you expect, eg castToButton
--
-- * the third parameter is the ID of the widget in the glade xml
--   file, eg \"button1\".
--
xmlGetWidget :: (WidgetClass widget) => GladeXML -> (GObject -> widget) -> String -> IO widget
xmlGetWidget xml cast name = do
  maybeWidget <- xmlGetWidgetRaw xml name
  return $ case maybeWidget of
    Just widget -> cast (toGObject widget) --the cast will return an error if the object is of the wrong type
    Nothing -> error $ "glade.xmlGetWidget: no object named " ++ show name ++ " in the glade file"

xmlGetWidgetRaw :: GladeXML -> String -> IO (Maybe Widget)
xmlGetWidgetRaw xml name =
  withCString name $ \strPtr1 -> do
  widgetPtr <- {#call unsafe xml_get_widget#} xml strPtr1
  if widgetPtr==nullPtr then return Nothing
                        else liftM Just $ makeNewObject mkWidget (return widgetPtr)

-- Auxilliary routines
-- -------------------

-- Marshall an optional string
--
withMaybeCString :: Maybe String -> (Ptr CChar -> IO a) -> IO a
withMaybeCString  = maybeWith withCString