{-# LANGUAGE ForeignFunctionInterface #-}

{-# LINE 2 "./System/XFCE/Xfconf/Values.chs" #-}
-- we want to be able to write "instance Foobar String where"
{-# LANGUAGE TypeSynonymInstances #-}

{-# LINE 4 "./System/XFCE/Xfconf/Values.chs" #-}
{-# LANGUAGE FlexibleInstances #-}

{-# LINE 5 "./System/XFCE/Xfconf/Values.chs" #-}
-- we want to be able to write "instance Foobar String where"
-- ... and "instance Foobar a => Foobar [a] where"
{-# LANGUAGE OverlappingInstances #-}

{-# LINE 8 "./System/XFCE/Xfconf/Values.chs" #-}

-- vim:filetype=haskell:


{- This module provides generic 'XfconfValue' data types and specific
   GObject types used by the Xfconf daemon.

   For more information, see:
   http:\/\/docs.xfce.org\/api\/xfconf\/xfconf-xfconf-types.html
-}


-- Gtk2hs ignore #include<foobar> instructions
-- I let them here, because they are pretty.





{-# LINE 27 "./System/XFCE/Xfconf/Values.chs" #-}

module System.XFCE.Xfconf.Values (
        -- * Generic XfconfValue
        XfconfValue(..),
        XfconfValueClass(toXfconfValue),

        -- * Additional GValue type
        -- $additionalTypes
        int16,
        valueGetInt16,
        valueSetInt16,
        uint16,
        valueGetUInt16,
        valueSetUInt16,

        -- * Array hack
        -- $arrayHack
        array,
        allocaGValueArray
        ) where

import Control.Monad (forM, forM_, replicateM)

import System.Glib.GType
import System.Glib.GValue
{-# LINE 52 "./System/XFCE/Xfconf/Values.chs" #-}
import System.Glib.GValueTypes
import System.Glib.GTypeConstants

import System.XFCE.Xfconf.FFI

data XfconfValue = XfconfString String
                 | XfconfStringList [String]
                 | XfconfInt Int32
                 | XfconfUInt Word32
                 | XfconfInt16 Int16
                 | XfconfUInt16 Word16
                 | XfconfUInt64 Word64
                 | XfconfDouble Double
                 | XfconfBool Bool
                 | XfconfArray [XfconfValue]
                 | XfconfNotImplemented GType
                 deriving (Eq, Show)

class XfconfValueClass a where
        toXfconfValue :: a -> IO XfconfValue

instance XfconfValueClass XfconfValue where
        toXfconfValue = return . id

instance XfconfValueClass String where
        toXfconfValue = return . XfconfString

instance XfconfValueClass [String] where
        toXfconfValue = return . XfconfStringList

instance XfconfValueClass Int32 where
        toXfconfValue = return . XfconfInt

instance XfconfValueClass Word32 where
        toXfconfValue = return . XfconfUInt

instance XfconfValueClass Int16 where
        toXfconfValue = return . XfconfInt16

instance XfconfValueClass Word16 where
        toXfconfValue = return . XfconfUInt16

instance XfconfValueClass Word64 where
        toXfconfValue = return . XfconfUInt64

instance XfconfValueClass Double where
        toXfconfValue = return . XfconfDouble

instance XfconfValueClass Bool where
        toXfconfValue = return . XfconfBool

instance XfconfValueClass a => XfconfValueClass [a] where
        toXfconfValue xs = XfconfArray `fmap` (mapM toXfconfValue xs)

instance XfconfValueClass GValue where
 -- | Encapsulates a GValue in a XfconfValue
 toXfconfValue gvalue = valueGetType gvalue >>= getVal gvalue

   where getVal :: GValue -> GType -> IO XfconfValue
         getVal v t | t == bool = XfconfBool `fmap` valueGetBool v
                    | t == int = xInt `fmap` valueGetInt v
                    | t == int16 = xInt16 `fmap` valueGetInt16 v
                    | t == uint16 = xUInt16 `fmap` valueGetUInt16 v
                    | t == uint = xUInt `fmap` valueGetUInt v
                    | t == uint64 = xUInt64 `fmap` valueGetUInt64 v
                    | t == double = XfconfDouble `fmap` valueGetDouble v
                    | t == string = XfconfString `fmap` valueGetString v
                    | t == array = XfconfArray `fmap` xArray v
                    | otherwise = return (XfconfNotImplemented t)

         xInt = XfconfInt . fromIntegral
         xUInt = XfconfUInt . fromIntegral
         xUInt64 = XfconfUInt64 . fromIntegral
         xUInt16 = XfconfUInt16 . fromIntegral
         xInt16 = XfconfInt16 . fromIntegral
         xArray = arrayToXfconfValues

{----------------------------------------------------------------------
-- Additional types
----------------------------------------------------------------------}

-- $additionalTypes
-- libgobject lacks GObject fundamental types for 16-bit signed and
-- unsigned integers, which may be useful to use in an Xfconf store.
-- GObject types for these primitive types are provided here.
--
-- Note that, strangely, the xfconfd backend consider uint16 and int16
-- as, respectively, simple uint32 and int32. This Haskell FFI binding
-- hides this fact by converting uint32 and int32 back to uint16 and
-- int16 when using 'channelGetUInt16WithDefault' and
-- 'channelGetInt16WithDefault', but other frontends may behave
-- differently (notably the original C library or the
-- 'channelGetProperty' function).

{----------------------------------------------------------------------
-- gint16
----------------------------------------------------------------------}

int16 :: GType
int16 = unsafePerformIO $ xfconf_int16_get_type
{-# LINE 152 "./System/XFCE/Xfconf/Values.chs" #-}

foreign import ccall unsafe "xfconf.h xfconf_g_value_get_int16"
        c_get_int16 :: GValue -> IO CShort

valueGetInt16 :: GValue -> IO Int16
valueGetInt16 gvalue = fromIntegral `fmap` c_get_int16 gvalue

foreign import ccall unsafe "xfconf.h xfconf_g_value_set_int16"
        c_set_int16 :: GValue -> CShort -> IO ()

valueSetInt16 :: GValue -> Int16 -> IO ()
valueSetInt16 gvalue i = c_set_int16 gvalue (fromIntegral i)

{----------------------------------------------------------------------
-- guint16
----------------------------------------------------------------------}

uint16 :: GType
uint16 = unsafePerformIO $ xfconf_uint16_get_type
{-# LINE 171 "./System/XFCE/Xfconf/Values.chs" #-}

foreign import ccall unsafe "xfconf.h xfconf_g_value_get_uint16"
        c_get_uint16 :: GValue -> IO CUShort

valueGetUInt16 :: GValue -> IO Word16
valueGetUInt16 gvalue = fromIntegral `fmap` c_get_uint16 gvalue

foreign import ccall unsafe "xfconf.h xfconf_g_value_set_uint16"
        c_set_uint16 :: GValue -> CUShort -> IO ()

valueSetUInt16 :: GValue -> Word16 -> IO ()
valueSetUInt16 gvalue i = c_set_uint16 gvalue (fromIntegral i)

{----------------------------------------------------------------------
-- XFCONF Array hack
----------------------------------------------------------------------}

-- $arrayHack
-- xfconf code source defines in the directory @common/@ some hidden
-- functions. Among them, one can find helpers for array manipulation.

-- | From xfconf-common-private.h:
-- @
-- #define XFCONF_TYPE_G_VALUE_ARRAY (dbus_g_type_get_collection(\"GPtrArray\", G_TYPE_VALUE))
-- @

array :: GType
array = unsafePerformIO $
        withCString "GPtrArray" $ \name -> do
        gtype <- g_value_get_type
{-# LINE 201 "./System/XFCE/Xfconf/Values.chs" #-}
        dbus_g_type_get_collection name gtype

-- | Read 'GValue's from a 'GPtrArray' of GValues
arrayToXfconfValues :: GValue -> IO [XfconfValue]
arrayToXfconfValues gvalue = do
        a <- (\(GValue arg1) -> g_value_get_boxed arg1) gvalue
        size <- fromIntegral `fmap` (\ptr -> do {peekByteOff ptr 8 ::IO CUInt}) a
        if size == 0
          then return []
          -- From glib sources:
          -- #define ((array)->pdata)[index_]
          -- ((array)->pdata)[index_]
          else gPtrArrayMapM (toXfconfValue . GValue) a size

-- | The big bro' of 'System.Glib.GValue.allocaGValue'.
-- This function works in three steps:
--
-- 1. Allocate memory for an array of 'XfconfValue' /not/ containing
-- complex elements such as 'XfconfStringList', 'XfconfArray' or
-- 'XfconfNotImplemented'
--
-- 2. perform the operation @(GValue -> IO b)@ where the 'GValue' is a
-- boxed value wrapping our array of 'GValue*'.
--
-- 3. free the memory.
--
allocaGValueArray :: [XfconfValue] -> (GValue -> IO b) -> IO b
allocaGValueArray xs action = do
        -- First and foremost, we do NOT handle complex xfconfvalues
        forM xs $ \x ->
           case x of
             XfconfArray _ -> error "cannot store XfconfArrays containing XfconfArray"
             XfconfStringList _ -> error "cannot store XfconfArrays containing XfconfStringList"
             XfconfNotImplemented _ -> error "cannot store XfconfArrays containing XfconftImplemented"
             _ -> return ()

        gvalue <- xfconfArrayToGValue xs
        result <- action gvalue
        xfconfGValueArrayFree gvalue

        return result

  where len = length xs

        -- | Awful memory leak: malloc without free.
        -- Remember to free the memory later with 'xfconfGValueArrayFree'
        xfconfArrayToGValue xfvalues = do
                gPtrArray <- g_ptr_array_sized_new (fromIntegral len)

                gvalues <- replicateM len (GValue `fmap` mallocGValue)

                forM_ (zip gvalues xfvalues) $ \(gvalue,xfvalue) -> do
                    case xfvalue of
                        XfconfInt i -> valueInit gvalue int >> valueSetInt gvalue (fromIntegral i)
                        XfconfUInt i -> valueInit gvalue uint >> valueSetUInt gvalue (fromIntegral i)
                        XfconfUInt64 i -> valueInit gvalue uint64 >> valueSetUInt64 gvalue i
                        XfconfDouble d -> valueInit gvalue double >> valueSetDouble gvalue d
                        XfconfBool b -> valueInit gvalue bool >> valueSetBool gvalue b
                        XfconfString s -> valueInit gvalue string >> valueSetString gvalue s
                        XfconfInt16 i -> valueInit gvalue int16 >> valueSetInt16 gvalue i
                        XfconfUInt16 i -> valueInit gvalue uint16 >> valueSetUInt16 gvalue i
                        _ -> error "unknown XfconfValue type"

                forM gvalues $ \(GValue ptr) ->
                        g_ptr_array_add gPtrArray (castPtr ptr)


                ptrBox <- mallocGValue
                let gvBox = GValue ptrBox
                valueInit gvBox array
                (\(GValue arg1) arg2 -> g_value_set_boxed arg1 arg2) gvBox gPtrArray

                return gvBox

          where mallocGValue :: IO (Ptr GValue)
                -- From glib-0.11.2/System/Glib/GValue.chs:
                -- c2hs is broken in that it can't handle arrays of compound arrays in the
                -- sizeof hook
                -- Correction: vanilla c2hs is fixed now, but your gtk2hsC2hs is still broken, so ...
                mallocGValue = do gvPtr <- mallocBytes (8 + 2* 8)
                                  (\ptr val -> do {pokeByteOff ptr 0 (val::CULong)}) gvPtr (0 :: GType)
                                  return (castPtr gvPtr)


        xfconfGValueArrayFree gvBox = do
                gPtrArray <- (\(GValue arg1) -> g_value_get_boxed arg1) gvBox
                gPtrArrayMapM free gPtrArray len
                g_ptr_array_free gPtrArray (fromBool True)


-- | As 'Control.Monad.mapM', but for 'GPtrArray*'s
gPtrArrayMapM :: (Ptr GValue -> IO b) -- ^ function
              -> Ptr () -- ^ GPtrArray*
              -> Int -- ^ array size
              -> IO [b] -- ^ results
gPtrArrayMapM f gPtrArray len = do
        -- From glib sources:
        -- #define ((array)->pdata)[index_]
        -- ((array)->pdata)[index_]
        pdata <- (\ptr -> do {peekByteOff ptr 0 ::IO (Ptr (Ptr ()))}) gPtrArray
        gvaluesPtr <- peekArray len (castPtr pdata :: Ptr (Ptr GValue))
        mapM f gvaluesPtr

foreign import ccall unsafe "xfconf_int16_get_type"
  xfconf_int16_get_type :: (IO CULong)

foreign import ccall unsafe "xfconf_uint16_get_type"
  xfconf_uint16_get_type :: (IO CULong)

foreign import ccall unsafe "g_value_get_type"
  g_value_get_type :: (IO CULong)

foreign import ccall unsafe "dbus_g_type_get_collection"
  dbus_g_type_get_collection :: ((Ptr CChar) -> (CULong -> (IO CULong)))

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

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

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

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

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