{-# LINE 2 "./System/Glib/GObject.chs" #-}
-- -*-haskell-*-
-- GIMP Toolkit (GTK) GObject
--
-- Author : Axel Simon
--
-- Created: 9 April 2001
--
-- Copyright (C) 2001 Axel Simon
--
-- This library is free software; you can redistribute it and/or
-- modify it under the terms of the GNU Lesser General Public
-- License as published by the Free Software Foundation; either
-- version 2.1 of the License, or (at your option) any later version.
--
-- This library is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-- Lesser General Public License for more details.
--
-- |
-- Maintainer : gtk2hs-users@lists.sourceforge.net
-- Stability : provisional
-- Portability : portable (depends on GHC)
--
-- The base object type for all glib objects
--
module System.Glib.GObject (
  -- * Types
  module System.Glib.Types,

  -- * Low level binding functions

  -- | All these functions are internal and are only interesting to people
  -- writing bindings to GObject-style C libraries.
  objectNew,
  objectRef,

  objectRefSink,

  makeNewGObject,
  constructNewGObject,
  wrapNewGObject,

  -- ** GType queries
  gTypeGObject,
  isA,

  -- ** Callback support
  DestroyNotify,
  destroyFunPtr,
  destroyStablePtr,

  -- ** User-Defined Attributes
  Quark,
  quarkFromString,
  objectCreateAttribute,
  objectSetAttribute,
  objectGetAttributeUnsafe
  ) where

import Control.Monad (liftM, when)
import Data.IORef (newIORef, readIORef, writeIORef)
import qualified Data.Text as T (pack)

import System.Glib.FFI
import System.Glib.UTFString
import System.Glib.Types
{-# LINE 69 "./System/Glib/GObject.chs" #-}
import System.Glib.GValue (GValue)
import System.Glib.GType (GType, typeInstanceIsA)
import System.Glib.GTypeConstants ( object )
import System.Glib.GParameter
import System.Glib.Attributes (newNamedAttr, Attr)
import Foreign.StablePtr
import Control.Concurrent.MVar ( MVar, newMVar, modifyMVar )


{-# LINE 78 "./System/Glib/GObject.chs" #-}

type GParm = Ptr (GParameter)
{-# LINE 80 "./System/Glib/GObject.chs" #-}

-- | Construct a new object (should rairly be used directly)
--
objectNew :: GType -> [(String, GValue)] -> IO (Ptr GObject)
objectNew objType parameters =
  liftM castPtr $ --caller must makeNewGObject as we don't know
                  --if it this a GObject or a GtkObject
  withArray (map GParameter parameters) $ \paramArrayPtr ->
  g_object_newv objType
  (fromIntegral $ length parameters) paramArrayPtr


-- | Reference and sink an object.
objectRefSink :: GObjectClass obj => Ptr obj -> IO ()
objectRefSink obj = do
  g_object_ref_sink (castPtr obj)
  return ()


-- | Increase the reference counter of an object
--
objectRef :: GObjectClass obj => Ptr obj -> IO ()
objectRef obj = do
  g_object_ref (castPtr obj)
  return ()

-- | The type constant to check if an instance is of 'GObject' type.
gTypeGObject :: GType
gTypeGObject = object

-- | This function wraps any object that does not derive from Object.
-- It should be used whenever a function returns a pointer to an existing
-- 'GObject' (as opposed to a function that constructs a new object).
--
-- * The first argument is the contructor of the specific object.
--
makeNewGObject ::
    GObjectClass obj
 => (ForeignPtr obj -> obj, FinalizerPtr obj)
    -- ^ constructor for the Haskell object and finalizer C function
 -> IO (Ptr obj) -- ^ action which yields a pointer to the C object
 -> IO obj
makeNewGObject (constr, objectUnref) generator = do
  objPtr <- generator
  when (objPtr == nullPtr) (fail "makeNewGObject: object is NULL")
  objectRef objPtr
  obj <- newForeignPtr objPtr objectUnref
  return $! constr obj

type DestroyNotify = FunPtr (((Ptr ()) -> (IO ())))
{-# LINE 130 "./System/Glib/GObject.chs" #-}

-- | This function wraps any newly created objects that derives from
-- GInitiallyUnowned also known as objects with
-- \"floating-references\". The object will be refSink (for glib
-- versions >= 2.10). On non-floating objects, this function behaves
-- exactly the same as "makeNewGObject".
--
constructNewGObject :: GObjectClass obj =>
  (ForeignPtr obj -> obj, FinalizerPtr obj) -> IO (Ptr obj) -> IO obj
constructNewGObject (constr, objectUnref) generator = do
  objPtr <- generator

  -- change the exisiting floating reference into a proper reference;
  -- the name is confusing, what the function does is ref,sink,unref
  objectRefSink objPtr

  obj <- newForeignPtr objPtr objectUnref
  return $! constr obj

-- | This function wraps any newly created object that does not derived
-- from GInitiallyUnowned (that is a GObject with no floating
-- reference). Since newly created 'GObject's have a reference count of
-- one, they don't need ref'ing.
--
wrapNewGObject :: GObjectClass obj =>
  (ForeignPtr obj -> obj, FinalizerPtr obj) -> IO (Ptr obj) -> IO obj
wrapNewGObject (constr, objectUnref) generator = do
  objPtr <- generator
  when (objPtr == nullPtr) (fail "wrapNewGObject: object is NULL")
  obj <- newForeignPtr objPtr objectUnref
  return $! constr obj

-- | Many methods in classes derived from GObject take a callback function and
-- a destructor function which is called to free that callback function when
-- it is no longer required. This constants is an address of a functions in
-- C land that will free a function pointer.
foreign import ccall unsafe "&freeHaskellFunctionPtr" destroyFunPtr :: DestroyNotify

type Quark = (CUInt)
{-# LINE 169 "./System/Glib/GObject.chs" #-}

-- | A counter for generating unique names.
{-# NOINLINE uniqueCnt #-}
uniqueCnt :: MVar Int
uniqueCnt = unsafePerformIO $ newMVar 0

-- | Create a unique id based on the given string.
quarkFromString :: GlibString string => string -> IO Quark
quarkFromString name = withUTFString name g_quark_from_string
{-# LINE 178 "./System/Glib/GObject.chs" #-}

-- | Add an attribute to this object.
--
-- * The function returns a new attribute that can be set or retrieved from
-- any 'GObject'. The attribute is wrapped in a 'Maybe' type to reflect
-- the circumstance when the attribute is not set or if it should be unset.
--
objectCreateAttribute :: GObjectClass o => IO (Attr o (Maybe a))
objectCreateAttribute = do
  cnt <- modifyMVar uniqueCnt (\cnt -> return (cnt+1, cnt))
  let propName = "Gtk2HsAttr"++show cnt
  attr <- quarkFromString $ T.pack propName
  return (newNamedAttr propName (objectGetAttributeUnsafe attr)
                                (objectSetAttribute attr))

-- | The address of a function freeing a 'StablePtr'. See 'destroyFunPtr'.
foreign import ccall unsafe "&hs_free_stable_ptr" destroyStablePtr :: DestroyNotify

-- | Set the value of an association.
--
objectSetAttribute :: GObjectClass o => Quark -> o -> Maybe a -> IO ()
objectSetAttribute attr obj Nothing = do
  (\(GObject arg1) arg2 arg3 -> withForeignPtr arg1 $ \argPtr1 ->g_object_set_qdata argPtr1 arg2 arg3) (toGObject obj) attr nullPtr
objectSetAttribute attr obj (Just val) = do
  sPtr <- newStablePtr val
  (\(GObject arg1) arg2 arg3 arg4 -> withForeignPtr arg1 $ \argPtr1 ->g_object_set_qdata_full argPtr1 arg2 arg3 arg4) (toGObject obj) attr (castStablePtrToPtr sPtr)
                                 destroyStablePtr

-- | Get the value of an association.
--
-- * Note that this function may crash the Haskell run-time since the
-- returned type can be forced to be anything. See 'objectCreateAttribute'
-- for a safe wrapper around this funciton.
--
objectGetAttributeUnsafe :: GObjectClass o => Quark -> o -> IO (Maybe a)
objectGetAttributeUnsafe attr obj = do
  sPtr <- (\(GObject arg1) arg2 -> withForeignPtr arg1 $ \argPtr1 ->g_object_get_qdata argPtr1 arg2) (toGObject obj) attr
  if sPtr==nullPtr then return Nothing else
    liftM Just $! deRefStablePtr (castPtrToStablePtr sPtr)

-- | Determine if this is an instance of a particular GTK type
--
isA :: GObjectClass o => o -> GType -> Bool
isA obj gType =
        typeInstanceIsA ((unsafeForeignPtrToPtr.castForeignPtr.unGObject.toGObject) obj) gType

-- at this point we would normally implement the notify signal handler;
-- I've moved this definition into the Object class of the gtk package
-- since there's a quite a bit of machinery missing here (generated signal
-- register functions and the problem of recursive modules)

foreign import ccall safe "g_object_newv"
  g_object_newv :: (CULong -> (CUInt -> ((Ptr GParameter) -> (IO (Ptr ())))))

foreign import ccall unsafe "g_object_ref_sink"
  g_object_ref_sink :: ((Ptr ()) -> (IO (Ptr ())))

foreign import ccall unsafe "g_object_ref"
  g_object_ref :: ((Ptr ()) -> (IO (Ptr ())))

foreign import ccall unsafe "g_quark_from_string"
  g_quark_from_string :: ((Ptr CChar) -> (IO CUInt))

foreign import ccall safe "g_object_set_qdata"
  g_object_set_qdata :: ((Ptr GObject) -> (CUInt -> ((Ptr ()) -> (IO ()))))

foreign import ccall safe "g_object_set_qdata_full"
  g_object_set_qdata_full :: ((Ptr GObject) -> (CUInt -> ((Ptr ()) -> ((FunPtr ((Ptr ()) -> (IO ()))) -> (IO ())))))

foreign import ccall unsafe "g_object_get_qdata"
  g_object_get_qdata :: ((Ptr GObject) -> (CUInt -> (IO (Ptr ()))))