{-# LANGUAGE CPP, ForeignFunctionInterface #-}
-- we want to be able to write "instance Foobar String where"
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-}
-- we want to be able to write "instance Foobar String where"
-- ... and  "instance Foobar a => Foobar [a] where"
{-# LANGUAGE OverlappingInstances #-}

-- 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.
#include <glib.h>
#include <dbus/dbus-glib.h>
#include <xfconf/xfconf.h>

{# context lib="xfconf-0" prefix="xfconf" #}

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 #}
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 $ {#call unsafe int16_get_type #}

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 $ {#call unsafe uint16_get_type #}

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 <- {#call unsafe g_value_get_type #}
        {#call unsafe dbus_g_type_get_collection #} name gtype

-- | Read 'GValue's from a 'GPtrArray' of GValues
arrayToXfconfValues :: GValue -> IO [XfconfValue]
arrayToXfconfValues gvalue = do
        a <- {#call unsafe g_value_get_boxed #} gvalue
        size <- fromIntegral `fmap` {#get GPtrArray->len #} a
        if size == 0
          then return []
          -- From glib sources:
          -- #define    g_ptr_array_index(array,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 <- {#call unsafe 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) ->
                        {#call unsafe g_ptr_array_add #} gPtrArray (castPtr ptr)


                ptrBox <- mallocGValue
                let gvBox = GValue ptrBox
                valueInit gvBox array
                {#call unsafe g_value_set_boxed#} 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 ({# sizeof GType #} + 2* {# sizeof guint64 #})
                                  {# set GValue->g_type #} gvPtr (0 :: GType)
                                  return (castPtr gvPtr)


        xfconfGValueArrayFree gvBox = do
                gPtrArray <- {#call unsafe g_value_get_boxed#} gvBox
                gPtrArrayMapM free gPtrArray len
                {#call unsafe 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    g_ptr_array_index(array,index_)
        --            ((array)->pdata)[index_]
        pdata <- {#get GPtrArray->pdata #} gPtrArray
        gvaluesPtr <- peekArray len (castPtr pdata :: Ptr (Ptr GValue))
        mapM f gvaluesPtr