{-# 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 :: GType -> [(String, GValue)] -> IO (Ptr GObject)
objectNew GType
objType [(String, GValue)]
parameters =
  (Ptr () -> Ptr GObject) -> IO (Ptr ()) -> IO (Ptr GObject)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Ptr () -> Ptr GObject
forall a b. Ptr a -> Ptr b
castPtr (IO (Ptr ()) -> IO (Ptr GObject))
-> IO (Ptr ()) -> IO (Ptr GObject)
forall a b. (a -> b) -> a -> b
$ --caller must makeNewGObject as we don't know
                  --if it this a GObject or a GtkObject
  [GParameter] -> (Ptr GParameter -> IO (Ptr ())) -> IO (Ptr ())
forall a b. Storable a => [a] -> (Ptr a -> IO b) -> IO b
withArray (((String, GValue) -> GParameter)
-> [(String, GValue)] -> [GParameter]
forall a b. (a -> b) -> [a] -> [b]
map (String, GValue) -> GParameter
GParameter [(String, GValue)]
parameters) ((Ptr GParameter -> IO (Ptr ())) -> IO (Ptr ()))
-> (Ptr GParameter -> IO (Ptr ())) -> IO (Ptr ())
forall a b. (a -> b) -> a -> b
$ \Ptr GParameter
paramArrayPtr ->
  GType -> CUInt -> Ptr GParameter -> IO (Ptr ())
g_object_newv GType
objType
  (Int -> CUInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> CUInt) -> Int -> CUInt
forall a b. (a -> b) -> a -> b
$ [(String, GValue)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(String, GValue)]
parameters) Ptr GParameter
paramArrayPtr


-- | Reference and sink an object.
objectRefSink :: GObjectClass obj => Ptr obj -> IO ()
objectRefSink :: forall obj. GObjectClass obj => Ptr obj -> IO ()
objectRefSink Ptr obj
obj = do
  Ptr () -> IO (Ptr ())
g_object_ref_sink (Ptr obj -> Ptr ()
forall a b. Ptr a -> Ptr b
castPtr Ptr obj
obj)
  () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()


-- | Increase the reference counter of an object
--
objectRef :: GObjectClass obj => Ptr obj -> IO ()
objectRef :: forall obj. GObjectClass obj => Ptr obj -> IO ()
objectRef Ptr obj
obj = do
  Ptr () -> IO (Ptr ())
g_object_ref (Ptr obj -> Ptr ()
forall a b. Ptr a -> Ptr b
castPtr Ptr obj
obj)
  () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | The type constant to check if an instance is of 'GObject' type.
gTypeGObject :: GType
gTypeGObject :: GType
gTypeGObject = GType
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 constructor 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 :: forall obj.
GObjectClass obj =>
(ForeignPtr obj -> obj, FinalizerPtr obj) -> IO (Ptr obj) -> IO obj
makeNewGObject (ForeignPtr obj -> obj
constr, FinalizerPtr obj
objectUnref) IO (Ptr obj)
generator = do
  Ptr obj
objPtr <- IO (Ptr obj)
generator
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Ptr obj
objPtr Ptr obj -> Ptr obj -> Bool
forall a. Eq a => a -> a -> Bool
== Ptr obj
forall a. Ptr a
nullPtr) (String -> IO ()
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"makeNewGObject: object is NULL")
  Ptr obj -> IO ()
forall obj. GObjectClass obj => Ptr obj -> IO ()
objectRef Ptr obj
objPtr
  ForeignPtr obj
obj <- Ptr obj -> FinalizerPtr obj -> IO (ForeignPtr obj)
forall a. Ptr a -> FinalizerPtr a -> IO (ForeignPtr a)
newForeignPtr Ptr obj
objPtr FinalizerPtr obj
objectUnref
  obj -> IO obj
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (obj -> IO obj) -> obj -> IO obj
forall a b. (a -> b) -> a -> b
$! ForeignPtr obj -> obj
constr ForeignPtr obj
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 :: forall obj.
GObjectClass obj =>
(ForeignPtr obj -> obj, FinalizerPtr obj) -> IO (Ptr obj) -> IO obj
constructNewGObject (ForeignPtr obj -> obj
constr, FinalizerPtr obj
objectUnref) IO (Ptr obj)
generator = do
  Ptr obj
objPtr <- IO (Ptr obj)
generator

  -- change the existing floating reference into a proper reference;
  -- the name is confusing, what the function does is ref,sink,unref
  Ptr obj -> IO ()
