{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DataKinds, TypeFamilies #-}
module Data.GI.Base.GValue
    (
    -- * Constructing GValues
      GValue(..)
    , IsGValue(..)
    , GValueConstruct(..)

    , newGValue
    , buildGValue
    , disownGValue
    , noGValue
    , newGValueFromPtr
    , wrapGValuePtr
    , unsetGValue

    -- * Packing GValues into arrays
    , packGValueArray
    , unpackGValueArrayWithLength
    , mapGValueArrayWithLength

    -- * Setters and getters
    , set_string
    , get_string
    , set_pointer
    , get_pointer
    , set_int
    , get_int
    , set_uint
    , get_uint
    , set_long
    , get_long
    , set_ulong
    , get_ulong
    , set_int32
    , get_int32
    , set_uint32
    , get_uint32
    , set_int64
    , get_int64
    , set_uint64
    , get_uint64
    , set_float
    , get_float
    , set_double
    , get_double
    , set_boolean
    , get_boolean
    , set_gtype
    , get_gtype
    , set_object
    , get_object
    , set_boxed
    , get_boxed
    , set_variant
    , get_variant
    , set_enum
    , get_enum
    , set_flags
    , get_flags
    , set_stablePtr
    , get_stablePtr
    , take_stablePtr
    ) where

#include <glib-object.h>

import Data.Coerce (coerce)
import Data.Word
import Data.Int
import Data.Text (Text, pack, unpack)

import Foreign.C.Types (CInt(..), CUInt(..), CFloat(..), CDouble(..),
                        CLong(..), CULong(..))
import Foreign.C.String (CString)
import Foreign.Ptr (Ptr, nullPtr, plusPtr)
import Foreign.StablePtr (StablePtr, castStablePtrToPtr, castPtrToStablePtr)

import Data.GI.Base.BasicTypes
import Data.GI.Base.BasicConversions (cstringToText, textToCString)
import Data.GI.Base.GType
import Data.GI.Base.ManagedPtr
import Data.GI.Base.Overloading (HasParentTypes, ParentTypes)
import Data.GI.Base.Utils (callocBytes, freeMem)

-- | Haskell-side representation of a @GValue@.
newtype GValue = GValue (ManagedPtr GValue)

-- | A convenience alias for @`Nothing` :: `Maybe` `GValue`@.
noGValue :: Maybe GValue
noGValue = Nothing

foreign import ccall unsafe "g_value_get_type" c_g_value_get_type ::
    IO GType

-- | There are no types in the bindings that a `GValue` can be safely
-- cast to.
type instance ParentTypes GValue = '[]
instance HasParentTypes GValue

-- | Find the associated `GType` for `GValue`.
instance TypedObject GValue where
  glibType = c_g_value_get_type

-- | `GValue`s are registered as boxed in the GLib type system.
instance GBoxed GValue

foreign import ccall "g_value_init" g_value_init ::
    Ptr GValue -> CGType -> IO (Ptr GValue)

-- | A type holding a `GValue` with an associated label. It is
-- parameterized by a phantom type encoding the target type for the
-- `GValue` (useful when constructing properties).
data GValueConstruct o = GValueConstruct String GValue

-- | Build a new, empty, `GValue` of the given type.
newGValue :: GType -> IO GValue
newGValue (GType gtype) = do
  gvptr <- callocBytes (#size GValue)
  _ <- g_value_init gvptr gtype
  gv <- wrapBoxed GValue gvptr
  return $! gv

-- | Take ownership of a passed in 'Ptr'.
wrapGValuePtr :: Ptr GValue -> IO GValue
wrapGValuePtr ptr = wrapBoxed GValue ptr

-- | Construct a Haskell wrapper for the given 'GValue', making a
-- copy.
newGValueFromPtr :: Ptr GValue -> IO GValue
newGValueFromPtr ptr = newBoxed GValue ptr

-- | A convenience function for building a new GValue and setting the
-- initial value.
buildGValue :: GType -> (GValue -> a -> IO ()) -> a -> IO GValue
buildGValue gtype setter val = do
  gv <- newGValue gtype
  setter gv val
  return gv

-- | Disown a `GValue`, i.e. do not unref the underlying object when
-- the Haskell object is garbage collected.
disownGValue :: GValue -> IO (Ptr GValue)
disownGValue = disownManagedPtr

foreign import ccall "g_value_unset" g_value_unset :: Ptr GValue -> IO ()

-- | Unset the `GValue`, freeing all resources associated to it.
unsetGValue :: Ptr GValue -> IO ()
unsetGValue = g_value_unset

-- | A convenience class for marshaling back and forth between Haskell
-- values and `GValue`s.
class IsGValue a where
    toGValue :: a -> IO GValue
    fromGValue :: GValue -> IO a

instance IsGValue (Maybe String) where
    toGValue = buildGValue gtypeString set_string . fmap pack
    fromGValue v = (fmap unpack) <$> get_string v

instance IsGValue (Maybe Text) where
    toGValue = buildGValue gtypeString set_string
    fromGValue = get_string

instance IsGValue (Ptr a) where
    toGValue = buildGValue gtypePointer set_pointer
    fromGValue = get_pointer

instance IsGValue Int32 where
    toGValue = buildGValue gtypeInt set_int32
    fromGValue = get_int32

instance IsGValue Word32 where
    toGValue = buildGValue gtypeUInt set_uint32
    fromGValue = get_uint32

instance IsGValue CInt where
    toGValue = buildGValue gtypeInt set_int
    fromGValue = get_int

instance IsGValue CUInt where
    toGValue = buildGValue gtypeUInt set_uint
    fromGValue = get_uint

instance IsGValue CLong where
    toGValue = buildGValue gtypeLong set_long
    fromGValue = get_long

instance IsGValue CULong where
    toGValue = buildGValue gtypeULong set_ulong
    fromGValue = get_ulong

instance IsGValue Int64 where
    toGValue = buildGValue gtypeInt64 set_int64
    fromGValue = get_int64

instance IsGValue Word64 where
    toGValue = buildGValue gtypeUInt64 set_uint64
    fromGValue = get_uint64

instance IsGValue Float where
    toGValue = buildGValue gtypeFloat set_float
    fromGValue = get_float

instance IsGValue Double where
    toGValue = buildGValue gtypeDouble set_double
    fromGValue = get_double

instance IsGValue Bool where
    toGValue = buildGValue gtypeBoolean set_boolean
    fromGValue = get_boolean

instance IsGValue GType where
    toGValue = buildGValue gtypeGType set_gtype
    fromGValue = get_gtype

instance IsGValue (StablePtr a) where
    toGValue = buildGValue gtypeStablePtr set_stablePtr
    fromGValue = get_stablePtr

foreign import ccall "g_value_set_string" _set_string ::
    Ptr GValue -> CString -> IO ()
foreign import ccall "g_value_get_string" _get_string ::
    Ptr GValue -> IO CString

set_string :: GValue -> Maybe Text -> IO ()
set_string gv maybeStr =
    withManagedPtr gv $ \ptr -> do
      cstr <- case maybeStr of
                Just str -> textToCString str
                Nothing -> return nullPtr
      _set_string ptr cstr
      freeMem cstr

get_string :: GValue -> IO (Maybe Text)
get_string gv = withManagedPtr gv $ \gvptr -> do
                  cstr <- _get_string gvptr
                  if cstr /= nullPtr
                  then Just <$> cstringToText cstr
                  else return Nothing

foreign import ccall unsafe "g_value_set_pointer" _set_pointer ::
    Ptr GValue -> Ptr a -> IO ()
foreign import ccall unsafe "g_value_get_pointer" _get_pointer ::
    Ptr GValue -> IO (Ptr b)

set_pointer :: GValue -> Ptr a -> IO ()
set_pointer gv ptr = withManagedPtr gv $ flip _set_pointer ptr

get_pointer :: GValue -> IO (Ptr b)
get_pointer gv = withManagedPtr gv _get_pointer

foreign import ccall unsafe "g_value_set_int" _set_int ::
    Ptr GValue -> CInt -> IO ()
foreign import ccall unsafe "g_value_get_int" _get_int ::
    Ptr GValue -> IO CInt

set_int32 :: GValue -> Int32 -> IO ()
set_int32 gv n = withManagedPtr gv $ flip _set_int (coerce n)

get_int32 :: GValue -> IO Int32
get_int32 gv = coerce <$> withManagedPtr gv _get_int

set_int :: GValue -> CInt -> IO ()
set_int gv n = withManagedPtr gv $ flip _set_int n

get_int :: GValue -> IO CInt
get_int gv = withManagedPtr gv _get_int

foreign import ccall unsafe "g_value_set_uint" _set_uint ::
    Ptr GValue -> CUInt -> IO ()
foreign import ccall unsafe "g_value_get_uint" _get_uint ::
    Ptr GValue -> IO CUInt

set_uint32 :: GValue -> Word32 -> IO ()
set_uint32 gv n = withManagedPtr gv $ flip _set_uint (coerce n)

get_uint32 :: GValue -> IO Word32
get_uint32 gv = coerce <$> withManagedPtr gv _get_uint

set_uint :: GValue -> CUInt -> IO ()
set_uint gv n = withManagedPtr gv $ flip _set_uint n

get_uint :: GValue -> IO CUInt
get_uint gv = withManagedPtr gv _get_uint

foreign import ccall unsafe "g_value_set_long" _set_long ::
    Ptr GValue -> CLong -> IO ()
foreign import ccall unsafe "g_value_get_long" _get_long ::
    Ptr GValue -> IO CLong

set_long :: GValue -> CLong -> IO ()
set_long gv n = withManagedPtr gv $ flip _set_long n

get_long :: GValue -> IO CLong
get_long gv = withManagedPtr gv _get_long

foreign import ccall unsafe "g_value_set_ulong" _set_ulong ::
    Ptr GValue -> CULong -> IO ()
foreign import ccall unsafe "g_value_get_ulong" _get_ulong ::
    Ptr GValue -> IO CULong

set_ulong :: GValue -> CULong -> IO ()
set_ulong gv n = withManagedPtr gv $ flip _set_ulong n

get_ulong :: GValue -> IO CULong
get_ulong gv = withManagedPtr gv _get_ulong

foreign import ccall unsafe "g_value_set_int64" _set_int64 ::
    Ptr GValue -> Int64 -> IO ()
foreign import ccall unsafe "g_value_get_int64" _get_int64 ::
    Ptr GValue -> IO Int64

set_int64 :: GValue -> Int64 -> IO ()
set_int64 gv n = withManagedPtr gv $ flip _set_int64 n

get_int64 :: GValue -> IO Int64
get_int64 gv = withManagedPtr gv _get_int64

foreign import ccall unsafe "g_value_set_uint64" _set_uint64 ::
    Ptr GValue -> Word64 -> IO ()
foreign import ccall unsafe "g_value_get_uint64" _get_uint64 ::
    Ptr GValue -> IO Word64

set_uint64 :: GValue -> Word64 -> IO ()
set_uint64 gv n = withManagedPtr gv $ flip _set_uint64 n

get_uint64 :: GValue -> IO Word64
get_uint64 gv = withManagedPtr gv _get_uint64

foreign import ccall unsafe "g_value_set_float" _set_float ::
    Ptr GValue -> CFloat -> IO ()
foreign import ccall unsafe "g_value_get_float" _get_float ::
    Ptr GValue -> IO CFloat

set_float :: GValue -> Float -> IO ()
set_float gv f = withManagedPtr gv $ flip _set_float (realToFrac f)

get_float :: GValue -> IO Float
get_float gv = realToFrac <$> withManagedPtr gv _get_float

foreign import ccall unsafe "g_value_set_double" _set_double ::
    Ptr GValue -> CDouble -> IO ()
foreign import ccall unsafe "g_value_get_double" _get_double ::
    Ptr GValue -> IO CDouble

set_double :: GValue -> Double -> IO ()
set_double gv d = withManagedPtr gv $ flip _set_double (realToFrac d)

get_double :: GValue -> IO Double
get_double gv = realToFrac <$> withManagedPtr gv _get_double

foreign import ccall unsafe "g_value_set_boolean" _set_boolean ::
    Ptr GValue -> CInt -> IO ()
foreign import ccall unsafe "g_value_get_boolean" _get_boolean ::
    Ptr GValue -> IO CInt

set_boolean :: GValue -> Bool -> IO ()
set_boolean gv b = withManagedPtr gv $ \ptr ->
                   _set_boolean ptr (fromIntegral $ fromEnum b)

get_boolean :: GValue -> IO Bool
get_boolean gv = withManagedPtr gv $ \ptr -> (/= 0) <$> _get_boolean ptr

foreign import ccall unsafe "g_value_set_gtype" _set_gtype ::
    Ptr GValue -> CGType -> IO ()
foreign import ccall unsafe "g_value_get_gtype" _get_gtype ::
    Ptr GValue -> IO CGType

set_gtype :: GValue -> GType -> IO ()
set_gtype gv (GType g) = withManagedPtr gv $ \ptr -> _set_gtype ptr g

get_gtype :: GValue -> IO GType
get_gtype gv = GType <$> withManagedPtr gv _get_gtype

foreign import ccall "g_value_set_object" _set_object ::
    Ptr GValue -> Ptr a -> IO ()
foreign import ccall "g_value_get_object" _get_object ::
    Ptr GValue -> IO (Ptr a)

set_object :: GObject a => GValue -> Ptr a -> IO ()
set_object gv o = withManagedPtr gv $ flip _set_object o

get_object :: GObject b => GValue -> IO (Ptr b)
get_object gv = withManagedPtr gv _get_object

foreign import ccall "g_value_set_boxed" _set_boxed ::
    Ptr GValue -> Ptr a -> IO ()
foreign import ccall "g_value_get_boxed" _get_boxed ::
    Ptr GValue -> IO (Ptr b)

set_boxed :: GValue -> Ptr a -> IO ()
set_boxed gv b = withManagedPtr gv $ flip _set_boxed b

get_boxed :: GValue -> IO (Ptr b)
get_boxed gv = withManagedPtr gv _get_boxed

foreign import ccall "g_value_set_variant" _set_variant ::
    Ptr GValue -> Ptr GVariant -> IO ()
foreign import ccall "g_value_get_variant" _get_variant ::
    Ptr GValue -> IO (Ptr GVariant)

set_variant :: GValue -> Ptr GVariant -> IO ()
set_variant gv v = withManagedPtr gv $ flip _set_variant v

get_variant :: GValue -> IO (Ptr GVariant)
get_variant gv = withManagedPtr gv _get_variant

foreign import ccall unsafe "g_value_set_enum" _set_enum ::
    Ptr GValue -> CUInt -> IO ()
foreign import ccall unsafe "g_value_get_enum" _get_enum ::
    Ptr GValue -> IO CUInt

set_enum :: GValue -> CUInt -> IO ()
set_enum gv e = withManagedPtr gv $ flip _set_enum e

get_enum :: GValue -> IO CUInt
get_enum gv = withManagedPtr gv _get_enum

foreign import ccall unsafe "g_value_set_flags" _set_flags ::
    Ptr GValue -> CUInt -> IO ()
foreign import ccall unsafe "g_value_get_flags" _get_flags ::
    Ptr GValue -> IO CUInt

set_flags :: GValue -> CUInt -> IO ()
set_flags gv f = withManagedPtr gv $ flip _set_flags f

get_flags :: GValue -> IO CUInt
get_flags gv = withManagedPtr gv _get_flags

-- | Set the value of `GValue` containing a `StablePtr`
set_stablePtr :: GValue -> StablePtr a -> IO ()
set_stablePtr gv ptr = withManagedPtr gv $ flip _set_boxed (castStablePtrToPtr ptr)

foreign import ccall g_value_take_boxed :: Ptr GValue -> StablePtr a -> IO ()

-- | Like `set_stablePtr`, but the `GValue` takes ownership of the `StablePtr`
take_stablePtr :: Ptr GValue -> StablePtr a -> IO ()
take_stablePtr = g_value_take_boxed

-- | Get the value of a `GValue` containing a `StablePtr`
get_stablePtr :: GValue -> IO (StablePtr a)
get_stablePtr gv = castPtrToStablePtr <$> withManagedPtr gv _get_boxed

foreign import ccall g_value_copy :: Ptr GValue -> Ptr GValue -> IO ()
foreign import ccall "_haskell_gi_g_value_get_type" g_value_get_type :: Ptr GValue -> IO CGType

-- | Pack the given list of GValues contiguously into a C array
packGValueArray :: [GValue] -> IO (Ptr GValue)
packGValueArray gvalues = withManagedPtrList gvalues $ \ptrs -> do
  let nitems = length ptrs
  mem <- callocBytes $ #{size GValue} * nitems
  fill mem ptrs
  return mem
  where fill :: Ptr GValue -> [Ptr GValue] -> IO ()
        fill _ [] = return ()
        fill ptr (x:xs) = do
          gtype <- g_value_get_type x
          _ <- g_value_init ptr gtype
          g_value_copy x ptr
          fill (ptr `plusPtr` #{size GValue}) xs

-- | Unpack an array of contiguous GValues into a list of GValues.
unpackGValueArrayWithLength :: Integral a =>
                               a -> Ptr GValue -> IO [GValue]
unpackGValueArrayWithLength nitems gvalues = go (fromIntegral nitems) gvalues
  where go :: Int -> Ptr GValue -> IO [GValue]
        go 0 _ = return []
        go n ptr = do
          gv <- callocBytes #{size GValue}
          gtype <- g_value_get_type ptr
          _ <- g_value_init gv gtype
          g_value_copy ptr gv
          wrapped <- wrapGValuePtr gv
          (wrapped :) <$> go (n-1) (ptr `plusPtr` #{size GValue})

-- | Map over the `GValue`s inside a C array.
mapGValueArrayWithLength :: Integral a =>
                            a -> (Ptr GValue -> IO c) -> Ptr GValue -> IO ()
mapGValueArrayWithLength nvalues f arrayPtr
  | (arrayPtr == nullPtr) = return ()
  | (nvalues <= 0) = return ()
  | otherwise = go (fromIntegral nvalues) arrayPtr
  where go :: Int -> Ptr GValue -> IO ()
        go 0 _ = return ()
        go n ptr = do
          _ <- f ptr
          go (n-1) (ptr `plusPtr` #{size GValue})