module System.XFCE.Xfconf.Values (
XfconfValue(..),
XfconfValueClass(toXfconfValue),
int16,
valueGetInt16,
valueSetInt16,
uint16,
valueGetUInt16,
valueSetUInt16,
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
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
int16 :: GType
int16 = unsafePerformIO $ xfconf_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)
uint16 :: GType
uint16 = unsafePerformIO $ xfconf_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)
array :: GType
array = unsafePerformIO $
withCString "GPtrArray" $ \name -> do
gtype <- g_value_get_type
dbus_g_type_get_collection name gtype
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 []
else gPtrArrayMapM (toXfconfValue . GValue) a size
allocaGValueArray :: [XfconfValue] -> (GValue -> IO b) -> IO b
allocaGValueArray xs action = do
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
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)
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)
gPtrArrayMapM :: (Ptr GValue -> IO b)
-> Ptr ()
-> Int
-> IO [b]
gPtrArrayMapM f gPtrArray len = do
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 ())))))