forall obj. GObjectClass obj => Ptr obj -> IO ()
objectRefSink Ptr obj
objPtr

  ForeignPtr obj
obj <- Ptr obj -> FinalizerPtr obj -> IO (ForeignPtr obj)
forall a. Ptr a -> FinalizerPtr a -> IO (ForeignPtr a)
newForeignPtr Ptr obj
objPtr FinalizerPtr obj
objectUnref
  obj -> IO obj
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (obj -> IO obj) -> obj -> IO obj
forall a b. (a -> b) -> a -> b
$! ForeignPtr obj -> obj
constr ForeignPtr obj
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 :: forall obj.
GObjectClass obj =>
(ForeignPtr obj -> obj, FinalizerPtr obj) -> IO (Ptr obj) -> IO obj
wrapNewGObject (ForeignPtr obj -> obj
constr, FinalizerPtr obj
objectUnref) IO (Ptr obj)
generator = do
  Ptr obj
objPtr <- IO (Ptr obj)
generator
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Ptr obj
objPtr Ptr obj -> Ptr obj -> Bool
forall a. Eq a => a -> a -> Bool
== Ptr obj
forall a. Ptr a
nullPtr) (String -> IO ()
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"wrapNewGObject: object is NULL")
  ForeignPtr obj
obj <- Ptr obj -> FinalizerPtr obj -> IO (ForeignPtr obj)
forall a. Ptr a -> FinalizerPtr a -> IO (ForeignPtr a)
newForeignPtr Ptr obj
objPtr FinalizerPtr obj
objectUnref
  obj -> IO obj
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (obj -> IO obj) -> obj -> IO obj
forall a b. (a -> b) -> a -> b
$! ForeignPtr obj -> obj
constr ForeignPtr obj
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 :: MVar Int
uniqueCnt = IO (MVar Int) -> MVar Int
forall a. IO a -> a
unsafePerformIO (IO (MVar Int) -> MVar Int) -> IO (MVar Int) -> MVar Int
forall a b. (a -> b) -> a -> b
$ Int -> IO (MVar Int)
forall a. a -> IO (MVar a)
newMVar Int
0

-- | Create a unique id based on the given string.
quarkFromString :: GlibString string => string -> IO Quark
quarkFromString :: forall string. GlibString string => string -> IO CUInt
quarkFromString string
name = string -> (CString -> IO CUInt) -> IO CUInt
forall a. string -> (CString -> IO a) -> IO a
forall s a. GlibString s => s -> (CString -> IO a) -> IO a
withUTFString string
name CString -> IO CUInt
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 :: forall o a. GObjectClass o => IO (Attr o (Maybe a))
objectCreateAttribute = do
  Int
cnt <- MVar Int -> (Int -> IO (Int, Int)) -> IO Int
forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar MVar Int
uniqueCnt (\Int
cnt -> (Int, Int) -> IO (Int, Int)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
cntInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1, Int
cnt))
  let propName :: String
propName = String
"Gtk2HsAttr"String -> String -> String
forall a. [a] -> [a] -> [a]
++Int -> String
forall a. Show a => a -> String
show Int
cnt
  CUInt
