module System.Gnome.GConf.GConfValue (
GConfPrimitiveValueClass,
GConfValueClass(marshalFromGConfValue, marshalToGConfValue),
GConfValue(GConfValue),
GConfValueDyn(..),
) where
import Control.Monad (liftM, when)
import Control.Exception (catch, IOException)
import Prelude hiding (catch)
import Data.Text (Text)
import System.Glib.FFI
import System.Glib.UTFString
import System.Glib.GList (toGSList, readGSList)
data GConfValueType = GconfValueInvalid
| GconfValueString
| GconfValueInt
| GconfValueFloat
| GconfValueBool
| GconfValueSchema
| GconfValueList
| GconfValuePair
deriving (Enum,Eq,Show)
newtype GConfValue = GConfValue (Ptr (GConfValue))
class GConfValueClass value where
unsafeMarshalFromGConfValue :: GConfValue -> IO value
marshalFromGConfValue :: GConfValue -> IO value
marshalFromGConfValue value = do
checkForNullAndExpectedType (typeofGConfValue (undefined::value)) value
unsafeMarshalFromGConfValue value
typeofGConfValue :: value -> GConfValueType
marshalToGConfValue :: value -> IO GConfValue
data GConfValueDyn = GConfValueString Text
| GConfValueInt Int
| GConfValueFloat Double
| GConfValueBool Bool
| GConfValueSchema
| GConfValueList [GConfValueDyn]
| GConfValuePair (GConfValueDyn, GConfValueDyn)
instance GConfValueClass value => GConfValueClass (Maybe value) where
typeofGConfValue _ = typeofGConfValue (undefined :: value)
unsafeMarshalFromGConfValue = marshalFromGConfValue
marshalFromGConfValue value =
catch (liftM Just $ marshalFromGConfValue value)
(\(e :: IOException) -> return Nothing)
marshalToGConfValue (Just v) = marshalToGConfValue v
marshalToGConfValue Nothing = return $ GConfValue nullPtr
class GConfValueClass value => GConfPrimitiveValueClass value
instance GConfPrimitiveValueClass Int
instance GConfPrimitiveValueClass Bool
instance GConfPrimitiveValueClass Double
instance GConfPrimitiveValueClass Text
instance GConfValueClass Int where
typeofGConfValue _ = GconfValueInt
unsafeMarshalFromGConfValue = liftM fromIntegral . (\(GConfValue arg1) -> gconf_value_get_int arg1)
marshalToGConfValue n = do
value <- gconf_value_new
(fromIntegral $ fromEnum GconfValueInt)
(\(GConfValue arg1) arg2 -> gconf_value_set_int arg1 arg2) (GConfValue value) (fromIntegral n)
return (GConfValue value)
instance GConfValueClass Bool where
typeofGConfValue _ = GconfValueBool
unsafeMarshalFromGConfValue = liftM toBool . (\(GConfValue arg1) -> gconf_value_get_bool arg1)
marshalToGConfValue b = do
value <- gconf_value_new
(fromIntegral $ fromEnum GconfValueBool)
(\(GConfValue arg1) arg2 -> gconf_value_set_bool arg1 arg2) (GConfValue value) (fromBool b)
return (GConfValue value)
instance GConfValueClass Double where
typeofGConfValue _ = GconfValueFloat
unsafeMarshalFromGConfValue = liftM realToFrac . (\(GConfValue arg1) -> gconf_value_get_float arg1)
marshalToGConfValue f = do
value <- gconf_value_new
(fromIntegral $ fromEnum GconfValueFloat)
(\(GConfValue arg1) arg2 -> gconf_value_set_float arg1 arg2) (GConfValue value) (realToFrac f)
return (GConfValue value)
instance GlibString string => GConfValueClass string where
typeofGConfValue _ = GconfValueString
unsafeMarshalFromGConfValue value = do
strPtr <- (\(GConfValue arg1) -> gconf_value_get_string arg1) value
peekUTFString strPtr
marshalToGConfValue s = do
value <- gconf_value_new
(fromIntegral $ fromEnum GconfValueString)
withUTFString s $ \strPtr ->
(\(GConfValue arg1) arg2 -> gconf_value_set_string arg1 arg2) (GConfValue value) strPtr
return (GConfValue value)
instance (GConfPrimitiveValueClass a, GConfPrimitiveValueClass b) => GConfValueClass (a,b) where
typeofGConfValue _ = GconfValuePair
unsafeMarshalFromGConfValue value = do
a <- (\(GConfValue arg1) -> gconf_value_get_car arg1) value
b <- (\(GConfValue arg1) -> gconf_value_get_cdr arg1) value
a' <- marshalFromGConfValue (GConfValue a)
b' <- marshalFromGConfValue (GConfValue b)
return (a',b')
marshalToGConfValue (a,b) = do
value <- gconf_value_new
(fromIntegral $ fromEnum GconfValuePair)
a' <- marshalToGConfValue a
b' <- marshalToGConfValue b
(\(GConfValue arg1) (GConfValue arg2) -> gconf_value_set_car_nocopy arg1 arg2) (GConfValue value) a'
(\(GConfValue arg1) (GConfValue arg2) -> gconf_value_set_cdr_nocopy arg1 arg2) (GConfValue value) b'
return (GConfValue value)
instance GConfPrimitiveValueClass a => GConfValueClass [a] where
typeofGConfValue _ = GconfValueList
unsafeMarshalFromGConfValue value = do
gsList <- (\(GConfValue arg1) -> gconf_value_get_list arg1) value
valuesPtrs <- readGSList gsList
mapM (unsafeMarshalFromGConfValue . GConfValue) valuesPtrs
marshalFromGConfValue value = do
checkForNullAndExpectedType GconfValueList value
listType <- liftM (toEnum . fromIntegral) $
(\(GConfValue arg1) -> gconf_value_get_list_type arg1) value
when (listType /= typeofGConfValue (undefined :: a))
(fail "GConf: key is list with elements of unexpected type")
unsafeMarshalFromGConfValue value
marshalToGConfValue list = do
value <- gconf_value_new
(fromIntegral $ fromEnum GconfValueList)
valuesPtrs <- mapM (liftM (\(GConfValue ptr) -> ptr) . marshalToGConfValue) list
valuesList <- toGSList valuesPtrs
(\(GConfValue arg1) arg2 -> gconf_value_set_list_type arg1 arg2) (GConfValue value)
(fromIntegral $ fromEnum $ typeofGConfValue (undefined::a))
(\(GConfValue arg1) arg2 -> gconf_value_set_list_nocopy arg1 arg2) (GConfValue value) valuesList
return (GConfValue value)
gconfValueGetType :: GConfValue -> IO GConfValueType
gconfValueGetType (GConfValue valuePtr) =
liftM (toEnum . fromIntegral) $ peek (castPtr valuePtr :: Ptr CInt)
checkForNullAndExpectedType :: GConfValueType -> GConfValue -> IO ()
checkForNullAndExpectedType expectedType value@(GConfValue ptr)
| ptr == nullPtr = fail "GConf: cannot get value of key, key is unset"
| otherwise = do valueType <- gconfValueGetType value
when (valueType /= expectedType)
(fail $ "GConf: key is of unexpected type, expected: "
++ show expectedType ++ ", got: " ++ show valueType)
unsafeMarshalGConfValueDynListFromGConfValue :: GConfValue -> IO [GConfValueDyn]
unsafeMarshalGConfValueDynListFromGConfValue value = do
gsList <- (\(GConfValue arg1) -> gconf_value_get_list arg1) value
valuesPtrs <- readGSList gsList
mapM (unsafeMarshalFromGConfValue . GConfValue) valuesPtrs
marshalGConfValueDynListToGConfValue :: [GConfValueDyn] -> IO GConfValue
marshalGConfValueDynListToGConfValue as = do
value <- gconf_value_new
(fromIntegral $ fromEnum GconfValueList)
valuesPtrs <- mapM (liftM (\(GConfValue ptr) -> ptr) . marshalToGConfValue) as
valuesList <- toGSList valuesPtrs
(\(GConfValue arg1) arg2 -> gconf_value_set_list_type arg1 arg2) (GConfValue value)
(fromIntegral $ fromEnum $ (case as of
[] -> GconfValueInvalid
(a:_) -> gconfValueDynGetType (head as)))
(\(GConfValue arg1) arg2 -> gconf_value_set_list_nocopy arg1 arg2) (GConfValue value) valuesList
return (GConfValue value)
unsafeMarshalGConfValueDynPairFromGConfValue :: GConfValue -> IO (GConfValueDyn, GConfValueDyn)
unsafeMarshalGConfValueDynPairFromGConfValue value = do
a <- (\(GConfValue arg1) -> gconf_value_get_car arg1) value
b <- (\(GConfValue arg1) -> gconf_value_get_cdr arg1) value
a' <- marshalFromGConfValue (GConfValue a)
b' <- marshalFromGConfValue (GConfValue b)
return (a', b')
marshalGConfValueDynPairToGConfValue :: (GConfValueDyn, GConfValueDyn) -> IO GConfValue
marshalGConfValueDynPairToGConfValue (a,b) = do
value <- gconf_value_new
(fromIntegral $ fromEnum GconfValuePair)
a' <- marshalToGConfValue a
b' <- marshalToGConfValue b
(\(GConfValue arg1) (GConfValue arg2) -> gconf_value_set_car_nocopy arg1 arg2) (GConfValue value) a'
(\(GConfValue arg1) (GConfValue arg2) -> gconf_value_set_cdr_nocopy arg1 arg2) (GConfValue value) b'
return (GConfValue value)
instance GConfValueClass GConfValueDyn where
typeofGConfValue _ = undefined
unsafeMarshalFromGConfValue value = do
valueType <- gconfValueGetType value
case valueType of
GconfValueString -> liftM GConfValueString $ unsafeMarshalFromGConfValue value
GconfValueInt -> liftM GConfValueInt $ unsafeMarshalFromGConfValue value
GconfValueFloat -> liftM GConfValueFloat $ unsafeMarshalFromGConfValue value
GconfValueBool -> liftM GConfValueBool $ unsafeMarshalFromGConfValue value
GconfValueSchema -> return GConfValueSchema
GconfValueList -> liftM GConfValueList $ unsafeMarshalGConfValueDynListFromGConfValue value
GconfValuePair -> liftM GConfValuePair $ unsafeMarshalGConfValueDynPairFromGConfValue value
marshalFromGConfValue value@(GConfValue ptr) = do
when (ptr == nullPtr) $ fail "GConf: cannot get value of key, key is unset"
unsafeMarshalFromGConfValue value
marshalToGConfValue v = case v of
(GConfValueString v') -> marshalToGConfValue v'
(GConfValueInt v') -> marshalToGConfValue v'
(GConfValueFloat v') -> marshalToGConfValue v'
(GConfValueBool v') -> marshalToGConfValue v'
(GConfValueSchema ) -> fail "GConf: setting schema types not supported"
(GConfValueList v') -> marshalGConfValueDynListToGConfValue v'
(GConfValuePair v') -> marshalGConfValueDynPairToGConfValue v'
gconfValueDynGetType :: GConfValueDyn -> GConfValueType
gconfValueDynGetType (GConfValueString _) = GconfValueString
gconfValueDynGetType (GConfValueInt _) = GconfValueInt
gconfValueDynGetType (GConfValueFloat _) = GconfValueFloat
gconfValueDynGetType (GConfValueBool _) = GconfValueBool
gconfValueDynGetType (GConfValueList _) = GconfValueList
gconfValueDynGetType (GConfValuePair _) = GconfValuePair
foreign import ccall unsafe "gconf_value_get_int"
gconf_value_get_int :: ((Ptr GConfValue) -> (IO CInt))
foreign import ccall unsafe "gconf_value_new"
gconf_value_new :: (CInt -> (IO (Ptr GConfValue)))
foreign import ccall unsafe "gconf_value_set_int"
gconf_value_set_int :: ((Ptr GConfValue) -> (CInt -> (IO ())))
foreign import ccall unsafe "gconf_value_get_bool"
gconf_value_get_bool :: ((Ptr GConfValue) -> (IO CInt))
foreign import ccall unsafe "gconf_value_set_bool"
gconf_value_set_bool :: ((Ptr GConfValue) -> (CInt -> (IO ())))
foreign import ccall unsafe "gconf_value_get_float"
gconf_value_get_float :: ((Ptr GConfValue) -> (IO CDouble))
foreign import ccall unsafe "gconf_value_set_float"
gconf_value_set_float :: ((Ptr GConfValue) -> (CDouble -> (IO ())))
foreign import ccall unsafe "gconf_value_get_string"
gconf_value_get_string :: ((Ptr GConfValue) -> (IO (Ptr CChar)))
foreign import ccall unsafe "gconf_value_set_string"
gconf_value_set_string :: ((Ptr GConfValue) -> ((Ptr CChar) -> (IO ())))
foreign import ccall unsafe "gconf_value_get_car"
gconf_value_get_car :: ((Ptr GConfValue) -> (IO (Ptr GConfValue)))
foreign import ccall unsafe "gconf_value_get_cdr"
gconf_value_get_cdr :: ((Ptr GConfValue) -> (IO (Ptr GConfValue)))
foreign import ccall unsafe "gconf_value_set_car_nocopy"
gconf_value_set_car_nocopy :: ((Ptr GConfValue) -> ((Ptr GConfValue) -> (IO ())))
foreign import ccall unsafe "gconf_value_set_cdr_nocopy"
gconf_value_set_cdr_nocopy :: ((Ptr GConfValue) -> ((Ptr GConfValue) -> (IO ())))
foreign import ccall unsafe "gconf_value_get_list"
gconf_value_get_list :: ((Ptr GConfValue) -> (IO (Ptr ())))
foreign import ccall unsafe "gconf_value_get_list_type"
gconf_value_get_list_type :: ((Ptr GConfValue) -> (IO CInt))
foreign import ccall unsafe "gconf_value_set_list_type"
gconf_value_set_list_type :: ((Ptr GConfValue) -> (CInt -> (IO ())))
foreign import ccall unsafe "gconf_value_set_list_nocopy"
gconf_value_set_list_nocopy :: ((Ptr GConfValue) -> ((Ptr ()) -> (IO ())))