xfconf-4.8.0.0: System/XFCE/Xfconf/Values.chs
{-# 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