attr <- Text -> IO CUInt
forall string. GlibString string => string -> IO CUInt
quarkFromString (Text -> IO CUInt) -> Text -> IO CUInt
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
propName
  Attr o (Maybe a) -> IO (Attr o (Maybe a))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (String
-> (o -> IO (Maybe a))
-> (o -> Maybe a -> IO ())
-> Attr o (Maybe a)
forall o a b.
String -> (o -> IO a) -> (o -> b -> IO ()) -> ReadWriteAttr o a b
newNamedAttr String
propName (CUInt -> o -> IO (Maybe a)
forall o a. GObjectClass o => CUInt -> o -> IO (Maybe a)
objectGetAttributeUnsafe CUInt
attr)
                                (CUInt -> o -> Maybe a -> IO ()
forall o a. GObjectClass o => CUInt -> o -> Maybe a -> IO ()
objectSetAttribute CUInt
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 :: forall o a. GObjectClass o => CUInt -> o -> Maybe a -> IO ()
objectSetAttribute CUInt
attr o
obj Maybe a
Nothing = do
  (\(GObject ForeignPtr GObject
arg1) CUInt
arg2 Ptr ()
arg3 -> ForeignPtr GObject -> (Ptr GObject -> IO ()) -> IO ()
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr GObject
arg1 ((Ptr GObject -> IO ()) -> IO ())
-> (Ptr GObject -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr GObject
argPtr1 ->Ptr GObject -> CUInt -> Ptr () -> IO ()
g_object_set_qdata Ptr GObject
argPtr1 CUInt
arg2 Ptr ()
arg3) (o -> GObject
forall o. GObjectClass o => o -> GObject
toGObject o
obj) CUInt
attr Ptr ()
forall a. Ptr a
nullPtr
objectSetAttribute CUInt
attr o
obj (Just a
val) = do
  StablePtr a
sPtr <- a -> IO (StablePtr a)
forall a. a -> IO (StablePtr a)
newStablePtr a
val
  (\(GObject ForeignPtr GObject
arg1) CUInt
arg2 Ptr ()
arg3 FunPtr (Ptr () -> IO ())
arg4 -> ForeignPtr GObject -> (Ptr GObject -> IO ()) -> IO ()
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr GObject
arg1 ((Ptr GObject -> IO ()) -> IO ())
-> (Ptr GObject -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr GObject
argPtr1 ->Ptr GObject -> CUInt -> Ptr () -> FunPtr (Ptr () -> IO ()) -> IO ()
g_object_set_qdata_full Ptr GObject
argPtr1 CUInt
arg2 Ptr ()
arg3 FunPtr (Ptr () -> IO ())
arg4) (o -> GObject
forall o. GObjectClass o => o -> GObject
toGObject o
obj) CUInt
attr (StablePtr a -> Ptr ()
forall a. StablePtr a -> Ptr ()
castStablePtrToPtr StablePtr a
sPtr)
                                 FunPtr (Ptr () -> IO ())
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 function.
--
objectGetAttributeUnsafe :: GObjectClass o => Quark -> o -> IO (Maybe a)
objectGetAttributeUnsafe :: forall o a. GObjectClass o => CUInt -> o -> IO (Maybe a)
objectGetAttributeUnsafe CUInt
attr o
obj = do
  Ptr ()
sPtr <- (\(GObject ForeignPtr GObject
arg1) CUInt
arg2 -> ForeignPtr GObject -> (Ptr GObject -> IO (Ptr ())) -> IO (Ptr ())
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr GObject
arg1 ((Ptr GObject -> IO (Ptr ())) -> IO (Ptr ()))
-> (Ptr GObject -> IO (Ptr ())) -> IO (Ptr ())
forall a b. (a -> b) -> a -> b
$ \Ptr GObject
argPtr1 ->Ptr GObject -> CUInt -> IO (Ptr ())
g_object_get_qdata Ptr GObject
argPtr1 CUInt
arg2) (o -> GObject
forall o. GObjectClass o => o -> GObject
toGObject o
obj) CUInt
attr
  if Ptr ()
sPtrPtr () -> Ptr () -> Bool
forall a. Eq a => a -> a -> Bool
==Ptr ()
forall a. Ptr a
nullPtr then Maybe a -> IO (Maybe a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing else
    (a -> Maybe a) -> IO a -> IO (Maybe a)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM a -> Maybe a
forall a. a -> Maybe a
Just (IO a -> IO (Maybe a)) -> IO a -> IO (Maybe a)
forall a b. (a -> b) -> a -> b
$! StablePtr a -> IO a
forall a. StablePtr a -> IO a
deRefStablePtr (Ptr () -> StablePtr a
forall a. Ptr () -> StablePtr a
castPtrToStablePtr Ptr ()
sPtr)

-- | Determine if this is an instance of a particular GTK type
--
isA :: GObjectClass o => o -> GType -> Bool
isA :: forall o. GObjectClass o => o -> GType -> Bool
isA o
obj GType
gType =
        Ptr () -> GType -> Bool
typeInstanceIsA ((ForeignPtr () -> Ptr ()
forall a. ForeignPtr a -> Ptr a
unsafeForeignPtrToPtr(ForeignPtr () -> Ptr ()) -> (o -> ForeignPtr ()) -> o -> Ptr ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
.ForeignPtr GObject -> ForeignPtr ()
forall a b. ForeignPtr a -> ForeignPtr b
castForeignPtr(ForeignPtr GObject -> ForeignPtr ())
-> (o -> ForeignPtr GObject) -> o -> ForeignPtr ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
.GObject -> ForeignPtr GObject
unGObject(GObject -> ForeignPtr GObject)
-> (o -> GObject) -> o -> ForeignPtr GObject
forall b c a. (b -> c) -> (a -> b) -> a -> c
.o -> GObject
forall o. GObjectClass o => o -> GObject
toGObject) o
obj) GType
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 ()))))